From 9d67cee02262346526bb25cbcf54750ebf134ecb Mon Sep 17 00:00:00 2001 From: No Author Date: Thu, 21 Aug 1997 22:58:49 +0000 Subject: This commit was manufactured by cvs2svn to create tag 'start'. From-SVN: r14881 --- .cvsignore | 31 + COPYING | 340 + COPYING.LIB | 481 + ChangeLog | 5207 +++++ Makefile.in | 1608 ++ README | 47 + config-ml.in | 612 + config.guess | 833 + config.sub | 1177 ++ config/ChangeLog | 312 + config/mh-a68bsd | 12 + config/mh-aix386 | 1 + config/mh-apollo68 | 3 + config/mh-cxux | 14 + config/mh-cygwin32 | 16 + config/mh-decstation | 5 + config/mh-delta88 | 4 + config/mh-dgux | 4 + config/mh-dgux386 | 22 + config/mh-go32 | 4 + config/mh-hp300 | 13 + config/mh-hpux | 4 + config/mh-hpux8 | 4 + config/mh-irix4 | 7 + config/mh-irix5 | 3 + config/mh-irix6 | 7 + config/mh-lynxos | 2 + config/mh-lynxrs6k | 8 + config/mh-m68kpic | 1 + config/mh-ncr3000 | 17 + config/mh-ncrsvr43 | 9 + config/mh-necv4 | 11 + config/mh-papic | 1 + config/mh-ppcpic | 1 + config/mh-riscos | 15 + config/mh-sco | 10 + config/mh-solaris | 6 + config/mh-sparcpic | 1 + config/mh-sun3 | 3 + config/mh-sysv | 3 + config/mh-sysv4 | 11 + config/mh-vaxult2 | 2 + config/mh-windows | 16 + config/mh-x86pic | 1 + config/mpw-mh-mpw | 157 + config/mpw/ChangeLog | 53 + config/mpw/MoveIfChange | 19 + config/mpw/README | 23 + config/mpw/forward-include | 3 + config/mpw/g-mpw-make.sed | 293 + config/mpw/mpw-touch | 7 + config/mpw/mpw-true | 1 + config/mpw/null-command | 1 + config/mpw/open-brace | 4 + config/mpw/tr-7to8-src | 9 + config/mpw/true | 1 + config/mt-m68kpic | 1 + config/mt-netware | 1 + config/mt-papic | 1 + config/mt-ppcpic | 1 + config/mt-sparcpic | 1 + config/mt-v810 | 4 + config/mt-x86pic | 1 + configure | 1406 ++ configure.in | 874 + etc/ChangeLog | 392 + etc/Makefile.in | 88 + etc/configure | 858 + etc/configure.in | 7 + etc/make-stds.texi | 893 + etc/standards.texi | 3061 +++ gcc/config/alpha/vms-tramp.asm | 22 - gcc/config/float-i128.h | 96 - 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 + include/COPYING | 340 + include/ChangeLog | 1254 ++ include/ansidecl.h | 154 + include/demangle.h | 90 + include/floatformat.h | 111 + include/fnmatch.h | 69 + include/getopt.h | 129 + include/libiberty.h | 161 + include/objalloc.h | 115 + include/obstack.h | 570 + install-sh | 287 + libiberty/COPYING.LIB | 481 + libiberty/ChangeLog | 2233 +++ libiberty/Makefile.in | 336 + libiberty/README | 129 + libiberty/alloca-botch.h | 5 + libiberty/alloca-norm.h | 23 + libiberty/alloca.c | 479 + libiberty/argv.c | 333 + libiberty/atexit.c | 14 + libiberty/basename.c | 43 + libiberty/bcmp.c | 49 + libiberty/bcopy.c | 35 + libiberty/bzero.c | 31 + libiberty/choose-temp.c | 147 + libiberty/clock.c | 73 + libiberty/concat.c | 167 + libiberty/config.h-vms | 13 + libiberty/config.table | 69 + libiberty/config/mh-a68bsd | 2 + libiberty/config/mh-aix | 10 + libiberty/config/mh-apollo68 | 2 + libiberty/config/mh-cxux7 | 3 + libiberty/config/mh-cygwin32 | 2 + libiberty/config/mh-go32 | 1 + libiberty/config/mh-hpbsd | 2 + libiberty/config/mh-irix4 | 4 + libiberty/config/mh-ncr3000 | 19 + libiberty/config/mh-riscix | 6 + libiberty/config/mh-sysv | 1 + libiberty/config/mh-sysv4 | 3 + libiberty/config/mh-windows | 2 + libiberty/config/mt-sunos4 | 2 + libiberty/config/mt-vxworks5 | 28 + libiberty/configure.bat | 15 + libiberty/configure.in | 66 + libiberty/copysign.c | 140 + libiberty/cplus-dem.c | 3087 +++ libiberty/dummy.c | 49 + libiberty/fdmatch.c | 73 + libiberty/floatformat.c | 401 + libiberty/fnmatch.c | 223 + libiberty/functions.def | 69 + libiberty/getcwd.c | 52 + libiberty/getopt.c | 760 + libiberty/getopt1.c | 190 + libiberty/getpagesize.c | 89 + libiberty/getruntime.c | 82 + libiberty/hex.c | 33 + libiberty/index.c | 11 + libiberty/insque.c | 50 + libiberty/makefile.dos | 29 + libiberty/makefile.vms | 37 + libiberty/memchr.c | 60 + libiberty/memcmp.c | 38 + libiberty/memcpy.c | 28 + libiberty/memmove.c | 18 + libiberty/memset.c | 19 + libiberty/mpw-config.in | 9 + libiberty/mpw-make.sed | 51 + libiberty/mpw.c | 1010 + libiberty/msdos.c | 15 + libiberty/objalloc.c | 289 + libiberty/obstack.c | 514 + libiberty/pexecute.c | 580 + libiberty/random.c | 373 + libiberty/rename.c | 22 + libiberty/rindex.c | 11 + libiberty/sigsetmask.c | 30 + libiberty/spaces.c | 78 + libiberty/strcasecmp.c | 82 + libiberty/strchr.c | 34 + libiberty/strdup.c | 10 + libiberty/strerror.c | 831 + libiberty/strncasecmp.c | 82 + libiberty/strrchr.c | 34 + libiberty/strsignal.c | 638 + libiberty/strstr.c | 51 + libiberty/strtod.c | 122 + libiberty/strtol.c | 143 + libiberty/strtoul.c | 110 + libiberty/tmpnam.c | 39 + libiberty/vasprintf.c | 165 + libiberty/vfork.c | 8 + libiberty/vfprintf.c | 13 + libiberty/vmsbuild.com | 166 + libiberty/vprintf.c | 15 + libiberty/vsprintf.c | 55 + libiberty/waitpid.c | 11 + libiberty/xatexit.c | 82 + libiberty/xexit.c | 36 + libiberty/xmalloc.c | 113 + libiberty/xstrdup.c | 17 + libiberty/xstrerror.c | 56 + libio/ChangeLog | 1940 ++ libio/Makefile.in | 124 + libio/NEWS | 51 + libio/PlotFile.cc | 157 + libio/PlotFile.h | 89 + libio/README | 30 + libio/SFile.cc | 82 + libio/SFile.h | 55 + libio/builtinbuf.cc | 78 + libio/builtinbuf.h | 68 + libio/cleanup.c | 17 + libio/config.shared | 487 + libio/config/hpux.mt | 3 + libio/config/isc.mt | 4 + libio/config/linux.mt | 26 + libio/config/mn10200.mt | 3 + libio/config/netware.mt | 16 + libio/config/sco4.mt | 3 + libio/configure.in | 93 + libio/dbz/Makefile.in | 217 + libio/dbz/README | 25 + libio/dbz/altbytes | 7 + libio/dbz/byteflip.c | 38 + libio/dbz/case.c | 129 + libio/dbz/case.h | 12 + libio/dbz/configure.in | 17 + libio/dbz/dbz.1 | 221 + libio/dbz/dbz.3z | 547 + libio/dbz/dbz.c | 1763 ++ libio/dbz/dbz.h | 32 + libio/dbz/dbzmain.c | 519 + libio/dbz/fake.c | 144 + libio/dbz/firstlast25 | 50 + libio/dbz/getmap | 6 + libio/dbz/random.c | 31 + libio/dbz/revbytes | 7 + libio/dbz/stdio.h | 1 + libio/depend | 352 + libio/editbuf.cc | 717 + libio/editbuf.h | 185 + libio/filebuf.cc | 206 + libio/filedoalloc.c | 102 + libio/fileops.c | 755 + libio/floatconv.c | 2375 +++ libio/floatio.h | 51 + libio/fstream.cc | 110 + libio/fstream.h | 92 + libio/gen-params | 698 + libio/genops.c | 852 + libio/indstream.cc | 121 + libio/indstream.h | 77 + libio/ioassign.cc | 49 + libio/ioextend.cc | 132 + libio/iofclose.c | 47 + libio/iofdopen.c | 121 + libio/iofflush.c | 38 + libio/iofgetpos.c | 46 + libio/iofgets.c | 40 + libio/iofopen.c | 49 + libio/iofprintf.c | 48 + libio/iofputs.c | 37 + libio/iofread.c | 38 + libio/iofscanf.c | 48 + libio/iofsetpos.c | 43 + libio/ioftell.c | 45 + libio/iofwrite.c | 44 + libio/iogetdelim.c | 99 + libio/iogetline.c | 74 + libio/iogets.c | 47 + libio/ioignore.c | 46 + libio/iolibio.h | 53 + libio/iomanip.cc | 90 + libio/iomanip.h | 165 + libio/iopadn.c | 65 + libio/ioperror.c | 22 + libio/iopopen.c | 222 + libio/ioprims.c | 72 + libio/ioprintf.c | 47 + libio/ioputs.c | 38 + libio/ioscanf.c | 47 + libio/ioseekoff.c | 43 + libio/ioseekpos.c | 39 + libio/iosetbuffer.c | 36 + libio/iosetvbuf.c | 78 + libio/iosprintf.c | 47 + libio/iosscanf.c | 47 + libio/iostdio.h | 114 + libio/iostream.cc | 821 + libio/iostream.h | 258 + libio/iostream.texi | 1971 ++ libio/iostreamP.h | 26 + libio/iostrerror.c | 12 + libio/ioungetc.c | 35 + libio/iovfprintf.c | 885 + libio/iovfscanf.c | 787 + libio/iovsprintf.c | 40 + libio/iovsscanf.c | 37 + libio/isgetline.cc | 139 + libio/isgetsb.cc | 59 + libio/isscan.cc | 45 + libio/istream.h | 25 + libio/libio.h | 267 + libio/libioP.h | 497 + libio/osform.cc | 54 + libio/ostream.h | 25 + libio/outfloat.c | 204 + libio/parsestream.cc | 317 + libio/parsestream.h | 156 + libio/pfstream.cc | 92 + libio/pfstream.h | 59 + libio/procbuf.cc | 55 + libio/procbuf.h | 50 + libio/sbform.cc | 40 + libio/sbgetline.cc | 31 + libio/sbscan.cc | 45 + libio/stdfiles.c | 44 + libio/stdio/ChangeLog | 93 + libio/stdio/Makefile.in | 23 + libio/stdio/clearerr.c | 10 + libio/stdio/configure.in | 48 + libio/stdio/fdopen.c | 9 + libio/stdio/feof.c | 34 + libio/stdio/ferror.c | 10 + libio/stdio/fgetc.c | 10 + libio/stdio/fileno.c | 12 + libio/stdio/fputc.c | 11 + libio/stdio/freopen.c | 14 + libio/stdio/fseek.c | 12 + libio/stdio/getc.c | 11 + libio/stdio/getchar.c | 10 + libio/stdio/getline.c | 13 + libio/stdio/getw.c | 13 + libio/stdio/popen.c | 23 + libio/stdio/putc.c | 12 + libio/stdio/putchar.c | 10 + libio/stdio/putw.c | 15 + libio/stdio/rewind.c | 10 + libio/stdio/setbuf.c | 9 + libio/stdio/setfileno.c | 17 + libio/stdio/setlinebuf.c | 11 + libio/stdio/snprintf.c | 51 + libio/stdio/stdio.h | 181 + libio/stdio/vfprintf.c | 35 + libio/stdio/vfscanf.c | 36 + libio/stdio/vprintf.c | 33 + libio/stdio/vscanf.c | 34 + libio/stdio/vsnprintf.c | 43 + libio/stdiostream.cc | 159 + libio/stdiostream.h | 79 + libio/stdstrbufs.cc | 115 + libio/stdstreams.cc | 153 + libio/stream.cc | 170 + libio/stream.h | 59 + libio/streambuf.cc | 343 + libio/streambuf.h | 475 + libio/strfile.h | 62 + libio/strops.c | 290 + libio/strstream.cc | 116 + libio/strstream.h | 113 + libio/tests/ChangeLog | 140 + libio/tests/Makefile.in | 197 + libio/tests/configure.in | 21 + libio/tests/hounddog.cc | 85 + libio/tests/hounddog.exp | 7 + libio/tests/hounddog.inp | 7 + libio/tests/putbackdog.cc | 97 + libio/tests/tFile.cc | 550 + libio/tests/tFile.exp | 75 + libio/tests/tFile.inp | 5 + libio/tests/tfformat.c | 4181 ++++ libio/tests/tiformat.c | 5112 +++++ libio/tests/tiomanip.cc | 35 + libio/tests/tiomanip.exp | 4 + libio/tests/tiomisc.cc | 236 + libio/tests/tiomisc.exp | 11 + libio/tests/tstdiomisc.c | 43 + libio/tests/tstdiomisc.exp | 8 + libio/testsuite/ChangeLog | 49 + libio/testsuite/Makefile.in | 89 + libio/testsuite/config/default.exp | 1 + libio/testsuite/configure.in | 21 + libio/testsuite/lib/libio.exp | 164 + libio/testsuite/libio.tests/hounddog.exp | 3 + libio/testsuite/libio.tests/putbackdog.exp | 3 + libio/testsuite/libio.tests/tFile.exp | 3 + libio/testsuite/libio.tests/tfformat.exp | 1 + libio/testsuite/libio.tests/tiformat.exp | 1 + libio/testsuite/libio.tests/tiomanip.exp | 1 + libio/testsuite/libio.tests/tiomisc.exp | 1 + libio/testsuite/libio.tests/tstdiomisc.exp | 1 + libstdc++/ChangeLog | 823 + libstdc++/Makefile.in | 307 + libstdc++/NEWS | 13 + libstdc++/algorithm | 7 + libstdc++/cassert | 7 + libstdc++/cctype | 7 + libstdc++/cerrno | 7 + libstdc++/cfloat | 7 + libstdc++/cinst.cc | 155 + libstdc++/ciso646 | 7 + libstdc++/climits | 7 + libstdc++/clocale | 7 + libstdc++/cmath | 76 + libstdc++/cmathi.cc | 7 + libstdc++/complex | 18 + libstdc++/complex.h | 6 + libstdc++/config/aix.ml | 8 + libstdc++/config/dec-osf.ml | 6 + libstdc++/config/elf.ml | 8 + libstdc++/config/elfshlibm.ml | 6 + libstdc++/config/hpux.ml | 6 + libstdc++/config/irix5.ml | 6 + libstdc++/config/linux.ml | 6 + libstdc++/config/sol2shm.ml | 6 + libstdc++/config/sunos4.ml | 9 + libstdc++/configure.in | 85 + libstdc++/csetjmp | 8 + libstdc++/csignal | 7 + libstdc++/cstdarg | 7 + libstdc++/cstddef | 7 + libstdc++/cstdio | 7 + libstdc++/cstdlib | 23 + libstdc++/cstdlibi.cc | 7 + libstdc++/cstring | 96 + libstdc++/cstringi.cc | 7 + libstdc++/ctime | 7 + libstdc++/cwchar | 7 + libstdc++/cwctype | 7 + libstdc++/deque | 7 + libstdc++/functional | 7 + libstdc++/iterator | 7 + libstdc++/list | 7 + libstdc++/map | 7 + libstdc++/memory | 7 + libstdc++/numeric | 7 + libstdc++/queue | 7 + libstdc++/set | 7 + libstdc++/sinst.cc | 132 + libstdc++/stack | 7 + libstdc++/std/bastring.cc | 514 + libstdc++/std/bastring.h | 560 + libstdc++/std/complext.cc | 273 + libstdc++/std/complext.h | 423 + libstdc++/std/dcomplex.h | 94 + libstdc++/std/fcomplex.h | 90 + libstdc++/std/ldcomplex.h | 98 + libstdc++/std/straits.h | 161 + libstdc++/stdexcept | 93 + libstdc++/stdexcepti.cc | 8 + libstdc++/stl.h | 15 + libstdc++/stl/ChangeLog | 192 + libstdc++/stl/README | 16 + libstdc++/stl/algo.h | 2665 +++ libstdc++/stl/algobase.h | 841 + libstdc++/stl/alloc.h | 674 + libstdc++/stl/bvector.h | 585 + libstdc++/stl/defalloc.h | 87 + libstdc++/stl/deque.h | 1452 ++ libstdc++/stl/function.h | 634 + libstdc++/stl/hash_map.h | 319 + libstdc++/stl/hash_set.h | 306 + libstdc++/stl/hashtable.h | 1013 + libstdc++/stl/heap.h | 204 + libstdc++/stl/iterator.h | 598 + libstdc++/stl/list.h | 624 + libstdc++/stl/map.h | 188 + libstdc++/stl/multimap.h | 182 + libstdc++/stl/multiset.h | 167 + libstdc++/stl/pair.h | 63 + libstdc++/stl/pthread_alloc.h | 344 + libstdc++/stl/rope.h | 2055 ++ libstdc++/stl/ropeimpl.h | 1510 ++ libstdc++/stl/set.h | 167 + libstdc++/stl/slist.h | 729 + libstdc++/stl/stack.h | 171 + libstdc++/stl/stl_config.h | 170 + libstdc++/stl/tempbuf.h | 121 + libstdc++/stl/tree.h | 1085 ++ libstdc++/stl/type_traits.h | 227 + libstdc++/stl/vector.h | 544 + libstdc++/stlinst.cc | 8 + libstdc++/string | 13 + libstdc++/tests/ChangeLog | 87 + libstdc++/tests/Makefile.in | 35 + libstdc++/tests/configure.in | 50 + libstdc++/tests/tcomplex.cc | 151 + libstdc++/tests/tcomplex.exp | 37 + libstdc++/tests/tcomplex.inp | 1 + libstdc++/tests/tlist.cc | 165 + libstdc++/tests/tlist.exp | 44 + libstdc++/tests/tmap.cc | 69 + libstdc++/tests/tmap.exp | 7 + libstdc++/tests/tstring.cc | 189 + libstdc++/tests/tstring.exp | 20 + libstdc++/tests/tstring.inp | 1 + libstdc++/tests/tvector.cc | 23 + libstdc++/tests/tvector.exp | 4 + libstdc++/testsuite/ChangeLog | 54 + libstdc++/testsuite/Makefile.in | 66 + libstdc++/testsuite/config/default.exp | 1 + libstdc++/testsuite/configure.in | 23 + libstdc++/testsuite/lib/libstdc++.exp | 165 + libstdc++/testsuite/libstdc++.tests/test.exp | 34 + libstdc++/utility | 8 + libstdc++/vector | 7 + ltconfig | 1064 ++ ltmain.sh | 1819 ++ missing | 134 + mkinstalldirs | 36 + move-if-change | 32 + mpw-README | 376 + mpw-build.in | 204 + mpw-config.in | 113 + mpw-configure | 448 + symlink-tree | 48 + texinfo/COPYING | 339 + texinfo/ChangeLog | 2389 +++ texinfo/INSTALL | 181 + texinfo/INTRODUCTION | 119 + texinfo/Makefile.in | 244 + texinfo/NEWS | 93 + texinfo/README | 163 + texinfo/TODO | 35 + texinfo/aclocal.m4 | 45 + texinfo/configure | 2025 ++ texinfo/configure.in | 48 + texinfo/dir | 16 + texinfo/dir-example | 309 + texinfo/dir.info-template | 67 + texinfo/emacs/Makefile.in | 91 + texinfo/emacs/detexinfo.el | 250 + texinfo/emacs/elisp-comp | 7 + texinfo/emacs/info.el | 1846 ++ texinfo/emacs/informat.el | 429 + texinfo/emacs/makeinfo.el | 247 + texinfo/emacs/new-useful-setqs | 180 + texinfo/emacs/texinfmt.el | 3979 ++++ texinfo/emacs/texinfo.el | 932 + texinfo/emacs/texnfo-tex.el | 346 + texinfo/emacs/texnfo-upd.el | 2058 ++ texinfo/gen-info-dir | 101 + texinfo/gpl.texinfo | 398 + texinfo/info/Makefile.in | 232 + texinfo/info/NEWS | 200 + texinfo/info/README | 37 + texinfo/info/clib.c | 112 + texinfo/info/clib.h | 42 + texinfo/info/dir.c | 273 + texinfo/info/display.c | 561 + texinfo/info/display.h | 76 + texinfo/info/doc.h | 58 + texinfo/info/dribble.c | 71 + texinfo/info/dribble.h | 41 + texinfo/info/echo_area.c | 1508 ++ texinfo/info/echo_area.h | 63 + texinfo/info/filesys.c | 617 + texinfo/info/filesys.h | 84 + texinfo/info/footnotes.c | 265 + texinfo/info/footnotes.h | 46 + texinfo/info/gc.c | 95 + texinfo/info/gc.h | 36 + texinfo/info/general.h | 94 + texinfo/info/indices.c | 667 + texinfo/info/indices.h | 39 + texinfo/info/info-stnd.texi | 1365 ++ texinfo/info/info-utils.c | 672 + texinfo/info/info-utils.h | 140 + texinfo/info/info.1 | 229 + texinfo/info/info.c | 565 + texinfo/info/info.h | 100 + texinfo/info/info.texi | 929 + texinfo/info/infodoc.c | 771 + texinfo/info/infomap.c | 274 + texinfo/info/infomap.h | 82 + texinfo/info/m-x.c | 195 + texinfo/info/makedoc.c | 481 + texinfo/info/man.c | 643 + texinfo/info/man.h | 36 + texinfo/info/nodemenu.c | 329 + texinfo/info/nodes.c | 1207 ++ texinfo/info/nodes.h | 168 + texinfo/info/search.c | 519 + texinfo/info/search.h | 75 + texinfo/info/session.c | 4263 +++++ texinfo/info/session.h | 146 + texinfo/info/signals.c | 173 + texinfo/info/signals.h | 89 + texinfo/info/termdep.h | 76 + texinfo/info/terminal.c | 769 + texinfo/info/terminal.h | 129 + texinfo/info/tilde.c | 376 + texinfo/info/tilde.h | 58 + texinfo/info/userdoc.texi | 1270 ++ texinfo/info/variables.c | 272 + texinfo/info/variables.h | 64 + texinfo/info/window.c | 1482 ++ texinfo/info/window.h | 229 + texinfo/info/xmalloc.c | 80 + texinfo/install-sh | 250 + texinfo/lgpl.texinfo | 548 + texinfo/liblic.texi | 23 + texinfo/libtxi/Makefile.in | 84 + texinfo/libtxi/alloca.c | 504 + texinfo/libtxi/bzero.c | 44 + texinfo/libtxi/getopt.c | 762 + texinfo/libtxi/getopt.h | 129 + texinfo/libtxi/getopt1.c | 180 + texinfo/libtxi/memcpy.c | 20 + texinfo/libtxi/memmove.c | 24 + texinfo/libtxi/strdup.c | 43 + texinfo/license.texi | 24 + texinfo/makeinfo/Makefile.in | 116 + texinfo/makeinfo/macro.texi | 177 + texinfo/makeinfo/macros/example.texi | 224 + texinfo/makeinfo/macros/html.texi | 269 + texinfo/makeinfo/macros/multifmt.texi | 41 + texinfo/makeinfo/macros/res-samp.texi | 32 + texinfo/makeinfo/macros/resume.texi | 64 + texinfo/makeinfo/macros/simpledoc.texi | 135 + texinfo/makeinfo/makeinfo.c | 9349 +++++++++ texinfo/makeinfo/makeinfo.h | 193 + texinfo/makeinfo/makeinfo.texi | 311 + texinfo/makeinfo/multi.c | 418 + texinfo/makeinfo/multiformat.texi | 40 + texinfo/testsuite/ChangeLog | 37 + texinfo/testsuite/Makefile.in | 100 + texinfo/testsuite/config/unix.exp | 29 + texinfo/testsuite/configure | 707 + texinfo/testsuite/configure.in | 5 + texinfo/testsuite/lib/utils.exp | 31 + texinfo/testsuite/makeinfo.0/atnode.exp | 19 + texinfo/testsuite/makeinfo.0/conditions.exp | 21 + texinfo/testsuite/makeinfo.0/mini.exp | 17 + texinfo/testsuite/makeinfo.0/missnode.exp | 25 + texinfo/testsuite/makeinfo.0/nonsense.exp | 12 + texinfo/testsuite/makeinfo.0/not.exp | 15 + texinfo/testsuite/makeinfo.0/smstruct.exp | 14 + texinfo/testsuite/text/atnode.texi | 21 + texinfo/testsuite/text/conditions.texi | 26 + texinfo/testsuite/text/dfltnode.texi | 21 + texinfo/testsuite/text/minimal.texi | 2 + texinfo/testsuite/text/missnode.texi | 22 + texinfo/testsuite/text/nonsense.texi | 3 + texinfo/testsuite/text/not.texi | 1 + texinfo/testsuite/text/smstruct.texi | 21 + texinfo/texinfo.tex | 4800 +++++ texinfo/texinfo.texi | 16886 +++++++++++++++++ texinfo/util/Makefile.in | 105 + texinfo/util/deref.c | 238 + texinfo/util/fixfonts | 84 + texinfo/util/gen-dir-node | 176 + texinfo/util/install-info.c | 1111 ++ texinfo/util/mkinstalldirs | 40 + texinfo/util/tex3patch | 71 + texinfo/util/texi2dvi | 367 + texinfo/util/texindex.c | 1793 ++ xiberty/configure.in | 101 + ylwrap | 107 + 1006 files changed, 396320 insertions(+), 118 deletions(-) create mode 100644 .cvsignore create mode 100644 COPYING create mode 100644 COPYING.LIB create mode 100644 ChangeLog create mode 100644 Makefile.in create mode 100644 README create mode 100644 config-ml.in create mode 100755 config.guess create mode 100755 config.sub create mode 100644 config/ChangeLog create mode 100644 config/mh-a68bsd create mode 100644 config/mh-aix386 create mode 100644 config/mh-apollo68 create mode 100644 config/mh-cxux create mode 100644 config/mh-cygwin32 create mode 100644 config/mh-decstation create mode 100644 config/mh-delta88 create mode 100644 config/mh-dgux create mode 100644 config/mh-dgux386 create mode 100644 config/mh-go32 create mode 100644 config/mh-hp300 create mode 100644 config/mh-hpux create mode 100644 config/mh-hpux8 create mode 100644 config/mh-irix4 create mode 100644 config/mh-irix5 create mode 100644 config/mh-irix6 create mode 100644 config/mh-lynxos create mode 100644 config/mh-lynxrs6k create mode 100644 config/mh-m68kpic create mode 100644 config/mh-ncr3000 create mode 100644 config/mh-ncrsvr43 create mode 100644 config/mh-necv4 create mode 100644 config/mh-papic create mode 100644 config/mh-ppcpic create mode 100644 config/mh-riscos create mode 100644 config/mh-sco create mode 100644 config/mh-solaris create mode 100644 config/mh-sparcpic create mode 100644 config/mh-sun3 create mode 100644 config/mh-sysv create mode 100644 config/mh-sysv4 create mode 100644 config/mh-vaxult2 create mode 100644 config/mh-windows create mode 100644 config/mh-x86pic create mode 100644 config/mpw-mh-mpw create mode 100644 config/mpw/ChangeLog create mode 100644 config/mpw/MoveIfChange create mode 100644 config/mpw/README create mode 100644 config/mpw/forward-include create mode 100644 config/mpw/g-mpw-make.sed create mode 100644 config/mpw/mpw-touch create mode 100644 config/mpw/mpw-true create mode 100644 config/mpw/null-command create mode 100644 config/mpw/open-brace create mode 100644 config/mpw/tr-7to8-src create mode 100644 config/mpw/true create mode 100644 config/mt-m68kpic create mode 100644 config/mt-netware create mode 100644 config/mt-papic create mode 100644 config/mt-ppcpic create mode 100644 config/mt-sparcpic create mode 100644 config/mt-v810 create mode 100644 config/mt-x86pic create mode 100755 configure create mode 100644 configure.in create mode 100644 etc/ChangeLog create mode 100644 etc/Makefile.in create mode 100755 etc/configure create mode 100644 etc/configure.in create mode 100644 etc/make-stds.texi create mode 100644 etc/standards.texi delete mode 100644 gcc/config/alpha/vms-tramp.asm delete mode 100644 gcc/config/float-i128.h 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 create mode 100644 include/COPYING create mode 100644 include/ChangeLog create mode 100644 include/ansidecl.h create mode 100644 include/demangle.h create mode 100644 include/floatformat.h create mode 100644 include/fnmatch.h create mode 100644 include/getopt.h create mode 100644 include/libiberty.h create mode 100644 include/objalloc.h create mode 100644 include/obstack.h create mode 100755 install-sh create mode 100644 libiberty/COPYING.LIB create mode 100644 libiberty/ChangeLog create mode 100644 libiberty/Makefile.in create mode 100644 libiberty/README create mode 100644 libiberty/alloca-botch.h create mode 100644 libiberty/alloca-norm.h create mode 100644 libiberty/alloca.c create mode 100644 libiberty/argv.c create mode 100644 libiberty/atexit.c create mode 100644 libiberty/basename.c create mode 100644 libiberty/bcmp.c create mode 100644 libiberty/bcopy.c create mode 100644 libiberty/bzero.c create mode 100644 libiberty/choose-temp.c create mode 100644 libiberty/clock.c create mode 100644 libiberty/concat.c create mode 100644 libiberty/config.h-vms create mode 100644 libiberty/config.table create mode 100644 libiberty/config/mh-a68bsd create mode 100644 libiberty/config/mh-aix create mode 100644 libiberty/config/mh-apollo68 create mode 100644 libiberty/config/mh-cxux7 create mode 100644 libiberty/config/mh-cygwin32 create mode 100644 libiberty/config/mh-go32 create mode 100644 libiberty/config/mh-hpbsd create mode 100644 libiberty/config/mh-irix4 create mode 100644 libiberty/config/mh-ncr3000 create mode 100644 libiberty/config/mh-riscix create mode 100644 libiberty/config/mh-sysv create mode 100644 libiberty/config/mh-sysv4 create mode 100644 libiberty/config/mh-windows create mode 100644 libiberty/config/mt-sunos4 create mode 100644 libiberty/config/mt-vxworks5 create mode 100644 libiberty/configure.bat create mode 100644 libiberty/configure.in create mode 100644 libiberty/copysign.c create mode 100644 libiberty/cplus-dem.c create mode 100644 libiberty/dummy.c create mode 100644 libiberty/fdmatch.c create mode 100644 libiberty/floatformat.c create mode 100644 libiberty/fnmatch.c create mode 100644 libiberty/functions.def create mode 100644 libiberty/getcwd.c create mode 100644 libiberty/getopt.c create mode 100644 libiberty/getopt1.c create mode 100644 libiberty/getpagesize.c create mode 100644 libiberty/getruntime.c create mode 100644 libiberty/hex.c create mode 100644 libiberty/index.c create mode 100644 libiberty/insque.c create mode 100644 libiberty/makefile.dos create mode 100644 libiberty/makefile.vms create mode 100644 libiberty/memchr.c create mode 100644 libiberty/memcmp.c create mode 100644 libiberty/memcpy.c create mode 100644 libiberty/memmove.c create mode 100644 libiberty/memset.c create mode 100644 libiberty/mpw-config.in create mode 100644 libiberty/mpw-make.sed create mode 100644 libiberty/mpw.c create mode 100644 libiberty/msdos.c create mode 100644 libiberty/objalloc.c create mode 100644 libiberty/obstack.c create mode 100644 libiberty/pexecute.c create mode 100644 libiberty/random.c create mode 100644 libiberty/rename.c create mode 100644 libiberty/rindex.c create mode 100644 libiberty/sigsetmask.c create mode 100644 libiberty/spaces.c create mode 100644 libiberty/strcasecmp.c create mode 100644 libiberty/strchr.c create mode 100644 libiberty/strdup.c create mode 100644 libiberty/strerror.c create mode 100644 libiberty/strncasecmp.c create mode 100644 libiberty/strrchr.c create mode 100644 libiberty/strsignal.c create mode 100644 libiberty/strstr.c create mode 100644 libiberty/strtod.c create mode 100644 libiberty/strtol.c create mode 100644 libiberty/strtoul.c create mode 100644 libiberty/tmpnam.c create mode 100644 libiberty/vasprintf.c create mode 100644 libiberty/vfork.c create mode 100644 libiberty/vfprintf.c create mode 100644 libiberty/vmsbuild.com create mode 100644 libiberty/vprintf.c create mode 100644 libiberty/vsprintf.c create mode 100644 libiberty/waitpid.c create mode 100644 libiberty/xatexit.c create mode 100644 libiberty/xexit.c create mode 100644 libiberty/xmalloc.c create mode 100644 libiberty/xstrdup.c create mode 100644 libiberty/xstrerror.c create mode 100644 libio/ChangeLog create mode 100644 libio/Makefile.in create mode 100644 libio/NEWS create mode 100644 libio/PlotFile.cc create mode 100644 libio/PlotFile.h create mode 100644 libio/README create mode 100644 libio/SFile.cc create mode 100644 libio/SFile.h create mode 100644 libio/builtinbuf.cc create mode 100644 libio/builtinbuf.h create mode 100644 libio/cleanup.c create mode 100644 libio/config.shared create mode 100644 libio/config/hpux.mt create mode 100644 libio/config/isc.mt create mode 100644 libio/config/linux.mt create mode 100644 libio/config/mn10200.mt create mode 100644 libio/config/netware.mt create mode 100644 libio/config/sco4.mt create mode 100644 libio/configure.in create mode 100644 libio/dbz/Makefile.in create mode 100644 libio/dbz/README create mode 100644 libio/dbz/altbytes create mode 100644 libio/dbz/byteflip.c create mode 100644 libio/dbz/case.c create mode 100644 libio/dbz/case.h create mode 100644 libio/dbz/configure.in create mode 100644 libio/dbz/dbz.1 create mode 100644 libio/dbz/dbz.3z create mode 100644 libio/dbz/dbz.c create mode 100644 libio/dbz/dbz.h create mode 100644 libio/dbz/dbzmain.c create mode 100644 libio/dbz/fake.c create mode 100644 libio/dbz/firstlast25 create mode 100755 libio/dbz/getmap create mode 100644 libio/dbz/random.c create mode 100644 libio/dbz/revbytes create mode 100644 libio/dbz/stdio.h create mode 100644 libio/depend create mode 100644 libio/editbuf.cc create mode 100644 libio/editbuf.h create mode 100644 libio/filebuf.cc create mode 100644 libio/filedoalloc.c create mode 100644 libio/fileops.c create mode 100644 libio/floatconv.c create mode 100644 libio/floatio.h create mode 100644 libio/fstream.cc create mode 100644 libio/fstream.h create mode 100755 libio/gen-params create mode 100644 libio/genops.c create mode 100644 libio/indstream.cc create mode 100644 libio/indstream.h create mode 100644 libio/ioassign.cc create mode 100644 libio/ioextend.cc create mode 100644 libio/iofclose.c create mode 100644 libio/iofdopen.c create mode 100644 libio/iofflush.c create mode 100644 libio/iofgetpos.c create mode 100644 libio/iofgets.c create mode 100644 libio/iofopen.c create mode 100644 libio/iofprintf.c create mode 100644 libio/iofputs.c create mode 100644 libio/iofread.c create mode 100644 libio/iofscanf.c create mode 100644 libio/iofsetpos.c create mode 100644 libio/ioftell.c create mode 100644 libio/iofwrite.c create mode 100644 libio/iogetdelim.c create mode 100644 libio/iogetline.c create mode 100644 libio/iogets.c create mode 100644 libio/ioignore.c create mode 100644 libio/iolibio.h create mode 100644 libio/iomanip.cc create mode 100644 libio/iomanip.h create mode 100644 libio/iopadn.c create mode 100644 libio/ioperror.c create mode 100644 libio/iopopen.c create mode 100644 libio/ioprims.c create mode 100644 libio/ioprintf.c create mode 100644 libio/ioputs.c create mode 100644 libio/ioscanf.c create mode 100644 libio/ioseekoff.c create mode 100644 libio/ioseekpos.c create mode 100644 libio/iosetbuffer.c create mode 100644 libio/iosetvbuf.c create mode 100644 libio/iosprintf.c create mode 100644 libio/iosscanf.c create mode 100644 libio/iostdio.h create mode 100644 libio/iostream.cc create mode 100644 libio/iostream.h create mode 100644 libio/iostream.texi create mode 100644 libio/iostreamP.h create mode 100644 libio/iostrerror.c create mode 100644 libio/ioungetc.c create mode 100644 libio/iovfprintf.c create mode 100644 libio/iovfscanf.c create mode 100644 libio/iovsprintf.c create mode 100644 libio/iovsscanf.c create mode 100644 libio/isgetline.cc create mode 100644 libio/isgetsb.cc create mode 100644 libio/isscan.cc create mode 100644 libio/istream.h create mode 100644 libio/libio.h create mode 100644 libio/libioP.h create mode 100644 libio/osform.cc create mode 100644 libio/ostream.h create mode 100644 libio/outfloat.c create mode 100644 libio/parsestream.cc create mode 100644 libio/parsestream.h create mode 100644 libio/pfstream.cc create mode 100644 libio/pfstream.h create mode 100644 libio/procbuf.cc create mode 100644 libio/procbuf.h create mode 100644 libio/sbform.cc create mode 100644 libio/sbgetline.cc create mode 100644 libio/sbscan.cc create mode 100644 libio/stdfiles.c create mode 100644 libio/stdio/ChangeLog create mode 100644 libio/stdio/Makefile.in create mode 100644 libio/stdio/clearerr.c create mode 100644 libio/stdio/configure.in create mode 100644 libio/stdio/fdopen.c create mode 100644 libio/stdio/feof.c create mode 100644 libio/stdio/ferror.c create mode 100644 libio/stdio/fgetc.c create mode 100644 libio/stdio/fileno.c create mode 100644 libio/stdio/fputc.c create mode 100644 libio/stdio/freopen.c create mode 100644 libio/stdio/fseek.c create mode 100644 libio/stdio/getc.c create mode 100644 libio/stdio/getchar.c create mode 100644 libio/stdio/getline.c create mode 100644 libio/stdio/getw.c create mode 100644 libio/stdio/popen.c create mode 100644 libio/stdio/putc.c create mode 100644 libio/stdio/putchar.c create mode 100644 libio/stdio/putw.c create mode 100644 libio/stdio/rewind.c create mode 100644 libio/stdio/setbuf.c create mode 100644 libio/stdio/setfileno.c create mode 100644 libio/stdio/setlinebuf.c create mode 100644 libio/stdio/snprintf.c create mode 100644 libio/stdio/stdio.h create mode 100644 libio/stdio/vfprintf.c create mode 100644 libio/stdio/vfscanf.c create mode 100644 libio/stdio/vprintf.c create mode 100644 libio/stdio/vscanf.c create mode 100644 libio/stdio/vsnprintf.c create mode 100644 libio/stdiostream.cc create mode 100644 libio/stdiostream.h create mode 100644 libio/stdstrbufs.cc create mode 100644 libio/stdstreams.cc create mode 100644 libio/stream.cc create mode 100644 libio/stream.h create mode 100644 libio/streambuf.cc create mode 100644 libio/streambuf.h create mode 100644 libio/strfile.h create mode 100644 libio/strops.c create mode 100644 libio/strstream.cc create mode 100644 libio/strstream.h create mode 100644 libio/tests/ChangeLog create mode 100644 libio/tests/Makefile.in create mode 100644 libio/tests/configure.in create mode 100644 libio/tests/hounddog.cc create mode 100644 libio/tests/hounddog.exp create mode 100644 libio/tests/hounddog.inp create mode 100644 libio/tests/putbackdog.cc create mode 100644 libio/tests/tFile.cc create mode 100644 libio/tests/tFile.exp create mode 100644 libio/tests/tFile.inp create mode 100644 libio/tests/tfformat.c create mode 100644 libio/tests/tiformat.c create mode 100644 libio/tests/tiomanip.cc create mode 100644 libio/tests/tiomanip.exp create mode 100644 libio/tests/tiomisc.cc create mode 100644 libio/tests/tiomisc.exp create mode 100644 libio/tests/tstdiomisc.c create mode 100644 libio/tests/tstdiomisc.exp create mode 100644 libio/testsuite/ChangeLog create mode 100644 libio/testsuite/Makefile.in create mode 100644 libio/testsuite/config/default.exp create mode 100644 libio/testsuite/configure.in create mode 100644 libio/testsuite/lib/libio.exp create mode 100644 libio/testsuite/libio.tests/hounddog.exp create mode 100644 libio/testsuite/libio.tests/putbackdog.exp create mode 100644 libio/testsuite/libio.tests/tFile.exp create mode 100644 libio/testsuite/libio.tests/tfformat.exp create mode 100644 libio/testsuite/libio.tests/tiformat.exp create mode 100644 libio/testsuite/libio.tests/tiomanip.exp create mode 100644 libio/testsuite/libio.tests/tiomisc.exp create mode 100644 libio/testsuite/libio.tests/tstdiomisc.exp create mode 100644 libstdc++/ChangeLog create mode 100644 libstdc++/Makefile.in create mode 100644 libstdc++/NEWS create mode 100644 libstdc++/algorithm create mode 100644 libstdc++/cassert create mode 100644 libstdc++/cctype create mode 100644 libstdc++/cerrno create mode 100644 libstdc++/cfloat create mode 100644 libstdc++/cinst.cc create mode 100644 libstdc++/ciso646 create mode 100644 libstdc++/climits create mode 100644 libstdc++/clocale create mode 100644 libstdc++/cmath create mode 100644 libstdc++/cmathi.cc create mode 100644 libstdc++/complex create mode 100644 libstdc++/complex.h create mode 100644 libstdc++/config/aix.ml create mode 100644 libstdc++/config/dec-osf.ml create mode 100644 libstdc++/config/elf.ml create mode 100644 libstdc++/config/elfshlibm.ml create mode 100644 libstdc++/config/hpux.ml create mode 100644 libstdc++/config/irix5.ml create mode 100644 libstdc++/config/linux.ml create mode 100644 libstdc++/config/sol2shm.ml create mode 100644 libstdc++/config/sunos4.ml create mode 100644 libstdc++/configure.in create mode 100644 libstdc++/csetjmp create mode 100644 libstdc++/csignal create mode 100644 libstdc++/cstdarg create mode 100644 libstdc++/cstddef create mode 100644 libstdc++/cstdio create mode 100644 libstdc++/cstdlib create mode 100644 libstdc++/cstdlibi.cc create mode 100644 libstdc++/cstring create mode 100644 libstdc++/cstringi.cc create mode 100644 libstdc++/ctime create mode 100644 libstdc++/cwchar create mode 100644 libstdc++/cwctype create mode 100644 libstdc++/deque create mode 100644 libstdc++/functional create mode 100644 libstdc++/iterator create mode 100644 libstdc++/list create mode 100644 libstdc++/map create mode 100644 libstdc++/memory create mode 100644 libstdc++/numeric create mode 100644 libstdc++/queue create mode 100644 libstdc++/set create mode 100644 libstdc++/sinst.cc create mode 100644 libstdc++/stack create mode 100644 libstdc++/std/bastring.cc create mode 100644 libstdc++/std/bastring.h create mode 100644 libstdc++/std/complext.cc create mode 100644 libstdc++/std/complext.h create mode 100644 libstdc++/std/dcomplex.h create mode 100644 libstdc++/std/fcomplex.h create mode 100644 libstdc++/std/ldcomplex.h create mode 100644 libstdc++/std/straits.h create mode 100644 libstdc++/stdexcept create mode 100644 libstdc++/stdexcepti.cc create mode 100644 libstdc++/stl.h create mode 100644 libstdc++/stl/ChangeLog create mode 100644 libstdc++/stl/README create mode 100644 libstdc++/stl/algo.h create mode 100644 libstdc++/stl/algobase.h create mode 100644 libstdc++/stl/alloc.h create mode 100644 libstdc++/stl/bvector.h create mode 100644 libstdc++/stl/defalloc.h create mode 100644 libstdc++/stl/deque.h create mode 100644 libstdc++/stl/function.h create mode 100644 libstdc++/stl/hash_map.h create mode 100644 libstdc++/stl/hash_set.h create mode 100644 libstdc++/stl/hashtable.h create mode 100644 libstdc++/stl/heap.h create mode 100644 libstdc++/stl/iterator.h create mode 100644 libstdc++/stl/list.h create mode 100644 libstdc++/stl/map.h create mode 100644 libstdc++/stl/multimap.h create mode 100644 libstdc++/stl/multiset.h create mode 100644 libstdc++/stl/pair.h create mode 100644 libstdc++/stl/pthread_alloc.h create mode 100644 libstdc++/stl/rope.h create mode 100644 libstdc++/stl/ropeimpl.h create mode 100644 libstdc++/stl/set.h create mode 100644 libstdc++/stl/slist.h create mode 100644 libstdc++/stl/stack.h create mode 100644 libstdc++/stl/stl_config.h create mode 100644 libstdc++/stl/tempbuf.h create mode 100644 libstdc++/stl/tree.h create mode 100644 libstdc++/stl/type_traits.h create mode 100644 libstdc++/stl/vector.h create mode 100644 libstdc++/stlinst.cc create mode 100644 libstdc++/string create mode 100644 libstdc++/tests/ChangeLog create mode 100644 libstdc++/tests/Makefile.in create mode 100644 libstdc++/tests/configure.in create mode 100644 libstdc++/tests/tcomplex.cc create mode 100644 libstdc++/tests/tcomplex.exp create mode 100644 libstdc++/tests/tcomplex.inp create mode 100644 libstdc++/tests/tlist.cc create mode 100644 libstdc++/tests/tlist.exp create mode 100644 libstdc++/tests/tmap.cc create mode 100644 libstdc++/tests/tmap.exp create mode 100644 libstdc++/tests/tstring.cc create mode 100644 libstdc++/tests/tstring.exp create mode 100644 libstdc++/tests/tstring.inp create mode 100644 libstdc++/tests/tvector.cc create mode 100644 libstdc++/tests/tvector.exp create mode 100644 libstdc++/testsuite/ChangeLog create mode 100644 libstdc++/testsuite/Makefile.in create mode 100644 libstdc++/testsuite/config/default.exp create mode 100644 libstdc++/testsuite/configure.in create mode 100644 libstdc++/testsuite/lib/libstdc++.exp create mode 100644 libstdc++/testsuite/libstdc++.tests/test.exp create mode 100644 libstdc++/utility create mode 100644 libstdc++/vector create mode 100755 ltconfig create mode 100644 ltmain.sh create mode 100755 missing create mode 100755 mkinstalldirs create mode 100755 move-if-change create mode 100644 mpw-README create mode 100644 mpw-build.in create mode 100644 mpw-config.in create mode 100644 mpw-configure create mode 100755 symlink-tree create mode 100644 texinfo/COPYING create mode 100644 texinfo/ChangeLog create mode 100644 texinfo/INSTALL create mode 100644 texinfo/INTRODUCTION create mode 100644 texinfo/Makefile.in create mode 100644 texinfo/NEWS create mode 100644 texinfo/README create mode 100644 texinfo/TODO create mode 100644 texinfo/aclocal.m4 create mode 100755 texinfo/configure create mode 100644 texinfo/configure.in create mode 100644 texinfo/dir create mode 100644 texinfo/dir-example create mode 100644 texinfo/dir.info-template create mode 100644 texinfo/emacs/Makefile.in create mode 100644 texinfo/emacs/detexinfo.el create mode 100755 texinfo/emacs/elisp-comp create mode 100644 texinfo/emacs/info.el create mode 100644 texinfo/emacs/informat.el create mode 100644 texinfo/emacs/makeinfo.el create mode 100644 texinfo/emacs/new-useful-setqs create mode 100644 texinfo/emacs/texinfmt.el create mode 100644 texinfo/emacs/texinfo.el create mode 100644 texinfo/emacs/texnfo-tex.el create mode 100644 texinfo/emacs/texnfo-upd.el create mode 100755 texinfo/gen-info-dir create mode 100644 texinfo/gpl.texinfo create mode 100644 texinfo/info/Makefile.in create mode 100644 texinfo/info/NEWS create mode 100644 texinfo/info/README create mode 100644 texinfo/info/clib.c create mode 100644 texinfo/info/clib.h create mode 100644 texinfo/info/dir.c create mode 100644 texinfo/info/display.c create mode 100644 texinfo/info/display.h create mode 100644 texinfo/info/doc.h create mode 100644 texinfo/info/dribble.c create mode 100644 texinfo/info/dribble.h create mode 100644 texinfo/info/echo_area.c create mode 100644 texinfo/info/echo_area.h create mode 100644 texinfo/info/filesys.c create mode 100644 texinfo/info/filesys.h create mode 100644 texinfo/info/footnotes.c create mode 100644 texinfo/info/footnotes.h create mode 100644 texinfo/info/gc.c create mode 100644 texinfo/info/gc.h create mode 100644 texinfo/info/general.h create mode 100644 texinfo/info/indices.c create mode 100644 texinfo/info/indices.h create mode 100644 texinfo/info/info-stnd.texi create mode 100644 texinfo/info/info-utils.c create mode 100644 texinfo/info/info-utils.h create mode 100644 texinfo/info/info.1 create mode 100644 texinfo/info/info.c create mode 100644 texinfo/info/info.h create mode 100644 texinfo/info/info.texi create mode 100644 texinfo/info/infodoc.c create mode 100644 texinfo/info/infomap.c create mode 100644 texinfo/info/infomap.h create mode 100644 texinfo/info/m-x.c create mode 100644 texinfo/info/makedoc.c create mode 100644 texinfo/info/man.c create mode 100644 texinfo/info/man.h create mode 100644 texinfo/info/nodemenu.c create mode 100644 texinfo/info/nodes.c create mode 100644 texinfo/info/nodes.h create mode 100644 texinfo/info/search.c create mode 100644 texinfo/info/search.h create mode 100644 texinfo/info/session.c create mode 100644 texinfo/info/session.h create mode 100644 texinfo/info/signals.c create mode 100644 texinfo/info/signals.h create mode 100644 texinfo/info/termdep.h create mode 100644 texinfo/info/terminal.c create mode 100644 texinfo/info/terminal.h create mode 100644 texinfo/info/tilde.c create mode 100644 texinfo/info/tilde.h create mode 100644 texinfo/info/userdoc.texi create mode 100644 texinfo/info/variables.c create mode 100644 texinfo/info/variables.h create mode 100644 texinfo/info/window.c create mode 100644 texinfo/info/window.h create mode 100644 texinfo/info/xmalloc.c create mode 100755 texinfo/install-sh create mode 100644 texinfo/lgpl.texinfo create mode 100644 texinfo/liblic.texi create mode 100644 texinfo/libtxi/Makefile.in create mode 100644 texinfo/libtxi/alloca.c create mode 100644 texinfo/libtxi/bzero.c create mode 100644 texinfo/libtxi/getopt.c create mode 100644 texinfo/libtxi/getopt.h create mode 100644 texinfo/libtxi/getopt1.c create mode 100644 texinfo/libtxi/memcpy.c create mode 100644 texinfo/libtxi/memmove.c create mode 100644 texinfo/libtxi/strdup.c create mode 100644 texinfo/license.texi create mode 100644 texinfo/makeinfo/Makefile.in create mode 100644 texinfo/makeinfo/macro.texi create mode 100644 texinfo/makeinfo/macros/example.texi create mode 100644 texinfo/makeinfo/macros/html.texi create mode 100644 texinfo/makeinfo/macros/multifmt.texi create mode 100644 texinfo/makeinfo/macros/res-samp.texi create mode 100644 texinfo/makeinfo/macros/resume.texi create mode 100644 texinfo/makeinfo/macros/simpledoc.texi create mode 100644 texinfo/makeinfo/makeinfo.c create mode 100644 texinfo/makeinfo/makeinfo.h create mode 100644 texinfo/makeinfo/makeinfo.texi create mode 100644 texinfo/makeinfo/multi.c create mode 100644 texinfo/makeinfo/multiformat.texi create mode 100644 texinfo/testsuite/ChangeLog create mode 100644 texinfo/testsuite/Makefile.in create mode 100644 texinfo/testsuite/config/unix.exp create mode 100755 texinfo/testsuite/configure create mode 100644 texinfo/testsuite/configure.in create mode 100644 texinfo/testsuite/lib/utils.exp create mode 100644 texinfo/testsuite/makeinfo.0/atnode.exp create mode 100644 texinfo/testsuite/makeinfo.0/conditions.exp create mode 100644 texinfo/testsuite/makeinfo.0/mini.exp create mode 100644 texinfo/testsuite/makeinfo.0/missnode.exp create mode 100644 texinfo/testsuite/makeinfo.0/nonsense.exp create mode 100644 texinfo/testsuite/makeinfo.0/not.exp create mode 100644 texinfo/testsuite/makeinfo.0/smstruct.exp create mode 100644 texinfo/testsuite/text/atnode.texi create mode 100644 texinfo/testsuite/text/conditions.texi create mode 100644 texinfo/testsuite/text/dfltnode.texi create mode 100644 texinfo/testsuite/text/minimal.texi create mode 100644 texinfo/testsuite/text/missnode.texi create mode 100644 texinfo/testsuite/text/nonsense.texi create mode 100644 texinfo/testsuite/text/not.texi create mode 100644 texinfo/testsuite/text/smstruct.texi create mode 100644 texinfo/texinfo.tex create mode 100644 texinfo/texinfo.texi create mode 100644 texinfo/util/Makefile.in create mode 100644 texinfo/util/deref.c create mode 100755 texinfo/util/fixfonts create mode 100755 texinfo/util/gen-dir-node create mode 100644 texinfo/util/install-info.c create mode 100755 texinfo/util/mkinstalldirs create mode 100755 texinfo/util/tex3patch create mode 100755 texinfo/util/texi2dvi create mode 100644 texinfo/util/texindex.c create mode 100644 xiberty/configure.in create mode 100755 ylwrap diff --git a/.cvsignore b/.cvsignore new file mode 100644 index 00000000000..944dd6db952 --- /dev/null +++ b/.cvsignore @@ -0,0 +1,31 @@ +*-all +*-co +*-dirs +*-done +*-info +*-install +*-install-info +*-src +*-stamp-* +*-tagged +blockit +cfg-paper.info +config.status +configure.aux +configure.cp +configure.cps +configure.dvi +configure.fn +configure.fns +configure.ky +configure.kys +configure.log +configure.pg +configure.pgs +configure.toc +configure.tp +configure.tps +configure.vr +configure.vrs +dir.info +Makefile diff --git a/COPYING b/COPYING new file mode 100644 index 00000000000..60549be514a --- /dev/null +++ b/COPYING @@ -0,0 +1,340 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 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. + + 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. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. 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. + + 1. 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. + + 2. 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: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) 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. + + c) 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.) + +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. + + 3. 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: + + a) 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, + + b) 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, + + c) 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.) + +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. + + 4. 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. + + 5. 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. + + 6. 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. + + 7. 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. + + 8. 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. + + 9. 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. + + 10. 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. + + NO WARRANTY + + 11. 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. + + 12. 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 OF TERMS AND CONDITIONS + + 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. + + + Copyright (C) 19yy + + 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 + + +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: + + Gnomovision version 69, Copyright (C) 19yy 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. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `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: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +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. diff --git a/COPYING.LIB b/COPYING.LIB new file mode 100644 index 00000000000..eb685a5ec98 --- /dev/null +++ b/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/ChangeLog b/ChangeLog new file mode 100644 index 00000000000..5d2401a295e --- /dev/null +++ b/ChangeLog @@ -0,0 +1,5207 @@ +Wed Aug 20 19:57:37 1997 Jason Merrill + + * Makefile.in (BISON, YACC): Use $$s. + (all-bison): Depend on all-texinfo. + +Tue Aug 19 01:41:32 1997 Jason Merrill + + * Makefile.in (BISON): Add -L flag. + (YACC): Likewise. + + + +Mon Aug 18 09:24:06 1997 Gavin Koch + + * config.sub: Add mipstx39. Delete r3900. + +Mon Aug 18 17:20:10 1997 Jason Molenda (crash@godzilla.cygnus.co.jp) + + * Makefile.in (all-autoconf): Depends on all-texinfo. + +Fri Aug 15 23:09:26 1997 Michael Meissner + + * config-ml.in ({powerpc,rs6000}*-*-*): Update to current AIX and + eabi targets. + +Thu Aug 14 14:42:17 1997 Ian Lance Taylor + + * configure: Get CFLAGS and CXXFLAGS from Makefile, if possible. + + * configure: When handling a Canadian Cross, handle YACC as well as + BISON. Just set BISON to bison. When setting YACC, prefer bison. + +Tue Aug 12 20:09:48 1997 Jason Merrill + + * Makefile.in (BISON): bison, not byacc or bison -y. + (YACC): bison -y or byacc or yacc. + (various): Add *-bison as appropriate. + (taz): No need to mess with BISON anymore. + +Tue Aug 12 22:33:08 1997 Ian Lance Taylor + + * configure: If OSTYPE matches *win32*, try to find a good value for + CONFIG_SHELL. + +Sun Aug 10 14:41:11 1997 Ian Lance Taylor + + * Makefile.in (taz): Get the version number from AM_INIT_AUTOMAKE in + configure.in if it is present. + +Sat Aug 9 00:58:01 1997 Ian Lance Taylor + + * Makefile.in (LD_FOR_TARGET): Change ld.new to ld-new. + +Fri Aug 8 16:30:13 1997 Doug Evans + + * config.sub: Recognize `arc' cpu. + * configure.in: Likewise. + * config-ml.in: Likewise. + +Thu Aug 7 11:02:34 1997 Ian Lance Taylor + + * Makefile.in ($(INSTALL_X11_MODULES)): Depend upon installdirs. + +Wed Aug 6 16:27:29 1997 Chris Provenzano + + * configure: Changed sed delimiter from ':' to '|' when + attempting to substitute ${config_shell} for SHELL. On + NT ${config_shell} may contain a ':' in it. + +Wed Aug 6 12:29:05 1997 Jason Merrill + + * Makefile.in (EXTRA_GCC_FLAGS): Fix for non-bash shells. + +Wed Aug 6 00:42:35 1997 Ian Lance Taylor + + * Makefile.in (AS_FOR_TARGET): Change as.new to as-new. + +Tue Aug 5 14:08:51 1997 Ian Lance Taylor + + * Makefile.in (NM_FOR_TARGET): Change nm.new to nm-new. + + * ylwrap: If the program is a relative path, force it to be + absolute. + +Tue Aug 5 12:12:44 1997 Andrew Cagney + + * configure (tooldir): Set BISON to `bison -y' and not just bison. + +Mon Aug 4 22:59:02 1997 Andrew Cagney + + * Makefile.in (CC_FOR_TARGET): When winsup/Makefile present, + correctly specify the target build directory $(TARGET_SUBDIR)/winsup + for libraries. + +Mon Aug 4 12:40:24 1997 Jason Merrill + + * Makefile.in (EXTRA_GCC_FLAGS): Fix handling of macros with values + separated by spaces. + +Thu Jul 31 19:49:49 1997 Ian Lance Taylor + + * ylwrap: New file. + * Makefile.in (DEVO_SUPPORT): Add ylwrap. + + * ltmain.sh: Handle /bin/sh at start of install program. + + * Makefile.in (DEVO_SUPPORT): Add ltconfig, ltmain.sh, and missing. + + * ltconfig, ltmain.sh: New files, from libtool 1.0. + * missing: New file, from automake 1.2. + +Thu Jul 24 12:57:56 1997 Ian Lance Taylor + + * Makefile.in: Treat tix like tk, putting it in X11_MODULES. Add + check-tk to CHECK_X11_MODULES. + +Wed Jul 23 17:03:29 1997 Ian Lance Taylor + + * config.sub: Merge with FSF. + +Tue Jul 22 19:08:29 1997 Ian Lance Taylor + + * config.guess: Merge with FSF. + +Tue Jul 22 14:50:42 1997 Robert Hoehne + + * configure: Treat msdosdjgpp like go32. + * configure.in: Likewise. Don't remove gprof for go32. + + * configure: Change Makefile.tem2 to Makefile.tm2. + +Mon Jul 21 10:31:26 1997 Stephen Peters + + * configure.in (noconfigdirs): For alpha-dec-osf*, don't ignore grep. + +Tue Jul 15 14:33:03 1997 Brendan Kehoe + + * install-sh (chmodcmd): Set to null if the DST directory already + exists. Same as Nov 11th change. + +Mon Jul 14 11:01:15 1997 Martin M. Hunt + + * configure (GDB_TK): Needs itcl and tix. + +Mon Jul 14 00:32:10 1997 Jason Merrill + + * config.guess: Update from FSF. + +Fri Jul 11 11:57:11 1997 Martin M. Hunt + + * Makefile.in (GDB_TK): Depend on itcl and tix. + +Fri Jul 4 13:25:31 1997 Ian Lance Taylor + + * Makefile.in (INSTALL_PROGRAM_ARGS): New variable. + (INSTALL_PROGRAM): Use $(INSTALL_PROGRAM_ARGS). + (INSTALL_SCRIPT): New variable. + (BASE_FLAGS_TO_PASS): Pass down INSTALL_SCRIPT. + * configure.in: If host is *-*-cygwin32*, set INSTALL_PROGRAM_ARGS + to -x. + * install-sh: Add support for -x option. + +Mon Jun 30 15:51:30 1997 Ian Lance Taylor + + * configure.in, Makefile.in: Treat tix like itcl. + +Thu Jun 26 13:59:19 1997 Ian Lance Taylor + + * Makefile.in (WINDRES): New variable. + (WINDRES_FOR_TARGET): New variable. + (BASE_FLAGS_TO_PASS): Add WINDRES_FOR_TARGET. + (EXTRA_HOST_FLAGS): Add WINDRES. + (EXTRA_TARGET_FLAGS): Add WINDRES. + (EXTRA_GCC_FLAGS): Add WINDRES. + ($(DO_X)): Pass down WINDRES. + ($(CONFIGURE_TARGET_MODULES)): Set WINDRES when configuring. + * configure: Treat WINDRES like DLLTOOL, and WINDRES_FOR_TARGET like + DLLTOOL_FOR_TARGET. + +Wed Jun 25 15:01:26 1997 Felix Lee + + * configure.in: configure sim before gdb for win32-x-ppc + +Wed Jun 25 12:18:54 1997 Brendan Kehoe + + Move gperf into the toplevel, from libg++. + * configure.in (target_tools): Add target-gperf. + (native_only): Add target-gperf. + * Makefile.in (all-target-gperf): New target, depend on + all-target-libg++. + (configure-target-gperf): Empty rule. + (ALL_TARGET_MODULES): Add all-target-gperf. + (CONFIGURE_TARGET_MODULES): Add configure-target-gperf. + (CHECK_TARGET_MODULES): Add check-target-gperf. + (INSTALL_TARGET_MODULES): Add install-target-gperf. + (CLEAN_TARGET_MODULES): Add clean-target-gperf. + +Mon Jun 23 10:51:53 1997 Jeffrey A Law (law@cygnus.com) + + * config.sub (mn10200): Recognize new basic machine. + +Thu Jun 19 14:16:42 1997 Brendan Kehoe + + * configure.in: Don't set ENABLE_MULTILIB, so we'll be passing + --enable-multilib down to subdirs; setting TARGET_SUBDIR was enough. + +Tue Jun 17 15:31:20 1997 Brendan Kehoe + + * configure.in: If we're building mips-sgi-irix6* native, turn on + ENABLE_MULTILIB and set TARGET_SUBDIR. + +Tue Jun 17 12:20:59 1997 Tom Tromey + + * Makefile.in (all-sn): Depend on all-grep. + +Mon Jun 16 11:11:10 1997 Ian Lance Taylor + + * configure.in: Use mh-ppcpic and mt-ppcpic for powerpc*-* targets. + + * configure: Set CFLAGS and CXXFLAGS, and substitute them into + Makefile. From Jeff Makey . + * Makefile.in: Add comment for CFLAGS and CXXFLAGS. + + * Makefile.in (DISTBISONFILES): Remove. + (taz): Don't futz with DISTBISONFILES. Change BISON to use + $(DEFAULT_YACC). + + * configure.in: Build itl, db, sn, etc., when building for native + cygwin32. + + * Makefile.in (LD): New variable. + (EXTRA_HOST_FLAGS): Pass down LD. + ($(DO_X)): Likewise. + +Mon Jun 16 11:10:35 1997 Philip Blundell + + * Makefile.in (INSTALL): Use $(SHELL) when executing install-sh. + +Fri Jun 13 10:22:56 1997 Bob Manson + + * configure.in (targargs): Strip out any supplied --build argument + before adding our own. Always add --build. + +Thu Jun 12 21:12:28 1997 Bob Manson + + * configure.in (targargs): Pass --build if we're doing + a cross-compile. + +Fri Jun 6 21:38:40 1997 Rob Savoye + + * configure: Use '|' instead of ":" as the seperator in + sed. Otherwise sed chokes on NT path names with drive + designators. Also look for "?:*" as the leading characters in an + absolute pathname. + +Mon Jun 2 13:05:20 1997 Gavin Koch + + * config.sub: Support for r3900. + +Wed May 21 17:33:31 1997 Ian Lance Taylor + + * configure.in: Use install-sh, not install.sh. + +Wed May 14 16:06:51 1997 Ian Lance Taylor + + * Makefile.in (taz): Improve check for BISON so it doesn't try to + apply it twice. + +Fri May 9 17:22:05 1997 Ian Lance Taylor + + * Makefile.in (INSTALL_MODULES): Put install-opcodes before + install-binutils. + +Thu May 8 17:29:50 1997 Ian Lance Taylor + + * Makefile.in: Add automake targets. + * configure.in (host_tools): Add automake. + +Tue May 6 15:49:52 1997 Ian Lance Taylor + + * configure: Default CXX to c++, not gcc. + * Makefile.in (CXX): Set to c++, not gcc. + (CXX_FOR_TARGET): When cross, transform c++, not gcc. + +Thu May 1 10:11:43 1997 Geoffrey Noer + + * install-sh: try appending a .exe if source file doesn't + exist + +Wed Apr 30 12:05:36 1997 Jason Merrill + + * configure.in: Turn on multilib by default. + (cross_only): Remove target-libiberty. + + * Makefile.in (all-gcc): Don't depend on libiberty. + +Mon Apr 28 18:39:45 1997 Michael Snyder + + * config.guess: improve algorithm for recognizing Gnu Hurd x86. + +Thu Apr 24 19:30:07 1997 Ian Lance Taylor + + * Makefile.in (DEVO_SUPPORT): Add mpw-install. + (DISTBISONFILES): Add ld/Makefile.in + +Tue Apr 22 17:17:28 1997 Geoffrey Noer + + * configure.in: if target is cygwin32 but host isn't cygwin32, + don't configure gdb tcl tk expect, not just gdb. + +Mon Apr 21 13:33:39 1997 Tom Tromey + + * configure.in: Added gnuserv everywhere sn appears. + + * Makefile.in (ALL_MODULES): Added all-gnuserv. + (CROSS_CHECK_MODULES): Added check-gnuserv. + (INSTALL_MODULES): Added install-gnuserv. + (CLEAN_MODULES): Added clean-gnuserv. + (all-gnuserv): New target. + +Thu Apr 17 13:57:06 1997 Per Fogelstrom + + * config.guess: Fixes for MIPS OpenBSD systems. + +Tue Apr 15 12:21:07 1997 Ian Lance Taylor + + * Makefile.in (INSTALL_XFORM): Remove. + (BASE_FLAGS_TO_PASS): Remove INSTALL_XFORM. + + * mkinstalldirs: New file, copied from automake. + * Makefile.in (installdirs): Rename from install-dirs. Use + mkinstalldirs. Change all users. + (DEVO_SUPPORT): Add mkinstalldirs. + +Mon Apr 14 11:21:38 1997 Ian Lance Taylor + + * install-sh: Rename from install.sh. + * Makefile.in (INSTALL): Change install.sh to install-sh. + (DEVO_SUPPORT): Likewise. + + * configure: Use ${config_shell} with ${moveifchange}. From Thomas + Graichen . + +Fri Apr 11 16:37:10 1997 Niklas Hallqvist + + * config.guess: Recognize OpenBSD systems correctly. + +Fri Apr 11 17:07:04 1997 Jason Molenda (crash@godzilla.cygnus.co.jp) + + * README, Makefile.in (ETC_SUPPORT): Remove references to + cfg-paper*, configure.{texi,man,info*}._ + +Sun Apr 6 18:47:57 1997 Andrew Cagney + + * Makefile.in (all.normal): Ensure that gcc is built after all + the x11 - ie gdb - targets. + +Tue Apr 1 16:28:50 1997 Klaus Kaempf + + * makefile.vms: Don't run conf-a-gas. + +Mon Mar 31 16:26:55 1997 Joel Sherrill + + * configure.in (hppa1.1-*-rtems*): New target, like hppa-*-*elf*. + +Fri Mar 28 18:28:52 1997 Ian Lance Taylor + + * configure: Set cache_file to config.cache. + * Makefile.in (local-distclean): Remove config.cache. + +Wed Mar 26 18:49:39 1997 Ian Lance Taylor + + * COPYING: Update FSF address. + +Mon Mar 24 15:02:39 1997 Ian Lance Taylor + + * Makefile.in (install-dirs): Don't crash if prefix, and hence + MAKEDIRS, is empty. + +Mon Mar 24 12:40:55 1997 Doug Evans + + * config.sub: Tweak mn10300 entry. + +Fri Mar 21 15:35:27 1997 Michael Meissner + + * configure.in (host_tools): Put sim before gdb, so gdb's + configure.tgt can determine if the simulator was configured. + +Sun Mar 16 16:07:08 1997 Fred Fish + + * config.sub: Move BeOS $os case to be with other Cygnus + local cases. + +Sun Mar 16 01:34:55 1997 Martin Hunt + + * config.sub: Remove misplaced comment that broke Linux. + +Sat Mar 15 22:50:15 1997 Fred Fish + + * config.sub: Add BeOS support. + +Mon Mar 10 13:30:11 1997 Tom Tromey + + * Makefile.in (CHECK_X11_MODULES): Don't run check-tk. + +Wed Mar 5 12:09:29 1997 Martin + + * configure.in (noconfigdirs): Remove tcl and tk from + noconfigdirs for cygwin32 builds. + +Thu Feb 27 14:57:26 1997 Ken Raeburn + + * Makefile.in (GAS_SUPPORT_DIRS, BINUTILS_SUPPORT_DIRS): Remove + make-all.com, use makefile.vms instead. + +Tue Feb 25 18:46:14 1997 Stan Shebs + + * config.sub: Accept -lnews*. + +Thu Feb 13 22:04:44 1997 Klaus Kaempf + + * makefile.vms: New file. + * make-all.com: Remove. + +Wed Feb 12 12:54:18 1997 Jim Wilson + + * Makefile.in (EXTRA_GCC_FLAGS): Add LIBGCC2_DEBUG_CFLAGS. + +Sat Feb 8 20:36:49 1997 Michael Meissner + + * Makefile.in (all-itcl): The rule is all-itcl, not all-tcl. + +Tue Feb 4 11:39:29 1997 Tom Tromey + + * Makefile.in (ALL_MODULES): Added all-db. + (CROSS_CHECK_MODULES): Addec check-db. + (INSTALL_MODULES): Added install-db. + (CLEAN_MODULES): Added clean-db. + +Mon Feb 3 13:29:36 1997 Ian Lance Taylor + + * config.guess: Merge with latest FSF sources. + +Tue Jan 28 09:20:37 1997 Tom Tromey + + * Makefile.in (ALL_MODULES): Added all-itcl. + (CROSS_CHECK_MODULES): Added check-itcl. + (INSTALL_MODULES): Added install-itcl. + (CLEAN_MODULES): Added clean-itcl. + +Thu Jan 23 01:44:27 1997 Geoffrey Noer + + * configure.in: build gdb for mn10200 + +Fri Jan 17 15:32:15 1997 Doug Evans + + * Makefile.in (all-target-winsup): Depend on all-target-libio. + +Fri Jan 3 16:04:03 1997 Ian Lance Taylor + + * Makefile.in (MAKEINFO): Check for the existence of the Makefile, + rather than the makeinfo program. + (do-info): Depend upon all-texinfo. + +Tue Dec 31 16:00:31 1996 Ian Lance Taylor + + * configure.in: Remove uses of config/mh-linux. + + * config.sub, config.guess: Merge with latest FSF sources. + +Fri Dec 27 12:07:59 1996 Ian Lance Taylor + + * config.sub, config.guess: Merge with latest FSF sources. + +Wed Dec 18 22:46:39 1996 Stan Shebs + + * mpw-build.in: Build ld before gcc, use NewFolderRecursive. + * mpw-config.in: Test for NewFolderRecursive. + * mpw-install: Use symbolic name for startup filename. + * mpw-README: Add various additional details. + +Wed Dec 18 13:11:46 1996 Jim Wilson + + * configure.in (mips*-sgi-irix6*): Remove binutils from noconfigdirs. + +Wed Dec 18 10:29:31 1996 Jeffrey A Law (law@cygnus.com) + + * configure.in: Do build gcc and the target libraries for + the mn10200. + +Wed Dec 4 16:53:05 1996 Geoffrey Noer + + * configure.in: don't avoid building gdb for mn10300 any more + * Makefile.in: double-quote GCC_FOR_TARGET line in EXTRA_GCC_FLAGS + instead of single-quoting it. + +Tue Dec 3 23:26:50 1996 Jason Merrill + + * configure.in: Don't use --with-stabs on IRIX 6. + +Tue Dec 3 09:05:25 1996 Doug Evans + + * configure.in (m32r): Build gdb, libg++ now. + +Sun Dec 1 00:18:59 1996 Peter Schauer (pes@regent.e-technik.tu-muenchen.de) + + * configure.in (mips*-sgi-irix6*): Remove gdb and related + directories from noconfigdirs. + +Tue Nov 26 11:45:33 1996 Kim Knuttila + + * config.sub (basic_machine): added mips16 configuration + +Sat Nov 23 19:26:22 1996 Michael Meissner + + * config.sub: Handle d10v-unknown. + +Thu Nov 21 16:19:44 1996 Geoffrey Noer + + * Makefile.in: add findutils + * configure.in: add findutils to list of host_tools + +Wed Nov 20 10:09:01 1996 Jeffrey A Law (law@cygnus.com) + + * config.sub: Handle mn10200 and mn10300. + +Tue Nov 19 16:35:14 1996 Michael Meissner + + * configure.in (d10v-*): Do not build librx. + +Mon Nov 18 13:28:41 1996 Jeffrey A Law (law@cygnus.com) + + * configure.in (mn10300): Build everything except gdb & libgloss. + +Wed Nov 13 14:59:46 1996 Per Bothner + + * config.guess: Patch for Dansk Data Elektronik servers, + from Niels Skou Olsen . + + For ncr, use /bin/uname rather than uname, since GNU uname does not + support -p. Suggested by Mark Mitchell . + + Patch for MIPS R4000 running System V, + from Eric S. Raymond . + + Fix thinko for nextstep. + + Patch for OSF1 in i?86, from Dan Murphy via Harlan Stenn. + + Sat Jun 24 18:58:17 1995 Morten Welinder + * config.guess: Guess mips-dec-mach_bsd4.3. + + Thu Oct 10 04:07:04 1996 Harlan Stenn + * config.guess (i?86-ncr-sysv*): Emit just enough of the minor + release numbers. + * config.guess (mips-mips-riscos*): Emit just enough of the + release number. + + Tue Oct 8 10:37:22 1996 Frank Vance + * config.guess (sparc-auspex-sunos*): Added. + (f300-fujitsu-*): Added. + + Wed Sep 25 22:00:35 1996 Jeff Woolsey + * config.guess: Recognize a Tadpole as a sparc. + +Wed Nov 13 00:53:09 1996 David J. MacKenzie + + * config.guess: Don't assume that NextStep version is either 2 or + 3. NextStep 4 (aka OpenStep 4) has come out now. + +Mon Nov 11 23:52:03 1996 David J. MacKenzie + + * config.guess: Support Cray T90 that reports itself as "CRAY TS". + From Rik Faith . + +Fri Nov 8 11:34:58 1996 David J. MacKenzie + + * config.sub: Contributions from bug-gnu-utils to: + Support plain "hppa" (no version given) architecture, reported by + OpenStep. + OpenBSD like NetBSD. + LynxOs is not a hardware supplier. + + * config.guess: Contributions from bug-gnu-utils to add support for: + OpenBSD like NetBSD. + Stratus systems. + More Pyramid systems. + i[n>4]86 Intel chips. + M680[n>4]0 Motorola chips. + Use unknown instead of lynx for hardware manufacturer. + +Mon Nov 11 10:09:08 1996 Brendan Kehoe + + * install.sh (chmodcmd): Set to null if the DST directory already + exists. + +Mon Nov 11 10:43:41 1996 Michael Meissner + + * configure.in (powerpc*-{eabi,elf,linux,rtem,sysv,solaris}*): Do + not use mt-ppc target Makefile fragment any more. + +Sun Nov 3 19:17:07 1996 Stu Grossman (grossman@critters.cygnus.com) + + * configure.in (*-*-windows): Exclude everything but those dirs + needed to build windows. + +Tue Oct 29 16:41:31 1996 Doug Evans + + * Makefile.in (all-target-winsup): Depend on all-target-librx. + +Mon Oct 28 17:32:46 1996 Stu Grossman (grossman@critters.cygnus.com) + + * configure.in: Exclude mmalloc from i386-windows. + * config/mh-windows: Add rules for building MSVC makefiles. + +Thu Oct 24 09:22:46 1996 Stu Grossman (grossman@critters.cygnus.com) + + * Undo my previous change. + +Thu Oct 24 12:12:04 1996 Ian Lance Taylor + + * Makefile.in (EXTRA_GCC_FLAGS): Pass down GCC_FOR_TARGET + unconditionally. + (MAKEOVERRIDES): Define (revert this part of October 18 change). + +Thu Oct 24 09:02:07 1996 Stu Grossman (grossman@critters.cygnus.com) + + * Makefile.in (FLAGS_TO_PASS): Add $(HOST_FLAGS) to allow the + host to add it's own flags. + * config/mh-windows (HOST_FLAGS): Set srcroot, which is needed + for MSVC build procedure. + +Tue Oct 22 15:20:26 1996 Ian Lance Taylor + + * configure: Handle GCC_FOR_TARGET like CC_FOR_TARGET. + +Fri Oct 18 13:37:13 1996 Ian Lance Taylor + + * Makefile.in (CC_FOR_TARGET): Check for xgcc, not Makefile. + (CXX_FOR_TARGET): Likewise. + (GCC_FOR_TARGET): Define. + (BASE_FLAGS_TO_PASS): Remove GCC_FOR_TARGET. + (EXTRA_GCC_FLAGS): Define GCC_FOR_TARGET based on whether + CC_FOR_TARGET was specified on the command line. + (MAKEOVERRIDES): Don't define. + +Thu Oct 17 10:27:56 1996 Doug Evans + + * configure.in (m32r): Fix spelling of libg++ libs. + +Thu Oct 10 10:37:17 1996 Stan Shebs + + * config.sub (-apple*): Remove, now redundant. + +Thu Oct 10 12:30:54 1996 Ian Lance Taylor + + * configure: Don't get confused by CPU-VENDOR-linux-gnu. + + * configure: Rework yesterday's sed script patch. + + * config.sub: Merge with FSF. + +Wed Oct 9 17:24:59 1996 Per Bothner + + * config.guess: Merge from FSF. + + 1996-09-12 Richard Stallman + * config.guess: Use pc instead of unknown, for pc clone systems. + Change linux to linux-gnu. + + Mon Jul 15 23:51:11 1996 Karl Heuer + * config.guess: Avoid non-portable tr syntax. + +Wed Oct 9 06:06:46 1996 Jeffrey A Law (law@cygnus.com) + + * test-build.mk (HOLES): Add "xargs" for gdb. + + * configure: Avoid hpux10.20 sed bug. + +Tue Oct 8 08:32:48 1996 Stu Grossman (grossman@critters.cygnus.com) + + * configure.in config/mh-windows: Add support for windows host + (that is a build done under the Microsoft build environment). + +Tue Oct 8 10:39:08 1996 Ian Lance Taylor + + * Makefile.in: Replace all uses of srcroot with s, to shrink + command line lengths. + + Patches from Geoffrey Noer : + * configure.in: If configuring for newlib, pass --with-newlib to + subdirectories. + * Makefile.in (CC_FOR_TARGET): If winsup/Makefile exists, pass a + -Bnewlib/ and -Lwinsup to gcc. + (CXX_FOR_TARGET): Likewise. + +Mon Oct 7 10:59:35 1996 Ian Lance Taylor + + * Makefile.in (ETC_SUPPORT): Add configure. + +Fri Oct 4 12:22:58 1996 Angela Marie Thomas (angela@cygnus.com) + + * configure.in: Use config/mh-dgux386 for i[345]86-dg-dgux + host configuration file. + +Thu Oct 3 09:28:25 1996 Jeffrey A Law (law@cygnus.com) + + * configure.in: Break mn10x00 support into separate + mn10200 and mn10300 configurations. + * config.sub: Likewise. + +Wed Oct 2 22:27:52 1996 Jeffrey A Law (law@cygnus.com) + + * configure.in: Add lots of stuff to noconfigdirs for + the mn10x00 targets. + + * config.sub, configure.in: Add mn10x00 support. + +Wed Oct 2 15:52:36 1996 Klaus Kaempf + + * make-all.com: Call conf-a-gas, not config-a-gas. + +Tue Oct 1 01:28:41 1996 James G. Smith + + * configure.in (noconfigdirs): Don't build libgloss for arm-coff + targets. + +Mon Sep 30 14:24:01 1996 Stan Shebs + + * mpw-README: Add much more detail for native PowerMac. + * mpw-install: New file. + * mpw-configure: Add --norecursion and --help options. + * mpw-config.in: Translate readme and install files when + copying to objdir. + * mpw-build.in: Don't always depend on byacc and flex. + (install-only-top): New action. + +Tue Sep 24 19:05:12 1996 Stan Shebs + + * configure.in (noconfigdirs): Don't configure any C++ dirs + if targeting D10V. + +Tue Sep 17 12:15:31 1996 Ian Lance Taylor + + * config.sub: Recognize mips64vr5000. + +Mon Sep 16 17:00:52 1996 Ian Lance Taylor + + * configure.in: Use a single line for host_tools and native_only. + +Mon Sep 9 12:21:30 1996 Doug Evans + + * config.sub, configure.in: Add entries for m32r. + +Thu Sep 5 13:52:47 1996 Tom Tromey + + * Makefile.in (inet-install): Don't run install-gzip. + +Wed Sep 4 17:26:13 1996 Stu Grossman (grossman@critters.cygnus.com) + + * configure.in: Don't config lots of things for *-*-windows*. + +Sat Aug 31 11:45:57 1996 Stan Shebs + + * mpw-config.in: Test for mpw-true, true, and null-command scripts. + (host_libs, host_tools): Copy from configure.in. + * mpw-configure: Don't complain about directories not found. + +Thu Aug 29 16:44:58 1996 Michael Meissner + + * configure.in (i[345]86): Recognize i686 for pentium pro. + (i[3456]86-*-dgux*): Use config/mh-sysv for the host configuration + file. + + * config.guess (i[345]86): Ditto. + +Mon Aug 26 18:34:42 1996 Martin M. Hunt + + * configure.in (noconfigdirs): Removed gdb for D10V. + +Wed Aug 21 18:56:38 1996 Fred Fish + + * configure: Fix three locations where shell scripts were + being run directly rather than with config_shell. + +Thu Aug 15 12:19:33 1996 Stan Shebs + + * mpw-configure: Handle multiple enable/disable options and + pass them down recursively, handle -c and -s flags appropriately + depending on choice of compiler, add escape mechanism for + quoted arguments to gC. + +Mon Aug 12 13:15:13 1996 Michael Meissner + + * configure.in (powerpc*-*-*): For eabi, system V.4, Linux, and + solaris targets, use config/mt-ppc to set C{,XX}FLAGS_FOR_TARGETS + so that -mrelocatable-lib and -mno-eabi are used. + + * Makefile.in (CONFIGURE_TARGET_MODULES): If target compiler does + not support --print-multi-lib, don't abort. + +Sun Aug 11 20:51:50 1996 Stu Grossman (grossman@critters.cygnus.com) + + * config/mh-cygwin32 (CFLAGS): Define _WIN32 to be compatible + with normal Windows compilation environment. + +Thu Aug 8 12:18:59 1996 Klaus Kaempf + + * make-all.com: Run config-a-gas. + * setup.com: Don't copy subdirectory files around. + +Tue Jul 30 17:49:31 1996 Brendan Kehoe + + * configure.in (*-*-ose): Remove exclusion of libgloss for this + target, it now compiles correctly. + +Sat Jul 27 15:10:43 1996 Stan Shebs + + * mpw-config.in: Generate Mac include for elf/dwarf2.h. + +Tue Jul 23 10:47:04 1996 Martin M. Hunt + + * configure.in (d10v-*-*): Remove ld from $noconfigdirs. + +Mon Jul 22 13:28:51 1996 Brendan Kehoe + + * configure.in (native_only): Add prms. + +Mon Jul 22 12:27:58 1996 Ian Lance Taylor + + * Makefile.in (GAS_SUPPORT_DIRS): Add make-all.com and setup.com. + (BINUTILS_SUPPORT_DIRS): Likewise. + +Thu Jul 18 12:55:40 1996 Michael Meissner + + * configure.in (d10v-*-*): Don't configure ld or gdb until the + d10v support is added. + +Wed Jul 17 14:33:09 1996 Martin M. Hunt + + * configure.in (d10v-*-*): New target. + +Mon Jul 15 11:53:00 1996 Jeffrey A Law (law@cygnus.com) + + * config.guess (HP 9000/811): Recognize this as a PA1.1 + machine. + +Fri Jul 12 23:21:17 1996 Ken Raeburn + + * Makefile.in (do-tar-gz): New target, split out from tail end of + taz target. Run each command separately, don't use pipes. + (taz): Use it. + +Fri Jul 12 12:08:04 1996 Stan Shebs + + * mpw-configure: Look for g-mpw-make.sed in config/mpw. + * mpw-build.in: No builds should depend on building byacc or flex, + they are assumed to be installed already. + +Fri Jul 12 09:52:52 1996 Michael Meissner + + * Makefile.in (CONFIGURE_TARGET_MODULES): Set r environment + variable that CC_FOR_TARGET needs. + +Thu Jul 11 10:09:45 1996 Michael Meissner + + * Makefile.in (CONFIGURE_TARGET_MODULES): Determine if the multlib + options have changed since the last time the subdirectory was + configured, and if it has, reconfigure. + (CLEAN_TARGET_MODULES): Delete multilib.out and tmpmulti.out, which + CONFIGURE_TARGET_MODULES uses to remember the old multilib options. + +Wed Jul 10 18:56:59 1996 Doug Evans + + * Makefile.in (ALL_MODULES,CROSS_CHECK_MODULES,INSTALL_MODULES, + CLEAN_MODULES): Add bash. + (all-bash): New target. + +Mon Jul 8 17:33:14 1996 Jim Wilson + + * configure.in (mips-sgi-irix6*): Use mh-irix6 instead of mh-irix5. + +Mon Jul 1 13:31:35 1996 Michael Meissner + + * config.sub (basic_machine): Recognize d10v as a valid processor. + +Fri Jun 28 12:14:35 1996 Stan Shebs + + * mpw-configure: Add support for --bindir. + * mpw-build.in: Use a GCC-specific build script for GCC actions. + +Wed Jun 26 17:20:12 1996 Geoffrey Noer + + * configure.in: add bash, time, gawk to list of hosttools and things + to only build for native toolchains + +Tue Jun 25 23:09:03 1996 Jason Molenda (crash@godzilla.cygnus.co.jp) + + * Makefile.in (docdir): Remove. + +Tue Jun 25 19:00:08 1996 Jason Molenda (crash@godzilla.cygnus.co.jp) + + * Makefile.in (datadir): Set to $(prefix)/share. + +Mon Jun 24 23:26:07 1996 Geoffrey Noer + + * configure.in: build diff and patch for cygwin32-hosted + toolchains. + +Mon Jun 24 15:01:12 1996 Joel Sherrill + + * config.sub: Accept -rtems*. + +Sun Jun 23 22:41:54 1996 Geoffrey Noer + + * configure.in: enable dosrel for cygwin32-hosted builds, + remove diff from the list of things not buildable + via Canadian Cross + +Sat Jun 22 11:39:01 1996 Jason Merrill + + * Makefile.in (TARGET_SUBDIR): Move comment to previous line so we + don't get ". ". + +Fri Jun 21 17:24:48 1996 Jim Wilson + + * configure.in (mips*-sgi-irix6*): Set noconfigdirs appropriately. + +Thu Jun 20 16:57:40 1996 Ken Raeburn + + * Makefile.in (taz): Handle case where tex3patch didn't even get + checked out. Also, if it was found, put the symlink in a new util + subdirectory. + +Thu Jun 20 12:20:33 1996 Michael Meissner + + * config.guess (*:Linux:*:*): Add support for PowerPC Linux. + +Tue Jun 18 14:24:12 1996 Klaus Kaempf (kkaempf@progis.de) + + * config.sub: Recognize -openvms. + * configure.in (alpha*-*-*vms*): Set noconfigdirs. + * make-all.com, setup.com: New files. + +Mon Jun 17 16:34:46 1996 Jason Merrill + + * Makefile.in (taz): tex3patch moved to texinfo/util. + +Sat Jun 15 17:13:25 1996 Geoffrey Noer + + * configure: enable_gdbtk=no for cygwin32-hosted toolchains + * configure.in: remove make from disable-if-Can-Cross list + enable gdb if ${host} and ${target} are cygwin32 + +Fri Jun 7 18:16:52 1996 Harlan Stenn + + * config.guess (i?86-ncr-sysv*): Emit minor release numbers. + Recognize the NCR 4850 machine and NCR Pentium-based platforms. + +Wed Jun 5 00:09:17 1996 Per Bothner + + * config.guess: Combine mips-mips-riscos cases, and use cpp to + distinguish sysv/svr4/bsd variants. + Based on a patch from Harlan Stenn . + +Fri Jun 7 14:24:49 1996 Tom Tromey + + * configure.in: Added copyright notice. + * move-if-change: Added copyright notice. + +Thu Jun 6 16:27:05 1996 Michael Meissner + + * configure.in (powerpcle-*-solaris*): Until we get shared + libraries working, don't build gdb, sim, make, tcl, tk, or + expect. + +Tue Jun 4 20:41:45 1996 Per Bothner + + * config.guess: Merge with FSF: + + Mon Jun 3 08:49:14 1996 Karl Heuer + * config.guess (*:Linux:*:*): Add guess for sparc-unknown-linux. + + Fri May 24 18:34:53 1996 Roland McGrath + * config.guess (AViiON:dgux:*:*): Fix typo in recognizing mc88110. + + Fri Apr 12 20:03:59 1996 Per Bothner + * config.guess: Combine two OSF1 rules. + Also recognize field test versions. From mjr@zk3.dec.com. + * config.guess (dgux): Use /usr/bin/uname rather than uname, + because GNU uname does not support -p. From pmr@pajato.com. + +Tue Jun 4 11:07:25 1996 Tom Tromey + + * Makefile.in (MAKEDIRS): Removed $(tooldir). + +Tue May 28 12:30:50 1996 Stan Shebs + + * mpw-README: Document GCCIncludes. + +Sun May 26 15:16:27 1996 Fred Fish + + * configure.in (alpha-*-linux*): Set enable_shared to yes. + +Tue May 21 15:41:39 1996 Stan Shebs + + * mpw-configure: Handle --enable-FOO and --disable-FOO. + +Mon May 20 10:12:29 1996 Geoffrey Noer + + * configure.in (*-*-cygwin32): Configure make. + +Tue May 7 14:19:42 1996 Tom Tromey + + * Makefile.in (inet-install): Quote value of INSTALL_MODULES. + +Fri May 3 08:57:17 1996 Tom Tromey + + * Makefile.in (all-inet): Depend on all-perl. + + * Makefile.in (inet-install): New target. + + * Makefile.in (all-inet): Depend on all-tcl. + (all-inet): Depend on all-send-pr. + +Tue Apr 30 13:55:51 1996 Michael Meissner + + * configure.in (powerpcle-*-solaris*): Turn off tk and tcl + temporarily. + +Thu Apr 25 11:48:20 1996 Ian Lance Taylor + + * configure.in: Don't configure --with-gnu-ld on AIX. + +Thu Apr 25 06:33:36 1996 Michael Meissner + + * configure.in (powerpcle-*-solaris*): Turn off gdb temporarily. + +Tue Apr 23 09:07:39 1996 Tom Tromey + + * Makefile.in (ALL_MODULES): Added all-inet. + (CROSS_CHECK_MODULES): Added check-inet. + (INSTALL_MODULES): Added install-inet. + (CLEAN_MODULES): Added clean-inet. + (all-indent): New target. + + * configure.in (host_tools): Added inet. + (native_only): Added inet. + (noconfigdirs): Added inet. + +Fri Apr 19 15:35:29 1996 Ian Lance Taylor + + * configure.in: Don't configure libgloss if we are not configuring + newlib. + +Wed Apr 17 19:30:01 1996 Rob Savoye + + * configure.in: Don't configure libgloss for unsupported + architectures. + +Tue Apr 16 11:17:05 1996 Michael Meissner + + * Makefile.in (CLEAN_MODULES): Add clean-apache. + +Mon Apr 15 15:09:05 1996 Tom Tromey + + * Makefile.in (ALL_MODULES): Include all-apache. + (CROSS_CHECK_MODULES): Include check-apache. + (INSTALL_MODULES): Include install-apache. + (all-apache): New target. + + * configure.in: Added apache everywhere perl is seen. + +Mon Apr 15 14:59:13 1996 Michael Meissner + + * Makefile.in: Add support for clean-{module} and + clean-target-{module} rules. + +Wed Apr 10 21:37:41 PDT 1996 Marilyn E. Sander + + * configure.in (*-*-ose) do not build libgloss. + +Mon Apr 8 16:16:20 1996 Michael Meissner + + * config.guess (prep*:SunOS:5.*:*): Turn into + powerpele-unknown-solaris2. + +Mon Apr 8 14:45:41 1996 Ian Lance Taylor + + * configure.in: Permit --enable-shared to specify a list of + directories. + +Fri Apr 5 08:17:57 1996 Jason Molenda (crash@phydeaux.cygnus.com) + + * configure.in (host==solaris): Pass only the first word of $CC + to /usr/bin/which when checking if we're using /usr/ccs/bin/cc. + +Fri Apr 5 03:16:13 1996 Jason Molenda (crash@phydeaux.cygnus.com) + + * Makefile.in (BASE_FLAGS_TO_PASS): pass down $(MAKE). + +Thu Mar 28 14:11:11 1996 Tom Tromey + + * Makefile.in (ALL_MODULES): Include all-perl. + (CROSS_CHECK_MODULES): Include check-perl. + (INSTALL_MODULES): Include install-perl. + (ALL_X11_MODULES): Include all-guile. + (CHECK_X11_MODULES): Include check-guile. + (INSTALL_X11_MODULES): Include install-guile. + (all-perl): New target. + (all-guile): New target. + + * configure.in (host_tools): Include perl and guile. + (native_only): Include perl and guile. + (noconfigdirs): Don't build guile and perl; no ports have been + done. + +Tue Mar 26 21:18:50 1996 Andrew Cagney + + * configure (--enable-*): Handle quoted option lists such as + --enable-sim-cflags='-g0 -O' better. + +Thu Mar 21 11:53:08 1996 Michael Meissner + + * Makefile.in ({,inst}all-target): New rule so we can make and + install all of the target directories easily. + +Wed Mar 20 18:10:57 1996 Andreas Schwab + + * configure.in: Add missing global flag in sed substitution when + deleting `target-' from ${configdirs}. + +Thu Mar 14 19:15:06 1996 Ian Lance Taylor + + * Makefile.in (DO_X): Don't get confused if CC contains `=' in an + option. + + * configure.in (mips*-nec-sysvr4*): Use a host_makefile_frag of + config/mh-necv4. + + * install.sh: Correct misspelling of transformbasename. + + * config.guess: Recognize mips-*-sysv*. + +Mon Mar 11 15:36:42 1996 Dawn Perchik + + * config.sub: Recognize mon960. + +Sun Mar 10 13:18:38 1996 Ian Lance Taylor + + * configure: Restore Canadian Cross handling of BISON and LEX, + removed in Feb 20 change. + +Fri Mar 8 20:07:09 1996 Per Bothner + + * README: Suggestions from Torbjorn Granlund : + Mention make install. Remove the old copyright date as well the + clumsy and rather pointless copyright on the README file. + +Fri Mar 8 17:51:35 1996 Ian Lance Taylor + + * Makefile.in ($(CONFIGURE_TARGET_MODULES)): If there is a + Makefile after running symlink-tree, then run `make distclean' to + avoid clobbering any generated files in srcdir. + +Tue Mar 5 08:21:44 1996 J.T. Conklin + + * configure.in (m68k-*-netbsd*): Build everything now. + +Wed Feb 28 12:25:46 1996 Jason Merrill + + * Makefile.in (taz): Fix quoting. + +Tue Feb 27 11:33:57 1996 Doug Evans + + * configure.in (sparclet-*-*): Build everything now. + +Tue Feb 27 14:31:51 1996 Andreas Schwab + + * configure.in (m68k-*-linux*): New host. + +Mon Feb 26 14:32:44 1996 Ian Lance Taylor + + * configure: Check for bison before byacc. + +Tue Feb 20 23:12:35 1996 Stu Grossman (grossman@critters.cygnus.com) + + * Makefile.in configure: Change the way LEX and BISON/YACC are + set. configure now defines DEFAULT_LEX and DEFAULT_YACC by + searching PATH. These are used as fallbacks by Makefile.in if + flex/bison/byacc aren't in objdir. + +Mon Feb 19 11:45:30 1996 Ian Lance Taylor + + * Makefile.in: Make everything which depends upon all-bfd also + depend upon all-opcodes, in case --with-commonbfdlib is used. + +Thu Feb 15 19:50:50 1996 Michael Meissner + + * configure.in (host *-*-cygwin32): Don't build gdb if we are + building NT native compilers on Unix. + +Thu Feb 15 17:42:25 1996 Ian Lance Taylor + + * configure.in: Don't get CC from the host Makefile fragment if we + can find gcc in PATH, or if this is a Canadian Cross. Move the + Solaris test for /usr/ucb/cc to the post target script, just after + the compiler sanity test. + +Wed Feb 14 16:57:40 1996 Ian Lance Taylor + + * config.sub: Merge with FSF. + +Tue Feb 13 14:27:48 1996 Ian Lance Taylor + + * Makefile.in (RPATH_ENVVAR): New variable. + (REALLY_SET_LIB_PATH): Use it. + * configure.in: On HP/UX, set RPATH_ENVVAR to SHLIB_PATH. + +Mon Feb 12 15:28:49 1996 Doug Evans + + * config.sub, configure.in: Recognize sparclet cpu. + +Mon Feb 12 15:33:59 1996 Christian Bauernfeind + + * config.guess: Support m68k-cbm-sysv4. + +Sat Feb 10 12:06:42 1996 Andreas Schwab + + * config.guess (*:Linux:*:*): Guess m68k-unknown-linux and + m68k-unknown-linuxaout from linker help string. Put quotes around + $ld_help_string. + +Thu Dec 7 09:03:24 1995 Tom Horsley + + * config.guess (powerpc-harris-powerunix): Add guess for port + to new target. + +Thu Feb 8 15:37:52 1996 Brendan Kehoe + + * config.guess (UNAME_VERSION): Recognize X4.x as an OSF version. + +Mon Feb 5 16:36:51 1996 Ian Lance Taylor + + * configure.in: If --enable-shared was used, set SET_LIB_PATH to + $(REALLY_SET_LIB_PATH) in Makefile. + * Makefile.in (SET_LIB_PATH): New variable. + (REALLY_SET_LIB_PATH): New variable. + ($(DO_X)): Use $(SET_LIB_PATH). + (install.all, gcc-no-fixedincludes, $(ALL_MODULES)): Likewise. + ($(NATIVE_CHECK_MODULES), $(CROSS_CHECK_MODULES)): Likewise. + ($(INSTALL_MODULES), $(CONFIGURE_TARGET_MODULES)): Likewise. + ($(ALL_TARGET_MODULES), $(CHECK_TARGET_MODULES)): Likewise. + ($(INSTALL_TARGET_MODULES), $(ALL_X11_MODULES)): Likewise. + ($(CHECK_X11_MODULES), $(INSTALL_X11_MODULES)): Likewise. + (all-gcc, all-bootstrap, check-gcc, install-gcc): Likewise. + (install-dosrel): Likewise. + (all-opcodes): Depend upon all-libiberty. + +Sun Feb 4 16:51:11 1996 Steve Chamberlain + + * config.guess (*:CYGWIN*): New + +Sat Feb 3 10:42:35 1996 Michael Meissner + + * Makefile.in (all-target-winsup): All all-target-libiberty. + +Fri Feb 2 17:58:56 1996 Michael Meissner + + * configure.in (noconfigdirs): Add missing # in front of comment. + +Thu Feb 1 14:38:13 1996 Geoffrey Noer + + * configure.in: add second pass to things added to noconfigdirs + so *-gm-magic can exclude libgloss properly. + +Thu Feb 1 11:10:16 1996 Stan Shebs + + * mpw-configure (extralibs_name, rez_name): Set correctly + for MWC68K compiler. + + * mpw-README: Add more info on the necessary build tools. + +Thu Feb 1 10:22:38 1996 Steve Chamberlain + + * configure.in, config.sub: Recognize cygwin32. + +Wed Jan 31 14:17:10 1996 Richard Henderson + + * config.guess, config.sub: Recognize A/UX. + +Wed Jan 31 13:52:14 1996 Ian Lance Taylor + + * config.sub: Merge with gcc/config.sub. + +Thu Jan 25 11:01:10 1996 Raymond Jou + + * mpw-build.in (do-binutils): Add build of stamps. + +Thu Jan 25 17:05:26 1996 James G. Smith + + * config.sub: Add recognition for mips64vr4100*-* targets. + +Wed Jan 24 12:47:55 1996 Brendan Kehoe + + * test-build.mk: Add checking of `hpux9' rather than just `hpux'. + Add creation of gconfigargs with `--enable-shared' turned on. + ($(host)-stamp-stage2-configured): Pass $(gconfigargs). + ($(host)-stamp-stage3-configured): Likewise. + (HOLES): Add chatr and ldd. + (i386-ncr-sysv4.3*): Add use of /usr/ccs/bin in the PATH and HOLE_DIRS. + +Wed Jan 24 20:32:30 1996 Torbjorn Granlund + + * configure: Pass --nfp to recursive configures. + +Mon Jan 22 10:41:56 1996 Steve Chamberlain + + * Makefile.in (DLLTOOL): New. + (DLLTOOL_FOR_TARGET): New. + (EXTRA_HOST_FLAGS): Pass down DLLTOOL. + (EXTRA_TARGET_FLAGS): Ditto. + (EXTRA_GCC_FLAGS): Ditto. + (CONFIGURE_TARGET_MODULES): Ditto. + (DO_X): Ditto. + * configure: Add DLLTOOL. + +Fri Jan 19 13:30:15 1996 Stan Shebs + + SCO OpenServer 5 changes from Robert Lipe : + * configure.in (i[345]86-*-sco3.2v5*): Use mh-sysv instead of + mh-sco, since old workarounds no longer needed, and don't + build ld, since libraries have weak symbols in COFF. + +Sun Jan 14 23:01:31 1996 Fred Fish + + * Makefile.in (CONFIGURE_TARGET_MODULES): Add missing ';'. + +Fri Jan 12 15:25:35 1996 Ian Lance Taylor + + * configure.in: Make sure that ${CC} can be used to compile an + executable. + +Sat Jan 6 07:23:33 1996 Michael Meissner + + * Makefile.in (all-gdb): Depend on $(GDB_TK). + * configure (GDB_TK): Set GDB_TK to either "all-tcl all-tk" or + nothing depending on whether gdbtk is being built. + +Wed Jan 3 17:54:41 1996 Doug Evans + + * Makefile.in (newlib.tar.gz): Delete building of newlib's info files. + +Mon Jan 1 19:09:14 1996 Brendan Kehoe + + * configure.in (noconfigdirs): Put ld or gas in this early, if the + user specifically used --with-gnu-ld=no or --with-gnu-as=no. + +Sat Dec 30 16:08:57 1995 Doug Evans + + * config-ml.in: Add support for + --disable-{softfloat,m68881,m68000,m68020} on m68*-*-*. + Simplify setting of multidirs from --disable-foo. + +Fri Dec 29 07:56:11 1995 Michael Meissner + + * Makefile.in (EXTRA_GCC_FLAGS): If any of the make variables + LANGUAGES, BOOT_CFLAGS, STMP_FIXPROTO, LIMITS_H_TEST, + LIBGCC1_TEST, LIBGCC2_CFLAGS, LIBGCC2_INCLUDES, and ENQUIRE are + non-empty, pass them on to the GCC make. + (all-bootstrap): New rule that is like all-gcc, except it executes + the GCC bootstrap rule instead of the GCC all rule. + +Wed Dec 27 15:51:48 1995 Doug Evans + + * config-ml.in (ml_realsrcdir): New, to account for ${subdir}. + +Tue Dec 26 11:45:31 1995 Michael Meissner + + * config.guess (AViiON:dgux:*:*): Update from FSF to add pentium + DG/UX support. + +Fri Dec 15 10:01:27 1995 Stan Cox + + * config.sub (i*86*) Change [345] to [3456] + +Wed Dec 20 17:41:40 1995 Brendan Kehoe + + * configure.in (noconfigdirs): Add gas or ld if --with-gnu-as=no or + --with-gnu-ld=no. + +Wed Dec 20 15:15:35 1995 Michael Meissner + + * config-ml.in (rs6000*, powerpc*): Add switches to control which + AIX multilibs get built. + +Mon Dec 18 17:55:46 1995 Jason Molenda (crash@phydeaux.cygnus.com) + + * configure.in (i386-win32): Don't build expect if we're not + building the tcl subdir. + +Mon Dec 18 11:47:19 1995 Stan Shebs + + * Makefile.in: (configure-target-examples, all-target-examples): + New targets, configure and build example programs. + +Fri Dec 15 16:13:03 1995 Stan Shebs + + * mpw-configure: If an mpw-config.in generated a file mk.sed, + use it as input to sedit the generated MPW makefile. + * mpw-README: Add a suggestion about Gestalt.h. + +Wed Dec 13 16:43:51 1995 Ian Lance Taylor + + * config.sub: Accept *-*-ieee*. + +Tue Dec 12 11:52:57 1995 Ian Lance Taylor + + * Makefile.in (local-distclean): Remove $(TARGET_SUBDIR). From + Ronald F. Guilmette . + +Mon Dec 11 15:31:58 1995 Jason Molenda (crash@phydeaux.cygnus.com) + + * configure.in (host==powerpc-pe): Add many directories to noconfigdirs + for powerpc-pe native. + (target==i386-win32): add tcl, make to noconfigdirs if canadian cross. + (target==powerpc-pe): duplicate i386-win32 entry. + +Sat Dec 9 14:58:28 1995 Jim Wilson + + * configure.in (noconfigdirs): Exclude target-newlib for all versions + of vxworks, not just vxworks5.1. + +Mon Dec 4 12:05:40 1995 Stan Shebs + + * mpw-configure: Add support for exec-prefix. + +Mon Dec 4 10:22:50 1995 Jeffrey A. Law + + * config.guess: Recognize HP model 816 machines as having + a PA1.1 processor. + +Mon Dec 4 12:38:15 1995 Ian Lance Taylor + + * configure: Ignore new autoconf configure options. + +Thu Nov 30 14:45:25 1995 J.T. Conklin + + * config/mt-v810 (CC_FOR_TARGET): Add -ansi flag. NEC compiler + defaults to K&R mode, but doesn't have varargs.h, so we have to + compile in ANSI mode. + +Thu Nov 30 16:57:33 1995 Per Bothner + + * config.guess: Recognize Pentium under SCO. + From Robert Lipe . + +Wed Nov 29 13:49:08 1995 J.T. Conklin + + * configure.in (noconfigdirs): Disable target-libio on v810-*-*. + * config/mt-v810 (CC_FOR_TARGET, AS_FOR_TARGET, AR_FOR_TARGET, + RANLIB_FOR_TARGET): Set as appropriate for NEC v810 toolchain. + +Wed Nov 29 12:12:01 1995 Ian Lance Taylor + + * configure.in: Don't configure gas for alpha-dec-osf*. + +Tue Nov 28 17:16:48 1995 Ian Lance Taylor + + * configure.in: Default to --with-stabs for some targets for which + it makes sense: mips*-*-*, alpha*-*-osf*, i[345]86*-*-sysv4* and + i[345]86*-*-unixware*. + +Mon Nov 27 13:44:15 1995 Ian Lance Taylor + + * config-ml.in: Get list of multidirs using gcc --print-multi-lib + rather than basing it on the target. Simplify handling of options + controlling which directories to configure. Remove extraneous + slash in multi-clean target. + +Fri Nov 24 17:29:29 1995 Doug Evans + + * config-ml.in: Prefix more variables with ml_ so they don't collide + with configure's. + +Wed Nov 22 11:27:02 1995 Ian Lance Taylor + + * configure: Don't turn -v into --v. + +Tue Nov 21 16:48:02 1995 Doug Evans + + * configure.in (targargs): Fix typo. + + * Makefile.in (DEVO_SUPPORT): Add symlink-tree. + +Tue Nov 21 14:08:28 1995 Ian Lance Taylor + + * configure.in: Strip --host and --target options from + CONFIG_ARGUMENTS, and always configure for --host only. Add + --with-cross-host option when building with a cross-compiler. + * configure: Canonicalize the arguments put into config.status by + always using `=' for an option with an argument. Pass a presumed + --host or --target explicitly. + +Fri Nov 17 17:50:30 1995 Stan Shebs + + * config.sub: Merge -macos*, -magic*, -pe*, and -win32 cases + into general OS recognition case. + +Fri Nov 17 17:42:25 1995 Jason Molenda (crash@phydeaux.cygnus.com) + + * configure.in (target_configdirs): add target-winsup only + for win32 target systems. + +Thu Nov 16 14:04:47 1995 Ian Lance Taylor + + * Makefile.in (all-target-libgloss): Depend upon + configure-target-newlib, since when libgloss is built it looks to + see if the newlib directory exists. + +Wed Nov 15 14:47:52 1995 Ken Raeburn + + * Makefile.in (DEVO_SUPPORT): Use config-ml.in instead of + cfg-ml-*.in. + +Wed Nov 15 11:45:23 1995 Ian Lance Taylor + + * configure: Handle LD and LD_FOR_TARGET when configuring a + Canadian Cross. + +Tue Nov 14 15:03:12 1995 Jason Molenda (crash@phydeaux.cygnus.com) + + * config/mh-i386win32: add LD_FOR_TARGET. + +Tue Nov 14 14:56:11 1995 Jason Molenda (crash@phydeaux.cygnus.com) + + * configure.in (target_libs): add target-winsup. + (target==i386-win32): add patch diff flex make to $noconfigdirs. + (target==ppcle-pe): remove ld from $noconfigdirs. + +Tue Nov 14 01:25:50 1995 Doug Evans + + * Makefile.in (CONFIGURE_TARGET_MODULES): Pass --with-target-subdir. + Preserve relative path names in $srcdir. Build symlink tree if + configuring cross target dir and srcdir=. (= no VPATH support). + (configure-target-libg++): Depend on configure-target-librx. + * cfg-ml-com.in, cfg-ml-pos.in: Deleted. + * config-ml.in: New file. + * symlink-tree: New file. + * configure: Ensure srcdir="." if that's what it is. + +Mon Nov 13 12:34:20 1995 Stan Shebs + + * mpw-README: Clarify some phrasing, add notes about CodeWarrior + includes and FLEX_SKELETON setting. + * mpw-configure (--with-gnu-ld): New option, controls whether + to use PPCLink or ld with PowerMac GCC. + * mpw-build.in (all-grez, do-grez, install-grez): New targets. + * mpw-config.in: Configure grez if targeting Mac. + + * config.sub: Accept pmac and pmac-mpw as names for PowerMacs, + accept mpw and mac-mpw as names for m68k Macs, change macos7 to + just macos. + * configure.in: Configure grez resource compiler if targeting Mac. + * Makefile.in (all-grez, install-grez): New targets. + +Wed Nov 8 17:33:51 1995 Jason Merrill + + * configure: CXX defaults to gcc, not g++. If we find + gcc in the path, set CC to gcc -O2. + +Tue Nov 7 15:45:17 1995 Ian Lance Taylor + + * configure: Default ${build} correctly. Avoid picking up extra + spaces when reading CC and CXX from Makefile. When doing a + Canadian Cross, use plausible default values for numerous + variables. + * configure.in: When doing a Canadian Cross, don't try to + configure tools whose configure script can't handle it. + +Mon Nov 6 19:32:17 1995 Jim Wilson + + * cfg-ml-com.in (sh-*-*): Add m2 and ml/m2 to multidirs. + +Sun Nov 5 00:15:41 1995 Per Bothner + + * configure: Remove dubious bug reporting address. + +Fri Nov 3 08:17:54 1995 Per Bothner + + * Makefile.in ($(CONFIGURE_TARGET_MODULES)): If subdir has + configure script, run that instead of this directory's configure. + In either case, print a message that we're configuring the sub-dir. + +Thu Nov 2 23:23:36 1995 Per Bothner + + * configure.in: Before checking for the existence of various files, + use sed to filter out "target-". + +Thu Nov 2 13:24:56 1995 Ian Lance Taylor + + * Makefile.in (DO_X): Split rule to decrease command line length + for systems with small ARG_MAX values. From phdm@info.ucl.ac.be + (Philippe De Muyter). + +Wed Nov 1 15:18:35 1995 Jason Molenda (crash@phydeaux.cygnus.com) + + * Makefile.in (all-patch): depend on all-libiberty. + +Wed Nov 1 12:23:20 1995 Ian Lance Taylor + + * configure.in: If the only directory in target_configdirs which + actually exists is libiberty, then set target_configdirs to empty, + to avoid trying to build a target libiberty in a gas or gdb + distribution. + +Tue Oct 31 17:52:39 1995 J.T. Conklin + + * configure.in (host_makefile_frag): Use m68k-sun-sunos* instead + of m68k-sun-* when selecting mh-sun3 to avoid matching NetBSD/sun3 + systems. + +Tue Oct 31 16:57:32 1995 Jim Wilson + + * configure.in (copy_dirs): Use sys-include instead of include + for --with-headers option. + +Tue Oct 31 10:29:36 1995 steve chamberlain + + * Makefile.in, configure.in: Make winsup builds work with + new scheme. + +Mon Oct 30 18:57:09 1995 Ian Lance Taylor + + * configure.in: Build the linker on AIX. + +Mon Oct 30 12:27:16 1995 Per Bothner + + * Makefile.in (CC_FOR_TARGET, CXX_FOR_TARGET): Add $(TARGET_SUBDIR) + where needed. + +Mon Oct 30 12:45:25 1995 Doug Evans + + * Makefile.in (all-gcc): Fix typo. + +Sat Oct 28 10:27:59 1995 Per Bothner + + * Makefile.in ($(CHECK_TARGET_MODULES)): Fix typo. + +Fri Oct 27 23:14:12 1995 Per Bothner + + * configure.in: Rename libFOO to target-libFOO, and xiberty + to target-xiberty, to provide more flexibility. + (target_subdir): Define. Create if cross. + Set TARGET_SUBDIR in Makefile to ${target_subdir}. + * Makefile.in: Rename all-libFOO -> all-target-libFOO, all-xiberty + -> all-target-libiberty, configure-libFOO -> configure-target-libFOO, + check-libFOO -> check-target-libFOO, etc. + ($(DO_X)): Iterate over TARGET_CONFIGDIRS after SUBDIRS. + ($(CONFIGURE_TARGET_MODULES), $(CHECK_TARGET_MODULES), + $(ALL_TARGET_MODULES), $(INSTALL_TARGET_MODULES)): Update accordingly. + (configure-target-XXX): Depend on $(ALL_GCC), not all-gcc, to + allow ALL_GCC="" to only configure. + (DEVO_SUPPORT): Add cfg-ml-com.in and cfg-ml-pos.in. + (ETC_SUPPORT, ETC_SUPPORT_PFX): Merge; update 'taz' accordingly. + (LIBGXX_SUPPORT_DIRS): Remove xiberty. + +Sat Oct 28 01:53:49 1995 Ken Raeburn + + * Makefile.in (taz): Build "info" in etc explicitly. + +Fri Oct 27 09:32:30 1995 Stu Grossman (grossman@cygnus.com) + + * configure.in: Make sure that CC is undefined (as opposed to + null) if toplevel/config/mh-{host} doesn't define it. Fixes a + problem with autoconf trying to configure on a host without GCC. + +Thu Oct 26 22:35:01 1995 Stan Shebs + + * mpw-configure: Set host alias from choice of host compiler, + only use generic MPW Makefile sed if present, edit a file + named "hacked_Makefile.in" instead of "Makefile.in" if present. + * mpw-README: Add problem notes about CW6 and CW7. + +Thu Oct 26 05:45:10 1995 Ken Raeburn + + * Makefile.in (taz): Use ";" instead of ";;". + +Wed Oct 25 15:18:24 1995 Per Bothner + + * Makefile.in (taz): Grep for '^diststuff:' or '^info:' in + sub-directory Makefiles, instead of using DISTSTUFFDIRS and + DISTDOCDIRS. + (DISTSTUFFDIRS, DISTDOCDIRS): Removed - no longer used. + (newlib.tar.gz): Don't pass DISTDOCDIRS to recursive make. + +Wed Oct 25 14:43:55 1995 Per Bothner + + * Makefile.in (DISTDOCDIRS): Remove ld gprof bnutils gas libg++ gdb + and gnats, because they are now subsumed by DISTSTUFFDIRS. + Move bfd to DISTSTUFFDIRS. + +Tue Oct 24 18:19:09 1995 Jason Molenda (crash@phydeaux.cygnus.com) + + * Makefile.in (X11_LIB): Removed. + (X11_FLAGS_TO_PASS): pass only X11_EXTRA_CFLAGS and X11_EXTRA_LIBS. + + * configure.in (host_makefile_frag): mh-aix & mh-sun removed. + +Sun Oct 22 13:04:42 1995 Michael Meissner + + * cfg-ml-com.in (powerpc*): Shorten some of the multilib directory + names. + +Fri Oct 20 18:02:10 1995 Michael Meissner + + * cfg-ml-com.in (powerpc*-eabi*): Add mcall-aixdesc varients. + +Thu Oct 19 10:40:57 1995 steve chamberlain + + * configure.in (i[345]86-*-win32): Always build newlib. + Don't configure cvs, autoconf or texinfo. + * Makefile.in (LD_FOR_TARGET): New. + (BASE_FLAGS_TO_PASS, EXTRA_TARGET_FLAGS, CONFIGURE_TARGET_MODULES): + Pass down LD_FOR_TARGET. + +Wed Oct 18 15:53:56 1995 steve chamberlain + + * winsup: New directory. + * Makefile.in: Build winsup. + * configure.in: Winsup is configured when target is win32. + Can only build win32 target GDB when native. + +Mon Oct 16 09:42:31 1995 Jeffrey A Law (law@cygnus.com) + + * config.guess: Recognize HP model 819 machines as having + a PA 1.1 processor. + +Mon Oct 16 10:49:43 1995 Ian Lance Taylor + + * configure: Fix sed loop which substitutes for CC and CXX to + avoid bug found in various sed implementations. + +Wed Oct 11 16:16:20 1995 Michael Meissner + + * cfg-ml-com.in (powerpc-*-eabisim): Delete separate rule for + simulator. Use standard powerpc-*-eabi*. + +Mon Oct 9 17:21:56 1995 Ian Lance Taylor + + * configure.in: Stop putting gas and binutils in noconfigdirs for + powerpc-*-aix* and rs6000-*-*. + +Mon Oct 9 12:38:40 1995 Michael Meissner + + * cfg-ml-com.in (powerpc*-*-eabisim*): Add support for building + -mcall-aixdesc libraries. + +Fri Oct 6 16:17:57 1995 Ken Raeburn + + Mon Sep 25 22:49:32 1995 Andreas Schwab + + * config.sub (arm | armel | armeb): Fix shell syntax. + +Fri Oct 6 14:40:28 1995 Michael Meissner + + * cfg-ml-com.in ({powerpc,rs6000}-ibm-aix*): Add multilibs for + -msoft-float and -mcpu=common support. + (powerpc*-*-eabisim*): Add support for building -mcall-aix + libraries. + +Thu Oct 5 13:26:37 1995 Brendan Kehoe + + * configure.in: Allow configuration and build of emacs19 for the alpha. + +Wed Oct 4 22:05:36 1995 Jason Molenda (crash@phydeaux.cygnus.com) + + * configure.in (CC): Get ^CC, not just any old CC, from + ${host_makefile_frag}. + +Wed Oct 4 21:55:00 1995 Jason Molenda (crash@phydeaux.cygnus.com) + + * configure.in (CC): Try to get CC from + ${srcdir}/${host_makefile_frag}, not ${host_makefile_frag}. + +Wed Oct 4 21:44:12 1995 Jason Molenda (crash@phydeaux.cygnus.com) + + * Makefile.in (TARGET_CONFIGDIRS): configure targetdirs + only if it exists in $(srcdir). + +Wed Oct 4 11:52:31 1995 Ian Lance Taylor + + * configure: If CC and CXX are not set in the environment, set + them, based on either an existing Makefile or on searching for gcc + in PATH. Substitute for CC and CXX in Makefile. + * configure.in: Remove libm from target_libs. Separate + target_configdirs from configdirs. If CC is not set in + environment, try to get it from a host Makefile fragment. Rewrite + changes of configdirs to use skipdirs instead. A few minor + tweaks. Take directories out of target_configdirs as they are + taken out of configdirs. Remove existing Makefile files from + subdirectories. Substitute for TARGET_CONFIGDIRS and + CONFIG_ARGUMENTS in Makefile. + * Makefile.in (TARGET_CONFIGDIRS): New variable, automatically set + by configure.in. + (CONFIG_ARGUMENTS): Likewise. + (CONFIGURE_TARGET_MODULES): New variable. + ($(DO_X)): Loop over TARGET_CONFIGDIRS as well as SUBDIRS. + ($(CONFIGURE_TARGET_MODULES)): New target. + (configure-libg++, configure-libio): New targets. + (all-libg++): Depend upon configure-libg++. + (all-libio): Depend upon configure-libio. + (configure-libgloss, all-libgloss): New targets. + (configure-libstdc++): New target. + (all-libstdc++): Depend upon configure-libstdc++. + (configure-librx, all-librx): New targets. + (configure-newlib): New target. + (all-newlib): Depend upon configure-newlib + (configure-xiberty): New target. + (all-xiberty): Depend upon configure-xiberty. + +Sat Sep 30 04:32:59 1995 Jason Molenda (crash@phydeaux.cygnus.com) + + * configure.in (host i[345]86-*-win32): Expand the + noconfigdirs again. + +Thu Sep 28 21:18:49 1995 Stan Shebs + + * mpw-configure: Fix sed command file name. + +Thu Sep 28 17:39:56 1995 steve chamberlain + + * configure.in (host i[345]86-*-win32): Reduce the + noconfigdirs again. + +Wed Sep 27 12:24:00 1995 Ian Lance Taylor + + * configure.in: Don't configure ld and gdb for powerpc*-*-winnt* + or powerpc*-*-pe*, since they are not yet supported. + +Tue Sep 26 14:30:01 1995 Stan Shebs + + Add PowerMac support and many other enhancements. + * mpw-configure: New option --cc to select compiler to use, + paste options set according to --cc into the generated + Makefile, generate the Makefile by sed'ing the Unix Makefile.in + if mpw-make.sed is present. + * mpw-config.in: Don't test for gC1, test for mpw-touch, + add forward includes for PowerPC include files. + * mpw-build.in: Build using Makefile.PPC if present. + (do-byacc, etc): Remove separate version resource builds. + (do-gas): Build "stamps" before "all". + (do-gcc): Build "stamps-h" and "stamps-c" before "all". + * mpw-README: Update to reflect --cc option, PowerMac support, + and recently-reported compatibility problems. + +Fri Sep 22 12:15:42 1995 Doug Evans + + * cfg-ml-com.in (m68*-*-*): Only build multilibs for + embedded m68k systems (-aout, -coff, -elf, -vxworks). + (--with-multilib-top): Pass to recursive invocations. + +Tue Sep 19 13:51:05 1995 J.T. Conklin + + * configure.in (noconfigdirs): Disable libg++ and libstdc++ on + v810-*-*. + +Mon Sep 18 23:08:26 1995 J.T. Conklin + + * configure.in (noconfigdirs): Disable bfd, binutils, gas, gcc, + gdb, ld and opcodes on v810-*-*. + +Sat Sep 16 18:31:08 PDT 1995 Angela Marie Thomas + + * config/mh-ncrsvr43: Removed AR_FLAGS + +Tue Sep 12 18:03:31 1995 Ian Lance Taylor + + * Makefile.in (DO_X): Change do-realclean to do-maintainer-clean. + (local-maintainer-clean): New target. + (maintainer-clean): New target. + (realclean): Just depend upon maintainer-clean. + +Fri Sep 8 17:11:14 1995 J.T. Conklin + + * configure.in (noconfigdirs): Disable gdb on m68k-*-netbsd*. + +Fri Sep 8 16:46:29 1995 Ian Lance Taylor + + * configure.in: Build ld in mips*-*-bsd* case. + +Thu Sep 7 20:03:41 1995 Ken Raeburn + + * config.sub: Accept -lites* OS. From Ian Dall. + +Fri Sep 1 08:06:58 1995 James G. Smith + + * config.sub: recognise mips64vr4300 and mips64vr4300el as valid + targets. + +Wed Aug 30 21:06:50 1995 Jason Molenda (crash@phydeaux.cygnus.com) + + * configure.in: treat i386-win32 canadian cross the same as + i386-go32 canadian cross. + +Thu Aug 24 14:53:20 1995 Michael Meissner + + * cfg-ml-com.in (powerpc*-*-eabisim): Add support for PowerPC + running under the simulator to build a reduced set of libraries. + (powerpc-*-eabiaix): Add fine grained multilib support added to + other powerpc targets yesterday. + +Wed Aug 23 09:41:56 1995 Michael Meissner + + * cfg-ml-com.in (powerpc*): Add support for -disable-biendian, + -disable-softfloat, -disable-relocatable, -disable-aix, and + -disable-sysv to control which multilib libraries get built. + +Thu Aug 17 16:03:41 1995 Ken Raeburn + + * configure: Add Makefile.tem to list of files to remove in trap + handler. + +Mon Aug 14 19:27:56 1995 Per Bothner + + * config.guess (*Linux*): Add missing "exit"s. + Also, need specific check for alpha-unknown-linux (uses COFF). + +Fri Aug 11 15:38:20 1995 Per Bothner + + * config.guess: Merge with FSF: + + Wed Jun 28 17:57:27 1995 David Edelsohn + * config.guess (AIX4): More robust release numbering discovery. + + Thu Jun 22 19:01:24 1995 Kenneth Stailey (kstailey@eagle.dol-esa.gov) + * config.guess (i386-sequent-ptx): Properly get version number. + + Thu Jun 22 18:36:42 1995 Uwe Seimet (seimet@iris1.chemie.uni-kl.de) + * config.guess (mips:*:4*:UMIPS): New case. + +Mon Aug 7 09:21:35 1995 Doug Evans + + * configure.in (i386-go32 host): Fix typo (deja-gnu -> dejagnu). + (i386-win32 host): Likewise. Don't build readline. + +Sat Aug 5 09:51:49 1995 Fred Fish + + * Makefile.in (GDBTK_SUPPORT_DIRS): Define and pass as part of + SUPPORT_FILES to submakes. + +Fri Aug 4 13:04:36 1995 Fred Fish + + * Makefile.in (GDB_SUPPORT_DIRS): Add utils. + (DEVO_SUPPORT): Add mpw-README, mpw-build.in, mpw-config.h and + mpw-configure. + +Wed Aug 2 16:32:40 1995 Ken Raeburn + + * configure.in (appdirs): Use =, not ==, in test expression when + trying to build the text to print in the warning message for + Solaris users. + +Mon Jul 31 09:56:18 1995 steve chamberlain + + * cfg-ml-com.in (z8k-*-coff): Add 'std' multilib build. + +Fri Jul 28 00:16:31 1995 Jeffrey A. Law + + * config.guess: Recognize lynx-2.3. + +Thu Jul 27 15:47:59 1995 steve chamberlain + + * config.sub (z8ksim): Deleted + (z8k-*-coff): New, this is the one true name of the target. + +Thu Jul 27 14:33:33 1995 Doug Evans + + * cfg-ml-pos.in (dotdot): Work around SunOS sed bug. + +Thu Jul 27 13:31:05 1995 Fred Fish (fnf@cygnus.com) + + * config.guess (*:Linux:*:*): First try asking the linker what the + default object file format is (elf, aout, or coff). Then if this + fails, try previous methods. + +Thu Jul 27 11:28:17 1995 J.T. Conklin + + * configure.in: Don't build newlib for *-*-vxworks5.1. + +Thu Jul 27 11:18:47 1995 Brendan Kehoe + + * configure.in: Don't build newlib for a29k-*-vxworks5.1. + * test-build.mk: Add setting of --with-headers for a29k-vxworks5.1. + +Tue Jul 25 21:25:39 1995 Doug Evans + + * cfg-ml-pos.in (MULTITOP): Trim excess trailing "/.". + +Fri Jul 21 10:41:12 1995 Doug Evans + + * cfg-ml-com.in: New file. + * cfg-ml-pos.in: New file. + +Wed Jul 19 00:37:27 1995 Jeffrey A. Law + + * COPYING.NEWLIB: Add HP free copyright to list. + +Tue Jul 18 10:58:51 1995 Michael Meissner + + * config.sub: Recognize -eabi* for the system, not just -eabi. + +Mon Jul 3 13:44:51 1995 Steve Chamberlain + + * Makfile.in (DLLTOOL_FOR_TARGET): New name, pass it down. + * config.sub, configure.in (win32): New target and host. + +Wed Jun 28 23:57:08 1995 Steve Chamberlain + + * configure.in: Add i386-pe configuration. + +Fri Jun 23 14:28:44 1995 Stan Shebs + + * mpw-build.in (install): Install GDB after LD. + +Thu Jun 22 17:10:53 1995 Stan Shebs + + * mpw-config.in (elf/mips.h): Always forward-include, needed + for GDB to build. + +Wed Jun 21 15:17:30 1995 Rob Savoye + + * testsuite: New directory for customer acceptance and whole tool + chain tests. + +Wed Jun 21 16:50:29 1995 Ken Raeburn + + * configure: If per-host line isn't found, but AC_OUTPUT is found + and a configure script exists, run it instead. + +Thu Jun 15 21:09:24 1995 Per Bothner + + * config.guess: Update from FSF, for alpha-dec-winnt3.5 and Crays. + +Tue Jun 13 21:43:27 1995 Rob Savoye + + * configure: Set build_{cpu,vendor,os,alias} to host values when + --build isn't specified. + +Mon Jun 5 18:26:36 1995 Jason Merrill + + * Makefile.in (PICFLAG, PICFLAG_FOR_TARGET): New macros. + (FLAGS_TO_PASS): Pass them. + (EXTRA_TARGET_FLAGS): Ditto. + + * config/m?-*pic: Define PICFLAG* instead of LIB*FLAGS*. + +Wed May 31 22:27:42 1995 Jim Wilson + + * Makefile.in (all-libg++): Depend on all-libstdc++. + +Thu May 25 22:40:59 1995 J.T. Conklin + + * configure.in (noconfigdirs): Enable all packages for + i386-unknown-netbsd. + +Sat May 20 13:22:31 1995 Angela Marie Thomas + + * configure.in (noconfigdirs): Don't configure tk for i386-go32 + hosted builds (DOS builds) + +Thu May 18 18:08:49 1995 Ken Raeburn + + Changes for ARM based on patches from Richard Earnshaw: + * config.sub: Handle armeb and armel. + * configure.in: Omit arm linker only for riscix. + +Thu May 11 17:23:26 1995 Per Bothner + + * config.guess: Update from FSF. + +Tue May 9 15:52:05 1995 Michael Meissner + + * config.sub: Recognize powerpcle as the little endian varient of + the PowerPC. Recgonize ppc as a PowerPC variant, and ppcle as a + powerpcle variant. Convert pentium into i586, not i486. Add p5 + alias for i586. Map new x86 variants p6, k5, nexgen into i586 + temporarily. + +Tue May 2 16:29:41 1995 Jeff Law (law@snake.cs.utah.edu) + + * configure.in (hppa*-*-lites*): Treat like hppa*-*-*elf*. + +Sun Apr 30 21:38:09 1995 Jeff Law (law@snake.cs.utah.edu) + + * config.sub: Accept -lites* as a basic system type. + +Thu Apr 27 11:33:29 1995 Michael Meissner (meissner@cygnus.com) + + * config.guess (*:Linux:*:*): Check for whether the pre-BFD linker is + installed, and if so return linuxoldld as the system name. + +Wed Apr 26 10:59:02 1995 Jeff Law (law@snake.cs.utah.edu) + + * config.guess: Add hppa1.1-hp-lites support. + +Tue Apr 25 11:08:11 1995 Rob Savoye + + * configure.in: Don't build newlib for m68k-vxworks5.1. + +Wed Apr 19 17:02:43 1995 Jim Wilson + + * configure.in (mips-sgi-irix6): Use mh-irix5. + +Fri Apr 14 15:21:17 1995 Doug Evans + + * Makefile.in (all-gcc): Depend on all-ld (for libgcc1-test). + +Wed Apr 12 16:06:01 1995 Jason Merrill + + * test-build.mk: Enable building of shared libraries on IRIX 5 and + OSF/1. Fix compiler flags. + * build-all.mk: Support Linux and OSF/1 3.0. Fix compiler flags. + +Tue Apr 11 18:55:40 1995 Doug Evans + + * configure.in: Recognize --with-newlib. + (sparc-*-sunos4*): Build sim, dejagnu, expect, tcl if cross target. + +Mon Apr 10 14:38:20 1995 Jason Molenda (crash@phydeaux.cygnus.com) + + * Makefile.in: move {all,check,install}-gdb from *_MODULES + to *_X11_MODULES due to gdbtk needing X include files et al. + +Mon Apr 10 11:42:22 1995 Stan Shebs + + Merge in support for Mac MPW as a host. + (Old change descriptions retained for informational value.) + + * mpw-config.in: Add generic include forwards for cpu-specific + include files in aout and elf directories. + + * mpw-configure: Added copyright. + * mpw-config.in: Check for presence of required build tools. + (target_libs): Add newlib. + (target_tools): Add examples. + (Read Me): Generate as "Read Me for MPW" instead. + * mpw-build.in: Base sub-builds on all-foo instead of do-foo. + (all-byacc, do-byacc, all-flex, do-flex, do-newlib): New actions. + (do-gas, do-gcc, do-gdb, do-ld): Build Version.r first. + + * mpw-configure: Remove subdir-specific makefile hackery, + delete mk.tmp after using it. + + * mpw-build.in (all): Display start and end times. + + * mpw-configure (host_canonical): Set. + (target_cpu): Always add to makefiles. + (ARCHDEFS, EMUL): Add to makefile only if nonempty. + (TM_FILE, XM_FILE, NM_FILE): No longer add to makefile. + (mpw-mh-mpw): Look for in srcdir and srcroot. + Use sed instead of mpw-edit-prefix to edit prefix definitions. + + * mpw-build.in: (install-only): New target. + + * mpw-configure (host_alias, target_alias): Rename from hostalias + and targetalias, add into generated Makefile. + (mk.tmp): If present, add into generated Makefile. + * mpw-build.in (all-gas): Build config.h first before gas proper. + + * mpw-configure (config.status): Write only if changed. + * mpw-config.in (readline): Configure it (not built, just used for + definitions). + + * mpw-config.in (elf/mips.h): Add a forward include. + + * mpw-config.in: Forward-include most .h files in include into + extra-include. + (readline): Don't build. + mpw-build.in (install): Install GDB. + + * mpw-configure (prefix, mpw_prefix): Handle it. + * mpw-config.in (mmalloc, readline): Don't configure. + * mpw-build.in (thisscript): Rename to ThisScript. + Use mpw-build instead of BuildProgram everywhere. + (mmalloc, readline): Don't build. + * mpw-README: New file, basic documentation about the MPW port. + + * mpw-config.in: Use forward-include to create include files. + + * mpw-configure: Add more things to the top of each configured + Makefile, including contents of config/mpw-mh-mpw. + * mpw-config.in (extra-include): Create this directory and fill it + with Posix-like include files when configuring. + + * config.sub (apple, mac, mpw): Add various aliases. + + * mpw-build.in: New file, top-level build script fragment for MPW. + * mpw-configure: New file, configure script for MPW. + * mpw-config.in: New file, config fragment for MPW. + +Fri Apr 7 19:33:16 1995 Jim Kingdon (kingdon@lioth.cygnus.com) + + * configure.in (host_libs): Remove glob, since it is gone from the + sources. + +Fri Mar 31 11:36:17 1995 Jason Molenda (crash@phydeaux.cygnus.com) + + * Makefile.in: define empty GDB_NLM_DEPS var. + + * configure.in(target_makefile_frag): use config/mt-netware + for netware targets. + +Thu Mar 30 13:51:43 1995 Ian Lance Taylor + + * config.sub: Merge in recent FSF changes. Remove linux special + cases. + +Tue Mar 28 14:47:34 1995 Jason Molenda (crash@phydeaux.cygnus.com) + + build-all.mk,config/mh-solaris: revert these two changes: + + Tue Mar 30 10:03:09 1993 Ian Lance Taylor (ian@cygnus.com) + + * build-all.mk: Use CC=cc -Xs on Solaris. + + Mon Mar 29 19:59:26 1993 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * config/mh-solaris: SunPRO C needs -Xs to be able to get a + working xmakefile for Emacs. + +Tue Mar 21 10:43:32 1995 Jim Kingdon (kingdon@lioth.cygnus.com) + + * glob/*: Removed. Schauer's 24 Feb 1994 readline change made us + stop using it. + * Makefile.in: Nuke all references to glob subdirectory. + +Thu Mar 16 13:35:30 1995 Jason Merrill + + * configure.in: Fix --enable-shared logic in per-host. + +Mon Mar 13 12:33:15 1995 Ian Lance Taylor + + * configure.in (*-hp-hpux[78]*): Use mh-hpux8. + +Mon Mar 6 10:21:58 1995 Jim Kingdon (kingdon@lioth.cygnus.com) + + * configure.in (noconfigdirs): Don't build gas on AIX, for + powerpc*-*-aix* as well as for rs6000*-*-aix*. + +Wed Mar 1 12:51:53 1995 Ian Lance Taylor + + * configure: Fix --cache-file to work if the file argument is a + relative path. + +Tue Feb 28 17:36:07 1995 Ian Lance Taylor + + * configure: If the --cache-file is used, pass it down to + configure in subdirectories. + +Mon Feb 27 12:52:46 1995 Kung Hsu + + * config.sub: add vxworks29k configuration. + +Fri Feb 10 16:12:26 1995 Ken Raeburn + + * Makefile.in (taz): Do "diststuff" part quietly. + +Sun Feb 5 14:16:35 1995 Doug Evans + + * config.sub: Mini-merge with gcc/config.sub. + +Sat Feb 4 12:11:35 1995 Jim Wilson + + * config.guess (IRIX): Sed - to _. + +Fri Feb 3 11:54:42 1995 J.T. Conklin + + * Makefile.in (source-vault, binary-vault): New targets. + +Thu Jan 26 13:00:11 1995 Michael Meissner + + * config.sub: Recognize -eabi as a basic system type. + +Thu Jan 12 13:13:23 1995 Jason Merrill + + * configure.in (enable_shared stuff): Fix typo. + +Thu Jan 12 01:36:51 1995 deanm@medulla.LABS.TEK.COM (Dean Messing) + + * Makefile.in (BASE_FLAGS_TO_PASS): Fix typo in passing LIBCXXFLAGS*. + +Wed Jan 11 16:29:53 1995 Jason Merrill + + * Makefile.in (LIBCXXFLAGS_FOR_TARGET): Add -fno-implicit-templates. + +Mon Jan 9 12:48:01 1995 Jim Kingdon + + * configure.in (rs6000-*-*): Don't build gas. + +Wed Jan 4 23:53:49 1995 Ian Lance Taylor + + * Makefile.in: Use /x/x/ instead of /brokensed/brokensed/, to + reduce command line length. + (AS_FOR_TARGET): Check for as.new, not Makefile. + (NM_FOR_TARGET): Check for nm.new, not Makefile. + +Wed Jan 4 13:02:39 1995 Per Bothner + + * config.guess: Merge from FSF. + +Thu Dec 15 17:11:37 1994 Ian Lance Taylor + + * configure: Don't use $ when handling program_suffix. + +Mon Dec 12 12:09:37 1994 Stu Grossman (grossman@cygnus.com) + + * configure.in: Configure tk for hppa/hpux. + +Fri Dec 2 15:55:38 1994 Per Bothner + + * Makefile.in (LIBGXX_SUPPORT_DIRS): Add libstdc++. + +Tue Nov 29 19:37:56 1994 Per Bothner + + * Makefile.in: Move -fno-implicit-template from CXXFLAGS + to LIBCXXFLAGS. Tests are better run without it. + +Wed Nov 23 10:29:25 1994 Brendan Kehoe (brendan@lisa.cygnus.com) + + * Makefile.in (all-ispell): Depend on all-emacs19 instead of all-emacs. + +Mon Nov 21 11:14:01 1994 J.T. Conklin + + * configure.in (*-*-netware*): Don't configure xiberty. + +Mon Nov 14 08:49:15 1994 Stu Grossman (grossman@cygnus.com) + + * configure.in: Remove tk from native_only list. + +Fri Nov 11 15:31:26 1994 Bill Cox (bill@rtl.cygnus.com) + + * build-all.mk: Add mips-ncd-elf target to sun4 targets + for special NCD build. + +Mon Nov 7 20:58:17 1994 Ken Raeburn + + * Makefile.in (DEVO_SUPPORT): Remove configure.bat and + makeall.bat, they're only useful for binutils snapshots. + (binutils.tar.gz, gas+binutils.tar.gz): Add configure.bat and + makeall.bat to specified SUPPORT_FILES. + +Mon Nov 7 17:25:18 1994 Bill Cox (bill@cirdan.cygnus.com) + + * build-all.mk: Add Ericsson targets to sun4 and solaris + hosts. Add BNR's sun4 target to solaris host, so their + build-from-source will be tested in-house first. + +Sat Nov 5 18:43:30 1994 Jason Merrill (jason@phydeaux.cygnus.com) + + * Makefile.in (LIBCFLAGS): New variable. + (CFLAGS_FOR_TARGET): Ditto. + (LIBCFLAGS_FOR_TARGET): Ditto. + (LIBCXXFLAGS): Ditto. + (CXXFLAGS_FOR_TARGET): Ditto. + (LIBCXXFLAGS_FOR_TARGET): Ditto. + (BASE_FLAGS_TO_PASS): Pass them. + (EXTRA_TARGET_FLAGS): Ditto. + + * configure.in, config/m[th]-*pic: Support --enable-shared. + +Sat Nov 5 15:44:00 1994 Per Bothner + + * configure.in (target_libs): Include libstdc++ again. + * config.guess: Update from FSF (for FreeBSD). + +Thu Nov 3 16:32:30 1994 Ken Raeburn + + * Makefile.in (DEVO_SUPPORT): Include configure.bat and + makeall.bat. + (DISTDOCDIRS): Add `etc'. + (ETC_SUPPORT_PFX): New variable. + (taz): Include anything from etc starting with a word in + ETC_SUPPORT_PFX. + +Wed Oct 26 16:19:35 1994 Ian Lance Taylor + + * config.sub: Update for recent FSF changes. Remove obsolete + h8300hds entry. Add -windows* and -osx as basic os. Minor + spacing changes. + +Thu Oct 20 18:41:56 1994 Per Bothner + + * configure.in (target_libs): Remove libstdc++ for libg++-2.6.1. + + * config.guess: Merge with FSF. + * configure.in: Match on i?86-ncr-sysv4.3, not i?86-ncr-sysv43. + +Thu Oct 20 19:26:56 1994 Ken Raeburn + + * configure: Since the "trap 0" handler will override the exit + status on many systems, only use it for "exit 1", and make it set + a non-zero exit status; reset it before "exit 0". Also, check + exit status of config.sub, and error out if it failed. + +Wed Oct 19 18:49:55 1994 Rob Savoye (rob@cygnus.com) + + * Makefile.in: (ALL_TARGET_MODULES,INSTALL_TARGET_MODULES) Build + and install libgloss. + +Tue Oct 18 15:25:24 1994 Ian Lance Taylor + + * Makefile.in (all-binutils): Depend upon all-byacc. + + * configure.in: Don't build emacs on Irix 5. + +Mon Oct 17 16:22:12 1994 J.T. Conklin (jtc@phishhead.cygnus.com) + + * configure.in (*-*-netware*): Add libio. + +Thu Oct 13 15:51:20 1994 Jason Merrill (jason@phydeaux.cygnus.com) + + * Makefile.in (ALL_TARGET_MODULES): Add libstdc++. + (CHECK_TARGET_MODULES): Ditto. + (INSTALL_TARGET_MODULES): Ditto. + (TARGET_LIBS): Ditto. + (all-libstdc++): Note dependencies. + +Thu Oct 13 01:43:08 1994 Ken Raeburn + + * Makefile.in (BINUTILS_SUPPORT_DIRS): Add gas. + +Tue Oct 11 12:12:29 1994 Jason Merrill (jason@phydeaux.cygnus.com) + + * Makefile.in (CXXFLAGS): Use -fno-implicit-templates instead of + -fexternal-templates. + + * configure.in (target_libs): Add libstdc++. + (noconfigdirs): Add libstdc++ as appropriate. + +Thu Oct 6 18:00:54 1994 Per Bothner (bothner@kalessin.cygnus.com) + + * config.guess: Update from FSF. + +Tue Oct 4 12:05:42 1994 Ian Lance Taylor + + * configure: Use ${config_shell} when running ${configsub}. + +Mon Oct 3 14:28:34 1994 Doug Evans + + * config.sub: No longer recognize h8300h. + +Mon Oct 3 12:40:54 1994 Ian Lance Taylor + + * config.sub: Remove extraneous differences between config.sub and + gcc/config.sub. + +Sat Oct 1 00:23:12 1994 Ken Raeburn + + * Makefile.in (DISTSTUFFDIRS): Add gas. + +Thu Sep 22 19:04:55 1994 Doug Evans (dje@canuck.cygnus.com) + + * COPYING.NEWLIB: New file. + +Mon Sep 19 18:25:40 1994 Per Bothner (bothner@kalessin.cygnus.com) + + * config.guess (HP-UX): Patch from Harlan Stenn + to also emit release level. + +Wed Sep 7 13:15:25 1994 Jim Wilson (wilson@sphagnum.cygnus.com) + + * config.guess (sun4*:SunOS:*:*): Change '-JL' to '_JL'. + +Tue Sep 6 23:23:18 1994 Per Bothner (bothner@kalessin.cygnus.com) + + * config.sub: Merge nextstep cleanup from FSF. + +Mon Sep 5 05:01:30 1994 Ken Raeburn (raeburn@kr-pc.cygnus.com) + + * configure.in (arm-*-*): Don't configure ld for this target. + +Thu Sep 1 09:35:00 1994 J.T. Conklin (jtc@phishhead.cygnus.com) + + * configure.in (*-*-netware): don't configure libg++, libio, + librx, or newlib. + +Wed Aug 31 13:52:08 1994 Ian Lance Taylor (ian@sanguine.cygnus.com) + + * configure.in (alpha-dec-osf*): Use osf*, not osf1*. Don't + configure ld--it works, but it doesn't support shared libraries. + +Sun Aug 28 18:13:45 1994 Per Bothner (bothner@kalessin.cygnus.com) + + * config.guess (*-unknown-freebsd*): Get rid of possible + trailing "(Release)" in version string. + Patch from Paul Richards . + +Sat Aug 27 15:00:49 1994 Per Bothner (bothner@kalessin.cygnus.com) + + * config.guess: Fix i486-ncr-sysv43 -> i486-ncr-sysv4.3. + Fix type: *-next-neststep -> *-next-nextstep. + + * config.guess: Merge from FSF: + + Fri Aug 26 18:45:25 1994 Philippe De Muyter (phdm@info.ucl.ac.be) + + * config.guess: Recognize powerpc-ibm-aix3.2.5. + + Wed Apr 20 06:36:32 1994 Philippe De Muyter (phdm@info.ucl.ac.be) + + * config.guess: Recognize UnixWare 1.1 (UNAME_SYSTEM is SYSTEM_V + instead of UNIX_SV for UnixWare 1.0). + +Sat Aug 27 01:56:30 1994 Stu Grossman (grossman@cygnus.com) + + * Makefile.in (all-gdb): Add dependencies on all-gcc and all-ld + to make gdb/nlm/* build after the compiler and linker. + +Fri Aug 26 14:30:05 1994 Per Bothner (bothner@kalessin.cygnus.com) + + * config.guess (netbsd, freebsd, linux): Accept any machine, + not just i[34]86. + (m68k-atari-sysv4): Relocate to match FSF version. + + * config.guess: More merges from the FSF: + + Add a space before function call or macro invocation. + + Tue May 10 16:53:55 1994 Roland McGrath (roland@churchy.gnu.ai.mit.edu) + + * config.guess: Add trap cmd to remove dummy.c and dummy when + interrupted. + + Wed Apr 20 18:07:13 1994 Roland McGrath (roland@churchy.gnu.ai.mit.edu) + + * config.guess (dummy.c): Redirect stderr for `hostinfo' command. + (dummy): Redirect stderr from compilation of dummy.c. + + Sat Apr 9 14:59:28 1994 Christian Kranz (kranz@sent5.uni-duisburg.de) + + * config.guess: Distinguish between NeXTStep 2.1 and 3.x. + +Fri Aug 26 13:42:20 1994 Ken Raeburn (raeburn@kr-laptop.cygnus.com) + + * configure: Accept and ignore --cache*, for compatibility with + new autoconf. + +Fri Aug 26 13:05:27 1994 Per Bothner (bothner@kalessin.cygnus.com) + + * config.guess: Merge from FSF: + + Thu Aug 25 20:28:51 1994 Richard Stallman + + * config.guess (Pyramid*:OSx*:*:*): New case. + (PATH): Add /.attbin at end for finding uname. + (dummy.c): Handle i860-alliant-bsd. Follow whitespace conventions. + + Wed Aug 17 18:21:02 1994 Tor Egge (tegge@pvv.unit.no) + + * config.guess (M88*:DolphinOS:*:*): New case. + + Thu Aug 11 17:00:13 1994 Stan Cox (coxs@dg-rtp.dg.com) + + * config.guess (AViiON:dgux:*:*): Use TARGET_BINARY_INTERFACE + to select whether to use ELF or COFF. + + Sun Jul 24 16:20:53 1994 Richard Stallman + + * config.guess: Recognize i860-stardent-sysv and i860-unknown-sysv. + + Sun May 1 10:23:10 1994 Richard Stallman (rms@mole.gnu.ai.mit.edu) + + * config.guess: Guess the OS version for HPUX. + + Tue Mar 1 21:53:03 1994 Karl Heuer (kwzh@hal.gnu.ai.mit.edu) + + * config.guess (UNAME_VERSION): Recognize aix3.2.4 and aix3.2.5. + +Fri Aug 26 11:19:08 1994 Ian Lance Taylor (ian@sanguine.cygnus.com) + + * configure.in: Recognize --with-headers, --with-libs, and + --without-newlib. + * Makefile.in (all-xiberty): Depend upon all-ld. + +Wed Aug 24 12:36:50 1994 Ian Lance Taylor (ian@sanguine.cygnus.com) + + * configure.in: Change i[34]86 to i[345]86. + +Mon Aug 22 10:58:33 1994 Ian Lance Taylor (ian@sanguine.cygnus.com) + + * configure (version): A few more tweaks to help message. + +Fri Aug 19 12:40:25 1994 Per Bothner (bothner@kalessin.cygnus.com) + + * Makefile.in: Remove (for now) librx as a host library, + now that we're building it for target. + +Fri Aug 19 10:49:17 1994 Ian Lance Taylor (ian@sanguine.cygnus.com) + + * configure: Fix up help message; from karl@owl.hq.ileaf.com + (Karl Berry). + +Tue Aug 16 16:11:08 1994 Per Bothner (bothner@kalessin.cygnus.com) + + * configure.in: Also configure librx. + +Mon Aug 15 16:51:45 1994 Per Bothner (bothner@kalessin.cygnus.com) + + * Makefile.in: Update various rules to reflect that librx + is now needed for libg++. + +Fri Aug 12 18:07:21 1994 Ian Lance Taylor (ian@sanguine.cygnus.com) + + * config.sub: Accept mips64orion and mips64orionel as a CPU name. + +Mon Aug 8 11:36:17 1994 Stan Shebs (shebs@andros.cygnus.com) + + * configure.in: Configure the examples directory. + +Thu Aug 4 16:12:36 1994 Ian Lance Taylor (ian@sanguine.cygnus.com) + + * configure: Simplify Jun 2 1994 change. + +Wed Aug 3 04:58:16 1994 D. V. Henkel-Wallace (gumby@cygnus.com) + + * change CC to /usr/latest/bin/gcc for lynx host builds, since + /bin/gcc isn't good enough to build gcc. + +Wed Jul 27 09:07:14 1994 Fred Fish (fnf@cygnus.com) + + * Makefile.in (GDB_SUPPORT_FILES): Remove + (setup-dirs-gdb, gdb.tar.gz, make-gdb.tar.gz): Remove old rules. + (gdb.tar.gz): Add new rule to use standard distribution building + mechanism. + +Mon Jul 25 11:10:06 1994 Ian Lance Taylor (ian@tweedledumb.cygnus.com) + + * configure.in: Warn about use of /usr/ucb/cc on Solaris. From + Bill Cox . + +Sat Jul 23 12:19:46 1994 Per Bothner (bothner@kalessin.cygnus.com) + + * config.guess: Recognize ISC. Patch from kwzh@gnu.ai.mit.edu. + +Fri Jul 22 17:53:59 1994 Stu Grossman (grossman@cygnus.com) + + * configure: Search current dir first in .gdbinit. + +Fri Jul 22 11:28:30 1994 Per Bothner (bothner@kalessin.cygnus.com) + + * config.sub: Recognize freebsd (merged from gcc config.sub). + +Thu Jul 21 14:10:52 1994 Per Bothner (bothner@kalessin.cygnus.com) + + * config.sub: Refer to NeXT's operating system as nextstep. + + * config.sub (case $basic_machine): Re-order the cases, to match + the order in the FSF version (which is mostly alphabethical). + Merge in some additions and changes from the FSF. + +Sat Jul 16 12:03:08 1994 Stan Shebs (shebs@andros.cygnus.com) + + * config.guess: Recognize m68k-atari-sysv4 and m88k-harris-csux7. + * config.sub: Recognize cxux7. + * configure.in: Use mh-cxux for m88k-harris-cxux*. + +Mon Jul 11 14:37:39 1994 Per Bothner (bothner@kalessin.cygnus.com) + + * config.sub: Fix typo powerpc -> powerpc-*. + +Sat Jul 9 13:03:43 1994 Michael Tiemann (tiemann@blues.cygnus.com) + + * Makefile.in: `all-emacs19' depends on `all-byacc'. + + * Makefile.in: Add all-emacs19 and install-emacs19 rules (in + parallel with all-emacs and install-emacs). Top-level command + `make all-emacs19 CC=gcc' now behaves as `make all-emacs CC=gcc'. + +Thu Jun 30 16:53:42 1994 Ian Lance Taylor (ian@sanguine.cygnus.com) + + * test-build.mk ($(host)-stamp-stage2-installed): Remove + $(relbindir)/make before doing ``make install'', and use + $(GNU_MAKE) while doing it. Avoids problem on SunOS with + installing over running make binary. + ($(host)-stamp-stage3-installed): Likewise. + +Tue Jun 28 13:43:25 1994 Jim Kingdon (kingdon@lioth.cygnus.com) + + * config.guess: Recognize Mach. + +Mon Jun 27 16:41:14 1994 Ian Lance Taylor (ian@sanguine.cygnus.com) + + * configure: Check ${exec_prefixoption}, not ${exec_prefix}, to + see whether --exec-prefix was used. + +Sun Jun 26 21:15:54 1994 Per Bothner (bothner@kalessin.cygnus.com) + + * README: Explicitly mention libg++/README. (Zoo's idea.) + +Tue Jun 21 12:45:55 1994 Jim Kingdon (kingdon@lioth.cygnus.com) + + * Makefile.in: Add all-librx target similar to all-libproc. + +Wed Jun 8 23:11:55 1994 Stu Grossman (grossman@cygnus.com) + + * config.guess: Rearrange tests for Alpha-OSF1 to properly deal + with post 1.2 uname bogosity. + +Thu Jun 9 00:27:59 1994 Ian Lance Taylor (ian@tweedledumb.cygnus.com) + + * configure: Remove temporary files on receipt of a signal. + +Tue Jun 7 12:06:24 1994 Ian Lance Taylor (ian@cygnus.com) + + * configure: If there is a package_makefile_frag, remove + ${subdir}/Makefile.tem after copying it in. + +Mon Jun 6 21:35:02 1994 D. V. Henkel-Wallace (gumby@cygnus.com) + + * build_all.mk: support rs6000 lynx identifies itself as + rs6000-lynx-lynxos2.2.2. Also, use /usr/cygnus/progressive/bin/gcc + since /bin/gcc is too feeble to compile a modern gcc. + +Mon Jun 6 16:06:34 1994 Karen Christiansen (karen@cirdan.cygnus.com) + + * brought devo/test-build.mk update-to-date with progressive/ + test-build.mk. Add lynx targets and hppa flag info. + +Sat Jun 4 17:23:54 1994 Per Bothner (bothner@kalessin.cygnus.com) + + * configure.in: Use mh-ncrsvr43. Patch from + Tom McConnell . + +Fri Jun 3 17:47:24 1994 Per Bothner (bothner@kalessin.cygnus.com) + + * config.guess (i386-unknown-bsdi): No longer need to + check #if defined(__bsdi__) && defined(__i386__). + +Thu Jun 2 18:56:46 1994 Ian Lance Taylor (ian@tweedledumb.cygnus.com) + + * configure: Set program_transform_nameoption correctly. + +Thu Jun 2 10:57:06 1994 Karen Christiansen (karen@cirdan.cygnus.com) + + * brought build-all.mk update-to-date with progressive build-all.mk, + added new targets and hppa info. + +Thu Jun 2 00:12:44 1994 Ian Lance Taylor (ian@tweedledumb.cygnus.com) + + * configure: If config.guess result is a prefix of the user + specified target, assume a native build and use the user specified + target as the host alias. Remove SunOS patch suffix removal hack. + * configure.in: Remove SunOS patch suffix removal hack. + + * Makefile.in (CROSS_CHECK_MODULES): Remove check-flex, since it's + in NATIVE_CHECK_MODULES. + +Wed Jun 1 10:49:41 1994 Bill Cox (bill@rtl.cygnus.com) + + * Makefile.in: Rename HOST_ONLY to NATIVE. + * configure: Delete SunOs patch suffix from host_canonical + and build_canonical variables that are prepended to Makefiles. + * configure.in: Add comments for easier maintenance. + +Tue May 31 19:39:47 1994 Jim Kingdon (kingdon@lioth.cygnus.com) + + * Makefile.in: Add all-libproc target similar to all-gui. + +Tue May 31 17:16:33 1994 Tom Lord (lord@cygnus.com) + + * Makefile.in (CHECK_MODULES): split into + HOST_ONLY_CHECK_MODULES and CROSS_CHECK_MODULES. + +Tue May 31 16:36:36 1994 Paul Eggert (eggert@twinsun.com) + + * config.guess (i386-unknown-bsdi): New system to guess. + +Wed May 25 16:47:10 1994 Jim Kingdon (kingdon@lioth.cygnus.com) + + * Makefile.in: Add all-gui target (but not yet build by "all"). + +Thu May 26 08:53:19 1994 Bill Cox (bill@rtl.cygnus.com) + + * config.sub: Move deletion of patch suffix from here... + * configure.in: To here, at Ian's suggestion. The top- + level scripts might need to know of a patch level. + +Wed May 25 09:15:54 1994 Bill Cox (bill@rtl.cygnus.com) + + * config.sub: Strip off patch suffix so rtl is recognized + as a sunos4.1.3 machine, even though it's been patched. + +Fri May 20 08:25:49 1994 Steve Chamberlain (sac@deneb.cygnus.com) + + * Makefile.in (INSTALL_LAST): Delete. + (INSTALL_DOSREL): New. + +Thu May 19 17:12:12 1994 Ian Lance Taylor (ian@tweedledumb.cygnus.com) + + * configure.in: Use ld for i[34]86-*-sysv4* and sparc-*-solaris2*. + Don't set use_gnu_ld to no for *-*-sysv4; that only controls + whether we pass down --with-gnu-ld anyhow. + +Thu May 19 09:29:12 1994 Steve Chamberlain (sac@cygnus.com) + + * Makefile.in (INSTALL_LAST): Change operation so it works + on more flavors of make. + * configure.in (go32): Don't build libg++ or libio. + +Fri May 13 13:28:34 1994 Steve Chamberlain (sac@cygnus.com) + + * Makefile.in (Move HOST_PREFIX_1 and friends up so + they can be overriden by templates. + +Sat May 7 16:46:44 1994 Steve Chamberlain (sac@cygnus.com) + + * configure.in (target==go32): Don't build gdb. + * dosrel: New directory. + +Fri May 6 14:19:25 1994 Steve Chamberlain (sac@cygnus.com) + + * configure.in (host==go32): Configure dosrel too. + * Makefile.in (INTALL_TARGET): Call INSTALL_LAST last. + (HOST_CC, HOST_PREFIX, HOST_PREFIX_1): Undefine, they should + be set by incoming names or templates. + (INSTALL_LAST): New rule. + * config/mh-go32: New fragment. + +Thu May 5 17:35:05 1994 Stan Shebs (shebs@andros.cygnus.com) + + * config.sub (sparclitefrw, sparclitefrwcompat): Don't set the os. + +Thu May 5 20:06:45 1994 Ken Raeburn (raeburn@cujo.cygnus.com) + + * config/mh-lynxrs6k: Renamed from mh-lynxosrs6k, to make it + unique in 8.3 naming schemes. + * configure.in (appdirs): New variable. Currently empty, but will + be used in gas distribution. If nonempty, lists a set of + directories at least one of which must get configured, or top + level configuration is considered to have failed. + (rs6000-*-lynxos*): Use new file name. + +Thu May 5 13:38:36 1994 Ian Lance Taylor (ian@tweedledumb.cygnus.com) + + Eliminate XTRAFLAGS. + * Makefile.in (CC_FOR_TARGET): If newlib exists, refer to the + newlib include files using -idirafter, and also use -nostdinc. + (CXX_FOR_TARGET): Likewise. + (XTRAFLAGS): Removed. + (BASE_FLAGS_TO_PASS): Remove XTRAFLAGS_FOR_TARGET. + (EXTRA_HOST_FLAGS): Remove XTRAFLAGS. + (EXTRA_TARGET_FLAGS, EXTRA_GCC_FLAGS): Likewise. + ($(DO_X)): Don't pass down XTRAFLAGS. + +Thu May 5 00:16:36 1994 Ken Raeburn (raeburn@kr-pc.cygnus.com) + + * configure.in (mips*-dec-bsd*): New target; do build linker. + (mips*-*-bsd*): New target; don't build linker. + +Wed May 4 20:10:10 1994 D. V. Henkel-Wallace (gumby@cygnus.com) + + * configure.in: support rs6000-*-lynxos* configuration. + support sunos4 as a cross target. + + * config.sub: look for lynx*, not lynx since the OS version may + legitimately be part of the name. + +Tue May 3 21:48:11 1994 Ken Raeburn (raeburn@cujo.cygnus.com) + + * configure.in (i[34]86-*-sco*): Move to be with other i386 + targets. + (romp-*-*): New target. Skip various binary utilities. + (vax-*-*): New target. Don't build newlib. + (vax-*-vms): Renamed from *-*-vms. Don't build opcodes or newlib. + +Thu Apr 28 15:03:05 1994 David J. Mackenzie (djm@rtl.cygnus.com) + + * configure.in: Only set host_makefile_frag if config + directory exists. + +Wed Apr 27 12:14:30 1994 David J. Mackenzie (djm@rtl.cygnus.com) + + * install.sh: If $dstdir exists, don't check whether each + component does. + +Tue Apr 26 18:11:33 1994 Ian Lance Taylor (ian@tweedledumb.cygnus.com) + + * test-build.mk (HOLES): Add sleep; used by rcs/src/conf.sh. + +Mon Apr 25 15:06:34 1994 Stan Shebs (shebs@andros.cygnus.com) + + * configure.in (*-*-lynxos*): Don't configure newlib for either + native or cross Lynx. + +Sat Apr 16 11:58:16 1994 Doug Evans (dje@canuck.cygnus.com) + + * config.sub (sparc64-elf): Fix os. + (z8k): Remove duplicate. + +Thu Apr 14 23:33:17 1994 Ian Lance Taylor (ian@tweedledumb.cygnus.com) + + * Makefile.in (gcc-no-fixedincludes): Touch gcc/include/fixed, not + gcc/stmp-fixproto, to try to prevent fixproto from being run. + +Wed Apr 13 15:14:52 1994 Bill Cox (bill@cygnus.com) + + * configure: Make file links cleanly even if Lynx fails on + an NFS symlink (at least fail cleanly). + +Mon Apr 11 10:58:56 1994 Jim Wilson (wilson@sphagnum.cygnus.com) + + * test-build.mk (CC): For mips-sgi-irix4, change -XNh1500 to + -XNh2000. + +Sat Apr 9 15:10:45 1994 David J. Mackenzie (djm@rtl.cygnus.com) + + * configure: Unknown options are fatal again. + +Fri Apr 8 12:01:41 1994 David J. Mackenzie (djm@cygnus.com) + + * configure: Ignore --x-includes and --x-libraries, for Autoconf + compatibility. + +Thu Apr 7 17:31:43 1994 Doug Evans (dje@canuck.cygnus.com) + + * build-all.mk: Add `clean' target. + +Wed Apr 6 20:44:56 1994 Peter Schauer (pes@regent.e-technik.tu-muenchen.de) + + * config.guess: Add SINIX support. + * configure.in: Add mips-*-sysv4* support. + +Mon Apr 4 17:41:44 1994 Doug Evans (dje@canuck.cygnus.com) + + * build-all.mk: Document all useful targets. + If canonhost is sparc-sun-solaris2.3, change it to sparc-sun-solaris2. + If canonhost is mips-sgi-irix4.0.5H, change it to mips-sgi-irix4. + +Thu Mar 31 04:55:57 1994 David J. Mackenzie (djm@rtl.cygnus.com) + + * configure: Support --silent, --quiet. + +Wed Mar 30 21:37:38 1994 David J. Mackenzie (djm@rtl.cygnus.com) + + * configure: Support --disable-FEATURE. + +Tue Mar 29 19:15:05 1994 Jim Kingdon (kingdon@lioth.cygnus.com) + + * config.guess: Recognize NCR running SVR4.3. + +Mon Mar 28 14:55:15 1994 Per Bothner (bothner@kalessin.cygnus.com) + + * config.guess: Make BSDI generate i386-unknown-bsd386. + Patch from Paul Eggert . + +Mon Mar 28 12:54:52 1994 Ian Lance Taylor (ian@tweedledumb.cygnus.com) + + * configure.in (powerpc-*-aix*): Treat like rs6000-*-*. + +Sat Mar 26 11:25:48 1994 David J. Mackenzie (djm@rtl.cygnus.com) + + * configure: Make unrecognized options give nonfatal warnings + instead of fatal errors, and pass them to any subdirectory + configures in case they recognize them. + Make --x equivalent to --with-x. + +Fri Mar 25 21:52:10 1994 David J. Mackenzie (djm@rtl.cygnus.com) + + * configure: Add --enable-* options. Clean up usage message and + some comments. + +Thu Mar 24 09:12:53 1994 Doug Evans (dje@canuck.cygnus.com) + + * Makefile.in (NM_FOR_TARGET): Build tree version is now nm.new. + +Sun Mar 20 11:28:22 1994 Jeffrey A. Law (law@snake.cs.utah.edu) + + * configure.in (hppa*-*-*): Enable binutils. + +Sat Mar 19 11:50:16 1994 Jim Kingdon (kingdon@lioth.cygnus.com) + + * config.sub: Recognize cisco. + +Fri Mar 18 16:42:32 1994 Jason Merrill (jason@deneb.cygnus.com) + + * Makefile.in (CXXFLAGS): Add -fexternal-templates. + +Tue Mar 15 11:25:55 1994 Jim Kingdon (kingdon@lioth.cygnus.com) + + * config.guess: about target *-hitachi-hiuxwe2, don't print more + than one configuration name. Add comment. + +Sun Mar 6 23:13:38 1994 Hisashi MINAMINO (minamino@sra.co.jp) + + * config.guess: about target *-hitachi-hiuxwe2, fixed + machine guessing order. [Hitachi's CPU_IS_HP_MC68K + macro is incorrect.] + +Sun Mar 13 09:10:08 1994 Jim Kingdon (kingdon@lioth.cygnus.com) + + * Makefile.in (TAGS): Just build TAGS in each subdirectory, rather + than the "make ls" stuff which used to be here. + +Fri Mar 11 12:52:39 1994 Per Bothner (bothner@kalessin.cygnus.com) + + * config.guess: Recognize i[34]86-unknown-freebsd. + From Shawn M Carey . + +Thu Mar 3 14:24:21 1994 Per Bothner (bothner@kalessin.cygnus.com) + + * configure.in (noconfigdirs for alpha): Remove libg++ and libio. + +Wed Mar 2 13:28:48 1994 Jim Kingdon (kingdon@deneb.cygnus.com) + + * config.guess: Check for ptx. + +Mon Feb 28 16:46:50 1994 Kung Hsu (kung@mexican.cygnus.com) + + * config.sub: Add os9k checking. + +Thu Feb 24 07:09:04 1994 Jeffrey A. Law (law@snake.cs.utah.edu) + + * config.guess: Handle OSF1 running on HPPA processors + +Fri Feb 18 14:14:00 1994 Ken Raeburn (raeburn@rtl.cygnus.com) + + * configure: If subdir configure fails, print out a message with + subdirectory name, in case subdir's configure code didn't identify + itself. + +Fri Feb 18 12:50:15 1994 Doug Evans (dje@cygnus.com) + + * configure.in: Remove embedded newlines from configdirs. + Avoid mismatches of substrings. Fix matching strings at end + of configdirs. + +Fri Feb 11 15:33:33 1994 Stu Grossman (grossman at cygnus.com) + + * config.guess: Add Lynx/rs6000 config support. + +Tue Feb 8 13:41:09 1994 Ken Raeburn (raeburn@rtl.cygnus.com) + + * configure.in (alpha-dec-osf1*, alpha*-*-*): Build gas. + +Mon Feb 7 15:42:36 1994 Jeffrey A. Law (law@cygnus.com) + + * configure.in (hppa*-*-osf*): Treat this just like most other + PA configurations (eg no binutils or ld). + (hppa*-*-*elf*): These configurations have binutils and ld. + +Sun Feb 6 16:35:07 1994 Jeffrey A. Law (law@snake.cs.utah.edu) + + * config.sub (hiux): Fix typo. From m-kasahr@sramhc.sra.co.JP. + +Sat Feb 5 01:00:33 1994 Ian Lance Taylor (ian@tweedledumb.cygnus.com) + + * configure.in (rs6000-*-*): Build gas. + +Wed Feb 2 13:57:57 1994 Jeffrey A. Law (law@snake.cs.utah.edu) + + * Makefile.in: Avoid bug in losing hpux sed. + +Wed Feb 2 14:53:05 1994 Jim Kingdon (kingdon@lioth.cygnus.com) + + * Makefile.in, test-build.mk: Remove MUNCH_NM; it was only needed + for GDB and GDB has been fixed to not need it. + +Mon Jan 31 18:40:55 1994 Stu Grossman (grossman at cygnus.com) + + * config/mh-lynxosrs6k: Account for lack of ranlib! + +Sun Jan 30 17:58:06 1994 Ken Raeburn (raeburn@cujo.cygnus.com) + + * config.guess: Recognize vax hosts. + +Fri Jan 28 15:29:38 1994 Ken Raeburn (raeburn@cujo.cygnus.com) + + * configure (while loop): Don't use "break 2" inside case + statement -- the case statement isn't an enclosing loop. + +Mon Jan 24 18:40:06 1994 Per Bothner (bothner@kalessin.cygnus.com) + + * config.guess: Clean up NeXT support, to allow nextstep + on Intel machines. Make OS be nextstep. + +Sun Jan 23 18:47:22 1994 Richard Kenner (kenner@vlsi1.ultra.nyu.edu) + + * config.guess: Add alternate forms for Convex. + +Thu Jan 20 16:13:41 1994 Stu Grossman (grossman at cygnus.com) + + * configure: Completely rewrite option processing. Take + advantage of pattern-matching to avoid invoking test frequently. + Also clean up host and target defaulting logic. + +Mon Jan 17 15:06:56 1994 Ken Raeburn (raeburn@cujo.cygnus.com) + + * Makefile.in: Replace all occurrances of "rootme" with "r" and + "$${rootme}" with "$$r", to increase the likelihood that the do-* + commands (plus user environment) will fit SCO limits. + +Thu Jan 6 11:20:57 1994 Ian Lance Taylor (ian@tweedledumb.cygnus.com) + + * configure.in: Don't issue warnings about directories which are + not being configured if -norecursion is set. Correct test for + --with-gnu-as and --with-gnu-ld to not get confused by substring + matches. + + * configure.in: Don't build gas for alpha-dec-osf1*. + +Tue Jan 4 17:10:19 1994 Stu Grossman (grossman at cygnus.com) + + * configure: Back out Per's change of 12/19/1993. It changes the + behavior of configure in unexpected and confusing ways. + + Also, use different delim char when calculating + program_transform_name so that the name can contain slashes. + +Sat Jan 1 13:45:31 1994 Rob Savoye (rob@darkstar.cygnus.com) + + * configure.in, config.sub: Add support for VSTa micro-kernel. + +Sat Dec 25 20:00:47 1993 Jeffrey A. Law (law@snake.cs.utah.edu) + + * configure.in: Nuke hacks which were used to get a special + version of GAS for HPPA configurations. + +Sun Dec 19 20:40:44 1993 Per Bothner (bothner@kalessin.cygnus.com) + + * configure: If only ${target_alias} is given, use that + as the default for ${host_alias}. + * configure: Add missing back-slashes before nested quotes. + +Wed Dec 15 18:07:18 1993 david d `zoo' zuhn (zoo@andros.cygnus.com) + + * Makefile.in (BASE_FLAGS_TO_PASS): add YACC=$(BISON) + +Tue Dec 14 21:25:33 1993 Per Bothner (bothner@cygnus.com) + + * config.guess: Recognize some Tektronix configurations. + From Kaveh R. Ghazi . + +Sat Dec 11 11:18:00 1993 Steve Chamberlain (sac@thepub.cygnus.com) + + * config.sub: Match any flavor of SH. + +Thu Dec 2 17:16:58 1993 Ken Raeburn (raeburn@cujo.cygnus.com) + + * configure.in: Don't try to configure newlib for Alpha. + +Thu Dec 2 14:35:54 1993 Ian Lance Taylor (ian@tweedledumb.cygnus.com) + + * configure.in: Don't build ld for Irix 5. Don't build gas, + libg++ or libio for any Alpha target. + + * configure.in (mips*-sgi-irix5*): New target; use mh-irix5. + * config/mh-irix5. New file for Irix 5. + +Wed Dec 1 17:00:33 1993 Jason Merrill (jason@deneb.cygnus.com) + + * Makefile.in (GZIPPROG): Renamed from GZIP, which gzip uses for + default arguments -- so it tried to compress itself. + +Tue Nov 30 13:45:15 1993 david d `zoo' zuhn (zoo@andros.cygnus.com) + + * configure.in (notsupp): ensure that a space is always at the end + of the configdirs list, since the grep checks for an explicit space + +Tue Nov 16 15:04:27 1993 david d `zoo' zuhn (zoo@rtl.cygnus.com) + + * configure.in (target i386-sysv4.2): don't build ld, since static + versions of many libraries are not available. + +Tue Nov 16 14:28:12 1993 Jim Kingdon (kingdon@lioth.cygnus.com) + + * config.guess: Recognize Apollos (using environment variables). + * configure.in: Don't configure ld, binutils, or gprof for Apollo. + +Thu Nov 11 12:03:50 1993 Jim Kingdon (kingdon@lioth.cygnus.com) + + * config.guess: Recognize Sony news mips running newsos. + +Wed Nov 10 16:57:00 1993 Mark Eichin (eichin@cygnus.com) + + * Makefile.in (all-cygnus, build-cygnus): "fi else" needs to be + "fi ; else" for bash. + +Tue Nov 9 15:54:01 1993 Mark Eichin (eichin@cygnus.com) + + * Makefile.in (BASE_FLAGS_TO_PASS): pass SHELL. + +Fri Nov 5 08:07:27 1993 D. V. Henkel-Wallace (gumby@blues.cygnus.com) + + * config.sub: accept unixware as an alias for svr4.2. + Fix some inconsistancies with the gcc version. + +Fri Nov 5 15:14:12 1993 Jim Kingdon (kingdon@lioth.cygnus.com) + + * Makefile.in (DISTDOCDIRS): Add gdb. + +Fri Nov 5 11:59:42 1993 Per Bothner (bothner@kalessin.cygnus.com) + + * Makefile.in (DISTDOCDIRS): Add libg++ and libio. + +Fri Nov 5 10:35:05 1993 Ken Raeburn (raeburn@rover.cygnus.com) + + * Makefile.in (taz): Only build "info" in DISTDOCDIRS. + (DISTDOCDIRS): Don't assume libg++ and gdb folks necessarily want + this now. + +Thu Nov 4 18:58:23 1993 Jim Kingdon (kingdon@lioth.cygnus.com) + + * config.sub: Accept hiux* as an OS name. + + * Makefile.in: Change RUNTEST_FLAGS back to RUNTESTFLAGS per + etc/make-stds.texi. The underscore came from gcc, and dje now + agrees that RUNTESTFLAGS is the correct name. + +Thu Nov 4 10:49:01 1993 Per Bothner (bothner@kalessin.cygnus.com) + + * install.sh: Remove 'set -e'. It makes any conditionals + in the script useless. + + * config.guess: Automatically recognize arm-acorn-riscix + Patch from Richard Earnshaw (rwe11@cl.cam.ac.uk). + +Thu Nov 04 08:08:04 1993 Jeffrey Wheat (cassidy@cygnus.com) + + * Makefile.in: Change RUNTESTFLAGS to RUNTEST_FLAGS + +Wed Nov 3 22:09:46 1993 Ken Raeburn (raeburn@rtl.cygnus.com) + + * Makefile.in (DISTDOCDIRS): New variable. + (taz): Edit local Makefile.in sooner, instead of proto-toplev + Makefile.in later. Build "info" and "dvi" in DISTDOCDIRS. + +Wed Nov 3 21:31:52 1993 david d `zoo' zuhn (zoo@rtl.cygnus.com) + + * configure.in (hppa target): check the source directory for the + pagas sub-directory + +Wed Nov 3 11:12:22 1993 Doug Evans (dje@canuck.cygnus.com) + + * config.sub: Allow -aout* and -elf*. + +Wed Nov 3 11:08:33 1993 Ken Raeburn (raeburn@rtl.cygnus.com) + + * configure.in: Don't build ld on i386-solaris2, same as for + sparc-solaris2. + +Tue Nov 2 14:21:25 1993 Per Bothner (bothner@kalessin.cygnus.com) + + * Makefile.in (taz): Add texinfo/lgpl.texinfo (for libg++). + +Tue Nov 2 13:38:30 1993 Peter Schauer (pes@regent.e-technik.tu-muenchen.de) + + * configure.in: Configure gdb for alpha. + +Mon Nov 1 10:42:54 1993 Jim Kingdon (kingdon@lioth.cygnus.com) + + * Makefile.in (CXXFLAGS): Add -O. + +Wed Oct 27 10:45:06 1993 david d `zoo' zuhn (zoo@rtl.cygnus.com) + + * config.guess: added support for DG Aviion + +Tue Oct 26 14:37:37 1993 Ken Raeburn (raeburn@rover.cygnus.com) + + * configure.in: Produce warning message for subdirectories not + configurable for this host/target combination. Don't try to + configure gdb for vms. + +Mon Oct 25 11:22:15 1993 Ken Raeburn (raeburn@rover.cygnus.com) + + * Makefile.in (taz): Replace "byacc" with "bison -y" in the + appropriate files before making "diststuff". + (DISTBISONFILES): New var: list of files to be edited. + (DISTSTUFFDIRS): Add binutils. + +Fri Oct 22 20:32:15 1993 david d `zoo' zuhn (zoo@rtl.cygnus.com) + + * config.sub: also handle mipsel and mips64el (for little endian mips) + +Fri Oct 22 07:59:20 1993 Jim Kingdon (kingdon@lioth.cygnus.com) + + * configure.in: Add * to end of all OS names. + +Thu Oct 21 11:38:28 1993 Stan Shebs (shebs@rtl.cygnus.com) + + * configure.in: Build newlib for LynxOS native. + +Wed Oct 20 09:56:12 1993 Jim Kingdon (kingdon@lioth.cygnus.com) + + * config.guess: Add support for delta 88k running SVR3. + + * configure.in: Add comment about HP compiler vs. emacs. + +Tue Oct 19 16:02:22 1993 david d `zoo' zuhn (zoo@rtl.cygnus.com) + + * configure.in: don't build ld on solaris2 (not a viable option + due to bugs in getpwnam & getpwuid) + +Tue Oct 19 15:13:56 1993 Ken Raeburn (raeburn@rtl.cygnus.com) + + * configure.in: Accept alpha-dec-osf1*, not just -osf1, since + config.guess will produce a full version number. + +Tue Oct 19 15:58:01 1993 Ian Lance Taylor (ian@tweedledumb.cygnus.com) + + * configure.in: Build linker and binutils for alpha-dec-osf1. + +Tue Oct 19 11:41:55 1993 Jim Kingdon (kingdon@lioth.cygnus.com) + + * Makefile.in: Remove -O from CXXFLAGS for consistency with CFLAGS, + and gdb/testsuite/Makefile.in. + +Sat Oct 9 18:39:07 1993 david d `zoo' zuhn (zoo@rtl.cygnus.com) + + * configure.in: recognize mips*- instead of mips- + +Fri Oct 8 14:15:39 1993 Ken Raeburn (raeburn@cygnus.com) + + * config.sub: Accept linux*coff and linux*elf as operating + systems. + +Thu Oct 7 12:57:19 1993 Ian Lance Taylor (ian@tweedledumb.cygnus.com) + + * config.sub: Recognize mips64, and mips3 as an alias for it. + +Wed Oct 6 13:54:21 1993 Peter Schauer (pes@regent.e-technik.tu-muenchen.de) + + * configure.in: Remove alpha-dec-osf*, no longer necessary now that + gdb knows how to handle OSF/1 shared libraries. + +Tue Oct 5 11:55:04 1993 Jim Kingdon (kingdon@lioth.cygnus.com) + + * configure.in: Recognize hppa*-*-hiux* (currently synonym for hpux). + * config.guess: Recognize Hitachi's HIUX. + * config.sub: Recognize h3050r* and hppahitachi. + Remove redundant cases for hp9k[23]*. + +Mon Oct 4 16:15:09 1993 david d `zoo' zuhn (zoo@rtl.cygnus.com) + + * configure.in: default to '--with-gnu-as' and '--with-gnu-ld' + if gas and ld are in the source tree and are in ${configdirs}. + If ${use_gnu_as} or ${use_gnu_ld} are 'no', then don't set the + the --with options (but still pass them down on the command line, + if they were explicitly specified). + +Fri Sep 24 19:11:13 1993 david d `zoo' zuhn (zoo@rtl.cygnus.com) + + * configure: substitute SHELL value in Makefile.in with + ${CONFIG_SHELL} + +Thu Sep 23 18:05:13 1993 Ian Lance Taylor (ian@tweedledumb.cygnus.com) + + * configure.in: Build gas, ld, and binutils for *-*-sysv4* and + *-*-solaris2* targets. + +Sun Sep 19 17:01:41 1993 david d `zoo' zuhn (zoo@rtl.cygnus.com) + + * Makefile.in: define M4, and pass it down to sub-makes; + all-autoconf now depends on all-m4 + +Sat Sep 18 00:38:23 1993 david d `zoo' zuhn (zoo@rtl.cygnus.com) + + * Makefile.in ({AR,RANLIB}_FOR_TARGET): make contingent on + presence of {ar,ranlib} instead of a configured directory + +Wed Sep 15 08:41:44 1993 Jim Kingdon (kingdon@cirdan.cygnus.com) + + * config.guess: Accept 34?? as well as 33?? for NCR. + +Mon Sep 13 12:28:43 1993 david d `zoo' zuhn (zoo@rtl.cygnus.com) + + * configure.in: grab mt-hppa for HPPA targets; use 'gas ' instead + of 'gas' in sed commands, since 'gash' is now in the tree as well. + +Fri Sep 10 11:23:52 1993 david d `zoo' zuhn (zoo@rtl.cygnus.com) + + * configure: grab values for $(CC) and $(CXX) from the + environment, so that someone can do "CC=gcc configure; make" and + have it work right (matching the way that autoconf works now) + + * configure.in, Makefile.in: add support for gash, the tcl + interface to Galaxy + + * config.guess: add NetBSD variants (hp300, x86) + +Thu Sep 9 16:48:52 1993 Jason Merrill (jason@deneb.cygnus.com) + + * install.sh: Support -d option (in the manner of SunOS 4 install, + as it is more deterministic than that of GNU install) + (chmodcmd): Set file to mode 755 by default (should also do default + chgrp and chown, but I don't feel like dealing with that now) + +Tue Sep 7 11:59:39 1993 Doug Evans (dje@canuck.cygnus.com) + + * config.sub: Remove h8300hhms alias. + +Tue Aug 31 11:00:09 1993 Jim Kingdon (kingdon@lioth.cygnus.com) + + * configure.in: Match *-*-solaris2* not *-sun-solaris2*. + +Mon Aug 30 18:29:10 1993 david d `zoo' zuhn (zoo@rtl.cygnus.com) + + * Makefile.in (gcc-no-fixedincludes): touch stmp-fixproto as well + as stmp-fixinc + +Wed Aug 25 16:35:59 1993 K. Richard Pixley (rich@sendai.cygnus.com) + + * config.sub: recognize m88110-bug-coff. + +Tue Aug 24 10:23:24 1993 david d `zoo' zuhn (zoo@rtl.cygnus.com) + + * Makefile.in (all-libio): all dependencies on the toolchain used + to build this (gcc, gas, ld, etc) + +Fri Aug 20 17:24:24 1993 Jim Kingdon (kingdon@lioth.cygnus.com) + + * config.guess: Deal with OSF/1 1.3 on alpha. + +Thu Aug 19 11:43:04 1993 david d `zoo' zuhn (zoo@rtl.cygnus.com) + + * install.sh: add some 'else true' clauses for portability + + * configure.in: don't build libio for h8[35]00-*-* targets + +Tue Aug 17 19:02:31 1993 Per Bothner (bothner@kalessin.cygnus.com) + + * Makefile.in: Add support for new libio. + +Sun Aug 15 20:48:55 1993 Jim Kingdon (kingdon@lioth.cygnus.com) + + * install.sh: If one command fails, don't try the rest. Don't try + to remove $dsttmp (via trap) unless we have already created it. + If $src doesn't exist, detect it and exit with an error. + + * config.guess: Recognize BSD on hp300. + +Wed Aug 11 18:35:13 1993 Per Bothner (bothner@kalessin.cygnus.com) + + * config.guess: Map (9000/[34]??:HP-UX:*:*) to m68k-hp-hpux. + Bug report from "Hamish (H.I.) Macdonald" . + +Wed Aug 11 15:37:51 1993 Jason Merrill (jason@deneb.cygnus.com) + + * Makefile.in (all-send-pr): depends on all-prms + +Wed Aug 11 16:56:03 1993 Jim Kingdon (kingdon@lioth.cygnus.com) + + * config.guess: Fix typo (9000/8??:4.3bsd -> 9000/7??:4.3bsd). + +Fri Aug 6 14:45:02 1993 Ian Lance Taylor (ian@tweedledumb.cygnus.com) + + * config.guess: From michael@mercury.cs.mun.ca (Michael Rendell): + Added test for mips-mips-riscos5. + +Thu Aug 5 15:45:08 1993 david d `zoo' zuhn (zoo@rtl.cygnus.com) + + * configure.in: use mh-hp300 for 68k HP hosts + +Mon Aug 2 11:56:53 1993 david d `zoo' zuhn (zoo@rtl.cygnus.com) + + * configure: add support for CONFIG_SHELL, so that you can use + some alternate shell for evaluating configure scripts + +Sun Aug 1 11:36:27 1993 Fred Fish (fnf@deneb.cygnus.com) + + * Makefile.in (make-gdb.tar.gz): Sed bug reporting address + in configure script to bug-gdb@prep.ai.mit.edu when building + distribution archive. + * Makefile.in (COMPRESS): Remove def. + * Makefile.in (gdb.tar.gz, make-gdb.tar.gz): Renamed from + gdb.tar.Z and make-gdb.tar.Z respectively. + * Makefile.in (make-gdb.tar.gz): Now only build gzip'd archive. + * Makefile.in (make-gdb.tar.gz): Minor changes to move closer + to convergence with 'taz' target in Makefile.in. + +Fri Jul 30 12:34:57 1993 david d `zoo' zuhn (zoo@rtl.cygnus.com) + + * install.sh (dsttmp): use trap to ensure that tmp files go + away on error conditions + +Wed Jul 28 11:57:36 1993 david d `zoo' zuhn (zoo@rtl.cygnus.com) + + * Makefile.in (BASE_FLAGS_TO_PASS): remove LOADLIBES + +Tue Jul 27 12:43:40 1993 Jim Kingdon (kingdon@lioth.cygnus.com) + + * Makefile.in (install-dirs): Deal with a prefix like /gnu; + its parent is '/' not ''. + + * Makefile.in (DEVO_SUPPORT): Add comments about ChangeLog. + +Fri Jul 23 09:53:37 1993 Jason Merrill (jason@wahini.cygnus.com) + + * configure: if ${newsrcdir}/configure doesn't exist, don't assume + that ${newsrcdir}/configure.in does. + +Tue Jul 20 11:28:50 1993 david d `zoo' zuhn (zoo@rtl.cygnus.com) + + * test-build.mk: support for CONFIG_SHELL + +Mon Jul 19 21:54:46 1993 Fred Fish (fnf@deneb.cygnus.com) + + * config.sub (netware): Add as a basic system type. + +Wed Jul 14 12:03:11 1993 K. Richard Pixley (rich@sendai.cygnus.com) + + * Makefile.in (Makefile): depend on configure.in. Also drop the + $(srcdir)/ from the dependency on Makefile.in. + +Tue Jul 13 20:10:58 1993 Doug Evans (dje@canuck.cygnus.com) + + * config.sub: Recognize h8300hhms as h8300h-hitachi-hms. + (h8300hhms is temporary until multi-libraries are implemented). + * configure.in: Handle h8300h too. + +Sun Jul 11 17:35:27 1993 Jim Kingdon (kingdon@lioth.cygnus.com) + + * config.guess: Recognize dpx/2 as m68k-bull-sysv3. + +Thu Jul 8 18:26:12 1993 John Gilmore (gnu@cygnus.com) + + * configure: Remove extraneous output when guessing host type. + * config.guess: Remove extraneous output when guessing using C + compiler rather than uname, or when guessing fails. + +Wed Jul 7 17:58:14 1993 david d `zoo' zuhn (zoo at rtl.cygnus.com) + + * Makefile.in: remove all.cross and install.cross targets + + * configure: remove CROSS=-DCROSS_COMPILE and ALL=all.cross + definitions + +Tue Jul 6 10:39:44 1993 Steve Chamberlain (sac@phydeaux.cygnus.com) + + * configure.in (target sh): Build gprof. + +Thu Jul 1 16:52:56 1993 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * config.sub: change -solaris to -solaris2 + +Thu Jul 1 15:46:16 1993 Jim Kingdon (kingdon@lioth.cygnus.com) + + * configure.in: Use config/mh-riscos for mips-*-sysv*. + +Wed Jun 30 09:31:58 1993 Ian Lance Taylor (ian@cygnus.com) + + * configure: Correct error message for missing Makefile.in to + print correct directory. + +Tue Jun 29 13:52:16 1993 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * install.sh: kludge around 386BSD shell bug + +Tue Jun 29 13:06:49 1993 Per Bothner (bothner@rtl.cygnus.com) + + * config.guess: Recognize NeXT. + * config.guess: Recognize i486-ncr-sysv4. + * Makefile.in (taz): rm $(TOOL)-$$VER before linking. + +Tue Jun 29 12:50:57 1993 Ian Lance Taylor (ian@cygnus.com) + + * Makefile.in (MAKEINFOFLAGS): New variable. + (FLAGS_TO_PASS): Pass MAKEINFO as MAKEINFO MAKEINFOFLAGS. + * build-all.mk, test-build.mk: Pass down --no-split as + MAKEINFOFLAGS when hosted on DOS. Compile DOS hosted without -g. + +Thu Jun 24 13:39:11 1993 Per Bothner (bothner@rtl.cygnus.com) + + * Makefile.in (DEVO_SUPPORT): Add COPYING COPYING.LIB install.sh. + +Wed Jun 23 12:59:21 1993 Per Bothner (bothner@rtl.cygnus.com) + + * Makefile.in (libg++.tar.z): New rule. + * Makefile.in (taz): Replace 'configure -rm' by 'make distclean'. + * Makefile.in (taz): Only do a single chmod. + +Fri Jun 18 12:03:10 1993 david d `zoo' zuhn (zoo at majipoor.cygnus.com) + + * install.sh: don't use dirname anymore (replaced with sed usage) + +Thu Jun 17 18:43:42 1993 Fred Fish (fnf@cygnus.com) + + * Makefile.in: Change extension for gzip'd files from '.z' to + '.gz' per new FSF standard usage. + +Thu Jun 17 16:58:50 1993 david d `zoo' zuhn (zoo at majipoor.cygnus.com) + + * configure: put quotes around the final value of program_transform_name + +Tue Jun 15 16:48:51 1993 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * Makefile.in: new install.sh support; update install-info rules + +Wed Jun 9 12:31:34 1993 Ian Lance Taylor (ian@cygnus.com) + + * configure.in: Build diff for crosses, but not for go32 host. + + * configure.in: Build gprof only for native, and don't build it + for mips-*-*, rs6000-*-*, or i[34]86-*-sco*. + +Mon Jun 7 13:12:11 1993 david d `zoo' zuhn (zoo at deneb.cygnus.com) + + * configure.in: don't build gas,ld,binutils on for *-*-sysv4 + +Mon Jun 7 11:40:11 1993 Brendan Kehoe (brendan@lisa.cygnus.com) + + * configure.in (host_tools): Add prms. + +Fri Jun 4 13:30:42 1993 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * Makefile.in: install gcc, do installation of $(INSTALL_MODULES) + with $(FLAGS_TO_PASS) on the command line + + * config.sub: Recognize lynx and lynxos + +Fri Jun 4 10:59:56 1993 Ian Lance Taylor (ian@cygnus.com) + + * config.sub: Accept -ecoff*, not just -ecoff. + +Thu Jun 3 17:38:54 1993 Ken Raeburn (raeburn@cambridge.cygnus.com) + + * Makefile.in (taz): Use .gz suffix instead of .z. + (binutils.tar.gz, gas+binutils.tar.gz, gas.tar.gz): Fixed target + names. + +Thu Jun 3 00:27:06 1993 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * Makefile.in (vault-install): add an 'else true' (for Ultrix) + +Wed Jun 2 18:19:16 1993 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * Makefile.in (install-no-fixedincludes): install gcc last, so + that rebuilds that might happen during 'make install' don't get + bogus gcc include files + +Wed Jun 2 16:14:10 1993 Ken Raeburn (raeburn@cambridge.cygnus.com) + + Change from Utah for HPPA support: + * config.guess: Recognize hppa1.x-hp-bsd. + +Wed Jun 2 11:53:33 1993 Per Bothner (bothner@rtl.cygnus.com) + + * config.guess: Add support for Motorola Delta 68k, up to r3v7. + Patch from pot@fly.cnuce.cnr.it (Francesco Potorti`). + +Tue Jun 1 17:48:42 1993 Rob Savoye (rob at darkstar.cygnus.com) + + * config.sub: Add support for rom68k and bug boot monitors. + +Mon May 31 09:36:37 1993 Jim Kingdon (kingdon@cygnus.com) + + * Makefile.in: Make all-opcodes depend on all-bfd. + +Thu May 27 08:05:31 1993 Ian Lance Taylor (ian@cygnus.com) + + * config.guess: Added special check for i[34]86-univel-sysv4*. + +Wed May 26 16:33:40 1993 Ian Lance Taylor (ian@cygnus.com) + + * config.guess: For i[34]86-unknown-sysv4 use UNAME_MACHINE for + the processor rather than assuming i486. + +Wed May 26 09:40:18 1993 Jim Kingdon (kingdon@lioth.cygnus.com) + + * config.guess: Recognize SunOS6 as Solaris3. + +Tue May 25 23:03:11 1993 Per Bothner (bothner@cygnus.com) + + * config.guess: Fix typo. Avoid #elif (not in K&R 1). + Recognize SunOS 5.* only (and not [6-9].*) as being Solaris2. + +Tue May 25 12:44:18 1993 Ian Lance Taylor (ian@cygnus.com) + + * build-all.mk (all-cross): New target for Canadian Cross. + Added Q2 go32 targets. + * test-build.mk: Configure go32 cross sparclite-aout and + mips-idt-ecoff -with-gnu-ld. Moved build binary directory from + PARTIAL_HOLE_DIRS to BUILD_HOLES_DIRS. + +Mon May 24 15:30:06 1993 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * configure.in: fix Alpha GDB typo; also, don't build DejaGnu for + GO32 hosted toolchains + +Mon May 24 14:18:41 1993 Rob Savoye (rob at darkstar.cygnus.com) + + * configure: change so "-exec-prefix" gets passed down rather + than "-exec_prefix" so autoconf generated Makefiles get the + exec_prefix set right. + +Fri May 21 10:42:25 1993 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * config.guess: get the Solaris2 minor version number + + * Makefile.in: add standards.texi and make-stds.texi to ETC_SUPPORT + +Fri May 21 06:20:52 1993 Brendan Kehoe (brendan@lisa.cygnus.com) + + * config.guess: Recognize some Sequent platforms. + +Thu May 20 14:33:48 1993 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * Makefile.in: added the vault-install target + + * configure.in: actually use the Sun3 makefile fragment that's in + config, also added the release dir to configdirs + +Thu May 20 14:19:18 1993 Ken Raeburn (raeburn@cambridge.cygnus.com) + + * Makefile.in (taz): Fix modes on stuff in $(TOOL) dir also. + +Tue May 18 20:26:41 1993 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * configure.in: remove some program from Alpha targetted toolchains + +Tue May 18 15:23:19 1993 Ken Raeburn (raeburn@cygnus.com) + + * Makefile.in (DISTSTUFFDIRS): Renamed from PROTODIRS. Add ld and + gprof. + (taz): Run "make diststuff" in those directories instead of "make + proto-dir". Look for "VERSION=" only at start of line in subdir + Makefile. Use "gzip -9" for compression. + (TEXINFO_SUPPORT, DIST_SUPPORT, BINUTILS_SUPPORT_DIRS): New vars. + (binutils.tar.z): New target. + +Mon May 17 17:01:15 1993 Ken Raeburn (raeburn@deneb.cygnus.com) + + * Makefile.in (taz): Include gpl.texinfo. + +Fri May 14 06:48:38 1993 Ken Raeburn (raeburn@deneb.cygnus.com) + + * Makefile.in (setup-dirs): Merged into "taz" target. + (taz): Only do `proto-dir' stuff if a directory is actually needed + for this target. + +Wed May 12 13:09:44 1993 Ian Lance Taylor (ian@cygnus.com) + + * Makefile.in (MUNCH_NM): New variable, defined to be $(NM). + (FLAGS_TO_PASS): Pass down MUNCH_NM. + (HOST_CC, HOST_PREFIX, HOST_PREFIX_1): New variables. + (EXTRA_GCC_FLAGS): Pass down HOST_* variables. + (gcc-no-fixedincludes): Correct for current gcc Makefile. + +Tue May 11 10:14:25 1993 Fred Fish (fnf@cygnus.com) + + * Makefile.in (make-gdb.tar.Z): Add configure, config.guess, + config.sub, and move-if-change to gdb testsuite distribution + archive, so the testsuite can be extracted, configured, and + run separately from the gdb distribution. Blow away the Chill + tests that require a Chill compiled executable, since GNU Chill + is not yet publically available. + +Mon May 10 17:22:26 1993 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * test-build.mk: set environment variables in a single command, + instead of a list of assignments and exports + + * config.guess: recognize Alpha/OSF1 systems + +Mon May 10 14:55:51 1993 K. Richard Pixley (rich@rtl.cygnus.com) + + * configure: Change help message to prefer --options rather than + -options. + +Mon May 10 05:58:35 1993 Ken Raeburn (raeburn@kr-pc.cygnus.com) + + * config.sub: Convergent Tech. "miniframe" uses m68010, sez + zippy@ecst.csuchico.edu. + * config.guess: Recognize miniframe. + +Sun May 9 17:47:57 1993 Rob Savoye (rob at darkstar.cygnus.com) + + * Makefile.in: Use srcroot to find runtest rather than rootme. + Pass RUNTESTFLAGS and EXPECT down in BASE_FLAGS_TO_PASS. + +Fri May 7 14:55:59 1993 Ian Lance Taylor (ian@cygnus.com) + + * test-build.mk: Extensive additions to support building on a + machine other than the host. + +Wed May 5 08:35:04 1993 Ken Raeburn (raeburn@deneb.cygnus.com) + + * configure (tooldir): Fix for i386-aix again. + +Mon May 3 19:00:27 1993 Per Bothner (bothner@cygnus.com) + + * configure, Makefile.in: Change definition of $(tooldir) + to match the FSF. + +Fri Apr 30 15:55:21 1993 Fred Fish (fnf@cygnus.com) + + * config.guess: Recognize i[34]86/SVR4. + +Fri Apr 30 15:52:46 1993 Steve Chamberlain (sac@thepub.cygnus.com) + + * Makefile.in (all-gdb): gdb depends on sim. + +Thu Apr 29 23:30:48 1993 Fred Fish (fnf@cygnus.com) + + * Makefile.in (gdb.tar.Z): Make prototype gdb testsuite directory + at the same time we make the prototype gdb directory. + * Makefile.in (make-gdb.tar.Z): Make the testsuite distribution + files at the same time as the gdb base release distribution. + +Thu Apr 29 12:50:37 1993 Ian Lance Taylor (ian@cygnus.com) + + * Makefile.in (check): Use individual check targets rather than + DO_X rule. + (check-gcc): Added. + +Thu Apr 29 09:50:07 1993 Jim Kingdon (kingdon@cygnus.com) + + * config.sub: Use sysv3.2 not sysv32 for canonical OS + for System V release 3.2. + +Thu Apr 29 10:33:22 1993 Ken Raeburn (raeburn@cambridge.cygnus.com) + + * config.sub: Recognize hppaosf. + * configure.in: Do configure ld/binutils/gas for it. + +Tue Apr 27 06:25:34 1993 Ken Raeburn (raeburn@kr-pc.cygnus.com) + + * configure (tooldir): Alter syntax used to set this, for systems + where "\$" isn't handled right, like i386-aix. + +Thu Apr 22 08:17:35 1993 Ian Lance Taylor (ian@cygnus.com) + + * configure: Pass program-transform-name, not + program_transform_name, to recursive configures. + +Thu Apr 22 02:58:21 1993 Ken Raeburn (raeburn@cygnus.com) + + * Makefile.in (gas+binutils.tar.z): New rule for building snapshots + of gas+ld+binutils. + +Mon Apr 19 17:41:30 1993 Per Bothner (bothner@cygnus.com) + + * config.guess: Recognize AIX3.2 as distinct from 3.1. + +Sat Apr 17 17:19:50 1993 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * configure.in: rename m88k-motorola-m88kbcs to m88k-motorola-sysv + + * config/mh-delta88: remove extraneous GCC references + +Tue Apr 13 16:52:16 1993 Brendan Kehoe (brendan@lisa.cygnus.com) + + * Makefile.in (PRMS): Set back to all-prms. + +Sat Apr 10 12:04:07 1993 Ian Lance Taylor (ian@cygnus.com) + + * test-build.mk: Pass -with-gnu-as for known MIPS native and MIPS + targets, rather than for MIPS hosts. + +Fri Apr 9 13:51:06 1993 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * configure.in: add comment for --with-x default values + + * config.guess: handle Motorola Delta88 box for SVR3 and SVR4. + + * Makefile.in: add check-* targets for each of the directories in + the tree. Add a definition of RUNTEST that will use the one we + just built, if it exists. Pass this down via FLAGS_TO_PASS. + +Thu Apr 8 09:21:30 1993 Ian Lance Taylor (ian@cygnus.com) + + * configure.in: Removed obsolete references to bfd_target and + target_makefile_frag. + + * build-all.mk: Set assorted targets for Q2. + * config.sub: Recognize z8k-sim and h8300-hms. + * test-build.mk: Really don't pass host to configure. + (HOLES): Added uname. + +Wed Apr 7 15:48:19 1993 Ian Lance Taylor (ian@cygnus.com) + + * configure: Handle an empty program-prefix, program-suffix or + program-transform-name correctly. + +Tue Apr 6 13:48:41 1993 Ian Lance Taylor (ian@cygnus.com) + + * build-all.mk: -G 8 no longer required for MIPS targets. + * test-build.mk: Don't pass host argument to configure; make it + guess. + +Tue Apr 6 10:36:53 1993 Fred Fish (fnf@cygnus.com) + + * Makefile.in (gdb.tar.Z): Fix for building gzip'd distribution. + * Makefile.in (COMPRESS): New macro, like GZIP. + +Fri Apr 2 09:02:31 1993 Ian Lance Taylor (ian@cygnus.com) + + * test-build.mk: Use -with-gnu-as for mips-sgi-irix4 as well. + + * build-all.mk: Set GCC to gcc -O -G 8 for MIPS targets, since gcc + with gas currently defaults to -G 0. + +Thu Apr 1 08:25:42 1993 Ian Lance Taylor (ian@cygnus.com) + + * Makefile.in (all-flex): flex depends on byacc. + + * build-all.mk: If host not specified, use config.guess. Pass TAG + to test-build.mk as RELEASE_TAG. + * test-build.mk (configargs): New variable containing arguments to + pass to configure. Set to -with-gnu-as on mips-dec-ultrix. + (FLAGS_TO_PASS): Pass down RELEASE_TAG. + + * config.guess: Use /bin/uname when checking -X argument on SCO, + to avoid invoking GNU uname which doesn't understand -X. + + * test-build.mk: Don't use /usr/unsupported/bin/as on AIX. + + * configure.in: Build gas for mips-*-*. + +Wed Mar 31 21:20:58 1993 K. Richard Pixley (rich@rtl.cygnus.com) + + * Makefile.in (all.normal): insert missing backslash. + +Wed Mar 31 12:31:56 1993 Ian Lance Taylor (ian@cygnus.com) + + * build-all.mk, config/mh-irix4: Bump -XNh value to 1500 to match + gcc requirements. + + * Makefile.in: Complete overhaul to merge many almost identical + targets. + +Tue Mar 30 20:17:01 1993 Ken Raeburn (raeburn@cambridge.cygnus.com) + + * Makefile.in (setup-dirs-gdb): Renamed from setup-dirs. + (gdb.tar.Z): Adjusted. + + * Makefile.in (setup-dirs, taz): New targets; should be general + enough to adapt for gdb sometime. Build only .z file. + (gas.tar.z): New target. + +Tue Mar 30 10:03:09 1993 Ian Lance Taylor (ian@cygnus.com) + + * build-all.mk: Use CC=cc -Xs on Solaris. + +Mon Mar 29 19:59:26 1993 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * config/mh-sun3: cc needs -J to compile cp-parse.c correctly + + * config/mh-solaris: SunPRO C needs -Xs to be able to get a + working xmakefile for Emacs. + +Thu Mar 25 15:14:30 1993 Fred Fish (fnf@cygnus.com) + + * Makefile.in: Incorporate changes suggested by wilson@cygnus.com + for handling BISON for FSF releases. + +Thu Mar 25 06:19:48 1993 Ken Raeburn (raeburn@kr-pc.cygnus.com) + + * configure: Actually implement the change zoo just documented. + +Wed Mar 24 13:02:44 1993 david d `zoo' zuhn (zoo at poseidon.cygnus.com) + + * configure: when using config.guess, only set target_alias when + it's not already been set (ie, on the command line) + +Mon Mar 22 23:07:39 1993 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * Makefile.in: add installcheck target, set PRMS to install-prms + +Sun Mar 21 16:46:12 1993 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * configure: add support for package_makefile_fragment, handle the + case where a directory has a configure.in file but no Makefile.in + more gracefully (with an actual understandable error message, even); + add support for --without (and add this to the usage message); also + explicitly add a --host=${host_alias} to the command line when + config.guess is used + +Sun Mar 21 12:11:58 1993 Jim Wilson (wilson@sphagnum.cygnus.com) + + * configure: Must use both --host and --target in recursive calls. + +Thu Mar 18 12:31:35 1993 Ian Lance Taylor (ian@cygnus.com) + + * Makefile.in: Change deja-gnu to dejagnu. + +Mon Mar 15 15:44:35 1993 Ian Lance Taylor (ian@cygnus.com) + + * configure.in (h8300-*-*, h8500-*-*): Don't build libg++. + +Fri Mar 12 18:30:14 1993 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * configure.in: canonicalize all instances to *-*-solaris2*, + also strip out a number of tools to not build for go32 host + +Wed Mar 10 12:08:27 1993 K. Richard Pixley (rich@rtl.cygnus.com) + + * config.guess: add GPL. + + * Makefile.in, config.guess, config.sub, configure: bump + copyrights to 93. + +Wed Mar 10 07:12:48 1993 Ian Lance Taylor (ian@cygnus.com) + + * Makefile.in (do-info): Removed obsolete check for existence of + localenv file. + + * Makefile.in (MAKEOVERRIDES): Define to be empty. + +Wed Mar 10 03:11:56 1993 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * Makefile.in: a couple of 'else true' for decstation, + support for TclX + + * configure.in: configure tclX too; don't remove Tk on RS/6000 anymore + +Tue Mar 9 16:06:12 1993 K. Richard Pixley (rich@cygnus.com) + + * Makefile.in (setup-dirs): change invocation of make to $(MAKE). + +Mon Mar 8 14:52:11 1993 Ken Raeburn (raeburn@cambridge) + + * config.guess: Recognize i386-ibm-aix (PS/2). + * configure.in: Use config/mh-aix386 file for it. + +Mon Mar 8 11:12:43 1993 Ian Lance Taylor (ian@cygnus.com) + + * Makefile.in (GCC_FOR_TARGET): Eliminated definition; use + CC_FOR_TARGET instead. + (BASE_FLAGS_TO_PASS): Pass GCC_FOR_TARGET=$(CC_FOR_TARGET). + +Wed Mar 3 16:00:28 1993 Steve Chamberlain (sac@ok.cygnus.com) + + * Makefile.in: Add sim to list of directories sent with gdb + +Wed Mar 3 11:42:39 1993 Ken Raeburn (raeburn@cygnus.com) + + * configure.in: Put back mips-dec-bsd* case. + +Tue Mar 2 21:15:58 1993 Fred Fish (fnf@cygnus.com) + + (Ultrix 2.2 support from Michael Rendell ) + * configure.in (vax-*-ultrix2*): Add Ultrix 2.2 triplet. + * config.guess: Change 'VAX*:ULTRIX:*:*' to 'VAX*:ULTRIX*:*:*'. + * config/mh-vaxult2: New file. + +Tue Mar 2 18:11:03 1993 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * configure.in: remove no-op mips-dec-bsd* in "case $target" + + * Makefile.in (dir.info): only run gen-info-dir if it exists, + (install-info): install dir.info only if it exists, + (all-expect, install-expect): pass along X11_FLAGS_TO_PASS + +Tue Mar 2 09:01:30 1993 Ken Raeburn (raeburn@cygnus.com) + + * configure.in: For vms target, skip bfd, ld, binutils. Do build + gas for mips-dec-bsd. + +Tue Mar 2 08:35:24 1993 Ian Lance Taylor (ian@cygnus.com) + + * configure (makesrcdir): If ${srcdir} is relative and not ".", + and ${subdir} is not ".", set makesrcdir based on ${invsubdir}. + +Tue Feb 23 14:18:28 1993 Mike Werner (mtw@poseidon.cygnus.com) + + * configure.in: Added "dejagnu" to hosttools list. + +Mon Feb 22 23:28:38 1993 Per Bothner (bothner@rtl.cygnus.com) + + * config.sub, configure.in, config.guess: Add support + for Bosx, an AIX variant from Bull. + Patches from F.Pierresteguy@frcl.bull.fr. + +Sun Feb 21 11:15:22 1993 Mike Werner (mtw@poseidon.cygnus.com) + + * devo/dejagnu: Initial creation of devo/dejagnu. + Migrated dejagnu testcases and support files for testing software + tools to reside as subdirectories, currently called "testsuite", + within the directory of the software tool. Migrated all programs, + support libraries, etc. beloging to dejagnu proper from + devo/deja-gnu to devo/dejagnu. These files were moved "as is" + with no modifications. The changes to these files which will + allow them to configure, build, and execute properly will be made + in a future update. + +Fri Feb 19 20:19:39 1993 Brendan Kehoe (brendan@lisa.cygnus.com) + + * Makefile.in: Change send_pr to send-pr. + * configure.in: Likewise. + * send_pr: Renamed directory to send-pr. + +Fri Feb 19 19:00:13 1993 Per Bothner (bothner@cygnus.com) + + * Makefile.in: Add some extra semi-colons (needed if SHELL=bash). + +Fri Feb 19 00:59:33 1993 John Gilmore (gnu@cygnus.com) + + * README: Update for gdb-4.8 release. + * Makefile.in (gdb.tar.Z): Add texinfo/tex3patch. Build + gdb-xxx.tar.z (gzip'd) file also. + +Thu Feb 18 09:16:17 1993 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * Makefile.in: make all-diff depend on all-libiberty + +Tue Feb 16 16:06:31 1993 K. Richard Pixley (rich@cygnus.com) + + * config.guess: add vax-ultrix in the spirit of mips-ultrix. + +Tue Feb 16 05:57:15 1993 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * configure.in, Makefile.in: add hello, tar, gzip, recode, indent + +Tue Feb 16 00:58:20 1993 John Gilmore (gnu@cygnus.com) + + * Makefile.in (DEVO_SUPPORT): Remove etc directory + (ETC_SUPPORT): Only add the files GDB wants from etc/. + (gdb.tar.Z): Use ETC_SUPPORT. Use byacc when building the file. + +Thu Feb 11 20:14:28 1993 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * Makefile.in: makeinfo binary is in a new location + +Tue Feb 9 12:42:27 1993 Ian Lance Taylor (ian@cygnus.com) + + * config.sub: Accept -ecoff as an OS. + + * Makefile.in: Various changes to eliminate a level of make + recursion and reduce the required command line length. + (BASE_FLAGS_TO_PASS): New variable holding flags passed to all + sub-makes. + (EXTRA_HOST_FLAGS, EXTRA_TARGET_FLAGS, EXTRA_GCC_FLAGS): New + variables holding settings for specific sub-makes. + (FLAGS_TO_PASS, TARGET_FLAGS_TO_PASS, GCC_FLAGS_TO_PASS): Rewrote + in terms of BASE_FLAGS_TO_PASS. + (TARGET_LIBS): New variable listing directories which use + TARGET_FLAGS_TO_PASS. + (subdir_do): Eliminated. + (do-*): New set of targets to replace subdir_do. + (various): All targets which used subdir_do now depend on do-*. + (local-clean): Renamed from do_clean. + (local-distclean): New target, dependency of distclean and + realclean. + (install-info): Don't create directories. Depend on dir.info + rather than calling make recursively. + (install-dir.info): Eliminated. + (install-info-dirs): Create all info directories here. + (dir.info): Depend upon do-install-info. + + * test-build.mk (HOLES): Added false. + +Sat Feb 6 14:05:09 1993 Per Bothner (bothner@rtl.cygnus.com) + + * config.guess: Recognize BSDI and BSDJ (Jolitz 386bsd). + +Thu Feb 4 20:49:18 1993 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * Makefile.in (info): remove dependency on all-texinfo. The + problem was really in texinfo/C, not at this level. + +Thu Feb 4 13:38:41 1993 Ian Lance Taylor (ian@cygnus.com) + + * Makefile.in (info): Added dependency on all-texinfo (PR 2112). + +Thu Feb 4 01:50:53 1993 John Gilmore (gnu@cygnus.com) + + * Makefile.in (make-gdb.tar.Z): Change BISON to 'bison -y' for + GDB releases. + +Wed Feb 3 17:22:16 1993 Ken Raeburn (raeburn@cambridge.cygnus.com) + + * configure: Include srcdir in message about target of link not + being found. Don't convert `-' to `_' in `with' options being + passed to subdirs. + +Tue Feb 2 18:57:59 1993 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * configure.in: add uudecode to host_tools + + * Makefile.in: added {all,install}-uudecode targets, added them to + the appropriate lists + +Tue Feb 2 11:45:53 1993 Ian Lance Taylor (ian@cygnus.com) + + * Makefile.in (all-gcc): Added dependency on all-gas. + + * configure.in (mips-*-*): Build ld and binutils. + +Mon Feb 1 12:35:41 1993 K. Richard Pixley (rich@rtl.cygnus.com) + + * configure: check return code from mkdir, print error message and + exit on failure. + +Sat Jan 30 16:40:28 1993 John Gilmore (gnu@cygnus.com) + + * Makefile.in (make-gdb.tar.Z): New location for texinfo.tex. + +Thu Jan 28 15:09:59 1993 Ian Lance Taylor (ian@cygnus.com) + + * test-build.mk (HOLES): Added tar, cpio and uudecode. + +Wed Jan 27 16:50:32 1993 Jim Wilson (wilson@sphagnum.cygnus.com) + + * config.sub (h8500): Recognize this as a cpu type. + +Sat Jan 23 20:32:01 1993 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * configure: source directory missing is no longer a warning + + * configure.in: recognize irix[34]* instead of irix[34] + + * Makefile.in: define and pass down X11_LIB + + * config/mh-sco: define X11_LIB to the mess that SCO ODT requires + +Sat Jan 23 13:49:40 1993 Per Bothner (bothner@cygnus.com) + + * guess-systype: Renamed to ... + * config.guess: ... by popular request. + * configure.in, Makefile.in: Update accordingly. + +Thu Jan 21 12:20:55 1993 Per Bothner (bothner@cygnus.com) + + * guess-systype: Patches from John Eaton : + + Add Convex, Cray/Unicos, and Encore/Multimax support. + + Execute ./dummy instead of assuming . is in PATH. + +Tue Jan 19 17:18:06 1993 Per Bothner (bothner@cygnus.com) + + * guess-systype: New shell script. Attempts to guess the + canonical host name of the executing host. + Only a few hosts are supported so far. + * configure: Call guess-systype if no host is specified. + +Tue Jan 19 08:26:07 1993 Ian Lance Taylor (ian@cygnus.com) + + * Makefile.in (gcc-no-fixedincludes): Made to work with current + gcc Makefile. + + +Fri Jan 15 10:27:02 1993 Ian Lance Taylor (ian@cygnus.com) + + * Makefile.in (GCC_FLAGS_TO_PASS): New variable. + (all-gcc, install-gcc, subdir_do): Use it. + +Wed Jan 13 17:06:45 1993 Jim Wilson (wilson@sphagnum.cygnus.com) + + * Makefile.in: Rename uninstalled gcc driver from gcc to xgcc. + +Wed Jan 6 20:29:16 1993 Mike Werner (mtw@rtl.cygnus.com) + + * Makefile.in: Removed explicit setting of SUBDIRS. SUBDIRS is now + set exclusively by configure, using configure.in . + +Wed Jan 6 13:44:11 1993 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * test-build.mk: set $PATH for all builds + + * Makefile.in: pass TARGET_FLAGS_TO_PASS for xiberty and libm + +Wed Jan 6 11:02:10 1993 Fred Fish (fnf@cygnus.com) + + * Makefile.in (GCC_FOR_TARGET): Supply a default that matches + the one used in gcc/Makefile.in, so that a null expansion doesn't + override the one needed to build gcc with a native cc. + + +Tue Jan 5 07:55:12 1993 Ken Raeburn (raeburn@cambridge.cygnus.com) + + * configure: Accept -with arguments. + +Sun Jan 3 15:15:09 1993 Steve Chamberlain (sac@thepub.cygnus.com) + + * Makefile.in: added h8300sim + +Tue Dec 29 15:06:00 1992 Ian Lance Taylor (ian@cygnus.com) + + * config/mh-sco: Don't override BISON definition. + + * build-all.mk: If canonhost is i386-unknown-sco3.2v4, change it + to i386-sco3.2v4. Set TARGETS and CFLAGS for i386-sco3.2v4. + (all-cygnus, native, build-cygnus): Make + $(canonhost)-stamp-3stage-done, not $(host).... + * test-build.mk (stamp-3stage-compared): Use tail +10c for + i386-sco3.2v4. Added else true to if command. + +Mon Dec 28 12:08:56 1992 Ken Raeburn (raeburn@cygnus.com) + + * config.sub: (from FSF) Sequent uses a BSD-like OS. + +Mon Dec 28 08:32:06 1992 Minh Tran-Le (mtranle@paris.intellicorp.com) + + * configure.in (i[34]86-*-isc*): added; uses mh-sysv. + +Thu Dec 24 17:26:24 1992 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * configure.in: don't remove binutils from Solaris builds + +Thu Dec 24 14:08:38 1992 david d`zoo' zuhn (zoo@cygnus.com) + + * Makefile.in: get rid of earlier definitions for *clean, + also handle the recursive info rule better + +Thu Dec 24 12:40:21 1992 Per Bothner (bothner@rtl.cygnus.com) + + * Makefile.in (mostlyclean, distclean, realclean): Fix to + do more-or-less the right thing. + +Wed Dec 16 10:25:31 1992 Ian Lance Taylor (ian@cygnus.com) + + * Makefile.in: Add lines defining CC and CXX, and use CXX rather + than gcc in definitions of CXX_FOR_BUILD and CXX_FOR_TARGET. + +Tue Dec 15 00:34:32 1992 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * Makefile.in: change all $(host_cpu)-$(host_vendor)-$(host_os) to + $(host_canonical). + + * configure.in: split the configdirs list into 4 categories (native + v. cross, library v. tool) and handle the cross-only and native- + only in more reasonable (and correct!) way. + +Mon Dec 14 17:04:22 1992 Stu Grossman (grossman at cygnus.com) + + * configure.in (hppa*-*-*): Don't remove bfd and gdb from + configdirs anymore. + +Sun Dec 13 00:37:26 1992 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * Makefile.in: extensive cleanup:: removed all of the explicit + clean-* targets, collapsed many wrappers around subdir_do into + one, added additional targets to satisfy standards.texi, deleted + some old targets, some changes for consistency + +Fri Dec 11 20:18:02 1992 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * configure.in: handle some programs as cross-only, and others as + native only + + * test-build.mk: handle partial holes in a more generic manner + + * Makefile.in: m4 depends on libiberty + +Mon Dec 7 06:43:27 1992 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * config/mh-sco: don't default $(CC) to gcc + +Thu Dec 3 21:52:11 1992 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * configure.in: add m4, textutils, fileutils, sed, shellutils, + time, wdiff, and find to configdirs + + * Makefile.in: all, clean, and install rules for the new programs + added to configure.in + +Mon Nov 30 14:54:34 1992 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * configure.in: use mh-sun for all *-sun-* hosts + + * config/mh-solaris: rework standard X location to use + $OPENWINHOME, if defined. + + * config/mh-sun: handle X11 include locations + + * config/mh-decstation: define NeedFunctionPrototypes to 0, to + work around dain-bramaged DECwindows include files + +Fri Nov 27 18:35:54 1992 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * Makefile.in: define flags for X11 include files and library file + locations, pass them down to the programs that need this info + + * build-all.mk: added a 'native' target, to 3stage the native toolchain + + * config/{mh-hpux,mh-solaris}: define the "standard" locations for + the vendor supplied X11 headers and libraries + +Sun Nov 22 18:59:13 1992 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * configure.in: start building libg++ for HP-UX targets + +Wed Nov 18 19:33:11 1992 John Gilmore (gnu@cygnus.com) + + * README: Update references to files moved into etc/. + +Sun Nov 15 09:36:08 1992 Fred Fish (fnf@cygnus.com) + + * config.sub (i386sol2, i486sol2): i[34]86-unknown-solaris2. + * configure.in (i[34]86-*-solaris2*): Use config/mh-sysv4. + +Thu Nov 12 08:50:42 1992 Ian Lance Taylor (ian@cygnus.com) + + * configure: accept dash as well as underscore in long option + names for FSF compatibility. + +Wed Nov 11 08:04:37 1992 Ian Lance Taylor (ian@cygnus.com) + + * config.sub: added -sco3.2v4 support from FSF. + +Sun Nov 8 21:14:30 1992 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * configure.in: expand the section that adds or removes + directories from the list of programs to build, to handle native + vs. cross in addition to host v. native + +Sat Nov 7 18:52:27 1992 Per Bothner (bothner@rtl.cygnus.com) + + * Makefile.in: Replace C++ in macro names with CXX. + This is less likely to break ... + +Sat Nov 7 15:16:58 1992 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * test-build.mk: add -w to GNU_MAKE + +Fri Nov 6 23:10:37 1992 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * config.sub: remove 'sparc'-->'sparc-sun' default transformation, + add 'sparc' to list of recognized cpus. This needed to make + 'sparc-aout' expand to 'sparc-unknown-aout' instead of 'sparc-sun-aout'. + Delete some redundant ose68 variants. Recognize -wrs as an os, + then changes that into $CPU-wrs-vxworks. + + * configure.in: remove most references to gdbtest, regularize + target based program removal + + * test-build.mk: import from p3 tree (many fixes and changes) + +Fri Nov 6 20:59:00 1992 david d `zoo' zuhn (zoo@cygnus.com) + + * Makefile.in: added rules to handle tcl, tk, and expect + + * configure.in: handle those directories if they exist + +Thu Nov 5 14:35:41 1992 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * config.sub: removed bogus hppabsd and hppahpux names, since + "hppa" is not a valid cpu (hppa1.1 or hppa1.0 are, though) + +Thu Oct 29 00:12:41 1992 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * Makefile.in: all-gcc now depends on all-binutils. all-libg++ + depends upon all-xiberty + + * Makefile.in: changes from p3, including: + + Thu Oct 8 15:00:17 1992 Ian Lance Taylor (ian@cygnus.com) + + * Makefile.in (XTRAFLAGS): include newlib directories if + newlib/Makefile exists, rather than if host != target. + + Fri Sep 25 13:41:52 1992 Ian Lance Taylor (ian@cygnus.com) + + * Makefile.in: added -nostdinc to XTRAFLAGS if we are using gcc + from the same source tree and not building a cross-compiler. This + matters for the libg++ configuration if reconfiguring a tree that + has already been installed. + + Thu Sep 10 10:35:51 1992 Ian Lance Taylor (ian@cygnus.com) + + * Makefile.in: added -I for newlib/targ-include to XTRAFLAGS, to + pick up the machine and system specific header files. + + * Makefile.in: added AS_FOR_TARGET, passed down in + TARGET_FLAGS_TO_PASS. Added CC_FOR_BUILD, which is intended to be + the C compiler to use to create programs which are run in the + build environment, set it to default to $(CC), and passed it down + in FLAGS_TO_PASS and TARGET_FLAGS_TO_PASS. + + Mon Sep 7 22:34:42 1992 Ian Lance Taylor (ian@cirdan.cygnus.com) + + * Makefile.in: add $(host) = $(target) tests back to *_FOR_TARGET. + We need them for unusual native builds, like systems without + ranlib. + + * configure: also define $(host_canonical) and + $(target_canonical), which are the full, canonical names for the + given host and target + +Sun Nov 1 16:38:17 1992 Per Bothner (bothner@cygnus.com) + + * Makefile.in: Added separate definitions for C++. + +Fri Oct 30 11:37:52 1992 Fred Fish (fnf@cygnus.com) + + * configure.in (configdirs): Add deja-gnu. + +Fri Oct 23 00:39:18 1992 John Gilmore (gnu@cygnus.com) + + * README: Update for configure.texi and gdb-4.7 release. + +Wed Oct 21 21:54:27 1992 John Gilmore (gnu@cygnus.com) + + * Makefile.in: Move "all" target to top of file. + Previously, first target was ".PHONY" which caused BSD4.4 make + to build .PHONY when make was run without arguments. + +Mon Oct 19 01:17:54 1992 John Gilmore (gnu@cygnus.com) + + * Makefile.in: Add COPYING.LIB to GDB releases, now that there's + Library-copylefted code in libiberty. + +Tue Oct 13 01:22:32 1992 John Gilmore (gnu@cygnus.com) + + * config.sub: Replace m68kmote with plain old m68k. + +Fri Oct 9 03:14:24 1992 John Gilmore (gnu@cygnus.com) + + * Makefile.in: Remove space from blank line, avoid Make complaints. + +Thu Oct 8 18:41:45 1992 Ken Raeburn (raeburn@cygnus.com) + + * config.sub: Complain if no argument is given. Added support for + 386bsd as OS and target alias. + +Thu Oct 8 15:07:22 1992 Ian Lance Taylor (ian@cygnus.com) + + * Makefile.in (XTRAFLAGS): include newlib directories if + newlib/Makefile exists, rather than if host != target. + +Mon Oct 5 03:00:09 1992 Mark Eichin (eichin at tweedledumber.cygnus.com) + + * config.sub: recognize sparclite-wrs-vxworks. + + * Makefile.in (install-xiberty): added *-xiberty make rules (from + p3.) Added clean-xiberty to clean. + +Thu Oct 1 17:59:19 1992 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * configure.in: use *-*-* instead of nested cases for host and target + +Tue Sep 29 14:11:18 1992 Ian Lance Taylor (ian@cygnus.com) + + * Makefile.in: added -nostdinc to XTRAFLAGS if we are using gcc + from the same source tree and not building a cross-compiler. This + matters for the libg++ configuration if reconfiguring a tree that + has already been installed. + +Sep 20 08:53:10 1992 Fred Fish (fnf@cygnus.com) + + * config.sub (i486v/i486v4): Merge in from FSF version. + +Fri Sep 18 00:32:00 1992 Mark Eichin (eichin@cygnus.com) + + * configure: only set PWD if it is already set. + +Thu Sep 17 23:05:53 1992 Mark Eichin (eichin@cygnus.com) + + * configure: just set PWD=`pwd` at the top, since Ultrix sh + doesn't have unset and all success paths (and most error paths) + out set it anyway. (Note: should change all uses of ${PWD=`pwd`} + to just ${PWD} to avoid confusion.) + +Tue Sep 15 16:00:54 1992 Ian Lance Taylor (ian@cygnus.com) + + * configure: always set $(tooldir) to $(libdir)/$(target_alias), + even for a native compilation. + +Tue Sep 15 02:22:56 1992 John Gilmore (gnu@cygnus.com) + + Changes to make the gdb.tar.Z rule work better. + + * Makefile.in (GDB_SUPPORT_DIRS): Add opcodes. + (DEVO_SUPPORT): Add configure.texi. + (bfd-ilrt.tar.Z): Remove ancient rule. + +Thu Sep 10 10:43:19 1992 Ian Lance Taylor (ian@cygnus.com) + + * Makefile.in: added -I for newlib/targ-include to XTRAFLAGS, to + pick up the machine and system specific header files. + + * configure.in, config.sub: added new target m68010-adobe-scout, + with alias of adobe68k. Changed configure.in to check for + -scout before -sco* to avoid a false match. + + * Makefile.in: added AS_FOR_TARGET, passed down in + TARGET_FLAGS_TO_PASS. Added CC_FOR_BUILD, which is intended to be + the C compiler to use to create programs which are run in the + build environment, set it to default to $(CC), and passed it down + in FLAGS_TO_PASS and TARGET_FLAGS_TO_PASS. + +Wed Sep 9 12:21:42 1992 Ian Lance Taylor (ian@cygnus.com) + + * Makefile.in: added TARGET_FLAGS_TO_PASS, CC_FOR_TARGET, + AR_FOR_TARGET, RANLIB_FOR_TARGET, NM_FOR_TARGET. Pass + TARGET_FLAGS_TO_PASS, which defines CC, AR, RANLIB and NM as the + FOR_TARGET variants, to newlib and libg++. + +Tue Sep 8 17:28:30 1992 Ken Raeburn (raeburn@cambridge.cygnus.com) + + * Makefile.in (all-gas, all-gdb): Require all-opcodes to be built + first. + +Wed Sep 2 02:50:05 1992 John Gilmore (gnu@cygnus.com) + + * config.sub: Accept `elf' as an environment. + +Tue Sep 1 15:48:30 1992 Steve Chamberlain (sac@thepub.cygnus.com) + + * Makefile.in (all-opcodes): cd into the right directory + +Sun Aug 30 21:12:11 1992 Ian Lance Taylor (ian@cygnus.com) + + * configure: added -program_transform_name option, used as + argument to sed when installing programs. + configure.texi: added documentation for -program_prefix, + -program_suffix and -program_transform_name. + +Thu Aug 27 21:59:44 1992 John Gilmore (gnu@cygnus.com) + + * config.sub: Accept i486 where i386 ok. + +Thu Aug 27 13:04:42 1992 Brendan Kehoe (brendan@rtl.cygnus.com) + + * config.sub: accept we32k + +Mon Aug 24 14:05:14 1992 Ian Lance Taylor (ian@cygnus.com) + + * config.sub, configure.in: accept OSE68000 and OSE68k. + + * Makefile.in: don't create all directories for ``make install''; + let the subdirectories create the ones they need. + +Tue Aug 11 23:13:17 1992 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * COPYING: new file, GPL v2 + +Tue Aug 4 01:12:43 1992 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * Makefile.in: use the new gen-info-dir, which needs a template + argument (which also lives in texinfo) + + * configure.texi, standards.texi: fix INFO-DIR-ENTRY + +Mon Aug 3 15:41:28 1992 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * config/mh-solaris: removed the -xs from CFLAGS (let the people + with Sun's C compiler deal with it themselved) + +Mon Aug 3 00:34:17 1992 Fred Fish (fnf@cygnus.com) + + * config.sub (ncr3000): Change i386 to i486. + +Thu Jul 23 00:12:17 1992 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * Makefile.in: add install-rcs, install-grep to + install-no-fixedincludes, removed install-bison and install-libgcc + +Tue Jul 21 01:01:50 1992 david d `zoo' zuhn (zoo@cygnus.com) + + * configure.in: grab the HPUX makefile fragment if on HPUX + +Mon Jul 20 11:02:09 1992 D. V. Henkel-Wallace (gumby@cygnus.com) + + * Makefile.in: eradicate bison spoor (ditto libgcc). + configure.in: recognise m68{k,000}-ericsson-OSE. + es1800 is alias for m68k-ericsson-OSE + +Sun Jul 19 17:49:02 1992 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * configure.in: rearrange the parts that remove programs from + configdirs, based now on HOST==TARGET or by canonical triple. + +Fri Jul 17 22:52:49 1992 K. Richard Pixley (rich@rtl.cygnus.com) + + * test-build.mk: recurse explicitly with -f test-build.mk when + appropriate. predicate stage3 and comparison on the existence + of gcc. That is, if gcc isn't around, we aren't three-staging. + On very clean, also remove ...stamp-co. Build in-place before + doing other builds. + +Thu Jul 16 18:33:09 1992 Steve Chamberlain (sac@thepub.cygnus.com) + + * Makefile.in, configure.in: add tgas + +Thu Jul 16 16:05:28 1992 K. Richard Pixley (rich@rtl.cygnus.com) + + * Makefile.in: a number of changes merged in from progressive. + + * configure.in: add libm. + + * .cvsignore: ignore some stuff that comes from test-build.mk. + +Wed Jul 8 00:01:30 1992 Stu Grossman (grossman at cygnus.com) + + * config/mh-solaris: Use -xs when compiling so that Sun-C puts + a symbol-table into the executable. + +Tue Jul 7 00:24:52 1992 Fred Fish (fnf@cygnus.com) + + * config.sub: Add es1800 (m68k-ericsson-es1800). + +Tue Jun 30 20:24:41 1992 D. V. Henkel-Wallace (gumby@cygnus.com) + + * configure: Add program_suffix (parallel to program_prefix) + * Makefile.in: adjust directory-creating script for losing decstation + +Mon Jun 22 23:43:48 1992 Per Bothner (bothner@cygnus.com) + + * configure: Minor $subdir-related fixes. + +Mon Jun 22 18:30:26 1992 Steve Chamberlain (sac@thepub.cygnus.com) + + * configure: fix various problems with propogating + makefile_target_frag in subdirs. + * configure.in: config libgcc if its there + +Fri Jun 19 15:19:40 1992 Stu Grossman (grossman at cygnus.com) + + * config.sub: HPPA merge. + +Mon Jun 15 12:31:52 1992 Fred Fish (fnf@cygnus.com) + + * config/mh-ncr3000 (INSTALL): Don't use /usr/ucb/install, + it is broken on ncr 3000's. + +Sun Jun 14 10:29:19 1992 John Gilmore (gnu at cygnus.com) + + * Makefile.in: Replace all-bison with all-byacc in all + dependency lines for other tools (which now use byacc). + +Fri Jun 12 22:21:57 1992 John Gilmore (gnu at cygnus.com) + + * config.sub: Add sun4sol2 => sparc-sun-solaris2. + +Tue Jun 9 17:18:11 1992 Fred Fish (fnf at cygnus.com) + + * config/{mh-ncr3000, mh-sysv4}: Add INSTALL. + +Thu Jun 4 12:07:32 1992 Mark Eichin (eichin@cygnus.com) + + * Makefile.in: make gprof rules similar to byacc rules (instead of + vestigal $(unsubdir) that didn't work...) + +Thu Jun 4 00:37:05 1992 Per Bothner (bothner@rtl.cygnus.com) + + * config.sub: Add support for Linux. + * Makefile.in: Use $(FLAGS_TO_PASS) more consistently + (at least for libg++). + +Tue Jun 02 20:03:00 1992 david d `zoo' zuhn (zoo@cygnus.com) + + * configure.texi: fix doc for the -nfp option to configure + +Tue Jun 2 17:20:52 1992 Michael Tiemann (tiemann@cygnus.com) + + * Makefile.in (all-binutils): ar needs flex, so depend on all-flex. + +Sun May 31 15:04:08 1992 Mark Eichin (eichin at cygnus.com) + + * config.sub: changed [^-]+ to [^-][^-]* so that it works under + Sun sed. (BSD 4.3 sed doesn't handle [^-]+ either.) + * configure.in: added solaris* host_makefile_frag hook. + +Sun May 31 01:10:34 1992 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * config.sub: changed recognition of m68000 so that various + m68k types can be specified via m680[01234]0 + +Sat May 30 21:01:06 1992 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * config.sub (basic_machine): fix sed so that '-foo' isn't + completely substituted out while .+'-foo' loses the '-foo' + +Wed May 27 23:18:52 1992 Michael Tiemann (tiemann@rtl.cygnus.com) + + * config.sub ($os): Add -aout. + +Fri May 22 14:00:02 1992 Per Bothner (bothner@cygnus.com) + + * configure: If host_makefile_frag is absolute, don't + prefix ${invsubdir} (relevant to libg++ auto-configure). + +Thu May 21 18:00:09 1992 Michael Tiemann (tiemann@rtl.cygnus.com) + + * Makefile.in (tooldir): Define it. + (all-ld): Depend on all-flex. + +Sun May 10 21:45:59 1992 Per Bothner (bothner@rtl.cygnus.com) + + * Makefile.in (check): Fix libg++ special case. + +Fri May 8 08:31:41 1992 K. Richard Pixley (rich@cygnus.com) + + * configure: do not bury `pwd` into config.status, thus do fewer + pwd's. + + * configure: print the "Building in" message only when building in + other than "." AND verbose. + + * configure: remove -s, rework -v to better accomodate guested + configures. + + * standards.texi: updated to 3 may, fixed librid <-> libdir typo. + +Fri May 1 18:00:50 1992 K. Richard Pixley (rich@cygnus.com) + + * Makefile.in: macroize flags passed on recursion. remove + fileutils. + +Thu Apr 30 08:56:20 1992 K. Richard Pixley (rich@cygnus.com) + + * configure: get makesrcdir right for subdirs deeper than 1. + + * Makefile.in: pass INSTALL, INSTALL_DATA, INSTALL_PROGRAM on + install. + +Fri Apr 24 15:51:51 1992 K. Richard Pixley (rich@cygnus.com) + + * Makefile.in: don't print subdir_do or recursion lines. + +Fri Apr 24 15:22:04 1992 K. Richard Pixley (rich@cygnus.com) + + * standards.texi: added menu item. + + * Makefile.in: build and install standards.info. + + * standards.texi: new file. + +Wed Apr 22 18:06:55 1992 K. Richard Pixley (rich@rtl.cygnus.com) + + * configure: test for and move config.status pieces from + ${subdir}/. + +Wed Apr 22 14:38:34 1992 Fred Fish (fnf@cygnus.com) + + * config/mh-delta88, config/mh-ncr3000: Replace MINUS_G with + CFLAGS per new configuration strategy. + * configure: Test for existance of files before trying to mv + them, to avoid numerous non-existance messages. + +Tue Apr 21 12:31:33 1992 K. Richard Pixley (rich@cygnus.com) + + * configure: correct final line of config.status. + + * configure: patch from eggert. Avoids a protection problem if + the original Makefile.in is read only. + + * configure: use move-if-change from gcc to create config.status. + Some makefiles depend on config.status to tell if a directory + has been reconfigured for a different host. This change + prevents those directories from remaking everything in the case + where the reconfig was only intended to rebuild a Makefile. + + * configure: test for config.sub with "config.sub sun4" rather + than "config.sub ${host_alias}". Otherwise we can't tell a bad + host alias from a missing config.sub. + +Mon Apr 20 18:16:36 1992 K. Richard Pixley (rich@rtl.cygnus.com) + + * Makefile.in: explicitly pass CFLAGS on recursion. no longer pass + MINUS_G (this can be done with CFLAGS). Default CFLAGS to -g. + +Fri Apr 17 18:27:51 1992 Per Bothner (bothner@cygnus.com) + + * configure: mkdir ${subdir} as needed. + +Wed Apr 15 17:37:22 1992 K. Richard Pixley (rich@cygnus.com) + + * Makefile.in,configure.in: added autoconf. + +Wed Apr 15 17:27:34 1992 K. Richard Pixley (rich@rtl.cygnus.com) + + * Makefile.in: no longer pass against on recursion. + + * Makefile.in: added .NOEXPORT: so that stray makefile_frag + definitions are not inherited. + + * configure: correct makesrcdir when subdir is . + +Tue Apr 14 11:56:09 1992 Per Bothner (bothner@cygnus.com) + + * configure: Add support for 'subdirs' variable, which is + like 'configdirs', except that configure doesn't re-invoke + itself for subdirs, it just creates a Makefile for each subdir. + * configure.texi: Document subdirs. + +Mon Apr 13 18:50:16 1992 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * configure.in: added flex to configdirs + +Mon Apr 13 18:43:55 1992 K. Richard Pixley (rich@cygnus.com) + + * Makefile.in: remove clean-stamps from clean. + +Sat Apr 11 03:52:03 1992 John Gilmore (gnu at cygnus.com) + + * configure.in: Add gdbtest to configdirs. + +Fri Apr 10 23:11:49 1992 Fred Fish (fnf@cygnus.com) + + * Makefile.in (MINUS_G): Add macro, default to -g, pass on + to recursive makes. + * configure.in: Recognize new ncr3000 config. + +Wed Apr 8 23:08:12 1992 K. Richard Pixley (rich@cygnus.com) + + * Makefile.in, configure.in: removed references to gdbm. + +Tue Apr 7 16:48:20 1992 Per Bothner (bothner@cygnus.com) + + * config.sub: Don't canonicalize os value + newsos* to bsd (readline needs to check for newsos). + (This fix was earlier made Jan 31, but got re-broken.) + +Mon Apr 6 14:34:08 1992 Stu Grossman (grossman at cygnus.com) + + * configure.in: sco is an os, not a vendor! + + * configure: Quote $( better. Keep various shells happy. + +Tue Mar 31 16:32:57 1992 K. Richard Pixley (rich@cygnus.com) + + * Makefile.in: eliminate stamp-files. + +Mon Mar 30 22:20:23 1992 K. Richard Pixley (rich@cygnus.com) + + * Makefile.in: add send_pr. remove "force" from .stmp-gprof rule. + Supress echoing of all the "if [ -d ... $(MAKE)" lines. + +Wed Mar 25 15:20:04 1992 Stu Grossman (grossman@cygnus.com) + + * config.sub: fix iris/iris3. + +Wed Mar 25 10:34:19 1992 K. Richard Pixley (rich@cygnus.com) + + * configure: re-add -rm. + +Tue Mar 24 23:50:16 1992 K. Richard Pixley (rich@cygnus.com) + + * Maskefile.in: add .stmp-rcs to all. + + * configure.in: remove gas from rs6000 build, use aix host fragment. + +Mon Mar 23 19:43:35 1992 K. Richard Pixley (rich@cygnus.com) + + * configure: pass down site_option during recursion. + +Thu Mar 19 16:49:36 1992 Stu Grossman (grossman at cygnus.com) + + * Makefile.in (all.cross): Add .stmp-bfd .stmp-readline. + +Wed Mar 18 15:29:33 1992 Mike Stump (mrs@cygnus.com) + + * configure: Change exec_prefix so that it really defaults to prefix. + +Sat Mar 14 17:20:38 1992 Fred Fish (fnf@cygnus.com) + + * Makefile.in, configure.in: Add support for mmalloc library. + +Fri Mar 13 18:44:18 1992 K. Richard Pixley (rich@cygnus.com) + + * Makefile.in: add stmp dependencies for a few more things. + +Thu Mar 12 04:56:24 1992 K. Richard Pixley (rich@cygnus.com) + + * configure: adjusted error message on objdir/srcdir configure + collision, per john's suggestion. + + * Makefile.in: add libiberty stmp to all and all.cross. + +Wed Mar 11 02:07:52 1992 K. Richard Pixley (rich@cygnus.com) + + * Makefile.in: remove force dependencies, add grep to all. + +Tue Mar 10 21:49:18 1992 K. Richard Pixley (rich@mars.cygnus.com) + + * Makefile.in: drop flex. make stamp files work. + + * configure: added test for conflicting configuration in srcdir, + remove trailing slashes from srcdir. Otherwise emacs gdb mode + gets cranky. use relative paths for configure and srcdir + whenever possible. Send some error messages to stderr that were + going to stdout. + +Tue Mar 10 18:01:55 1992 Per Bothner (bothner@cygnus.com) + + * Makefile.in: Fix libg++ rule to check for gcc directory + before using gcc/gcc. Also pass XTRAFLAGS. + +Thu Mar 5 21:45:07 1992 K. Richard Pixley (rich@sendai) + + * Makefile.in: added stmp-files so that directories aren't polled + when they are already built. + + * configure.texi: fixed a node pointer problem. + +Thu Mar 5 12:05:58 1992 Stu Grossman (grossman at cygnus.com) + + * config.sub configure.in config/mh-irix4 gdb/configure.in + gdb/mips-tdep.c gdb/mipsread.c gdb/procfs.c gdb/signame.h + gdb/tm-irix3.h gdb/tm-mips.h gdb/xm-irix4.h gdb/config/mt-irix3 + gdb/config/mh-irix4 texinfo/configure.in: Port to SGI Irix-4.x. + +Wed Mar 4 02:57:46 1992 K. Richard Pixley (rich@rtl.cygnus.com) + + * configure: -recurring becomes -silent. corrected help message + for -site= option. + + * Makefile.in: mkdir $(exec_prefix) and $(tooldir). + +Tue Mar 3 14:51:21 1992 K. Richard Pixley (rich@rtl.cygnus.com) + + * configure: when building Makefile for crosses, replace + tooldir and program_prefix. default srcdir from location of + config.sub. remove "for host in hosts" and "for target in + targets" loops. + +Wed Feb 26 19:48:25 1992 K. Richard Pixley (rich@rtl.cygnus.com) + + * Makefile.in: Do not pass bindir or mandir to cvs. + +Wed Feb 26 18:04:40 1992 K. Richard Pixley (rich@cygnus.com) + + * Makefile.in, configure.in: removed traces of namesubdir, + -subdirs, $(subdir), $(unsubdir), some rcs triggers. Forced + copyrights to '92, changed some from Cygnus to FSF. + + * configure.texi: remove most references to multiple hosts, + multiple targets, subdirs, etc. + + * configure.man: removed rcsid. reference config.sub not + config.subr. + + * Makefile.in: mkdir $(infodir) on install-info. + +Wed Feb 19 15:41:13 1992 John Gilmore (gnu at cygnus.com) + + * configure.texi: Explain better about .gdbinit and about + the environment that configure.in sections run in. + +Fri Feb 7 07:55:00 1992 John Gilmore (gnu at cygnus.com) + + * configure.in: Ultrix is only a decstation if it's a MIPS. + +Fri Jan 31 21:54:51 1992 John Gilmore (gnu at cygnus.com) + + * README: DOC.configure => cfg-paper.texi. + +Fri Jan 31 21:48:18 1992 Stu Grossman (grossman at cygnus.com) + + * config.sub (near case $os): Don't convert newsos* to bsd! + +Fri Jan 31 02:27:32 1992 John Gilmore (gnu at cygnus.com) + + * Makefile.in: Reinstall change from gdb-4.3 that reduces + the number of copies of COPYING that go into the GDB tar file. + +Thu Jan 30 16:17:30 1992 Stu Grossman (grossman at cygnus.com) + + * bfd/configure.in, config/mh-sco, gdb/config/mh-i386sco, + gdb/config/mt-i386v32, gdb/configure.in, readline/configure.in: + Fix SCO configuration stuff. + +Tue Jan 28 23:51:07 1992 Per Bothner (bothner at cygnus.com) + + * Makefile.in: For libg++, make sure the -I pointing + to the gcc directory goes *after* all the libg++-local -I flags. + Also, move just-gcc dependency from just-libg++ to all-libg++. + +Tue Jan 28 12:56:24 1992 Stu Grossman (grossman at cygnus.com) + + * configure: Change -x to -f to keep Ultrix /bin/test happy. + +Sat Jan 18 17:45:11 1992 Stu Grossman (grossman at cygnus.com) + + * Makefile.in (make-gdb.tar.Z): Remove texinfo targets. + +Sat Jan 18 17:03:21 1992 Fred Fish (fnf at cygnus.com) + + * config.sub: Add stratus configuration frags. Also + submitted to FSF. + +Sat Jan 18 15:35:29 1992 Stu Grossman (grossman at cygnus.com) + + * Makefile.in (DEV_SUPPORT): add configure.man. + + * config.sub(Decode manufacturer-specific): add -none*. + +Fri Jan 17 17:58:05 1992 Stu Grossman (grossman at cygnus.com) + + * Makefile.in: remove form feeds to make Sun's make happy. + (DEVO_SUPPORT): DOC.configure => cfg-paper.texi. + +Sat Jan 4 16:11:44 1992 John Gilmore (gnu at cygnus.com) + + * Makefile.in (AR_FLAGS): Make quieter. + +Thu Jan 2 22:57:12 1992 John Gilmore (gnu at cygnus.com) + + * configure.in: Add libg++. + * configure: When verbose, don't output the command line at each + level; it will be unremarkably the same as the previous version, + which will be the same as what the user typed. + +Fri Dec 27 16:26:47 1991 K. Richard Pixley (rich at cygnus.com) + + * configure.in, Makefile.in: fix clean-info, add flex. add + fileutils. + + * configure: be less sensitive to spaces in Makefile.in. Do not + look for sources in "..". Doing so breaks subdirectories that + might have their own configure. If a subdir has it's own + configure script, use it. + +Thu Dec 26 16:30:26 1991 K. Richard Pixley (rich at cygnus.com) + + * cfg-paper.texi: some changes suggested by rms. + +Thu Dec 26 10:13:36 1991 Fred Fish (fnf at cygnus.com) + + * config.sub: Merge in some small additions from the FSF version, + taken from the gcc distribution, to bring the Cygnus and FSF + versions into closer sync. + +Fri Dec 20 11:34:18 1991 Fred Fish (fnf at cygnus.com) + + * configure.in: Changed svr4 references to sysv4. + +Thu Dec 19 15:54:29 1991 K. Richard Pixley (rich at cygnus.com) + + * configure: added -V for version number option. + +Wed Dec 18 15:39:34 1991 K. Richard Pixley (rich at cygnus.com) + + * DOC.configure, cfg-paper.texi: revised, updated, and texinfo'd. + renamed from DOC.configure to cfg-paper.texi. + +Mon Dec 16 23:05:19 1991 K. Richard Pixley (rich at rtl.cygnus.com) + + * configure, config.subr, config.sub: config.subr is now + config.sub again. + +Fri Dec 13 01:17:06 1991 K. Richard Pixley (rich at cygnus.com) + + * configure.texi: new file, in progress. + + * Makefile.in: build info file and install the man page for + configure. + + * configure.man: new file, first cut. + + * configure: find config.subr again now that configuration "none" + has gone. removed all traces of the -ansi option. removed all + traces of the -languages option. + + * config.subr: resync from rms. + +Wed Dec 11 22:25:20 1991 K. Richard Pixley (rich at rtl.cygnus.com) + + * configure, config.sub, config.subr: merge config.sub into + config.subr, call the result config.subr, remove config.sub, use + config.subr. + + * Makefile.in: revised install for dir.info. + +Tue Dec 10 00:04:35 1991 K. Richard Pixley (rich at rtl.cygnus.com) + + * configure.in: add decstation host makefile frag. + + * Makefile.in: BISON now bison -y again. also install-gcc on + install. clean-gdbm on clean. infodir belongs in datadir. + Make directories for info install. Build dir.info here then + install it. + +Mon Dec 9 16:48:33 1991 K. Richard Pixley (rich at rtl.cygnus.com) + + * Makefile.in: fix for bad directory tests. + +Sat Dec 7 00:17:01 1991 K. Richard Pixley (rich at rtl.cygnus.com) + + * configure: \{1,2\} appears to be a sysv'ism. Use a different + regexp. -srcdir relative was being handled incorrectly. + + * Makefile.in: unwrapped some for loops so that parallel makes + work again and so one can focus one's attention on a particular + package. + +Fri Dec 6 00:22:08 1991 K. Richard Pixley (rich at rtl.cygnus.com) + + * configure: added PWD as a stand in for `pwd` (for speed). use + elif wherever possible. make -srcdir work without -objdir. + -objdir= commented out. + +Thu Dec 5 22:46:52 1991 K. Richard Pixley (rich at rtl.cygnus.com) + + * configure: +options become --options. -subdirs commented out. + added -host, -datadir. Renamed -destdir to -prefix. Comment in + Makefile now at top of generated Makefile. Removed cvs log + entries. added -srcdir. create .gdbinit only if there is one + in ${srcdir}. + + * Makefile.in: idestdir and ddestdir go away. Added copyrights + and shift gpl to v2. Added ChangeLog if it didn't exist. docdir + and mandir now keyed off datadir by default. + +Fri Nov 22 07:38:11 1991 K. Richard Pixley (rich at rtl.cygnus.com) + + * Freshly created ChangeLog. + + +Local Variables: +mode: change-log +left-margin: 8 +fill-column: 76 +version-control: never +End: diff --git a/Makefile.in b/Makefile.in new file mode 100644 index 00000000000..af7fb16c276 --- /dev/null +++ b/Makefile.in @@ -0,0 +1,1608 @@ +# +# Makefile for directory with subdirs to build. +# Copyright (C) 1990, 91, 92, 93, 94, 95, 96, 1997 Free Software Foundation +# +# This file 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. +# + +srcdir = . + +prefix = /usr/local + +exec_prefix = $(prefix) +bindir = $(exec_prefix)/bin +libdir = $(exec_prefix)/lib +tooldir = $(exec_prefix)/$(target) + +program_transform_name = + +datadir = $(prefix)/share +mandir = $(prefix)/man +man1dir = $(mandir)/man1 +man2dir = $(mandir)/man2 +man3dir = $(mandir)/man3 +man4dir = $(mandir)/man4 +man5dir = $(mandir)/man5 +man6dir = $(mandir)/man6 +man7dir = $(mandir)/man7 +man8dir = $(mandir)/man8 +man9dir = $(mandir)/man9 +infodir = $(prefix)/info +includedir = $(prefix)/include +GDB_NLM_DEPS = + +SHELL = /bin/sh + +# INSTALL_PROGRAM_ARGS is changed by configure.in to use -x for a +# cygwin32 host. +INSTALL_PROGRAM_ARGS = + +INSTALL = $(SHELL) $$s/install-sh -c +INSTALL_PROGRAM = $(INSTALL) $(INSTALL_PROGRAM_ARGS) +INSTALL_SCRIPT = $(INSTALL) +INSTALL_DATA = $(INSTALL) -m 644 + +INSTALL_DOSREL = install-dosrel-fake + +AS = as +AR = ar +AR_FLAGS = rc +CC = cc + +# Special variables passed down in EXTRA_GCC_FLAGS. They are defined +# here so that they can be overridden by Makefile fragments. +HOST_CC = $(CC_FOR_BUILD) +HOST_PREFIX = +HOST_PREFIX_1 = loser- + +# These flag values are normally overridden by the configure script. +CFLAGS = -g +CXXFLAGS = -g -O2 + +LIBCFLAGS = $(CFLAGS) +CFLAGS_FOR_TARGET = $(CFLAGS) +LDFLAGS_FOR_TARGET = +LIBCFLAGS_FOR_TARGET = $(CFLAGS_FOR_TARGET) +PICFLAG = +PICFLAG_FOR_TARGET = + +CXX = c++ + +# Use -O2 to stress test the compiler. +LIBCXXFLAGS = $(CXXFLAGS) -fno-implicit-templates +CXXFLAGS_FOR_TARGET = $(CXXFLAGS) +LIBCXXFLAGS_FOR_TARGET = $(CXXFLAGS_FOR_TARGET) -fno-implicit-templates + +RANLIB = ranlib + +DLLTOOL = dlltool +WINDRES = windres + +NM = nm + +LD = ld + +# Not plain GZIP, since gzip looks there for extra command-line options. +GZIPPROG = gzip + +# These values are substituted by configure. +DEFAULT_YACC = yacc +DEFAULT_LEX = lex + +BISON = `if [ -f $$r/bison/bison ] ; then \ + echo $$r/bison/bison -L $$s/bison/ ; \ + else \ + echo bison ; \ + fi` + +YACC = `if [ -f $$r/bison/bison ] ; then \ + echo $$r/bison/bison -y -L $$s/bison/ ; \ + elif [ -f $$r/byacc/byacc ] ; then \ + echo $$r/byacc/byacc ; \ + else \ + echo ${DEFAULT_YACC} ; \ + fi` + +LEX = `if [ -f $$r/flex/flex ] ; \ + then echo $$r/flex/flex ; \ + else echo ${DEFAULT_LEX} ; fi` + +M4 = `if [ -f $$r/m4/m4 ] ; \ + then echo $$r/m4/m4 ; \ + else echo m4 ; fi` + +MAKEINFO = `if [ -f $$r/texinfo/makeinfo/Makefile ] ; \ + then echo $$r/texinfo/makeinfo/makeinfo ; \ + else echo makeinfo ; fi` + +# This just becomes part of the MAKEINFO definition passed down to +# sub-makes. It lets flags be given on the command line while still +# using the makeinfo from the object tree. +MAKEINFOFLAGS = + +EXPECT = `if [ -f $$r/expect/expect ] ; \ + then echo $$r/expect/expect ; \ + else echo expect ; fi` + +RUNTEST = `if [ -f $$s/dejagnu/runtest ] ; \ + then echo $$s/dejagnu/runtest ; \ + else echo runtest ; fi` + + +# compilers to use to create programs which must be run in the build +# environment. +CC_FOR_BUILD = $(CC) +CXX_FOR_BUILD = $(CXX) + +SUBDIRS = "this is set via configure, don't edit this" +OTHERS = + +# This is set by the configure script to the list of directories which +# should be built using the target tools. +TARGET_CONFIGDIRS = libiberty libgloss newlib libio librx libstdc++ libg++ winsup + +# Target libraries are put under this directory: +# Changed by configure to $(target_alias) if cross. +TARGET_SUBDIR = . + +# This is set by the configure script to the arguments passed to configure. +CONFIG_ARGUMENTS = + +# This is set by configure to REALLY_SET_LIB_PATH if --enable-shared +# was used. +SET_LIB_PATH = + +# This is the name of the environment variable used for the path to +# the libraries. This may be changed by configure.in. +RPATH_ENVVAR = LD_LIBRARY_PATH + +# configure.in sets SET_LIB_PATH to this if --enable-shared was used. +REALLY_SET_LIB_PATH = \ + $(RPATH_ENVVAR)=$$r/bfd:$$r/opcodes:$$$(RPATH_ENVVAR); \ + export $(RPATH_ENVVAR); + +ALL = all.normal +INSTALL_TARGET = installdirs \ + $(INSTALL_MODULES) \ + $(INSTALL_TARGET_MODULES) \ + $(INSTALL_X11_MODULES) \ + install-gcc \ + $(INSTALL_DOSREL) + + +CC_FOR_TARGET = ` \ + if [ -f $$r/gcc/xgcc ] ; then \ + if [ -f $$r/$(TARGET_SUBDIR)/newlib/Makefile ] ; then \ + if [ -f $$r/$(TARGET_SUBDIR)/winsup/Makefile ] ; then \ + echo $$r/gcc/xgcc -B$$r/gcc/ -B$$r/newlib/ -L$$r/$(TARGET_SUBDIR)/winsup -idirafter $$r/$(TARGET_SUBDIR)/newlib/targ-include -idirafter $$s/newlib/libc/include -nostdinc; \ + else \ + echo $$r/gcc/xgcc -B$$r/gcc/ -idirafter $$r/$(TARGET_SUBDIR)/newlib/targ-include -idirafter $$s/newlib/libc/include -nostdinc; \ + fi; \ + else \ + echo $$r/gcc/xgcc -B$$r/gcc/; \ + fi; \ + else \ + if [ "$(host_canonical)" = "$(target_canonical)" ] ; then \ + echo $(CC); \ + else \ + t='$(program_transform_name)'; echo gcc | sed -e 's/x/x/' $$t; \ + fi; \ + fi` + +# If CC_FOR_TARGET is not overriden on the command line, then this +# variable is passed down to the gcc Makefile, where it is used to +# build libgcc2.a. We define it here so that it can itself be +# overridden on the command line. +GCC_FOR_TARGET = $$r/gcc/xgcc -B$$r/gcc/ + + +CXX_FOR_TARGET = ` \ + if [ -f $$r/gcc/xgcc ] ; then \ + if [ -f $$r/$(TARGET_SUBDIR)/newlib/Makefile ] ; then \ + if [ -f $$r/$(TARGET_SUBDIR)/winsup/Makefile ] ; then \ + echo $$r/gcc/xgcc -B$$r/gcc/ -B$$r/newlib/ -L$$r/winsup -idirafter $$r/$(TARGET_SUBDIR)/newlib/targ-include -idirafter $$s/newlib/libc/include -nostdinc; \ + else \ + echo $$r/gcc/xgcc -B$$r/gcc/ -idirafter $$r/$(TARGET_SUBDIR)/newlib/targ-include -idirafter $$s/newlib/libc/include -nostdinc; \ + fi; \ + else \ + echo $$r/gcc/xgcc -B$$r/gcc/; \ + fi; \ + else \ + if [ "$(host_canonical)" = "$(target_canonical)" ] ; then \ + echo $(CXX); \ + else \ + t='$(program_transform_name)'; echo c++ | sed -e 's/x/x/' $$t; \ + fi; \ + fi` + +AS_FOR_TARGET = ` \ + if [ -f $$r/gas/as-new ] ; then \ + echo $$r/gas/as-new ; \ + else \ + if [ "$(host_canonical)" = "$(target_canonical)" ] ; then \ + echo $(AS); \ + else \ + t='$(program_transform_name)'; echo as | sed -e 's/x/x/' $$t ; \ + fi; \ + fi` + +LD_FOR_TARGET = ` \ + if [ -f $$r/ld/ld-new ] ; then \ + echo $$r/ld/ld-new ; \ + else \ + if [ "$(host_canonical)" = "$(target_canonical)" ] ; then \ + echo $(LD); \ + else \ + t='$(program_transform_name)'; echo ld | sed -e 's/x/x/' $$t ; \ + fi; \ + fi` + +DLLTOOL_FOR_TARGET = ` \ + if [ -f $$r/binutils/dlltool ] ; then \ + echo $$r/binutils/dlltool ; \ + else \ + if [ "$(host_canonical)" = "$(target_canonical)" ] ; then \ + echo $(DLLTOOL); \ + else \ + t='$(program_transform_name)'; echo dlltool | sed -e 's/x/x/' $$t ; \ + fi; \ + fi` + +WINDRES_FOR_TARGET = ` \ + if [ -f $$r/binutils/windres ] ; then \ + echo $$r/binutils/windres ; \ + else \ + if [ "$(host_canonical)" = "$(target_canonical)" ] ; then \ + echo $(WINDRES); \ + else \ + t='$(program_transform_name)'; echo windres | sed -e 's/x/x/' $$t ; \ + fi; \ + fi` + +AR_FOR_TARGET = ` \ + if [ -f $$r/binutils/ar ] ; then \ + echo $$r/binutils/ar ; \ + else \ + if [ "$(host_canonical)" = "$(target_canonical)" ] ; then \ + echo $(AR); \ + else \ + t='$(program_transform_name)'; echo ar | sed -e 's/x/x/' $$t ; \ + fi; \ + fi` + +RANLIB_FOR_TARGET = ` \ + if [ -f $$r/binutils/ranlib ] ; then \ + echo $$r/binutils/ranlib ; \ + else \ + if [ "$(host_canonical)" = "$(target_canonical)" ] ; then \ + echo $(RANLIB); \ + else \ + t='$(program_transform_name)'; echo ranlib | sed -e 's/x/x/' $$t ; \ + fi; \ + fi` + +NM_FOR_TARGET = ` \ + if [ -f $$r/binutils/nm-new ] ; then \ + echo $$r/binutils/nm-new ; \ + else \ + if [ "$(host_canonical)" = "$(target_canonical)" ] ; then \ + echo $(NM); \ + else \ + t='$(program_transform_name)'; echo nm | sed -e 's/x/x/' $$t ; \ + fi; \ + fi` + +#### host and target specific makefile fragments come in here. +### + +# Flags to pass down to all sub-makes. +# Please keep these in alphabetical order. +BASE_FLAGS_TO_PASS = \ + "AR_FLAGS=$(AR_FLAGS)" \ + "AR_FOR_TARGET=$(AR_FOR_TARGET)" \ + "AS_FOR_TARGET=$(AS_FOR_TARGET)" \ + "BISON=$(BISON)" \ + "CC_FOR_BUILD=$(CC_FOR_BUILD)" \ + "CC_FOR_TARGET=$(CC_FOR_TARGET)" \ + "CFLAGS=$(CFLAGS)" \ + "CFLAGS_FOR_TARGET=$(CFLAGS_FOR_TARGET)" \ + "CXX_FOR_BUILD=$(CXX_FOR_BUILD)" \ + "CXXFLAGS=$(CXXFLAGS)" \ + "CXXFLAGS_FOR_TARGET=$(CXXFLAGS_FOR_TARGET)" \ + "CXX_FOR_TARGET=$(CXX_FOR_TARGET)" \ + "DLLTOOL_FOR_TARGET=$(DLLTOOL_FOR_TARGET)" \ + "INSTALL=$(INSTALL)" \ + "INSTALL_DATA=$(INSTALL_DATA)" \ + "INSTALL_PROGRAM=$(INSTALL_PROGRAM)" \ + "INSTALL_SCRIPT=$(INSTALL_SCRIPT)" \ + "LDFLAGS=$(LDFLAGS)" \ + "LEX=$(LEX)" \ + "LD_FOR_TARGET=$(LD_FOR_TARGET)" \ + "LIBCFLAGS=$(LIBCFLAGS)" \ + "LIBCFLAGS_FOR_TARGET=$(LIBCFLAGS_FOR_TARGET)" \ + "LIBCXXFLAGS=$(LIBCXXFLAGS)" \ + "LIBCXXFLAGS_FOR_TARGET=$(LIBCXXFLAGS_FOR_TARGET)" \ + "M4=$(M4)" \ + "MAKE=$(MAKE)" \ + "MAKEINFO=$(MAKEINFO) $(MAKEINFOFLAGS)" \ + "NM_FOR_TARGET=$(NM_FOR_TARGET)" \ + "PICFLAG=$(PICFLAG)" \ + "PICFLAG_FOR_TARGET=$(PICFLAG_FOR_TARGET)" \ + "RANLIB_FOR_TARGET=$(RANLIB_FOR_TARGET)" \ + "SHELL=$(SHELL)" \ + "EXPECT=$(EXPECT)" \ + "RUNTEST=$(RUNTEST)" \ + "RUNTESTFLAGS=$(RUNTESTFLAGS)" \ + "WINDRES_FOR_TARGET=$(WINDRES_FOR_TARGET)" \ + "YACC=$(YACC)" \ + "exec_prefix=$(exec_prefix)" \ + "prefix=$(prefix)" \ + "tooldir=$(tooldir)" + +# Flags to pass down to most sub-makes, in which we're building with +# the host environment. +# If any variables are added here, they must be added to do-*, below. +EXTRA_HOST_FLAGS = \ + 'AR=$(AR)' \ + 'AS=$(AS)' \ + 'CC=$(CC)' \ + 'CXX=$(CXX)' \ + 'DLLTOOL=$(DLLTOOL)' \ + 'LD=$(LD)' \ + 'NM=$(NM)' \ + 'RANLIB=$(RANLIB)' \ + 'WINDRES=$(WINDRES)' + +FLAGS_TO_PASS = $(BASE_FLAGS_TO_PASS) $(EXTRA_HOST_FLAGS) + +# Flags that are concerned with the location of the X11 include files +# and library files +# +# NOTE: until the top-level is getting the values via autoconf, it only +# causes problems to have this top-level Makefile overriding the autoconf-set +# values in child directories. Only variables that don't conflict with +# autoconf'ed ones should be passed by X11_FLAGS_TO_PASS for now. +# +X11_FLAGS_TO_PASS = \ + 'X11_EXTRA_CFLAGS=$(X11_EXTRA_CFLAGS)' \ + 'X11_EXTRA_LIBS=$(X11_EXTRA_LIBS)' + +# Flags to pass down to makes which are built with the target environment. +# The double $ decreases the length of the command line; the variables +# are set in BASE_FLAGS_TO_PASS, and the sub-make will expand them. +# If any variables are added here, they must be added to do-*, below. +EXTRA_TARGET_FLAGS = \ + 'AR=$$(AR_FOR_TARGET)' \ + 'AS=$$(AS_FOR_TARGET)' \ + 'CC=$$(CC_FOR_TARGET)' \ + 'CFLAGS=$$(CFLAGS_FOR_TARGET)' \ + 'CXX=$$(CXX_FOR_TARGET)' \ + 'CXXFLAGS=$$(CXXFLAGS_FOR_TARGET)' \ + 'DLLTOOL=$$(DLLTOOL_FOR_TARGET)' \ + 'LD=$$(LD_FOR_TARGET)' \ + 'LIBCFLAGS=$$(LIBCFLAGS_FOR_TARGET)' \ + 'LIBCXXFLAGS=$$(LIBCXXFLAGS_FOR_TARGET)' \ + 'NM=$$(NM_FOR_TARGET)' \ + 'PICFLAG=$$(PICFLAG_FOR_TARGET)' \ + 'RANLIB=$$(RANLIB_FOR_TARGET)' \ + 'WINDRES=$$(WINDRES_FOR_TARGET)' + +TARGET_FLAGS_TO_PASS = $(BASE_FLAGS_TO_PASS) $(EXTRA_TARGET_FLAGS) + +# Flags to pass down to gcc. gcc builds a library, libgcc.a, so it +# unfortunately needs the native compiler and the target ar and +# ranlib. +# If any variables are added here, they must be added to do-*, below. +# The HOST_* variables are a special case, which are used for the gcc +# cross-building scheme. +EXTRA_GCC_FLAGS = \ + 'AR=$$(AR_FOR_TARGET)' \ + 'AS=$(AS)' \ + 'CC=$(CC)' \ + 'CXX=$(CXX)' \ + 'DLLTOOL=$$(DLLTOOL_FOR_TARGET)' \ + 'HOST_CC=$(CC_FOR_BUILD)' \ + 'HOST_PREFIX=$(HOST_PREFIX)' \ + 'HOST_PREFIX_1=$(HOST_PREFIX_1)' \ + 'NM=$(NM)' \ + 'RANLIB=$$(RANLIB_FOR_TARGET)' \ + 'WINDRES=$$(WINDRES_FOR_TARGET)' \ + "GCC_FOR_TARGET=$(GCC_FOR_TARGET)" \ + "`if test x'$(LANGUAGES)' != x; then echo 'LANGUAGES=$(LANGUAGES)'; else echo 'XFOO=bar'; fi`" \ + "`if test x'$(STMP_FIXPROTO)' != x; then echo 'STMP_FIXPROTO=$(STMP_FIXPROTO)'; else echo 'XFOO=bar'; fi`" \ + "`if test x'$(LIMITS_H_TEST)' != x; then echo 'LIMITS_H_TEST=$(LIMITS_H_TEST)'; else echo 'XFOO=bar'; fi`" \ + "`if test x'$(LIBGCC1_TEST)' != x; then echo 'LIBGCC1_TEST=$(LIBGCC1_TEST)'; else echo 'XFOO=bar'; fi`" \ + "`if test x'$(LIBGCC2_CFLAGS)' != x; then echo 'LIBGCC2_CFLAGS=$(LIBGCC2_CFLAGS)'; else echo 'XFOO=bar'; fi`" \ + "`if test x'$(LIBGCC2_DEBUG_CFLAGS)' != x; then echo 'LIBGCC2_DEBUG_CFLAGS=$(LIBGCC2_DEBUG_CFLAGS)'; else echo 'XFOO=bar'; fi`" \ + "`if test x'$(LIBGCC2_INCLUDES)' != x; then echo 'LIBGCC2_INCLUDES=$(LIBGCC2_INCLUDES)'; else echo 'XFOO=bar'; fi`" \ + "`if test x'$(ENQUIRE)' != x; then echo 'ENQUIRE=$(ENQUIRE)'; else echo 'XFOO=bar'; fi`" \ + "`if test x'$(BOOT_CFLAGS)' != x; then echo 'BOOT_CFLAGS=$(BOOT_CFLAGS)'; else echo 'XFOO=bar'; fi`" + +GCC_FLAGS_TO_PASS = $(BASE_FLAGS_TO_PASS) $(EXTRA_GCC_FLAGS) + +# This is a list of the targets for all of the modules which are compiled +# using $(FLAGS_TO_PASS). +ALL_MODULES = \ + all-apache \ + all-autoconf \ + all-automake \ + all-bash \ + all-bfd \ + all-binutils \ + all-bison \ + all-byacc \ + all-cvs \ + all-db \ + all-dejagnu \ + all-diff \ + all-dosutils \ + all-etc \ + all-fileutils \ + all-findutils \ + all-find \ + all-flex \ + all-gas \ + all-gawk \ + all-gnuserv \ + all-gprof \ + all-grep \ + all-grez \ + all-gzip \ + all-hello \ + all-indent \ + all-inet \ + all-ispell \ + all-itcl \ + all-ld \ + all-libiberty \ + all-m4 \ + all-make \ + all-mmalloc \ + all-opcodes \ + all-patch \ + all-perl \ + all-prms \ + all-rcs \ + all-readline \ + all-release \ + all-recode \ + all-sed \ + all-send-pr \ + all-shellutils \ + all-sim \ + all-sn \ + all-tar \ + all-tcl \ + all-texinfo \ + all-textutils \ + all-tgas \ + all-time \ + all-uudecode \ + all-wdiff + +# This is a list of the check targets for all of the modules which are +# compiled using $(FLAGS_TO_PASS). +# +# The list is in two parts. The first lists those tools which +# are tested as part of the host's native tool-chain, and not +# tested in a cross configuration. +NATIVE_CHECK_MODULES = \ + check-bison \ + check-byacc \ + check-flex + +CROSS_CHECK_MODULES = \ + check-apache \ + check-autoconf \ + check-automake \ + check-bash \ + check-bfd \ + check-binutils \ + check-cvs \ + check-db \ + check-dejagnu \ + check-diff \ + check-etc \ + check-fileutils \ + check-findutils \ + check-find \ + check-gas \ + check-gawk \ + check-gnuserv \ + check-gprof \ + check-grep \ + check-gzip \ + check-hello \ + check-indent \ + check-inet \ + check-ispell \ + check-itcl \ + check-ld \ + check-libiberty \ + check-m4 \ + check-make \ + check-mmcheckoc \ + check-opcodes \ + check-patch \ + check-perl \ + check-prms \ + check-rcs \ + check-readline \ + check-recode \ + check-sed \ + check-send-pr \ + check-shellutils \ + check-sn \ + check-sim \ + check-tar \ + check-tcl \ + check-texinfo \ + check-textutils \ + check-tgas \ + check-time \ + check-uudecode \ + check-wdiff + +CHECK_MODULES=$(NATIVE_CHECK_MODULES) $(CROSS_CHECK_MODULES) + +# This is a list of the install targets for all of the modules which are +# compiled using $(FLAGS_TO_PASS). +# We put install-opcodes before install-binutils because the installed +# binutils might be on PATH, and they might need the shared opcodes +# library. +INSTALL_MODULES = \ + install-apache \ + install-autoconf \ + install-automake \ + install-bash \ + install-bfd \ + install-opcodes \ + install-binutils \ + install-bison \ + install-byacc \ + install-cvs \ + install-db \ + install-dejagnu \ + install-diff \ + install-dosutils \ + install-etc \ + install-fileutils \ + install-findutils \ + install-find \ + install-flex \ + install-gas \ + install-gawk \ + install-gnuserv \ + install-gprof \ + install-grep \ + install-grez \ + install-gzip \ + install-hello \ + install-indent \ + install-inet \ + install-ispell \ + install-itcl \ + install-ld \ + install-libiberty \ + install-m4 \ + install-make \ + install-mmalloc \ + install-patch \ + install-perl \ + install-prms \ + install-rcs \ + install-readline \ + install-recode \ + install-sed \ + install-send-pr \ + install-shellutils \ + install-sim \ + install-sn \ + install-tar \ + install-tcl \ + install-texinfo \ + install-textutils \ + install-tgas \ + install-time \ + install-uudecode \ + install-wdiff + +# This is a list of the targets for all of the modules which are compiled +# using $(X11_FLAGS_TO_PASS). +ALL_X11_MODULES = \ + all-emacs \ + all-emacs19 \ + all-gdb \ + all-expect \ + all-gash \ + all-guile \ + all-tclX \ + all-tk \ + all-tix + +# This is a list of the check targets for all of the modules which are +# compiled using $(X11_FLAGS_TO_PASS). +CHECK_X11_MODULES = \ + check-emacs \ + check-gdb \ + check-guile \ + check-expect \ + check-gash \ + check-tclX \ + check-tk \ + check-tix + +# This is a list of the install targets for all the modules which are +# compiled using $(X11_FLAGS_TO_PASS). +INSTALL_X11_MODULES = \ + install-emacs \ + install-emacs19 \ + install-gdb \ + install-guile \ + install-expect \ + install-gash \ + install-tclX \ + install-tk \ + install-tix + +# This is a list of the targets for all of the modules which are compiled +# using $(TARGET_FLAGS_TO_PASS). +ALL_TARGET_MODULES = \ + all-target-libio \ + all-target-libstdc++ \ + all-target-librx \ + all-target-libg++ \ + all-target-newlib \ + all-target-winsup \ + all-target-libgloss \ + all-target-libiberty \ + all-target-gperf \ + all-target-examples + +# This is a list of the configure targets for all of the modules which +# are compiled using the target tools. +CONFIGURE_TARGET_MODULES = \ + configure-target-libio \ + configure-target-libstdc++ \ + configure-target-librx \ + configure-target-libg++ \ + configure-target-newlib \ + configure-target-winsup \ + configure-target-libgloss \ + configure-target-libiberty \ + configure-target-gperf \ + configure-target-examples + +# This is a list of the check targets for all of the modules which are +# compiled using $(TARGET_FLAGS_TO_PASS). +CHECK_TARGET_MODULES = \ + check-target-libio \ + check-target-libstdc++ \ + check-target-libg++ \ + check-target-newlib \ + check-target-winsup \ + check-target-libiberty \ + check-target-gperf + +# This is a list of the install targets for all of the modules which are +# compiled using $(TARGET_FLAGS_TO_PASS). +INSTALL_TARGET_MODULES = \ + install-target-libio \ + install-target-libstdc++ \ + install-target-libg++ \ + install-target-newlib \ + install-target-winsup \ + install-target-libgloss \ + install-target-libiberty \ + install-target-gperf + +# This is a list of the targets for which we can do a clean-{target}. +CLEAN_MODULES = \ + clean-apache \ + clean-autoconf \ + clean-automake \ + clean-bash \ + clean-bfd \ + clean-binutils \ + clean-bison \ + clean-byacc \ + clean-cvs \ + clean-db \ + clean-dejagnu \ + clean-diff \ + clean-dosutils \ + clean-etc \ + clean-fileutils \ + clean-findutils \ + clean-find \ + clean-flex \ + clean-gas \ + clean-gawk \ + clean-gnuserv \ + clean-gprof \ + clean-grep \ + clean-grez \ + clean-gzip \ + clean-hello \ + clean-indent \ + clean-inet \ + clean-ispell \ + clean-itcl \ + clean-ld \ + clean-libiberty \ + clean-m4 \ + clean-make \ + clean-mmalloc \ + clean-opcodes \ + clean-patch \ + clean-perl \ + clean-prms \ + clean-rcs \ + clean-readline \ + clean-release \ + clean-recode \ + clean-sed \ + clean-send-pr \ + clean-shellutils \ + clean-sim \ + clean-sn \ + clean-tar \ + clean-tcl \ + clean-texinfo \ + clean-textutils \ + clean-tgas \ + clean-time \ + clean-uudecode \ + clean-wdiff + +# All of the target modules that can be cleaned +CLEAN_TARGET_MODULES = \ + clean-target-libio \ + clean-target-libstdc++ \ + clean-target-librx \ + clean-target-libg++ \ + clean-target-newlib \ + clean-target-winsup \ + clean-target-libgloss \ + clean-target-libiberty \ + clean-target-gperf \ + clean-target-examples + +# All of the x11 modules that can be cleaned +CLEAN_X11_MODULES = \ + clean-emacs \ + clean-emacs19 \ + clean-gdb \ + clean-expect \ + clean-gash \ + clean-guile \ + clean-tclX \ + clean-tk \ + clean-tix + +# The first rule in the file had better be this one. Don't put any above it. +all: all.normal +.PHONY: all + +# The target built for a native build. +.PHONY: all.normal +all.normal: \ + $(ALL_MODULES) \ + $(ALL_X11_MODULES) \ + $(ALL_TARGET_MODULES) \ + all-gcc + +# Do a target for all the subdirectories. A ``make do-X'' will do a +# ``make X'' in all subdirectories (because, in general, there is a +# dependency (below) of X upon do-X, a ``make X'' will also do this, +# but it may do additional work as well). +# This target ensures that $(BASE_FLAGS_TO_PASS) appears only once, +# because it is so large that it can easily overflow the command line +# length limit on some systems. +DO_X = \ + do-clean \ + do-distclean \ + do-dvi \ + do-info \ + do-install-info \ + do-installcheck \ + do-mostlyclean \ + do-maintainer-clean \ + do-TAGS +.PHONY: $(DO_X) +$(DO_X): + @target=`echo $@ | sed -e 's/^do-//'`; \ + r=`pwd`; export r; \ + s=`cd $(srcdir); pwd`; export s; \ + $(SET_LIB_PATH) \ + for i in $(SUBDIRS) -dummy-; do \ + if [ -f ./$$i/Makefile ]; then \ + case $$i in \ + gcc) \ + for flag in $(EXTRA_GCC_FLAGS); do \ + eval `echo "$$flag" | sed -e "s|^\([^=]*\)=\(.*\)|\1='\2'|"`; \ + done; \ + ;; \ + *) \ + for flag in $(EXTRA_HOST_FLAGS); do \ + eval `echo "$$flag" | sed -e "s|^\([^=]*\)=\(.*\)|\1='\2'|"`; \ + done; \ + ;; \ + esac ; \ + export AR AS CC CXX LD NM RANLIB DLLTOOL WINDRES; \ + if (cd ./$$i; \ + $(MAKE) $(BASE_FLAGS_TO_PASS) "AR=$${AR}" "AS=$${AS}" \ + "CC=$${CC}" "CXX=$${CXX}" "LD=$${LD}" "NM=$${NM}" \ + "RANLIB=$${RANLIB}" \ + "DLLTOOL=$${DLLTOOL}" "WINDRES=$${WINDRES}" \ + $${target}); \ + then true; else exit 1; fi; \ + else true; fi; \ + done + @target=`echo $@ | sed -e 's/^do-//'`; \ + r=`pwd`; export r; \ + s=`cd $(srcdir); pwd`; export s; \ + $(SET_LIB_PATH) \ + for i in $(TARGET_CONFIGDIRS) -dummy-; do \ + if [ -f $(TARGET_SUBDIR)/$$i/Makefile ]; then \ + for flag in $(EXTRA_TARGET_FLAGS); do \ + eval `echo "$$flag" | sed -e "s|^\([^=]*\)=\(.*\)|\1='\2'|"`; \ + done; \ + export AR AS CC CXX LD NM RANLIB DLLTOOL WINDRES; \ + if (cd $(TARGET_SUBDIR)/$$i; \ + $(MAKE) $(BASE_FLAGS_TO_PASS) "AR=$${AR}" "AS=$${AS}" \ + "CC=$${CC}" "CXX=$${CXX}" "LD=$${LD}" "NM=$${NM}" \ + "RANLIB=$${RANLIB}" \ + "DLLTOOL=$${DLLTOOL}" "WINDRES=$${WINDRES}" \ + $${target}); \ + then true; else exit 1; fi; \ + else true; fi; \ + done + +# Here are the targets which correspond to the do-X targets. + +.PHONY: info installcheck dvi install-info +.PHONY: clean distclean mostlyclean maintainer-clean realclean +.PHONY: local-clean local-distclean local-maintainer-clean +info: do-info +installcheck: do-installcheck +dvi: do-dvi + +# Make sure makeinfo is built before we do a `make info'. +do-info: all-texinfo + +install-info: do-install-info dir.info + s=`cd $(srcdir); pwd`; export s; \ + if [ -f dir.info ] ; then \ + $(INSTALL_DATA) dir.info $(infodir)/dir.info ; \ + else true ; fi + +local-clean: + -rm -f *.a TEMP errs core *.o *~ \#* TAGS *.E + +local-distclean: + -rm -f Makefile config.status config.cache + -if [ "$(TARGET_SUBDIR)" != "." ]; then \ + rm -rf $(TARGET_SUBDIR); \ + else true; fi + +local-maintainer-clean: + @echo "This command is intended for maintainers to use;" + @echo "it deletes files that may require special tools to rebuild." + +clean: do-clean local-clean +mostlyclean: do-mostlyclean local-clean +distclean: do-distclean local-clean local-distclean +maintainer-clean: local-maintainer-clean do-maintainer-clean local-clean +maintainer-clean: local-distclean +realclean: maintainer-clean + +# This rule is used to clean specific modules. +.PHONY: $(CLEAN_MODULES) $(CLEAN_X11_MODULES) clean-gcc +$(CLEAN_MODULES) $(CLEAN_X11_MODULES) clean-gcc: + @dir=`echo $@ | sed -e 's/clean-//'`; \ + if [ -f ./$${dir}/Makefile ] ; then \ + r=`pwd`; export r; \ + s=`cd $(srcdir); pwd`; export s; \ + $(SET_LIB_PATH) \ + (cd $${dir}; $(MAKE) $(FLAGS_TO_PASS) clean); \ + else \ + true; \ + fi + +.PHONY: $(CLEAN_TARGET_MODULES) +$(CLEAN_TARGET_MODULES): + @dir=`echo $@ | sed -e 's/clean-target-//'`; \ + rm -f $(TARGET_SUBDIR)/$${dir}/multilib.out $(TARGET_SUBDIR)/$${dir}/tmpmulti.out; \ + if [ -f $(TARGET_SUBDIR)/$${dir}/Makefile ] ; then \ + r=`pwd`; export r; \ + s=`cd $(srcdir); pwd`; export s; \ + $(SET_LIB_PATH) \ + (cd $(TARGET_SUBDIR)/$${dir}; $(MAKE) $(TARGET_FLAGS_TO_PASS) clean); \ + else \ + true; \ + fi + +clean-target: $(CLEAN_TARGET_MODULES) + +# Check target. + +.PHONY: check +check: $(CHECK_MODULES) \ + $(CHECK_TARGET_MODULES) \ + $(CHECK_X11_MODULES) \ + check-gcc + +# Installation targets. + +.PHONY: install uninstall source-vault binary-vault vault-install +install: $(INSTALL_TARGET) + +uninstall: + @echo "the uninstall target is not supported in this tree" + +source-vault: + $(MAKE) -f ./release/Build-A-Release \ + host=$(host_alias) source-vault + +binary-vault: + $(MAKE) -f ./release/Build-A-Release \ + host=$(host_alias) target=$(target_alias) + +vault-install: + @if [ -f ./release/vault-install ] ; then \ + ./release/vault-install $(host_alias) $(target_alias) ; \ + else \ + true ; \ + fi + +.PHONY: install.all +install.all: install-no-fixedincludes + @if [ -f ./gcc/Makefile ] ; then \ + r=`pwd` ; export r ; \ + $(SET_LIB_PATH) \ + (cd ./gcc; \ + $(MAKE) $(FLAGS_TO_PASS) install-headers) ; \ + else \ + true ; \ + fi + +# inet-install is used because the I*Net wants DejaGNU installed but +# not built. Similarly, gzip is built but not installed. +inet-install: + $(MAKE) INSTALL_MODULES="`echo $(INSTALL_MODULES) | sed -e 's/install-dejagnu//' -e 's/install-gzip//'`" install + +# install-no-fixedincludes is used because Cygnus can not distribute +# the fixed header files. +.PHONY: install-no-fixedincludes +install-no-fixedincludes: \ + installdirs \ + $(INSTALL_MODULES) \ + $(INSTALL_TARGET_MODULES) \ + $(INSTALL_X11_MODULES) \ + gcc-no-fixedincludes + +# Install the gcc headers files, but not the fixed include files, +# which Cygnus is not allowed to distribute. This rule is very +# dependent on the workings of the gcc Makefile.in. +.PHONY: gcc-no-fixedincludes +gcc-no-fixedincludes: + @if [ -f ./gcc/Makefile ]; then \ + rm -rf gcc/tmp-include; \ + mv gcc/include gcc/tmp-include 2>/dev/null; \ + mkdir gcc/include; \ + cp $(srcdir)/gcc/gsyslimits.h gcc/include/syslimits.h; \ + touch gcc/stmp-fixinc gcc/include/fixed; \ + rm -f gcc/stmp-headers gcc/stmp-int-hdrs; \ + r=`pwd`; export r; \ + s=`cd $(srcdir); pwd` ; export s; \ + $(SET_LIB_PATH) \ + (cd ./gcc; \ + $(MAKE) $(GCC_FLAGS_TO_PASS) install); \ + rm -rf gcc/include; \ + mv gcc/tmp-include gcc/include 2>/dev/null; \ + else true; fi + +# This rule is used to build the modules which use FLAGS_TO_PASS. To +# build a target all-X means to cd to X and make all. +# +# all-gui, and all-libproc are handled specially because +# they are still experimental, and if they fail to build, that +# shouldn't stop "make all". +.PHONY: $(ALL_MODULES) all-gui all-libproc +$(ALL_MODULES) all-gui all-libproc: + @dir=`echo $@ | sed -e 's/all-//'`; \ + if [ -f ./$${dir}/Makefile ] ; then \ + r=`pwd`; export r; \ + s=`cd $(srcdir); pwd`; export s; \ + $(SET_LIB_PATH) \ + (cd $${dir}; $(MAKE) $(FLAGS_TO_PASS) all); \ + else \ + true; \ + fi + +# These rules are used to check the modules which use FLAGS_TO_PASS. +# To build a target check-X means to cd to X and make check. Some +# modules are only tested in a native toolchain. + +.PHONY: $(CHECK_MODULES) $(NATIVE_CHECK_MODULES) $(CROSS_CHECK_MODULES) +$(NATIVE_CHECK_MODULES): + @if [ "$(host_canonical)" = "$(target_canonical)" ] ; then \ + dir=`echo $@ | sed -e 's/check-//'`; \ + if [ -f ./$${dir}/Makefile ] ; then \ + r=`pwd`; export r; \ + s=`cd $(srcdir); pwd`; export s; \ + $(SET_LIB_PATH) \ + (cd $${dir}; $(MAKE) $(FLAGS_TO_PASS) check); \ + else \ + true; \ + fi; \ + fi + +$(CROSS_CHECK_MODULES): + @dir=`echo $@ | sed -e 's/check-//'`; \ + if [ -f ./$${dir}/Makefile ] ; then \ + r=`pwd`; export r; \ + s=`cd $(srcdir); pwd`; export s; \ + $(SET_LIB_PATH) \ + (cd $${dir}; $(MAKE) $(FLAGS_TO_PASS) check); \ + else \ + true; \ + fi + +# This rule is used to install the modules which use FLAGS_TO_PASS. +# To build a target install-X means to cd to X and make install. +.PHONY: $(INSTALL_MODULES) +$(INSTALL_MODULES): installdirs + @dir=`echo $@ | sed -e 's/install-//'`; \ + if [ -f ./$${dir}/Makefile ] ; then \ + r=`pwd`; export r; \ + s=`cd $(srcdir); pwd`; export s; \ + $(SET_LIB_PATH) \ + (cd $${dir}; $(MAKE) $(FLAGS_TO_PASS) install); \ + else \ + true; \ + fi + +# This rule is used to configure the modules which are built with the +# target tools. +.PHONY: $(CONFIGURE_TARGET_MODULES) +$(CONFIGURE_TARGET_MODULES): + @dir=`echo $@ | sed -e 's/configure-target-//'`; \ + if [ -d $(TARGET_SUBDIR)/$${dir} ]; then \ + r=`pwd`; export r; \ + $(CC_FOR_TARGET) --print-multi-lib > $(TARGET_SUBDIR)/$${dir}/tmpmulti.out 2> /dev/null; \ + if [ -s $(TARGET_SUBDIR)/$${dir}/tmpmulti.out ]; then \ + if [ -f $(TARGET_SUBDIR)/$${dir}/multilib.out ]; then \ + if cmp $(TARGET_SUBDIR)/$${dir}/multilib.out $(TARGET_SUBDIR)/$${dir}/tmpmulti.out > /dev/null; then \ + rm -f $(TARGET_SUBDIR)/$${dir}/tmpmulti.out; \ + else \ + echo "Multilibs changed for $${dir}, reconfiguring"; \ + rm -f $(TARGET_SUBDIR)/$${dir}/multilib.out $(TARGET_SUBDIR)/$${dir}/Makefile; \ + mv $(TARGET_SUBDIR)/$${dir}/tmpmulti.out $(TARGET_SUBDIR)/$${dir}/multilib.out; \ + fi; \ + else \ + mv $(TARGET_SUBDIR)/$${dir}/tmpmulti.out $(TARGET_SUBDIR)/$${dir}/multilib.out; \ + fi; \ + fi; \ + fi; exit 0 # break command into two pieces + @dir=`echo $@ | sed -e 's/configure-target-//'`; \ + if [ ! -d $(TARGET_SUBDIR) ]; then \ + true; \ + elif [ -f $(TARGET_SUBDIR)/$${dir}/Makefile ] ; then \ + true; \ + elif echo " $(TARGET_CONFIGDIRS) " | grep " $${dir} " >/dev/null 2>&1; then \ + if [ -d $(srcdir)/$${dir} ]; then \ + [ -d $(TARGET_SUBDIR)/$${dir} ] || mkdir $(TARGET_SUBDIR)/$${dir};\ + r=`pwd`; export r; \ + s=`cd $(srcdir); pwd`; export s; \ + $(SET_LIB_PATH) \ + AR="$(AR_FOR_TARGET)"; export AR; \ + AS="$(AS_FOR_TARGET)"; export AS; \ + CC="$(CC_FOR_TARGET)"; export CC; \ + CFLAGS="$(CFLAGS_FOR_TARGET)"; export CFLAGS; \ + CXX="$(CXX_FOR_TARGET)"; export CXX; \ + CXXFLAGS="$(CXXFLAGS_FOR_TARGET)"; export CXXFLAGS; \ + DLLTOOL="$(DLLTOOL_FOR_TARGET)"; export DLLTOOL; \ + LD="$(LD_FOR_TARGET)"; export LD; \ + LDFLAGS="$(LDFLAGS_FOR_TARGET)"; export LDFLAGS; \ + NM="$(NM_FOR_TARGET)"; export NM; \ + RANLIB="$(RANLIB_FOR_TARGET)"; export RANLIB; \ + WINDRES="$(WINDRES_FOR_TARGET)"; export WINDRES; \ + echo Configuring in $(TARGET_SUBDIR)/$${dir}; \ + cd $(TARGET_SUBDIR)/$${dir}; \ + case $(srcdir) in \ + /*) \ + topdir=$(srcdir) ;; \ + *) \ + case "$(TARGET_SUBDIR)" in \ + .) topdir="../$(srcdir)" ;; \ + *) topdir="../../$(srcdir)" ;; \ + esac ;; \ + esac; \ + if [ "$(srcdir)" = "." ] ; then \ + if [ "$(TARGET_SUBDIR)" != "." ] ; then \ + if $(SHELL) $$s/symlink-tree $${topdir}/$${dir} "no-such-file" ; then \ + if [ -f Makefile ]; then \ + if $(MAKE) distclean; then \ + true; \ + else \ + exit 1; \ + fi; \ + else \ + true; \ + fi; \ + else \ + exit 1; \ + fi; \ + else \ + true; \ + fi; \ + srcdiroption="--srcdir=."; \ + libsrcdir="."; \ + else \ + srcdiroption="--srcdir=$${topdir}/$${dir}"; \ + libsrcdir="$$s/$${dir}"; \ + fi; \ + if [ -f $${libsrcdir}/configure ] ; then \ + $(SHELL) $${libsrcdir}/configure \ + $(CONFIG_ARGUMENTS) $${srcdiroption} \ + --with-target-subdir="$(TARGET_SUBDIR)"; \ + else \ + $(SHELL) $$s/configure \ + $(CONFIG_ARGUMENTS) $${srcdiroption} \ + --with-target-subdir="$(TARGET_SUBDIR)"; \ + fi; \ + else \ + true; \ + fi; \ + else \ + true; \ + fi + +# This rule is used to build the modules which use TARGET_FLAGS_TO_PASS. +# To build a target all-X means to cd to X and make all. +.PHONY: $(ALL_TARGET_MODULES) +$(ALL_TARGET_MODULES): + @dir=`echo $@ | sed -e 's/all-target-//'`; \ + if [ -f $(TARGET_SUBDIR)/$${dir}/Makefile ] ; then \ + r=`pwd`; export r; \ + s=`cd $(srcdir); pwd`; export s; \ + $(SET_LIB_PATH) \ + (cd $(TARGET_SUBDIR)/$${dir}; $(MAKE) $(TARGET_FLAGS_TO_PASS) all); \ + else \ + true; \ + fi + +# This rule is used to check the modules which use TARGET_FLAGS_TO_PASS. +# To build a target install-X means to cd to X and make install. +.PHONY: $(CHECK_TARGET_MODULES) +$(CHECK_TARGET_MODULES): + @dir=`echo $@ | sed -e 's/check-target-//'`; \ + if [ -f $(TARGET_SUBDIR)/$${dir}/Makefile ] ; then \ + r=`pwd`; export r; \ + s=`cd $(srcdir); pwd`; export s; \ + $(SET_LIB_PATH) \ + (cd $(TARGET_SUBDIR)/$${dir};$(MAKE) $(TARGET_FLAGS_TO_PASS) check);\ + else \ + true; \ + fi + +# This rule is used to install the modules which use +# TARGET_FLAGS_TO_PASS. To build a target install-X means to cd to X +# and make install. +.PHONY: $(INSTALL_TARGET_MODULES) +$(INSTALL_TARGET_MODULES): installdirs + @dir=`echo $@ | sed -e 's/install-target-//'`; \ + if [ -f $(TARGET_SUBDIR)/$${dir}/Makefile ] ; then \ + r=`pwd`; export r; \ + s=`cd $(srcdir); pwd`; export s; \ + $(SET_LIB_PATH) \ + (cd $(TARGET_SUBDIR)/$${dir}; \ + $(MAKE) $(TARGET_FLAGS_TO_PASS) install); \ + else \ + true; \ + fi + +# This rule is used to build the modules which use X11_FLAGS_TO_PASS. +# To build a target all-X means to cd to X and make all. +.PHONY: $(ALL_X11_MODULES) +$(ALL_X11_MODULES): + @dir=`echo $@ | sed -e 's/all-//'`; \ + if [ -f ./$${dir}/Makefile ] ; then \ + r=`pwd`; export r; \ + s=`cd $(srcdir); pwd`; export s; \ + $(SET_LIB_PATH) \ + (cd $${dir}; \ + $(MAKE) $(FLAGS_TO_PASS) $(X11_FLAGS_TO_PASS) all); \ + else \ + true; \ + fi + +# This rule is used to check the modules which use X11_FLAGS_TO_PASS. +# To build a target check-X means to cd to X and make all. +.PHONY: $(CHECK_X11_MODULES) +$(CHECK_X11_MODULES): + @dir=`echo $@ | sed -e 's/check-//'`; \ + if [ -f ./$${dir}/Makefile ] ; then \ + r=`pwd`; export r; \ + s=`cd $(srcdir); pwd`; export s; \ + $(SET_LIB_PATH) \ + (cd $${dir}; \ + $(MAKE) $(FLAGS_TO_PASS) $(X11_FLAGS_TO_PASS) check); \ + else \ + true; \ + fi + +# This rule is used to install the modules which use X11_FLAGS_TO_PASS. +# To build a target install-X means to cd to X and make install. +.PHONY: $(INSTALL_X11_MODULES) +$(INSTALL_X11_MODULES): installdirs + @dir=`echo $@ | sed -e 's/install-//'`; \ + if [ -f ./$${dir}/Makefile ] ; then \ + r=`pwd`; export r; \ + s=`cd $(srcdir); pwd`; export s; \ + $(SET_LIB_PATH) \ + (cd $${dir}; \ + $(MAKE) $(FLAGS_TO_PASS) $(X11_FLAGS_TO_PASS) install); \ + else \ + true; \ + fi + +# gcc is the only module which uses GCC_FLAGS_TO_PASS. +.PHONY: all-gcc +all-gcc: + @if [ -f ./gcc/Makefile ] ; then \ + r=`pwd`; export r; \ + s=`cd $(srcdir); pwd`; export s; \ + $(SET_LIB_PATH) \ + (cd gcc; $(MAKE) $(GCC_FLAGS_TO_PASS) all); \ + else \ + true; \ + fi + +.PHONY: all-bootstrap +all-bootstrap: + @if [ -f ./gcc/Makefile ] ; then \ + r=`pwd`; export r; \ + s=`cd $(srcdir); pwd`; export s; \ + $(SET_LIB_PATH) \ + (cd gcc; $(MAKE) $(GCC_FLAGS_TO_PASS) bootstrap); \ + else \ + true; \ + fi + +.PHONY: check-gcc +check-gcc: + @if [ -f ./gcc/Makefile ] ; then \ + r=`pwd`; export r; \ + s=`cd $(srcdir); pwd`; export s; \ + $(SET_LIB_PATH) \ + (cd gcc; $(MAKE) $(GCC_FLAGS_TO_PASS) check); \ + else \ + true; \ + fi + +.PHONY: install-gcc +install-gcc: + @if [ -f ./gcc/Makefile ] ; then \ + r=`pwd`; export r; \ + s=`cd $(srcdir); pwd`; export s; \ + $(SET_LIB_PATH) \ + (cd gcc; $(MAKE) $(GCC_FLAGS_TO_PASS) install); \ + else \ + true; \ + fi + + +# EXPERIMENTAL STUFF +# This rule is used to install the modules which use FLAGS_TO_PASS. +# To build a target install-X means to cd to X and make install. +.PHONY: install-dosrel +install-dosrel: installdirs info + @dir=`echo $@ | sed -e 's/install-//'`; \ + if [ -f ./$${dir}/Makefile ] ; then \ + r=`pwd`; export r; \ + s=`cd $(srcdir); pwd`; export s; \ + $(SET_LIB_PATH) \ + (cd $${dir}; $(MAKE) $(FLAGS_TO_PASS) install); \ + else \ + true; \ + fi + +install-dosrel-fake: + + +# This is a list of inter-dependencies among modules. +all-apache: +all-autoconf: all-m4 all-texinfo +all-automake: +all-bash: +all-bfd: +all-binutils: all-libiberty all-opcodes all-bfd all-flex all-bison all-byacc +all-bison: all-texinfo +all-byacc: +all-cvs: +all-db: +all-dejagnu: all-tcl all-expect all-tk +all-diff: all-libiberty +all-emacs: +all-emacs19: all-bison all-byacc +all-etc: +configure-target-examples: $(ALL_GCC) +all-target-examples: configure-target-examples +all-expect: all-tcl all-tk +all-fileutils: all-libiberty +all-findutils: +all-find: +all-flex: all-libiberty all-bison all-byacc +all-gas: all-libiberty all-opcodes all-bfd +all-gash: all-tcl +all-gawk: +ALL_GCC = all-gcc +all-gcc: all-bison all-byacc all-binutils all-gas all-ld +all-bootstrap: all-libiberty all-bison all-byacc all-binutils all-gas all-ld +GDB_TK = all-tk all-tcl all-itcl all-tix +all-gdb: all-libiberty all-opcodes all-bfd all-mmalloc all-readline all-bison all-byacc all-sim $(gdbnlmrequirements) $(GDB_TK) +all-gnuserv: +configure-target-gperf: $(ALL_GCC) +all-target-gperf: configure-target-gperf all-target-libiberty all-target-libg++ +all-gprof: all-libiberty all-bfd all-opcodes +all-grep: all-libiberty +all-grez: all-libiberty all-bfd all-opcodes +all-gui: all-gdb all-libproc all-target-librx +all-guile: +all-gzip: all-libiberty +all-hello: all-libiberty +all-indent: +all-inet: all-tcl all-send-pr all-perl +all-ispell: all-emacs19 +all-itcl: all-tcl all-tk +all-ld: all-libiberty all-bfd all-opcodes all-bison all-byacc all-flex +configure-target-libg++: $(ALL_GCC) configure-target-librx +all-target-libg++: configure-target-libg++ all-gas all-ld all-gcc all-target-libiberty all-target-newlib all-target-libio all-target-librx all-target-libstdc++ +configure-target-libgloss: $(ALL_GCC) +all-target-libgloss: configure-target-libgloss configure-target-newlib +configure-target-libio: $(ALL_GCC) +all-target-libio: configure-target-libio all-gas all-ld all-gcc all-target-libiberty all-target-newlib +all-libiberty: +configure-target-librx: $(ALL_GCC) configure-target-newlib +all-target-librx: configure-target-librx +configure-target-libstdc++: $(ALL_GCC) +all-target-libstdc++: configure-target-libstdc++ all-gas all-ld all-gcc all-target-libiberty all-target-newlib all-target-libio +all-m4: all-libiberty +all-make: all-libiberty +all-mmalloc: +configure-target-newlib: $(ALL_GCC) +all-target-newlib: configure-target-newlib all-binutils all-gas all-gcc +all-opcodes: all-bfd all-libiberty +all-patch: all-libiberty +all-perl: +all-prms: all-libiberty +all-rcs: +all-readline: +all-recode: all-libiberty +all-sed: all-libiberty +all-send-pr: all-prms +all-shellutils: +all-sim: all-libiberty all-bfd all-opcodes +all-sn: all-tcl all-tk all-itcl all-db all-grep +all-tar: all-libiberty +all-tcl: +all-tclX: all-tcl all-tk +all-tk: all-tcl +all-texinfo: all-libiberty +all-textutils: +all-tgas: all-libiberty all-bfd all-opcodes +all-time: +all-tix: all-tcl all-tk +all-wdiff: +all-target-winsup: all-target-newlib all-target-libiberty all-target-librx all-target-libio configure-target-winsup +configure-target-winsup: configure-target-newlib +all-uudecode: all-libiberty +configure-target-libiberty: $(ALL_GCC) +all-target-libiberty: configure-target-libiberty all-gcc all-ld all-target-newlib +all-target: $(ALL_TARGET_MODULES) +install-target: $(INSTALL_TARGET_MODULES) + +### other supporting targets + +MAKEDIRS= \ + $(prefix) \ + $(exec_prefix) +.PHONY: installdirs +installdirs: mkinstalldirs + $(SHELL) $(srcdir)/mkinstalldirs $(MAKEDIRS) + +dir.info: do-install-info + if [ -f $(srcdir)/texinfo/gen-info-dir ] ; then \ + $(srcdir)/texinfo/gen-info-dir $(infodir) $(srcdir)/texinfo/dir.info-template > dir.info.new ; \ + mv -f dir.info.new dir.info ; \ + else true ; \ + fi + +dist: + @echo "Building a full distribution of this tree isn't done" + @echo "via 'make dist'. Check out the etc/ subdirectory" + +etags tags: TAGS + +# Right now this just builds TAGS in each subdirectory. emacs19 has the +# ability to use several tags files at once, so there is probably no need +# to combine them into one big TAGS file (like CVS 1.3 does). We could +# (if we felt like it) have this Makefile write a piece of elisp which +# the user could load to tell emacs19 where all the TAGS files we just +# built are. +TAGS: do-TAGS + +# with the gnu make, this is done automatically. + +Makefile: Makefile.in configure.in $(host_makefile_frag) $(target_makefile_frag) + $(SHELL) ./config.status + +# +# Support for building net releases + +# Files in devo used in any net release. +# ChangeLog omitted because it may refer to files which are not in this +# distribution (perhaps it would be better to include it anyway). +DEVO_SUPPORT= README Makefile.in configure configure.in \ + config.guess config.sub config move-if-change \ + mpw-README mpw-build.in mpw-config.in mpw-configure mpw-install \ + COPYING COPYING.LIB install-sh config-ml.in symlink-tree \ + mkinstalldirs ltconfig ltmain.sh missing ylwrap + +# Files in devo/etc used in any net release. +# ChangeLog omitted because it may refer to files which are not in this +# distribution (perhaps it would be better to include it anyway). +ETC_SUPPORT= Makefile.in configure configure.in standards.texi \ + make-stds.texi standards.info* + +# When you use `make setup-dirs' or `make taz' you should always redefine +# this macro. +SUPPORT_FILES = list-of-support-files-for-tool-in-question + +.PHONY: taz + +taz: $(DEVO_SUPPORT) $(SUPPORT_FILES) \ + texinfo/texinfo.tex texinfo/gpl.texinfo texinfo/lgpl.texinfo + # Take out texinfo from a few places; make simple BISON=bison line. + sed -e '/^all\.normal: /s/\all-texinfo //' \ + -e '/^ install-texinfo /d' \ + tmp + mv -f tmp Makefile.in + # + ./configure sun4 + [ -z "$(CONFIGURE_TARGET_MODULES)" ] \ + || $(MAKE) $(CONFIGURE_TARGET_MODULES) ALL_GCC="" \ + CC_FOR_TARGET="$(CC)" CXX_FOR_TARGET="$(CXX)" + # Make links, and run "make diststuff" or "make info" when needed. + rm -rf proto-toplev ; mkdir proto-toplev + set -e ; dirs="$(TOOL) $(DEVO_SUPPORT) $(SUPPORT_FILES)" ; \ + for d in $$dirs ; do \ + if [ -d $$d ]; then \ + if [ ! -f $$d/Makefile ] ; then true ; \ + elif grep '^diststuff:' $$d/Makefile >/dev/null ; then \ + (cd $$d ; $(MAKE) diststuff ) || exit 1 ; \ + elif grep '^info:' $$d/Makefile >/dev/null ; then \ + (cd $$d ; $(MAKE) info ) || exit 1 ; \ + fi ; \ + if [ -d $$d/proto-$$d.dir ]; then \ + ln -s ../$$d/proto-$$d.dir proto-toplev/$$d ; \ + else \ + ln -s ../$$d proto-toplev/$$d ; \ + fi ; \ + else ln -s ../$$d proto-toplev/$$d ; fi ; \ + done + cd etc ; $(MAKE) info + $(MAKE) distclean + # + mkdir proto-toplev/etc + (cd proto-toplev/etc; \ + for i in $(ETC_SUPPORT); do \ + ln -s ../../etc/$$i . ; \ + done) + # + # Take out texinfo from configurable dirs + rm proto-toplev/configure.in + sed -e '/^host_tools=/s/texinfo //' \ + proto-toplev/configure.in + # + mkdir proto-toplev/texinfo + ln -s ../../texinfo/texinfo.tex proto-toplev/texinfo/ + ln -s ../../texinfo/gpl.texinfo proto-toplev/texinfo/ + ln -s ../../texinfo/lgpl.texinfo proto-toplev/texinfo/ + if test -r texinfo/util/tex3patch ; then \ + mkdir proto-toplev/texinfo/util && \ + ln -s ../../../texinfo/util/tex3patch proto-toplev/texinfo/util ; \ + else true; fi + chmod og=u `find . -print` + if grep AM_INIT_AUTOMAKE $(TOOL)/configure.in >/dev/null 2>&1; then \ + ver=`sed < $(TOOL)/configure.in -n 's/AM_INIT_AUTOMAKE[^,]*, *\([^)]*\))/\1/p'`; \ + else \ + ver=`sed <$(TOOL)/Makefile.in -n 's/^VERSION *= *//p'`; \ + fi; \ + $(MAKE) -f Makefile.in do-tar-gz TOOL=$(TOOL) VER=$$ver + +do-tar-gz: + echo "==> Making $(TOOL)-$(VER).tar.gz" + -rm -f $(TOOL)-$(VER) + ln -s proto-toplev $(TOOL)-$(VER) + tar cfh $(TOOL)-$(VER).tar $(TOOL)-$(VER) + $(GZIPPROG) -v -9 $(TOOL)-$(VER).tar + +TEXINFO_SUPPORT= texinfo/texinfo.tex texinfo/gpl.texinfo texinfo/lgpl.texinfo +DIST_SUPPORT= $(DEVO_SUPPORT) $(TEXINFO_SUPPORT) + +.PHONY: gas.tar.gz +GAS_SUPPORT_DIRS= bfd include libiberty opcodes setup.com makefile.vms +gas.tar.gz: $(DIST_SUPPORT) $(GAS_SUPPORT_DIRS) gas + $(MAKE) -f Makefile.in taz TOOL=gas \ + SUPPORT_FILES="$(GAS_SUPPORT_DIRS)" + +# The FSF "binutils" release includes gprof and ld. +.PHONY: binutils.tar.gz +BINUTILS_SUPPORT_DIRS= bfd gas include libiberty opcodes ld gprof setup.com makefile.vms +binutils.tar.gz: $(DIST_SUPPORT) $(BINUTILS_SUPPORT_DIRS) binutils + $(MAKE) -f Makefile.in taz TOOL=binutils \ + SUPPORT_FILES="$(BINUTILS_SUPPORT_DIRS) makeall.bat configure.bat" + +.PHONY: gas+binutils.tar.gz +GASB_SUPPORT_DIRS= $(GAS_SUPPORT_DIRS) binutils ld gprof +gas+binutils.tar.gz: $(DIST_SUPPORT) $(GASB_SUPPORT_DIRS) gas + $(MAKE) -f Makefile.in taz TOOL=gas \ + SUPPORT_FILES="$(GASB_SUPPORT_DIRS) makeall.bat configure.bat" + +.PHONY: libg++.tar.gz +LIBGXX_SUPPORT_DIRS=include libstdc++ libio librx libiberty +libg++.tar.gz: $(DIST_SUPPORT) libg++ + $(MAKE) -f Makefile.in taz TOOL=libg++ \ + SUPPORT_FILES="$(LIBGXX_SUPPORT_DIRS)" + +GNATS_SUPPORT_DIRS=include libiberty send-pr +gnats.tar.gz: $(DIST_SUPPORT) $(GNATS_SUPPORT_DIRS) gnats + $(MAKE) -f Makefile.in taz TOOL=gnats \ + SUPPORT_FILES="$(GNATS_SUPPORT_DIRS)" + +.PHONY: gdb.tar.gz +GDB_SUPPORT_DIRS= bfd include libiberty mmalloc opcodes readline sim utils +GDBTK_SUPPORT_DIRS= `if [ -d tcl -a -d tk ] ; then echo tcl tk ; fi` +gdb.tar.gz: $(DIST_SUPPORT) $(GDB_SUPPORT_DIRS) gdb + $(MAKE) -f Makefile.in taz TOOL=gdb \ + SUPPORT_FILES="$(GDB_SUPPORT_DIRS) $(GDBTK_SUPPORT_DIRS)" + +.PHONY: newlib.tar.gz +NEWLIB_SUPPORT_DIRS=libgloss +# taz configures for the sun4 target which won't configure newlib. +# We need newlib configured so that the .info files are made. +# Unfortunately, it is not enough to just configure newlib separately: +# taz will build the .info files but since SUBDIRS won't contain newlib, +# distclean won't be run (leaving Makefile, config.status, and the tmp files +# used in building the .info files, eg: *.def, *.ref). +# The problem isn't solvable however without a lot of extra work because +# target libraries are built in subdir $(target_alias) which gets nuked during +# the make distclean. For now punt on the issue of shipping newlib info files +# with newlib net releases and wait for a day when some native target (sun4?) +# supports newlib (if only minimally). +newlib.tar.gz: $(DIST_SUPPORT) $(NEWLIB_SUPPORT_DIRS) newlib + $(MAKE) -f Makefile.in taz TOOL=newlib \ + SUPPORT_FILES="$(NEWLIB_SUPPORT_DIRS)" \ + DEVO_SUPPORT="$(DEVO_SUPPORT) COPYING.NEWLIB" newlib + +.NOEXPORT: +MAKEOVERRIDES= + + +# end of Makefile.in diff --git a/README b/README new file mode 100644 index 00000000000..eb0e436d860 --- /dev/null +++ b/README @@ -0,0 +1,47 @@ + README for GNU development tools + +This directory contains various GNU compilers, assemblers, linkers, +debuggers, etc., plus their support routines, definitions, and documentation. + +If you are receiving this as part of a GDB release, see the file gdb/README. +If with a binutils release, see binutils/README; if with a libg++ release, +see libg++/README, etc. That'll give you info about this +package -- supported targets, how to use it, how to report bugs, etc. + +It is now possible to automatically configure and build a variety of +tools with one command. To build all of the tools contained herein, +run the ``configure'' script here, e.g.: + + ./configure + make + +To install them (by default in /usr/local/bin, /usr/local/lib, etc), +then do: + make install + +(If the configure script can't determine your type of computer, give it +the name as an argument, for instance ``./configure sun4''. You can +use the script ``config.sub'' to test whether a name is recognized; if +it is, config.sub translates it to a triplet specifying CPU, vendor, +and OS.) + +If you have more than one compiler on your system, it is often best to +explicitly set CC in the environment before running configure, and to +also set CC when running make. For example (assuming sh/bash/ksh): + + CC=gcc ./configure + make + +A similar example using csh: + + setenv CC gcc + ./configure + make + +Much of the code and documentation enclosed is copyright by +the Free Software Foundation, Inc. See the file COPYING or +COPYING.LIB in the various directories, for a description of the +GNU General Public License terms under which you can copy the files. + +REPORTING BUGS: Again, see gdb/README, binutils/README, etc., for info +on where and how to report problems. diff --git a/config-ml.in b/config-ml.in new file mode 100644 index 00000000000..57613d90d7e --- /dev/null +++ b/config-ml.in @@ -0,0 +1,612 @@ +# Configure fragment invoked in the post-target section for subdirs +# wanting multilib support. +# +# It is advisable to support a few --enable/--disable options to let the +# user select which libraries s/he really wants. +# +# Subdirectories wishing to use multilib should put the following lines +# in the "post-target" section of configure.in. +# +# if [ "${srcdir}" = "." ] ; then +# if [ "${with_target_subdir}" != "." ] ; then +# . ${with_multisrctop}../../config-ml.in +# else +# . ${with_multisrctop}../config-ml.in +# fi +# else +# . ${srcdir}/../config-ml.in +# fi +# +# See librx/configure.in in the libg++ distribution for an example of how +# to handle autoconf'd libraries. +# +# Things are complicated because 6 separate cases must be handled: +# 2 (native, cross) x 3 (absolute-path, relative-not-dot, dot) = 6. +# +# srcdir=. is special. It must handle make programs that don't handle VPATH. +# To implement this, a symlink tree is built for each library and for each +# multilib subdir. +# +# The build tree is layed out as +# +# ./ +# libg++ +# newlib +# m68020/ +# libg++ +# newlib +# m68881/ +# libg++ +# newlib +# +# The nice feature about this arrangement is that inter-library references +# in the build tree work without having to care where you are. Note that +# inter-library references also work in the source tree because symlink trees +# are built when srcdir=. +# +# Unfortunately, trying to access the libraries in the build tree requires +# the user to manually choose which library to use as GCC won't be able to +# find the right one. This is viewed as the lesser of two evils. +# +# Configure variables: +# ${with_target_subdir} = "." for native, or ${target_alias} for cross. +# Set by top level Makefile. +# ${with_multisrctop} = how many levels of multilibs there are in the source +# tree. It exists to handle the case of configuring in the source tree: +# ${srcdir} is not constant. +# ${with_multisubdir} = name of multilib subdirectory (eg: m68020/m68881). +# +# Makefile variables: +# MULTISRCTOP = number of multilib levels in source tree (+1 if cross) +# (FIXME: note that this is different than ${with_multisrctop}. Check out.). +# MULTIBUILDTOP = number of multilib levels in build tree +# MULTIDIRS = list of multilib subdirs (eg: m68000 m68020 ...) +# (only defined in each library's main Makefile). +# MULTISUBDIR = installed subdirectory name with leading '/' (eg: /m68000) +# (only defined in each multilib subdir). + +# FIXME: Multilib is currently disabled by default for everything other than +# newlib. It is up to each target to turn on multilib support for the other +# libraries as desired. + +# We have to handle being invoked by both Cygnus configure and Autoconf. +# +# Cygnus configure incoming variables: +# srcdir, subdir, target, arguments +# +# Autoconf incoming variables: +# srcdir, target, ac_configure_args +# +# We *could* figure srcdir and target out, but we'd have to do work that +# our caller has already done to figure them out and requiring these two +# seems reasonable. + +if [ -n "${ac_configure_args}" ]; then + Makefile=${ac_file-Makefile} + ml_config_shell=${CONFIG_SHELL-/bin/sh} + ml_arguments="${ac_configure_args}" + ml_realsrcdir=${srcdir} +else + Makefile=${Makefile-Makefile} + ml_config_shell=${config_shell-/bin/sh} + ml_arguments="${arguments}" + if [ -n "${subdir}" -a "${subdir}" != "." ] ; then + ml_realsrcdir=${srcdir}/${subdir} + else + ml_realsrcdir=${srcdir} + fi +fi + +# Scan all the arguments and set all the ones we need. + +for option in ${ml_arguments} +do + case $option in + --*) ;; + -*) option=-$option ;; + esac + + case $option in + --*=*) + optarg=`echo $option | sed -e 's/^[^=]*=//'` + ;; + esac + + case $option in + --disable-*) + enableopt=`echo ${option} | sed 's:^--disable-:enable_:;s:-:_:g'` + eval $enableopt=no + ;; + --enable-*) + case "$option" in + *=*) ;; + *) optarg=yes ;; + esac + enableopt=`echo ${option} | sed 's:^--::;s:=.*$::;s:-:_:g'` + eval $enableopt="$optarg" + ;; + --norecursion | --no*) + ml_norecursion=yes + ;; + --verbose | --v | --verb*) + ml_verbose=--verbose + ;; + --with-*) + case "$option" in + *=*) ;; + *) optarg=yes ;; + esac + withopt=`echo ${option} | sed 's:^--::;s:=.*$::;s:-:_:g'` + eval $withopt="$optarg" + ;; + --without-*) + withopt=`echo ${option} | sed 's:^--::;s:out::;s:-:_:g'` + eval $withopt=no + ;; + esac +done + +# Only do this if --enable-multilib. +if [ "${enable_multilib}" = yes ]; then + +# Compute whether this is the library's top level directory +# (ie: not a multilib subdirectory, and not a subdirectory like libg++/src). +# ${with_multisubdir} tells us we're in the right branch, but we could be +# in a subdir of that. +# ??? The previous version could void this test by separating the process into +# two files: one that only the library's toplevel configure.in ran (to +# configure the multilib subdirs), and another that all configure.in's ran to +# update the Makefile. It seemed reasonable to collapse all multilib support +# into one file, but it does leave us with having to perform this test. +ml_toplevel_p=no +if [ -z "${with_multisubdir}" ]; then + if [ "${srcdir}" = "." ]; then + # Use ${ml_realsrcdir} instead of ${srcdir} here to account for ${subdir}. + # ${with_target_subdir} = "." for native, otherwise target alias. + if [ "${with_target_subdir}" = "." ]; then + if [ -f ${ml_realsrcdir}/../config-ml.in ]; then + ml_toplevel_p=yes + fi + else + if [ -f ${ml_realsrcdir}/../../config-ml.in ]; then + ml_toplevel_p=yes + fi + fi + else + # Use ${ml_realsrcdir} instead of ${srcdir} here to account for ${subdir}. + if [ -f ${ml_realsrcdir}/../config-ml.in ]; then + ml_toplevel_p=yes + fi + fi +fi + +# If this is the library's top level directory, set multidirs to the +# multilib subdirs to support. This lives at the top because we need +# `multidirs' set right away. + +if [ "${ml_toplevel_p}" = yes ]; then + +multidirs= +for i in `${CC-gcc} --print-multi-lib 2>/dev/null`; do + dir=`echo $i | sed -e 's/;.*$//'` + if [ "${dir}" = "." ]; then + true + else + if [ -z "${multidirs}" ]; then + multidirs="${dir}" + else + multidirs="${multidirs} ${dir}" + fi + fi +done + +case "${target}" in +arc-*-elf*) + if [ x$enable_biendian != xyes ] + then + old_multidirs=${multidirs} + multidirs="" + for x in ${old_multidirs}; do + case "${x}" in + *be*) : ;; + *) multidirs="${multidirs} ${x}" ;; + esac + done + fi + ;; +m68*-*-*) + if [ x$enable_softfloat = xno ] + then + old_multidirs="${multidirs}" + multidirs="" + for x in ${old_multidirs}; do + case "$x" in + *soft-float* ) : ;; + *) multidirs="${multidirs} ${x}" ;; + esac + done + fi + if [ x$enable_m68881 = xno ] + then + old_multidirs="${multidirs}" + multidirs="" + for x in ${old_multidirs}; do + case "$x" in + *m68881* ) : ;; + *) multidirs="${multidirs} ${x}" ;; + esac + done + fi + if [ x$enable_m68000 = xno ] + then + old_multidirs="${multidirs}" + multidirs="" + for x in ${old_multidirs}; do + case "$x" in + *m68000* ) : ;; + *) multidirs="${multidirs} ${x}" ;; + esac + done + fi + if [ x$enable_m68020 = xno ] + then + old_multidirs="${multidirs}" + multidirs="" + for x in ${old_multidirs}; do + case "$x" in + *m68020* ) : ;; + *) multidirs="${multidirs} ${x}" ;; + esac + done + fi + ;; +mips*-*-*) + if [ x$enable_single_float = xno ] + then + old_multidirs="${multidirs}" + multidirs="" + for x in ${old_multidirs}; do + case "$x" in + *single* ) : ;; + *) multidirs="${multidirs} ${x}" ;; + esac + done + fi + if [ x$enable_biendian = xno ] + then + old_multidirs="${multidirs}" + multidirs="" + for x in ${old_multidirs}; do + case "$x" in + *el* ) : ;; + *eb* ) : ;; + *) multidirs="${multidirs} ${x}" ;; + esac + done + fi + if [ x$enable_softfloat = xno ] + then + old_multidirs="${multidirs}" + multidirs="" + for x in ${old_multidirs}; do + case "$x" in + *soft-float* ) : ;; + *) multidirs="${multidirs} ${x}" ;; + esac + done + fi + ;; +powerpc*-*-* | rs6000*-*-*) + if [ x$enable_softfloat = xno ] + then + old_multidirs="${multidirs}" + multidirs="" + for x in ${old_multidirs}; do + case "$x" in + *soft-float* ) : ;; + *) multidirs="${multidirs} ${x}" ;; + esac + done + fi + if [ x$enable_powercpu = xno ] + then + old_multidirs="${multidirs}" + multidirs="" + for x in ${old_multidirs}; do + case "$x" in + power | */power | */power/* ) : ;; + *) multidirs="${multidirs} ${x}" ;; + esac + done + fi + if [ x$enable_powerpccpu = xno ] + then + old_multidirs="${multidirs}" + multidirs="" + for x in ${old_multidirs}; do + case "$x" in + *powerpc* ) : ;; + *) multidirs="${multidirs} ${x}" ;; + esac + done + fi + if [ x$enable_powerpcos = xno ] + then + old_multidirs="${multidirs}" + multidirs="" + for x in ${old_multidirs}; do + case "$x" in + *mcall-linux* | *mcall-solaris* ) : ;; + *) multidirs="${multidirs} ${x}" ;; + esac + done + fi + if [ x$enable_biendian = xno ] + then + old_multidirs="${multidirs}" + multidirs="" + for x in ${old_multidirs}; do + case "$x" in + *mlittle* | *mbig* ) : ;; + *) multidirs="${multidirs} ${x}" ;; + esac + done + fi + if [ x$enable_sysv = xno ] + then + old_multidirs="${multidirs}" + multidirs="" + for x in ${old_multidirs}; do + case "$x" in + *mcall-sysv* ) : ;; + *) multidirs="${multidirs} ${x}" ;; + esac + done + fi + if [ x$enable_aix = xno ] + then + old_multidirs="${multidirs}" + multidirs="" + for x in ${old_multidirs}; do + case "$x" in + *mcall-aix* ) : ;; + *) multidirs="${multidirs} ${x}" ;; + esac + done + fi + ;; +esac + +# Remove extraneous blanks from multidirs. +# Tests like `if [ -n "$multidirs" ]' require it. +multidirs=`echo "$multidirs" | sed -e 's/^[ ][ ]*//' -e 's/[ ][ ]*$//' -e 's/[ ][ ]*/ /g'` + +# Add code to library's top level makefile to handle building the multilib +# subdirs. + +cat > Multi.tem <<\EOF + +# FIXME: There should be an @-sign in front of the `if'. +# Leave out until this is tested a bit more. +multi-do: + if [ -z "$(MULTIDIRS)" ]; then \ + true; \ + else \ + rootpre=`pwd`/; export rootpre; \ + srcrootpre=`cd $(srcdir); pwd`/; export srcrootpre; \ + lib=`echo $${rootpre} | sed -e 's,^.*/\([^/][^/]*\)/$$,\1,'`; \ + compiler="$(CC)"; \ + for i in `$${compiler} --print-multi-lib 2>/dev/null`; do \ + dir=`echo $$i | sed -e 's/;.*$$//'`; \ + if [ "$${dir}" = "." ]; then \ + true; \ + else \ + if [ -d ../$${dir}/$${lib} ]; then \ + flags=`echo $$i | sed -e 's/^[^;]*;//' -e 's/@/ -/g'`; \ + if (cd ../$${dir}/$${lib}; $(MAKE) $(FLAGS_TO_PASS) \ + CFLAGS="$(CFLAGS) $${flags}" \ + CXXFLAGS="$(CXXFLAGS) $${flags}" \ + LIBCFLAGS="$(LIBCFLAGS) $${flags}" \ + LIBCXXFLAGS="$(LIBCXXFLAGS) $${flags}" \ + $(DO)); then \ + true; \ + else \ + exit 1; \ + fi; \ + else true; \ + fi; \ + fi; \ + done; \ + fi + +# FIXME: There should be an @-sign in front of the `if'. +# Leave out until this is tested a bit more. +multi-clean: + if [ -z "$(MULTIDIRS)" ]; then \ + true; \ + else \ + lib=`pwd | sed -e 's,^.*/\([^/][^/]*\)$$,\1,'`; \ + for dir in Makefile $(MULTIDIRS); do \ + if [ -f ../$${dir}/$${lib}/Makefile ]; then \ + if (cd ../$${dir}/$${lib}; $(MAKE) $(FLAGS_TO_PASS) $(DO)); \ + then true; \ + else exit 1; \ + fi; \ + else true; \ + fi; \ + done; \ + fi +EOF + +cat ${Makefile} Multi.tem > Makefile.tem +rm -f ${Makefile} Multi.tem +mv Makefile.tem ${Makefile} + +fi # ${ml_toplevel_p} = yes + +if [ "${ml_verbose}" = --verbose ]; then + echo "Adding multilib support to Makefile in ${ml_realsrcdir}" + if [ "${ml_toplevel_p}" = yes ]; then + echo "multidirs=${multidirs}" + fi + echo "with_multisubdir=${with_multisubdir}" +fi + +if [ "${srcdir}" = "." ]; then + if [ "${with_target_subdir}" != "." ]; then + ml_srcdotdot="../" + else + ml_srcdotdot="" + fi +else + ml_srcdotdot="" +fi + +if [ -z "${with_multisubdir}" ]; then + ml_subdir= + ml_builddotdot= + : # ml_srcdotdot= # already set +else + ml_subdir="/${with_multisubdir}" + # The '[^/][^/]*' appears that way to work around a SunOS sed bug. + ml_builddotdot=`echo ${with_multisubdir} | sed -e 's:[^/][^/]*:..:g'`/ + if [ "$srcdir" = "." ]; then + ml_srcdotdot=${ml_srcdotdot}${ml_builddotdot} + else + : # ml_srcdotdot= # already set + fi +fi + +if [ "${ml_toplevel_p}" = yes ]; then + ml_do='$(MAKE)' + ml_clean='$(MAKE)' +else + ml_do=true + ml_clean=true +fi + +# TOP is used by newlib and should not be used elsewhere for this purpose. +# MULTI{SRC,BUILD}TOP are the proper ones to use. MULTISRCTOP is empty +# when srcdir != builddir. MULTIBUILDTOP is always some number of ../'s. +# FIXME: newlib needs to be updated to use MULTI{SRC,BUILD}TOP so we can +# delete TOP. Newlib may wish to continue to use TOP for its own purposes +# of course. +# MULTIDIRS is non-empty for the cpu top level Makefile (eg: newlib/Makefile) +# and lists the subdirectories to recurse into. +# MULTISUBDIR is non-empty in each cpu subdirectory's Makefile +# (eg: newlib/h8300h/Makefile) and is the installed subdirectory name with +# a leading '/'. +# MULTIDO is used for targets like all, install, and check where +# $(FLAGS_TO_PASS) augmented with the subdir's compiler option is needed. +# MULTICLEAN is used for the *clean targets. +# +# ??? It is possible to merge MULTIDO and MULTICLEAN into one. They are +# currently kept separate because we don't want the *clean targets to require +# the existence of the compiler (which MULTIDO currently requires) and +# therefore we'd have to record the directory options as well as names +# (currently we just record the names and use --print-multi-lib to get the +# options). + +sed -e "s:^TOP[ ]*=[ ]*\([./]*\)[ ]*$:TOP = ${ml_builddotdot}\1:" \ + -e "s:^MULTISRCTOP[ ]*=.*$:MULTISRCTOP = ${ml_srcdotdot}:" \ + -e "s:^MULTIBUILDTOP[ ]*=.*$:MULTIBUILDTOP = ${ml_builddotdot}:" \ + -e "s:^MULTIDIRS[ ]*=.*$:MULTIDIRS = ${multidirs}:" \ + -e "s:^MULTISUBDIR[ ]*=.*$:MULTISUBDIR = ${ml_subdir}:" \ + -e "s:^MULTIDO[ ]*=.*$:MULTIDO = $ml_do:" \ + -e "s:^MULTICLEAN[ ]*=.*$:MULTICLEAN = $ml_clean:" \ + ${Makefile} > Makefile.tem +rm -f ${Makefile} +mv Makefile.tem ${Makefile} + +# If this is the library's top level, configure each multilib subdir. +# This is done at the end because this is the loop that runs configure +# in each multilib subdir and it seemed reasonable to finish updating the +# Makefile before going on to configure the subdirs. + +if [ "${ml_toplevel_p}" = yes ]; then + +# We must freshly configure each subdirectory. This bit of code is +# actually partially stolen from the main configure script. FIXME. + +if [ -n "${multidirs}" ] && [ -z "${ml_norecursion}" ]; then + + if [ "${ml_verbose}" = --verbose ]; then + echo "Running configure in multilib subdirs ${multidirs}" + echo "pwd: `pwd`" + fi + + ml_origdir=`pwd` + ml_libdir=`echo $ml_origdir | sed -e 's,^.*/,,'` + # cd to top-level-build-dir/${with_target_subdir} + cd .. + + for ml_dir in ${multidirs}; do + + if [ "${ml_verbose}" = --verbose ]; then + echo "Running configure in multilib subdir ${ml_dir}" + echo "pwd: `pwd`" + fi + + if [ -d ${ml_dir} ]; then true; else mkdir ${ml_dir}; fi + if [ -d ${ml_dir}/${ml_libdir} ]; then true; else mkdir ${ml_dir}/${ml_libdir}; fi + + # Eg: if ${ml_dir} = m68000/m68881, dotdot = ../../ + dotdot=../`echo ${ml_dir} | sed -e 's|[^/]||g' -e 's|/|../|g'` + + case ${srcdir} in + ".") + echo Building symlink tree in `pwd`/${ml_dir}/${ml_libdir} + if [ "${with_target_subdir}" != "." ]; then + ml_unsubdir="../" + else + ml_unsubdir="" + fi + (cd ${ml_dir}/${ml_libdir}; + ../${dotdot}${ml_unsubdir}symlink-tree ../${dotdot}${ml_unsubdir}${ml_libdir} "") + ml_newsrcdir="." + ml_srcdiroption= + multisrctop=${dotdot} + ;; + *) + case "${srcdir}" in + /*) # absolute path + ml_newsrcdir=${srcdir} + ;; + *) # otherwise relative + ml_newsrcdir=${dotdot}${srcdir} + ;; + esac + ml_srcdiroption="-srcdir=${ml_newsrcdir}" + multisrctop= + ;; + esac + + case "${progname}" in + /*) ml_recprog=${progname} ;; + *) ml_recprog=${dotdot}${progname} ;; + esac + + # FIXME: POPDIR=${PWD=`pwd`} doesn't work here. + ML_POPDIR=`pwd` + cd ${ml_dir}/${ml_libdir} + + if [ -f ${ml_newsrcdir}/configure ]; then + ml_recprog=${ml_newsrcdir}/configure + fi + if eval ${ml_config_shell} ${ml_recprog} \ + --with-multisubdir=${ml_dir} --with-multisrctop=${multisrctop} \ + ${ml_arguments} ${ml_srcdiroption} ; then + true + else + exit 1 + fi + + cd ${ML_POPDIR} + + done + + cd ${ml_origdir} +fi + +fi # ${ml_toplevel_p} = yes +fi # ${enable_multilib} = yes diff --git a/config.guess b/config.guess new file mode 100755 index 00000000000..a73a8d93c0c --- /dev/null +++ b/config.guess @@ -0,0 +1,833 @@ +#! /bin/sh +# Attempt to guess a canonical system name. +# Copyright (C) 1992, 93, 94, 95, 96, 1997 Free Software Foundation, Inc. +# +# This file 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. +# +# As a special exception to the GNU General Public License, if you +# distribute this file as part of a program that contains a +# configuration script generated by Autoconf, you may include it under +# the same distribution terms that you use for the rest of that program. + +# Written by Per Bothner . +# The master version of this file is at the FSF in /home/gd/gnu/lib. +# +# This script attempts to guess a canonical system name similar to +# config.sub. If it succeeds, it prints the system name on stdout, and +# exits with 0. Otherwise, it exits with 1. +# +# The plan is that this can be called by configure scripts if you +# don't specify an explicit system type (host/target name). +# +# Only a few systems have been added to this list; please add others +# (but try to keep the structure clean). +# + +# This is needed to find uname on a Pyramid OSx when run in the BSD universe. +# (ghazi@noc.rutgers.edu 8/24/94.) +if (test -f /.attbin/uname) >/dev/null 2>&1 ; then + PATH=$PATH:/.attbin ; export PATH +fi + +UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown +UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown +UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown +UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown + +trap 'rm -f dummy.c dummy.o dummy; exit 1' 1 2 15 + +# Note: order is significant - the case branches are not exclusive. + +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. + cat <dummy.s + .globl main + .ent main +main: + .frame \$30,0,\$26,0 + .prologue 0 + .long 0x47e03d84 + cmoveq \$4,0,\$3 + addl \$3,\$31,\$0 + ret \$31,(\$26),1 + .end main +EOF + ${CC-cc} dummy.s -o dummy 2>/dev/null + if test "$?" = 0 ; then + ./dummy + case "$?" in + 1) + UNAME_MACHINE="alphaev5" + ;; + 2) + UNAME_MACHINE="alphaev56" + ;; + esac + fi + rm -f dummy.s dummy + echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[VTX]//'` + exit 0 ;; + 21064:Windows_NT:50:3) + echo alpha-dec-winnt3.5 + exit 0 ;; + Amiga*:UNIX_System_V:4.0:*) + echo m68k-cbm-sysv4 + exit 0;; + amiga:NetBSD:*:*) + echo m68k-cbm-netbsd${UNAME_RELEASE} + exit 0 ;; + amiga:OpenBSD:*:*) + echo m68k-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + arc64:OpenBSD:*:*) + echo mips64el-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + arc:OpenBSD:*:*) + echo mipsel-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + hkmips:OpenBSD:*:*) + echo mips-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + pmax:OpenBSD:*:*) + echo mipsel-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + sgi:OpenBSD:*:*) + echo mips-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + wgrisc:OpenBSD:*:*) + echo mipsel-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*) + echo arm-acorn-riscix${UNAME_RELEASE} + exit 0;; + arm32:NetBSD:*:*) + echo arm-unknown-netbsd`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'` + exit 0 ;; + SR2?01:HI-UX/MPP:*:*) + echo hppa1.1-hitachi-hiuxmpp + exit 0;; + Pyramid*:OSx*:*:*|MIS*:OSx*:*:*) + # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE. + if test "`(/bin/universe) 2>/dev/null`" = att ; then + echo pyramid-pyramid-sysv3 + else + echo pyramid-pyramid-bsd + fi + exit 0 ;; + NILE:*:*:dcosx) + echo pyramid-pyramid-svr4 + exit 0 ;; + sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*) + echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit 0 ;; + i86pc:SunOS:5.*:*) + echo i386-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit 0 ;; + sun4*:SunOS:6*:*) + # According to config.sub, this is the proper way to canonicalize + # SunOS6. Hard to guess exactly what SunOS6 will be like, but + # it's likely to be more like Solaris than SunOS4. + echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit 0 ;; + sun4*:SunOS:*:*) + case "`/usr/bin/arch -k`" in + Series*|S4*) + UNAME_RELEASE=`uname -v` + ;; + esac + # Japanese Language versions have a version number like `4.1.3-JL'. + echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'` + exit 0 ;; + sun3*:SunOS:*:*) + echo m68k-sun-sunos${UNAME_RELEASE} + exit 0 ;; + aushp:SunOS:*:*) + echo sparc-auspex-sunos${UNAME_RELEASE} + exit 0 ;; + atari*:NetBSD:*:*) + echo m68k-atari-netbsd${UNAME_RELEASE} + exit 0 ;; + atari*:OpenBSD:*:*) + echo m68k-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + sun3*:NetBSD:*:*) + echo m68k-sun-netbsd${UNAME_RELEASE} + exit 0 ;; + sun3*:OpenBSD:*:*) + echo m68k-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + mac68k:NetBSD:*:*) + echo m68k-apple-netbsd${UNAME_RELEASE} + exit 0 ;; + mac68k:OpenBSD:*:*) + echo m68k-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + mvme68k:OpenBSD:*:*) + echo m68k-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + mvme88k:OpenBSD:*:*) + echo m88k-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + powerpc:machten:*:*) + echo powerpc-apple-machten${UNAME_RELEASE} + exit 0 ;; + RISC*:Mach:*:*) + echo mips-dec-mach_bsd4.3 + exit 0 ;; + RISC*:ULTRIX:*:*) + echo mips-dec-ultrix${UNAME_RELEASE} + exit 0 ;; + VAX*:ULTRIX*:*:*) + echo vax-dec-ultrix${UNAME_RELEASE} + exit 0 ;; + 2020:CLIX:*:*) + echo clipper-intergraph-clix${UNAME_RELEASE} + exit 0 ;; + mips:*:*:UMIPS | mips:*:*:RISCos) + sed 's/^ //' << EOF >dummy.c + int main (argc, argv) int argc; char **argv; { + #if defined (host_mips) && defined (MIPSEB) + #if defined (SYSTYPE_SYSV) + printf ("mips-mips-riscos%ssysv\n", argv[1]); exit (0); + #endif + #if defined (SYSTYPE_SVR4) + printf ("mips-mips-riscos%ssvr4\n", argv[1]); exit (0); + #endif + #if defined (SYSTYPE_BSD43) || defined(SYSTYPE_BSD) + printf ("mips-mips-riscos%sbsd\n", argv[1]); exit (0); + #endif + #endif + exit (-1); + } +EOF + ${CC-cc} dummy.c -o dummy \ + && ./dummy `echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` \ + && rm dummy.c dummy && exit 0 + rm -f dummy.c dummy + echo mips-mips-riscos${UNAME_RELEASE} + exit 0 ;; + Night_Hawk:Power_UNIX:*:*) + echo powerpc-harris-powerunix + exit 0 ;; + m88k:CX/UX:7*:*) + echo m88k-harris-cxux7 + exit 0 ;; + m88k:*:4*:R4*) + echo m88k-motorola-sysv4 + exit 0 ;; + m88k:*:3*:R3*) + echo m88k-motorola-sysv3 + exit 0 ;; + AViiON:dgux:*:*) + # DG/UX returns AViiON for all architectures + UNAME_PROCESSOR=`/usr/bin/uname -p` + if [ $UNAME_PROCESSOR = mc88100 -o $UNAME_PROCESSOR = mc88110 ] ; then + if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx \ + -o ${TARGET_BINARY_INTERFACE}x = x ] ; then + echo m88k-dg-dgux${UNAME_RELEASE} + else + echo m88k-dg-dguxbcs${UNAME_RELEASE} + fi + else echo i586-dg-dgux${UNAME_RELEASE} + fi + exit 0 ;; + M88*:DolphinOS:*:*) # DolphinOS (SVR3) + echo m88k-dolphin-sysv3 + exit 0 ;; + M88*:*:R3*:*) + # Delta 88k system running SVR3 + echo m88k-motorola-sysv3 + exit 0 ;; + XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3) + echo m88k-tektronix-sysv3 + exit 0 ;; + Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD) + echo m68k-tektronix-bsd + exit 0 ;; + *:IRIX*:*:*) + 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 ;; + *:AIX:2:3) + if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then + sed 's/^ //' << EOF >dummy.c + #include + + main() + { + if (!__power_pc()) + exit(1); + puts("powerpc-ibm-aix3.2.5"); + exit(0); + } +EOF + ${CC-cc} dummy.c -o dummy && ./dummy && rm dummy.c dummy && exit 0 + rm -f dummy.c dummy + echo rs6000-ibm-aix3.2.5 + elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then + echo rs6000-ibm-aix3.2.4 + else + echo rs6000-ibm-aix3.2 + fi + exit 0 ;; + *:AIX:*:4) + if /usr/sbin/lsattr -EHl proc0 | grep POWER >/dev/null 2>&1; then + IBM_ARCH=rs6000 + else + IBM_ARCH=powerpc + fi + if [ -x /usr/bin/oslevel ] ; then + IBM_REV=`/usr/bin/oslevel` + else + IBM_REV=4.${UNAME_RELEASE} + fi + echo ${IBM_ARCH}-ibm-aix${IBM_REV} + exit 0 ;; + *:AIX:*:*) + echo rs6000-ibm-aix + exit 0 ;; + ibmrt:4.4BSD:*|romp-ibm:BSD:*) + echo romp-ibm-bsd4.4 + exit 0 ;; + ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC NetBSD and + echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to + exit 0 ;; # report: romp-ibm BSD 4.3 + *:BOSX:*:*) + echo rs6000-bull-bosx + exit 0 ;; + DPX/2?00:B.O.S.:*:*) + echo m68k-bull-sysv3 + exit 0 ;; + 9000/[34]??:4.3bsd:1.*:*) + echo m68k-hp-bsd + exit 0 ;; + hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*) + echo m68k-hp-bsd4.4 + exit 0 ;; + 9000/[3478]??:HP-UX:*:*) + case "${UNAME_MACHINE}" in + 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 + HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` + echo ${HP_ARCH}-hp-hpux${HPUX_REV} + exit 0 ;; + 3050*:HI-UX:*:*) + sed 's/^ //' << EOF >dummy.c + #include + int + main () + { + long cpu = sysconf (_SC_CPU_VERSION); + /* The order matters, because CPU_IS_HP_MC68K erroneously returns + true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct + results, however. */ + if (CPU_IS_PA_RISC (cpu)) + { + switch (cpu) + { + case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break; + case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break; + case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break; + default: puts ("hppa-hitachi-hiuxwe2"); break; + } + } + else if (CPU_IS_HP_MC68K (cpu)) + puts ("m68k-hitachi-hiuxwe2"); + else puts ("unknown-hitachi-hiuxwe2"); + exit (0); + } +EOF + ${CC-cc} dummy.c -o dummy && ./dummy && rm dummy.c dummy && exit 0 + rm -f dummy.c dummy + echo unknown-hitachi-hiuxwe2 + exit 0 ;; + 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* ) + echo hppa1.1-hp-bsd + exit 0 ;; + 9000/8??:4.3bsd:*:*) + echo hppa1.0-hp-bsd + exit 0 ;; + hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* ) + echo hppa1.1-hp-osf + exit 0 ;; + hp8??:OSF1:*:*) + echo hppa1.0-hp-osf + exit 0 ;; + i?86:OSF1:*:*) + if [ -x /usr/sbin/sysversion ] ; then + echo ${UNAME_MACHINE}-unknown-osf1mk + else + echo ${UNAME_MACHINE}-unknown-osf1 + fi + exit 0 ;; + parisc*:Lites*:*:*) + echo hppa1.1-hp-lites + exit 0 ;; + C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*) + echo c1-convex-bsd + exit 0 ;; + C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*) + if getsysinfo -f scalar_acc + then echo c32-convex-bsd + else echo c2-convex-bsd + fi + exit 0 ;; + C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*) + echo c34-convex-bsd + exit 0 ;; + C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*) + echo c38-convex-bsd + exit 0 ;; + C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*) + echo c4-convex-bsd + exit 0 ;; + CRAY*X-MP:*:*:*) + echo xmp-cray-unicos + exit 0 ;; + CRAY*Y-MP:*:*:*) + echo ymp-cray-unicos${UNAME_RELEASE} + exit 0 ;; + CRAY*[A-Z]90:*:*:*) + echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \ + | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \ + -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ + exit 0 ;; + CRAY*TS:*:*:*) + echo t90-cray-unicos${UNAME_RELEASE} + exit 0 ;; + CRAY-2:*:*:*) + echo cray2-cray-unicos + exit 0 ;; + F300:UNIX_System_V:*:*) + FUJITSU_SYS=`uname -p | tr [A-Z] [a-z] | sed -e 's/\///'` + FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'` + echo "f300-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" + exit 0 ;; + F301:UNIX_System_V:*:*) + echo f301-fujitsu-uxpv`echo $UNAME_RELEASE | sed 's/ .*//'` + exit 0 ;; + hp3[0-9][05]:NetBSD:*:*) + echo m68k-hp-netbsd${UNAME_RELEASE} + exit 0 ;; + hp300:OpenBSD:*:*) + echo m68k-unknown-openbsd${UNAME_RELEASE} + exit 0 ;; + i?86:BSD/386:*:* | *:BSD/OS:*:*) + echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE} + exit 0 ;; + *:FreeBSD:*:*) + echo ${UNAME_MACHINE}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` + exit 0 ;; + *:NetBSD:*:*) + echo ${UNAME_MACHINE}-unknown-netbsd`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'` + exit 0 ;; + *:OpenBSD:*:*) + echo ${UNAME_MACHINE}-unknown-openbsd`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'` + exit 0 ;; + i*:CYGWIN*:*) + echo i386-pc-cygwin32 + exit 0 ;; + i*:MINGW*:*) + echo i386-pc-mingw32 + exit 0 ;; + p*:CYGWIN*:*) + echo powerpcle-unknown-cygwin32 + exit 0 ;; + prep*:SunOS:5.*:*) + echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit 0 ;; + *:GNU:*:*) + echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` + exit 0 ;; + *:Linux:*:*) + # The BFD linker knows what the default object file format is, so + # first see if it will tell us. + ld_help_string=`ld --help 2>&1` + ld_supported_emulations=`echo $ld_help_string \ + | sed -ne '/supported emulations:/!d + s/[ ][ ]*/ /g + s/.*supported emulations: *// + s/ .*// + p'` + case "$ld_supported_emulations" in + i?86linux) echo "${UNAME_MACHINE}-pc-linux-gnuaout" ; exit 0 ;; + i?86coff) echo "${UNAME_MACHINE}-pc-linux-gnucoff" ; exit 0 ;; + sparclinux) echo "${UNAME_MACHINE}-unknown-linux-gnuaout" ; exit 0 ;; + m68klinux) echo "${UNAME_MACHINE}-unknown-linux-gnuaout" ; exit 0 ;; + elf32ppc) echo "powerpc-unknown-linux-gnu" ; exit 0 ;; + esac + + if test "${UNAME_MACHINE}" = "alpha" ; then + sed 's/^ //' <dummy.s + .globl main + .ent main + main: + .frame \$30,0,\$26,0 + .prologue 0 + .long 0x47e03d84 + cmoveq \$4,0,\$3 + addl \$3,\$31,\$0 + ret \$31,(\$26),1 + .end main +EOF + ${CC-cc} dummy.s -o dummy 2>/dev/null + if test "$?" = 0 ; then + ./dummy + case "$?" in + 1) + UNAME_MACHINE="alphaev5" + ;; + 2) + UNAME_MACHINE="alphaev56" + ;; + esac + fi + rm -f dummy.s dummy + echo ${UNAME_MACHINE}-unknown-linux-gnu ; exit 0 + elif test "${UNAME_MACHINE}" = "mips" ; then + cat >dummy.c </dev/null && ./dummy "${UNAME_MACHINE}" && rm dummy.c dummy && exit 0 + rm -f dummy.c dummy + else + # Either a pre-BFD a.out linker (linux-gnuoldld) + # or one that does not give us useful --help. + # GCC wants to distinguish between linux-gnuoldld and linux-gnuaout. + # If ld does not provide *any* "supported emulations:" + # that means it is gnuoldld. + echo "$ld_help_string" | grep >/dev/null 2>&1 "supported emulations:" + test $? != 0 && echo "${UNAME_MACHINE}-pc-linux-gnuoldld" && exit 0 + + case "${UNAME_MACHINE}" in + i?86) + VENDOR=pc; + ;; + *) + VENDOR=unknown; + ;; + esac + # Determine whether the default compiler is a.out or elf + cat >dummy.c < +main(argc, argv) + int argc; + char *argv[]; +{ +#ifdef __ELF__ +# ifdef __GLIBC__ +# if __GLIBC__ >= 2 + printf ("%s-${VENDOR}-linux-gnu\n", argv[1]); +# else + printf ("%s-${VENDOR}-linux-gnulibc1\n", argv[1]); +# endif +# else + printf ("%s-${VENDOR}-linux-gnulibc1\n", argv[1]); +# endif +#else + printf ("%s-${VENDOR}-linux-gnuaout\n", argv[1]); +#endif + return 0; +} +EOF + ${CC-cc} dummy.c -o dummy 2>/dev/null && ./dummy "${UNAME_MACHINE}" && rm dummy.c dummy && exit 0 + rm -f dummy.c dummy + fi ;; +# 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:UNIX_SV:4.2MP:2.*) + # Unixware is an offshoot of SVR4, but it has its own version + # number series starting with 2... + # I am not positive that other SVR4 systems won't match this, + # I just have to hope. -- rms. + # Use sysv4.2uw... so that sysv4* matches it. + echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION} + 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} + else + echo ${UNAME_MACHINE}-pc-sysv${UNAME_RELEASE} + fi + exit 0 ;; + i?86:*:3.2:*) + if test -f /usr/options/cb.name; then + UNAME_REL=`sed -n 's/.*Version //p' /dev/null >/dev/null ; then + UNAME_REL=`(/bin/uname -X|egrep Release|sed -e 's/.*= //')` + (/bin/uname -X|egrep i80486 >/dev/null) && UNAME_MACHINE=i486 + (/bin/uname -X|egrep '^Machine.*Pentium' >/dev/null) \ + && UNAME_MACHINE=i586 + echo ${UNAME_MACHINE}-pc-sco$UNAME_REL + else + echo ${UNAME_MACHINE}-pc-sysv32 + fi + exit 0 ;; + pc:*:*:*) + # uname -m prints for DJGPP always 'pc', but it prints nothing about + # the processor, so we play safe by assuming i386. + echo i386-pc-msdosdjgpp + exit 0 ;; + Intel:Mach:3*:*) + echo i386-pc-mach3 + exit 0 ;; + paragon:*:*:*) + echo i860-intel-osf1 + exit 0 ;; + i860:*:4.*:*) # i860-SVR4 + if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then + echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4 + else # Add other i860-SVR4 vendors below as they are discovered. + echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4 + fi + exit 0 ;; + mini*:CTIX:SYS*5:*) + # "miniframe" + 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 | 4850:*:4.0:3.0) + OS_REL='' + test -r /etc/.relid \ + && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` + /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ + && echo i486-ncr-sysv4.3${OS_REL} && exit 0 + /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ + && echo i586-ncr-sysv4.3${OS_REL} && exit 0 ;; + 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*) + /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ + && echo i486-ncr-sysv4 && exit 0 ;; + m68*:LynxOS:2.*:*) + echo m68k-unknown-lynxos${UNAME_RELEASE} + exit 0 ;; + mc68030:UNIX_System_V:4.*:*) + echo m68k-atari-sysv4 + exit 0 ;; + i?86:LynxOS:2.*:*) + echo i386-unknown-lynxos${UNAME_RELEASE} + exit 0 ;; + TSUNAMI:LynxOS:2.*:*) + echo sparc-unknown-lynxos${UNAME_RELEASE} + exit 0 ;; + rs6000:LynxOS:2.*:* | PowerPC:LynxOS:2.*:*) + echo rs6000-unknown-lynxos${UNAME_RELEASE} + exit 0 ;; + SM[BE]S:UNIX_SV:*:*) + echo mips-dde-sysv${UNAME_RELEASE} + exit 0 ;; + RM*:SINIX-*:*:*) + echo mips-sni-sysv4 + exit 0 ;; + *:SINIX-*:*:*) + if uname -p 2>/dev/null >/dev/null ; then + UNAME_MACHINE=`(uname -p) 2>/dev/null` + echo ${UNAME_MACHINE}-sni-sysv4 + else + echo ns32k-sni-sysv + fi + exit 0 ;; + PENTIUM:CPunix:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort + # says + echo i586-unisys-sysv4 + exit 0 ;; + *:UNIX_System_V:4*:FTX*) + # From Gerald Hewes . + # How about differentiating between stratus architectures? -djm + echo hppa1.1-stratus-sysv4 + exit 0 ;; + *:*:*:FTX*) + # From seanf@swdc.stratus.com. + echo i860-stratus-sysv4 + exit 0 ;; + mc68*:A/UX:*:*) + echo m68k-apple-aux${UNAME_RELEASE} + exit 0 ;; + news*:NEWS-OS:*:6*) + echo mips-sony-newsos6 + exit 0 ;; + R3000:*System_V*:*:* | R4000:UNIX_SYSV:*:*) + if [ -d /usr/nec ]; then + echo mips-nec-sysv${UNAME_RELEASE} + else + echo mips-unknown-sysv${UNAME_RELEASE} + fi + exit 0 ;; +esac + +#echo '(No uname command or uname output not recognized.)' 1>&2 +#echo "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" 1>&2 + +cat >dummy.c < +# include +#endif +main () +{ +#if defined (sony) +#if defined (MIPSEB) + /* BFD wants "bsd" instead of "newsos". Perhaps BFD should be changed, + I don't know.... */ + printf ("mips-sony-bsd\n"); exit (0); +#else +#include + printf ("m68k-sony-newsos%s\n", +#ifdef NEWSOS4 + "4" +#else + "" +#endif + ); exit (0); +#endif +#endif + +#if defined (__arm) && defined (__acorn) && defined (__unix) + printf ("arm-acorn-riscix"); exit (0); +#endif + +#if defined (hp300) && !defined (hpux) + printf ("m68k-hp-bsd\n"); exit (0); +#endif + +#if defined (NeXT) +#if !defined (__ARCHITECTURE__) +#define __ARCHITECTURE__ "m68k" +#endif + 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 + +#if defined (MULTIMAX) || defined (n16) +#if defined (UMAXV) + printf ("ns32k-encore-sysv\n"); exit (0); +#else +#if defined (CMU) + printf ("ns32k-encore-mach\n"); exit (0); +#else + printf ("ns32k-encore-bsd\n"); exit (0); +#endif +#endif +#endif + +#if defined (__386BSD__) + printf ("i386-pc-bsd\n"); exit (0); +#endif + +#if defined (sequent) +#if defined (i386) + printf ("i386-sequent-dynix\n"); exit (0); +#endif +#if defined (ns32000) + printf ("ns32k-sequent-dynix\n"); exit (0); +#endif +#endif + +#if defined (_SEQUENT_) + struct utsname un; + + uname(&un); + + if (strncmp(un.version, "V2", 2) == 0) { + printf ("i386-sequent-ptx2\n"); exit (0); + } + if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */ + printf ("i386-sequent-ptx1\n"); exit (0); + } + printf ("i386-sequent-ptx\n"); exit (0); + +#endif + +#if defined (vax) +#if !defined (ultrix) + printf ("vax-dec-bsd\n"); exit (0); +#else + printf ("vax-dec-ultrix\n"); exit (0); +#endif +#endif + +#if defined (alliant) && defined (i860) + printf ("i860-alliant-bsd\n"); exit (0); +#endif + + exit (1); +} +EOF + +${CC-cc} dummy.c -o dummy 2>/dev/null && ./dummy && rm dummy.c dummy && exit 0 +rm -f dummy.c dummy + +# Apollos put the system type in the environment. + +test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit 0; } + +# Convex versions that predate uname can use getsysinfo(1) + +if [ -x /usr/convex/getsysinfo ] +then + case `getsysinfo -f cpu_type` in + c1*) + echo c1-convex-bsd + exit 0 ;; + c2*) + if getsysinfo -f scalar_acc + then echo c32-convex-bsd + else echo c2-convex-bsd + fi + exit 0 ;; + c34*) + echo c34-convex-bsd + exit 0 ;; + c38*) + echo c38-convex-bsd + exit 0 ;; + c4*) + echo c4-convex-bsd + exit 0 ;; + esac +fi + +#echo '(Unable to guess system type)' 1>&2 + +exit 1 diff --git a/config.sub b/config.sub new file mode 100755 index 00000000000..eb77a640f01 --- /dev/null +++ b/config.sub @@ -0,0 +1,1177 @@ +#! /bin/sh +# Configuration validation subroutine script, version 1.1. +# Copyright (C) 1991, 92, 93, 94, 95, 96, 1997 Free Software Foundation, Inc. +# This file is (in principle) common to ALL GNU software. +# The presence of a machine in this file suggests that SOME GNU software +# can handle that machine. It does not imply ALL GNU software can. +# +# This file 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. + +# As a special exception to the GNU General Public License, if you +# distribute this file as part of a program that contains a +# configuration script generated by Autoconf, you may include it under +# the same distribution terms that you use for the rest of that program. + +# Configuration subroutine to validate and canonicalize a configuration type. +# Supply the specified configuration type as an argument. +# If it is invalid, we print an error message on stderr and exit with code 1. +# Otherwise, we print the canonical config type on stdout and succeed. + +# This file is supposed to be the same for all GNU packages +# and recognize all the CPU types, system types and aliases +# that are meaningful with *any* GNU software. +# Each package is responsible for reporting which valid configurations +# it does not support. The user should be able to distinguish +# a failure to support a valid configuration from a meaningless +# configuration. + +# The goal of this file is to map all the various variations of a given +# machine specification into a single specification in the form: +# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM +# or in some cases, the newer four-part form: +# CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM +# It is wrong to echo any other type of specification. + +if [ x$1 = x ] +then + echo Configuration name missing. 1>&2 + echo "Usage: $0 CPU-MFR-OPSYS" 1>&2 + echo "or $0 ALIAS" 1>&2 + echo where ALIAS is a recognized configuration type. 1>&2 + exit 1 +fi + +# First pass through any local machine types. +case $1 in + *local*) + echo $1 + exit 0 + ;; + *) + ;; +esac + +# Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any). +# Here we must recognize all the valid KERNEL-OS combinations. +maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'` +case $maybe_os in + linux-gnu*) + os=-$maybe_os + basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'` + ;; + *) + basic_machine=`echo $1 | sed 's/-[^-]*$//'` + if [ $basic_machine != $1 ] + then os=`echo $1 | sed 's/.*-/-/'` + else os=; fi + ;; +esac + +### Let's recognize common machines as not being operating systems so +### that things like config.sub decstation-3100 work. We also +### recognize some manufacturers as not being operating systems, so we +### can provide default operating systems below. +case $os in + -sun*os*) + # Prevent following clause from handling this invalid input. + ;; + -dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \ + -att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \ + -unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \ + -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\ + -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \ + -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \ + -apple) + os= + basic_machine=$1 + ;; + -sim | -cisco | -oki | -wec | -winbond ) # CYGNUS LOCAL + os= + basic_machine=$1 + ;; + -scout) # CYGNUS LOCAL + ;; + -wrs) # CYGNUS LOCAL + os=vxworks + basic_machine=$1 + ;; + -hiux*) + os=-hiuxwe2 + ;; + -sco5) + os=sco3.2v5 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco4) + os=-sco3.2v4 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco3.2.[4-9]*) + os=`echo $os | sed -e 's/sco3.2./sco3.2v/'` + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco3.2v[4-9]*) + # Don't forget version if it is 3.2v4 or newer. + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco*) + os=-sco3.2v2 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -isc) + os=-isc2.2 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -clix*) + basic_machine=clipper-intergraph + ;; + -isc*) + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -lynx*) + os=-lynxos + ;; + -ptx*) + basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'` + ;; + -windowsnt*) + os=`echo $os | sed -e 's/windowsnt/winnt/'` + ;; + -psos*) + os=-psos + ;; +esac + +# Decode aliases for certain CPU-COMPANY combinations. +case $basic_machine in + # Recognize the basic CPU types without company name. + # Some are omitted here because they have special meanings below. + tahoe | i860 | m32r | m68k | m68000 | m88k | ns32k | arc | arm \ + | arme[lb] | pyramid | mn10200 | mn10300 \ + | tron | a29k | 580 | i960 | h8300 | hppa | hppa1.0 | hppa1.1 \ + | alpha | alphaev5 | alphaev56 | we32k | ns16k | clipper \ + | i370 | sh | powerpc | powerpcle | 1750a | dsp16xx | pdp11 \ + | mips64 | mipsel | mips64el | mips64orion | mips64orionel \ + | mipstx39 | mipstx39el \ + | sparc | sparclet | sparclite | sparc64) + basic_machine=$basic_machine-unknown + ;; + m88110 | m680[01234]0 | m683?2 | m68360 | z8k | v70 | h8500 | w65) # CYGNUS LOCAL + basic_machine=$basic_machine-unknown + ;; + mips64vr4300 | mips64vr4300el) # CYGNUS LOCAL jsmith/vr4300 + basic_machine=$basic_machine-unknown + ;; + mips64vr4100 | mips64vr4100el) # CYGNUS LOCAL jsmith/vr4100 + basic_machine=$basic_machine-unknown + ;; + mips64vr5000 | mips64vr5000el) # CYGNUS LOCAL ian/vr5000 + basic_machine=$basic_machine-unknown + ;; + mips16) # CYGNUS LOCAL krk/mips16 + basic_machine=$basic_machine-unknown + ;; + d10v) # CYGNUS LOCAL meissner/d10v + basic_machine=$basic_machine-unknown + ;; + # We use `pc' rather than `unknown' + # because (1) that's what they normally are, and + # (2) the word "unknown" tends to confuse beginning users. + i[3456]86) + basic_machine=$basic_machine-pc + ;; + # Object if more than one company name word. + *-*-*) + echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 + exit 1 + ;; + # Recognize the basic CPU types with company name. + vax-* | tahoe-* | i[3456]86-* | i860-* | m32r-* | m68k-* | m68000-* \ + | m88k-* | sparc-* | ns32k-* | fx80-* | arc-* | arm-* | c[123]* \ + | mips-* | pyramid-* | tron-* | a29k-* | romp-* | rs6000-* \ + | power-* | none-* | 580-* | cray2-* | h8300-* | i960-* \ + | xmp-* | ymp-* | hppa-* | hppa1.0-* | hppa1.1-* \ + | alpha-* | alphaev5-* | alphaev56-* | we32k-* | cydra-* \ + | ns16k-* | pn-* | np1-* | xps100-* | clipper-* | orion-* \ + | sparclite-* | pdp11-* | sh-* | powerpc-* | powerpcle-* \ + | sparc64-* | mips64-* | mipsel-* \ + | mips64el-* | mips64orion-* | mips64orionel-* \ + | mipstx39-* | mipstx39el-* \ + | f301-*) + ;; + m88110-* | m680[01234]0-* | m683?2-* | m68360-* | z8k-* | h8500-* | d10v-*) # CYGNUS LOCAL + ;; + mips64vr4300-* | mips64vr4300el-*) # CYGNUS LOCAL jsmith/vr4300 + ;; + mips64vr4100-* | mips64vr4100el-*) # CYGNUS LOCAL jsmith/vr4100 + ;; + mips16-*) # CYGNUS LOCAL krk/mips16 + ;; + # Recognize the various machine names and aliases which stand + # for a CPU type and a company and sometimes even an OS. + 386bsd) # CYGNUS LOCAL + basic_machine=i386-unknown + os=-bsd + ;; + 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc) + basic_machine=m68000-att + ;; + 3b*) + basic_machine=we32k-att + ;; + a29khif) # CYGNUS LOCAL + basic_machine=a29k-amd + os=-udi + ;; + adobe68k) # CYGNUS LOCAL + basic_machine=m68010-adobe + os=-scout + ;; + alliant | fx80) + basic_machine=fx80-alliant + ;; + altos | altos3068) + basic_machine=m68k-altos + ;; + am29k) + basic_machine=a29k-none + os=-bsd + ;; + amdahl) + basic_machine=580-amdahl + os=-sysv + ;; + amiga | amiga-*) + basic_machine=m68k-cbm + ;; + amigados) + basic_machine=m68k-cbm + os=-amigados + ;; + amigaunix | amix) + basic_machine=m68k-cbm + os=-sysv4 + ;; + apollo68) + basic_machine=m68k-apollo + os=-sysv + ;; + apollo68bsd) # CYGNUS LOCAL + basic_machine=m68k-apollo + os=-bsd + ;; + aux) + basic_machine=m68k-apple + os=-aux + ;; + balance) + basic_machine=ns32k-sequent + os=-dynix + ;; + convex-c1) + basic_machine=c1-convex + os=-bsd + ;; + convex-c2) + basic_machine=c2-convex + os=-bsd + ;; + convex-c32) + basic_machine=c32-convex + os=-bsd + ;; + convex-c34) + basic_machine=c34-convex + os=-bsd + ;; + convex-c38) + basic_machine=c38-convex + os=-bsd + ;; + cray | ymp) + basic_machine=ymp-cray + os=-unicos + ;; + cray2) + basic_machine=cray2-cray + os=-unicos + ;; + [ctj]90-cray) + basic_machine=c90-cray + os=-unicos + ;; + crds | unos) + basic_machine=m68k-crds + ;; + da30 | da30-*) + basic_machine=m68k-da30 + ;; + decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn) + basic_machine=mips-dec + ;; + delta | 3300 | motorola-3300 | motorola-delta \ + | 3300-motorola | delta-motorola) + basic_machine=m68k-motorola + ;; + delta88) + basic_machine=m88k-motorola + os=-sysv3 + ;; + dpx20 | dpx20-*) + basic_machine=rs6000-bull + os=-bosx + ;; + dpx2* | dpx2*-bull) + basic_machine=m68k-bull + os=-sysv3 + ;; + ebmon29k) + basic_machine=a29k-amd + os=-ebmon + ;; + elxsi) + basic_machine=elxsi-elxsi + os=-bsd + ;; + encore | umax | mmax) + basic_machine=ns32k-encore + ;; + es1800 | OSE68k | ose68k | ose | OSE) # CYGNUS LOCAL + basic_machine=m68k-ericsson + os=-ose + ;; + fx2800) + basic_machine=i860-alliant + ;; + genix) + basic_machine=ns32k-ns + ;; + gmicro) + basic_machine=tron-gmicro + os=-sysv + ;; + h3050r* | hiux*) + basic_machine=hppa1.1-hitachi + os=-hiuxwe2 + ;; + h8300hms) + basic_machine=h8300-hitachi + os=-hms + ;; + h8300xray) # CYGNUS LOCAL + basic_machine=h8300-hitachi + os=-xray + ;; + h8500hms) # CYGNUS LOCAL + basic_machine=h8500-hitachi + os=-hms + ;; + harris) + basic_machine=m88k-harris + os=-sysv3 + ;; + hp300-*) + basic_machine=m68k-hp + ;; + hp300bsd) + basic_machine=m68k-hp + os=-bsd + ;; + hp300hpux) + basic_machine=m68k-hp + os=-hpux + ;; + w89k-*) # CYGNUS LOCAL + basic_machine=hppa1.1-winbond + os=-proelf + ;; + op50n-*) # CYGNUS LOCAL + basic_machine=hppa1.1-oki + os=-proelf + ;; + op60c-*) # CYGNUS LOCAL + basic_machine=hppa1.1-oki + os=-proelf + ;; + hppro) # CYGNUS LOCAL + basic_machine=hppa1.1-hp + os=-proelf + ;; + hp9k2[0-9][0-9] | hp9k31[0-9]) + basic_machine=m68000-hp + ;; + hp9k3[2-9][0-9]) + basic_machine=m68k-hp + ;; + hp9k7[0-9][0-9] | hp7[0-9][0-9] | hp9k8[0-9]7 | hp8[0-9]7) + basic_machine=hppa1.1-hp + ;; + hp9k8[0-9][0-9] | hp8[0-9][0-9]) + basic_machine=hppa1.0-hp + ;; + hppa-next) + os=-nextstep3 + ;; + hppaosf) # CYGNUS LOCAL + basic_machine=hppa1.1-hp + os=-osf + ;; + i370-ibm* | ibm*) + basic_machine=i370-ibm + os=-mvs + ;; +# I'm not sure what "Sysv32" means. Should this be sysv3.2? + i[3456]86v32) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-sysv32 + ;; + i[3456]86v4*) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-sysv4 + ;; + i[3456]86v) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-sysv + ;; + i[3456]86sol2) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-solaris2 + ;; + i386mach) # CYGNUS LOCAL + basic_machine=i386-mach + os=-mach + ;; + i386-vsta | vsta) # CYGNUS LOCAL + basic_machine=i386-unknown + os=-vsta + ;; + i386-go32 | go32) # CYGNUS LOCAL + basic_machine=i386-unknown + os=-go32 + ;; + iris | iris4d) + basic_machine=mips-sgi + case $os in + -irix*) + ;; + *) + os=-irix4 + ;; + esac + ;; + isi68 | isi) + basic_machine=m68k-isi + os=-sysv + ;; + m88k-omron*) + basic_machine=m88k-omron + ;; + magnum | m3230) + basic_machine=mips-mips + os=-sysv + ;; + merlin) + basic_machine=ns32k-utek + os=-sysv + ;; + miniframe) + basic_machine=m68000-convergent + ;; + mipsel*-linux*) + basic_machine=mipsel-unknown + os=-linux-gnu + ;; + mips*-linux*) + basic_machine=mips-unknown + os=-linux-gnu + ;; + mips3*-*) + basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'` + ;; + mips3*) + basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown + ;; + monitor) # CYGNUS LOCAL + basic_machine=m68k-rom68k + os=-coff + ;; + msdos) # CYGNUS LOCAL + basic_machine=i386-unknown + os=-msdos + ;; + ncr3000) + basic_machine=i486-ncr + os=-sysv4 + ;; + netbsd386) + basic_machine=i386-unknown # CYGNUS LOCAL + os=-netbsd + ;; + news | news700 | news800 | news900) + basic_machine=m68k-sony + os=-newsos + ;; + news1000) + basic_machine=m68030-sony + os=-newsos + ;; + news-3600 | risc-news) + basic_machine=mips-sony + os=-newsos + ;; + necv70) # CYGNUS LOCAL + basic_machine=v70-nec + os=-sysv + ;; + next | m*-next ) + basic_machine=m68k-next + case $os in + -nextstep* ) + ;; + -ns2*) + os=-nextstep2 + ;; + *) + os=-nextstep3 + ;; + esac + ;; + nh3000) + basic_machine=m68k-harris + os=-cxux + ;; + nh[45]000) + basic_machine=m88k-harris + os=-cxux + ;; + nindy960) + basic_machine=i960-intel + os=-nindy + ;; + mon960) # CYGNUS LOCAL + basic_machine=i960-intel + os=-mon960 + ;; + np1) + basic_machine=np1-gould + ;; + OSE68000 | ose68000) # CYGNUS LOCAL + basic_machine=m68000-ericsson + os=-ose + ;; + os68k) # CYGNUS LOCAL + basic_machine=m68k-none + os=-os68k + ;; + pa-hitachi) + basic_machine=hppa1.1-hitachi + os=-hiuxwe2 + ;; + paragon) + basic_machine=i860-intel + os=-osf + ;; + pbd) + basic_machine=sparc-tti + ;; + pbb) + basic_machine=m68k-tti + ;; + pc532 | pc532-*) + basic_machine=ns32k-pc532 + ;; + pentium | p5) + basic_machine=i586-intel + ;; + pentiumpro | p6) + basic_machine=i686-intel + ;; + pentium-* | p5-*) + basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pentiumpro-* | p6-*) + basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + k5) + # We don't have specific support for AMD's K5 yet, so just call it a Pentium + basic_machine=i586-amd + ;; + nexen) + # We don't have specific support for Nexgen yet, so just call it a Pentium + basic_machine=i586-nexgen + ;; + pn) + basic_machine=pn-gould + ;; + power) basic_machine=rs6000-ibm + ;; + ppc) basic_machine=powerpc-unknown + ;; + ppc-*) basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ppcle | powerpclittle | ppc-le | powerpc-little) + basic_machine=powerpcle-unknown + ;; + ppcle-* | powerpclittle-*) + basic_machine=powerpcle-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ps2) + basic_machine=i386-ibm + ;; + rom68k) # CYGNUS LOCAL + basic_machine=m68k-rom68k + os=-coff + ;; + rm[46]00) + basic_machine=mips-siemens + ;; + rtpc | rtpc-*) + basic_machine=romp-ibm + ;; + sa29200) # CYGNUS LOCAL + basic_machine=a29k-amd + os=-udi + ;; + sequent) + basic_machine=i386-sequent + ;; + sh) + basic_machine=sh-hitachi + os=-hms + ;; + sparclite-wrs) # CYGNUS LOCAL + basic_machine=sparclite-wrs + os=-vxworks + ;; + sps7) + basic_machine=m68k-bull + os=-sysv2 + ;; + spur) + basic_machine=spur-unknown + ;; + st2000) # CYGNUS LOCAL + basic_machine=m68k-tandem + ;; + stratus) # CYGNUS LOCAL + basic_machine=i860-stratus + os=-sysv4 + ;; + sun2) + basic_machine=m68000-sun + ;; + sun2os3) + basic_machine=m68000-sun + os=-sunos3 + ;; + sun2os4) + basic_machine=m68000-sun + os=-sunos4 + ;; + sun3os3) + basic_machine=m68k-sun + os=-sunos3 + ;; + sun3os4) + basic_machine=m68k-sun + os=-sunos4 + ;; + sun4os3) + basic_machine=sparc-sun + os=-sunos3 + ;; + sun4os4) + basic_machine=sparc-sun + os=-sunos4 + ;; + sun4sol2) + basic_machine=sparc-sun + os=-solaris2 + ;; + sun3 | sun3-*) + basic_machine=m68k-sun + ;; + sun4) + basic_machine=sparc-sun + ;; + sun386 | sun386i | roadrunner) + basic_machine=i386-sun + ;; + symmetry) + basic_machine=i386-sequent + os=-dynix + ;; + tx39) + basic_machine=mipstx39-unknown + ;; + tx39el) + basic_machine=mipstx39el-unknown + ;; + tower | tower-32) + basic_machine=m68k-ncr + ;; + udi29k) + basic_machine=a29k-amd + os=-udi + ;; + ultra3) + basic_machine=a29k-nyu + os=-sym1 + ;; + v810 | necv810) # CYGNUS LOCAL + basic_machine=v810-nec + os=-none + ;; + vaxv) + basic_machine=vax-dec + os=-sysv + ;; + vms) + basic_machine=vax-dec + os=-vms + ;; + vpp*|vx|vx-*) + basic_machine=f301-fujitsu + ;; + vxworks960) + basic_machine=i960-wrs + os=-vxworks + ;; + vxworks68) + basic_machine=m68k-wrs + os=-vxworks + ;; + vxworks29k) + basic_machine=a29k-wrs + os=-vxworks + ;; + w65*) # CYGNUS LOCAL + basic_machine=w65-wdc + os=-none + ;; + xmp) + basic_machine=xmp-cray + os=-unicos + ;; + xps | xps100) + basic_machine=xps100-honeywell + ;; + z8k-*-coff) # CYGNUS LOCAL + basic_machine=z8k-unknown + os=-sim + ;; + none) + basic_machine=none-none + os=-none + ;; + +# Here we handle the default manufacturer of certain CPU types. It is in +# some cases the only manufacturer, in others, it is the most popular. + w89k) # CYGNUS LOCAL + basic_machine=hppa1.1-winbond + ;; + op50n) # CYGNUS LOCAL + basic_machine=hppa1.1-oki + ;; + op60c) # CYGNUS LOCAL + basic_machine=hppa1.1-oki + ;; + mips) + if [ x$os = x-linux-gnu ]; then + basic_machine=mips-unknown + else + basic_machine=mips-mips + fi + ;; + romp) + basic_machine=romp-ibm + ;; + rs6000) + basic_machine=rs6000-ibm + ;; + vax) + basic_machine=vax-dec + ;; + pdp11) + basic_machine=pdp11-dec + ;; + we32k) + basic_machine=we32k-att + ;; + sparc) + basic_machine=sparc-sun + ;; + cydra) + basic_machine=cydra-cydrome + ;; + orion) + basic_machine=orion-highlevel + ;; + orion105) + basic_machine=clipper-highlevel + ;; + mac | mpw | mac-mpw) # CYGNUS LOCAL + basic_machine=m68k-apple + ;; + pmac | pmac-mpw) # CYGNUS LOCAL + basic_machine=powerpc-apple + ;; + *) + echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 + exit 1 + ;; +esac + +# Here we canonicalize certain aliases for manufacturers. +case $basic_machine in + *-digital*) + basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'` + ;; + *-commodore*) + basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'` + ;; + *) + ;; +esac + +# Decode manufacturer-specific aliases for certain operating systems. + +if [ x"$os" != x"" ] +then +case $os in + # First match some system type aliases + # that might get confused with valid system types. + # -solaris* is a basic system type, with this one exception. + -solaris1 | -solaris1.*) + os=`echo $os | sed -e 's|solaris1|sunos4|'` + ;; + -solaris) + os=-solaris2 + ;; + -unixware* | svr4*) + os=-sysv4 + ;; + -gnu/linux*) + os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'` + ;; + # First accept the basic system types. + # The portable systems comes first. + # Each alternative MUST END IN A *, to match a version number. + # -sysv* is not here because it comes later, after sysvr4. + -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \ + | -*vms* | -sco* | -esix* | -isc* | -aix* | -sunos | -sunos[34]*\ + | -hpux* | -unos* | -osf* | -luna* | -dgux* | -solaris* | -sym* \ + | -amigados* | -msdos* | -newsos* | -unicos* | -aof* | -aos* \ + | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \ + | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \ + | -hiux* | -386bsd* | -netbsd* | -openbsd* | -freebsd* | -riscix* \ + | -lynxos* | -bosx* | -nextstep* | -cxux* | -aout* | -elf* \ + | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \ + | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \ + | -cygwin32* | -pe* | -psos* | -moss* | -proelf* | -rtems* \ + | -mingw32* | -linux-gnu* | -uxpv*) + # Remember, each alternative MUST END IN *, to match a version number. + ;; + # CYGNUS LOCAL + -sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \ + | -windows* | -osx | -abug | -netware* | -os9* | -beos* \ + | -macos* | -mpw* | -magic* | -mon960* | -lnews* ) + ;; + -mac*) + os=`echo $os | sed -e 's|mac|macos|'` + ;; + # END CYGNUS LOCAL + -linux*) + os=`echo $os | sed -e 's|linux|linux-gnu|'` + ;; + -sunos5*) + os=`echo $os | sed -e 's|sunos5|solaris2|'` + ;; + -sunos6*) + os=`echo $os | sed -e 's|sunos6|solaris3|'` + ;; + -osfrose*) + os=-osfrose + ;; + -osf*) + os=-osf + ;; + -utek*) + os=-bsd + ;; + -dynix*) + os=-bsd + ;; + -acis*) + os=-aos + ;; + -386bsd) # CYGNUS LOCAL + os=-bsd + ;; + -ctix* | -uts*) + os=-sysv + ;; + -ns2 ) + os=-nextstep2 + ;; + # Preserve the version number of sinix5. + -sinix5.*) + os=`echo $os | sed -e 's|sinix|sysv|'` + ;; + -sinix*) + os=-sysv4 + ;; + -triton*) + os=-sysv3 + ;; + -oss*) + os=-sysv3 + ;; + -svr4) + os=-sysv4 + ;; + -svr3) + os=-sysv3 + ;; + -sysvr4) + os=-sysv4 + ;; + # This must come after -sysvr4. + -sysv*) + ;; + -ose*) # CYGNUS LOCAL + os=-ose + ;; + -es1800*) # CYGNUS LOCAL + os=-ose + ;; + -xenix) + os=-xenix + ;; + -none) + ;; + *) + # Get rid of the `-' at the beginning of $os. + os=`echo $os | sed 's/[^-]*-//'` + echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2 + exit 1 + ;; +esac +else + +# Here we handle the default operating systems that come with various machines. +# The value should be what the vendor currently ships out the door with their +# machine or put another way, the most popular os provided with the machine. + +# Note that if you're going to try to match "-MANUFACTURER" here (say, +# "-sun"), then you have to tell the case statement up towards the top +# that MANUFACTURER isn't an operating system. Otherwise, code above +# will signal an error saying that MANUFACTURER isn't an operating +# system, and we'll never get to this point. + +case $basic_machine in + *-acorn) + os=-riscix1.2 + ;; + arm*-semi) + os=-aout + ;; + pdp11-*) + os=-none + ;; + *-dec | vax-*) + os=-ultrix4.2 + ;; + m68*-apollo) + os=-domain + ;; + i386-sun) + os=-sunos4.0.2 + ;; + m68000-sun) + os=-sunos3 + # This also exists in the configure program, but was not the + # default. + # os=-sunos4 + ;; + m68*-cisco) # CYGNUS LOCAL + os=-aout + ;; + mips*-cisco) # CYGNUS LOCAL + os=-elf + ;; + mips*-*) # CYGNUS LOCAL + os=-elf + ;; + *-tti) # must be before sparc entry or we get the wrong os. + os=-sysv3 + ;; + sparc-* | *-sun) + os=-sunos4.1.1 + ;; + *-be) # CYGNUS LOCAL + os=-beos + ;; + *-ibm) + os=-aix + ;; + *-wec) # CYGNUS LOCAL + os=-proelf + ;; + *-winbond) # CYGNUS LOCAL + os=-proelf + ;; + *-oki) # CYGNUS LOCAL + os=-proelf + ;; + *-hp) + os=-hpux + ;; + *-hitachi) + os=-hiux + ;; + i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent) + os=-sysv + ;; + *-cbm) + os=-amigados + ;; + *-dg) + os=-dgux + ;; + *-dolphin) + os=-sysv3 + ;; + m68k-ccur) + os=-rtu + ;; + m88k-omron*) + os=-luna + ;; + *-next ) + os=-nextstep + ;; + *-sequent) + os=-ptx + ;; + *-crds) + os=-unos + ;; + *-ns) + os=-genix + ;; + i370-*) + os=-mvs + ;; + *-next) + os=-nextstep3 + ;; + *-gould) + os=-sysv + ;; + *-highlevel) + os=-bsd + ;; + *-encore) + os=-bsd + ;; + *-sgi) + os=-irix + ;; + *-siemens) + os=-sysv4 + ;; + *-masscomp) + os=-rtu + ;; + f301-fujitsu) + os=-uxpv + ;; + *-rom68k) # CYGNUS LOCAL + os=-coff + ;; + *-*bug) # CYGNUS LOCAL + os=-coff + ;; + *-apple) # CYGNUS LOCAL + os=-macos + ;; + *) + os=-none + ;; +esac +fi + +# Here we handle the case where we know the os, and the CPU type, but not the +# manufacturer. We pick the logical manufacturer. +vendor=unknown +case $basic_machine in + *-unknown) + case $os in + -riscix*) + vendor=acorn + ;; + -sunos*) + vendor=sun + ;; + -aix*) + vendor=ibm + ;; + -beos*) # CYGNUS LOCAL + vendor=be + ;; + -hpux*) + vendor=hp + ;; + -hiux*) + vendor=hitachi + ;; + -unos*) + vendor=crds + ;; + -dgux*) + vendor=dg + ;; + -luna*) + vendor=omron + ;; + -genix*) + vendor=ns + ;; + -mvs*) + vendor=ibm + ;; + -ptx*) + vendor=sequent + ;; + -vxsim* | -vxworks*) + vendor=wrs + ;; + -aux*) + vendor=apple + ;; + -hms*) # CYGNUS LOCAL + vendor=hitachi + ;; + -mpw* | -macos*) # CYGNUS LOCAL + vendor=apple + ;; + esac + basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"` + ;; +esac + +echo $basic_machine$os diff --git a/config/ChangeLog b/config/ChangeLog new file mode 100644 index 00000000000..b68a85c7a21 --- /dev/null +++ b/config/ChangeLog @@ -0,0 +1,312 @@ +Wed Jul 23 12:32:18 1997 Robert Hoehne + + * mh-go32 (CFLAGS): Don't set -fno-omit-frame-pointer. + +Mon Jun 16 19:06:41 1997 Geoff Keating + + * mh-ppcpic: New file. + * mt-ppcpic: New file. + +Thu Mar 27 15:52:40 1997 Geoffrey Noer + + * mh-cygwin32: override CXXFLAGS, setting to -O2 only + (no debug) + +Tue Mar 25 18:16:43 1997 Geoffrey Noer + + * mh-cygwin32: override LIBGCC2_DEBUG_CFLAGS so debug info + isn't included in cygwin32-hosted libgcc2.a by default + +Wed Jan 8 19:56:43 1997 Geoffrey Noer + + * mh-cygwin32: override CFLAGS so debug info isn't included + in cygwin32-hosted tools by default + +Tue Dec 31 16:04:26 1996 Ian Lance Taylor + + * mh-linux: Remove. + +Mon Nov 11 10:29:51 1996 Michael Meissner + + * mt-ppc: Delete file, options moved to newlib configure. + +Fri Oct 4 12:21:03 1996 Angela Marie Thomas (angela@cygnus.com) + + * mh-dgux386: New file. x86 dgux specific flags + +Mon Sep 30 15:10:07 1996 Stan Shebs + + * mpw-mh-mpw (EXTRALIBS_PPC_XCOFF): New, was EXTRALIBS_PPC. + (EXTRALIBS_PPC): Use shared libraries instead of xcoff. + +Sat Aug 17 04:56:25 1996 Geoffrey Noer + + * mh-cygwin32: don't -D_WIN32 here anymore + +Thu Aug 15 19:46:44 1996 Stan Shebs + + * mpw-mh-mpw (SEGFLAG_68K, SEGFLAG_PPC): Remove. + (EXTRALIBS_PPC): Add libgcc.xcoff. + +Thu Aug 8 14:51:47 1996 Michael Meissner + + * mt-ppc: New file, add -mrelocatable-lib and -mno-eabi to all + target builds for PowerPC eabi targets. + +Fri Jul 12 12:06:01 1996 Stan Shebs + + * mpw: New subdir, Mac MPW configuration support bits. + +Mon Jul 8 17:30:52 1996 Jim Wilson + + * mh-irix6: New file. + +Mon Jul 8 15:15:37 1996 Jason Merrill + + * mt-sparcpic (PICFLAG_FOR_TARGET): Use -fPIC. + +Fri Jul 5 11:49:02 1996 Ian Lance Taylor + + * mh-irix4 (RANLIB): Don't define; Irix 4 does have ranlib. + +Sun Jun 23 22:59:25 1996 Geoffrey Noer + + * mh-cygwin32: new file. Like mh-go32 without the CFLAGS entry. + +Tue Mar 26 14:10:41 1996 Ian Lance Taylor + + * mh-go32 (CFLAGS): Define. + +Thu Mar 14 19:20:54 1996 Ian Lance Taylor + + * mh-necv4: New file. + +Thu Feb 15 13:07:43 1996 Ian Lance Taylor + + * mh-cxux (CC): New variable. + (CFLAGS, LDFLAGS): Remove. + * mh-ncrsvr43 (CC): New variable. + (CFLAGS): Remove. + * mh-solaris (CFLAGS): Remove. + + * mh-go32: Remove most variable settings, since they presumed a + Canadian Cross, which is now handled correctly by the configure + script. + + * mh-sparcpic (PICFLAG): Set to -fPIC, not -fpic. + +Mon Feb 12 14:53:39 1996 Andreas Schwab + + * mh-m68kpic, mt-m68kpic: New files. + +Thu Feb 1 14:15:42 1996 Stan Shebs + + * mpw-mh-mpw (CC_MWC68K): Add options similar to those used + in CC_MWCPPC, and -mc68020 -model far. + (AR_MWLINK68K): Add -xm library. + (AR_AR): Define. + (CC_LD_MWLINK68K): Remove -d. + (EXTRALIBS_MWC68K): Define. + +Thu Jan 25 16:05:33 1996 Ian Lance Taylor + + * mh-ncrsvr43 (CFLAGS): Remove -Hnocopyr. + +Tue Nov 7 15:41:30 1995 Stan Shebs + + * mpw-mh-mpw (CC_MWC68K, CC_MWCPPC): Remove unused include path. + (CC_MWCPPC): Add -mpw_chars, disable warnings, add comments + explaining reasons for various flags. + (EXTRALIBS_PPC, EXTRALIBS_MWCPPC ): Put runtime library first. + +Fri Oct 13 14:44:25 1995 Jason Molenda (crash@phydeaux.cygnus.com) + + * mh-aix, mh-sun: Removed. + + * mh-decstation (X11_EXTRA_CFLAGS): Define. + + * mh-sco, mh-solaris, mh-sysv4 (X11_EXTRA_LIBS): Define. + + * mh-hp300, mh-hpux, mh-hpux8, mh-solaris, mh-sun3, mh-sysv4: Don't + hardcode location of X stuff here. + +Thu Sep 28 13:14:56 1995 Stan Shebs + + * mpw-mh-mpw: Add definitions for various 68K and PowerMac + compilers, add definitions for library and link steps for + PowerMacs. + +Thu Sep 14 08:20:04 1995 Fred Fish + + * mh-hp300 (CC): Add "CC = cc -Wp,-H256000" to avoid + "too much defining" errors from the HPUX compiler. + +Thu Aug 17 17:28:56 1995 Ken Raeburn + + * mh-hp300 (RANLIB): Use "ar ts", in case GNU ar was used and + didn't build a symbol table. + +Thu Jun 22 17:47:24 1995 Stan Shebs + + * mpw-mh-mpw (CC): Define ANSI_PROTOTYPES. + +Mon Apr 10 12:29:48 1995 Stan Shebs + + * mpw-mh-mpw (EXTRALIBS): Always link in Math.o, CSANELIB.o, + and ToolLibs.o. + + * mpw-mh-mpw (CC): Define ALMOST_STDC. + (CFLAGS): Remove ALMOST_STDC, -mc68881. + (LDFLAGS): add -w. + + * mpw-mh-mpw (CFLAGS): Add -b option to put strings at the ends of + functions. + + * mpw-mh-mpw: New file, host makefile definitions for MPW. + +Fri Mar 31 11:35:17 1995 Jason Molenda (crash@phydeaux.cygnus.com) + + * mt-netware: New file. + +Mon Mar 13 12:31:29 1995 Ian Lance Taylor + + * mh-hpux8: New file. + * mh-hpux: Use X11R5 rather than X11R4. + +Thu Feb 9 11:04:13 1995 Ian Lance Taylor + + * mh-linux (SYSV): Don't define. + (RANLIB): Don't define. + +Wed Jan 11 16:29:34 1995 Jason Merrill + + * m?-*pic (LIBCXXFLAGS): Add -fno-implicit-templates. + +Thu Nov 3 17:27:19 1994 Ken Raeburn + + * mh-irix4 (CC): Increase maximum string length. + + * mh-sco (CC): Define away const, it doesn't work right; elements + of arrays of ptr-to-const are considered const themselves. + +Sat Jul 16 12:17:49 1994 Stan Shebs (shebs@andros.cygnus.com) + + * mh-cxux: New file, from Bob Rusk (rrusk@mail.csd.harris.com). + +Sat Jun 4 17:22:12 1994 Per Bothner (bothner@kalessin.cygnus.com) + + * mh-ncrsvr43: New file from Tom McConnell + . + +Thu May 19 00:32:11 1994 Jeff Law (law@snake.cs.utah.edu) + + * mh-hpux (CC): Add -Wp,-H256000 to avoid "too much defining" + errors from the HPUX 8 compilers. + +Wed May 4 20:14:47 1994 D. V. Henkel-Wallace (gumby@cygnus.com) + + * mh-lynxrs6k: set SHELL to /bin/bash + +Tue Apr 12 12:38:17 1994 Ian Lance Taylor (ian@tweedledumb.cygnus.com) + + * mh-irix4 (CC): Change -XNh1500 to -XNh2000. + +Sat Dec 25 20:03:45 1993 Jeffrey A. Law (law@snake.cs.utah.edu) + + * mt-hppa: Delete. + +Tue Nov 16 22:54:39 1993 Jim Kingdon (kingdon@lioth.cygnus.com) + + * mh-a68bsd: Define CC to gcc. + +Mon Nov 15 16:56:51 1993 Jim Kingdon (kingdon@lioth.cygnus.com) + + * mh-linux: Don't put -static in LDFLAGS. Add comments. + +Mon Nov 15 13:37:58 1993 david d `zoo' zuhn (zoo@cirdan.cygnus.com) + + * mh-sysv4 (AR_FLAGS): change from cq to cr + +Fri Nov 5 08:12:32 1993 D. V. Henkel-Wallace (gumby@blues.cygnus.com) + + * mh-unixware: remove. It's the same as sysv4, and config.guess + can't tell the difference. So don't allow skew. + +Wed Oct 20 20:35:14 1993 Jim Kingdon (kingdon@lioth.cygnus.com) + + * mh-hp300: Revert yesterday's change, but add comment explaining. + +Tue Oct 19 18:58:21 1993 Jim Kingdon (kingdon@lioth.cygnus.com) + + * mh-hp300: Don't define CFLAGS to empty. Why should hp300 be + different from anything else? ("gdb doesn't understand the native + debug format" isn't a good enough answer because we might be using + gcc). + +Tue Oct 5 12:17:40 1993 Peter Schauer (pes@regent.e-technik.tu-muenchen.de) + + * mh-alphaosf: Remove, no longer necessary now that gdb knows + how to handle OSF/1 shared libraries. + +Tue Jul 6 11:27:33 1993 Steve Chamberlain (sac@phydeaux.cygnus.com) + + * mh-alphaosf: New file. + +Thu Jul 1 15:49:33 1993 Jim Kingdon (kingdon@lioth.cygnus.com) + + * mh-riscos: New file. + +Mon Jun 14 12:03:18 1993 david d `zoo' zuhn (zoo at rtl.cygnus.com) + + * mh-aix, mh-aix386, mh-decstation, mh-delta88, mh-hpux, mh-irix4, + mh-ncr3000, mh-solaris, mh-sysv, mh-sysv4: remove INSTALL=cp line, + now that we're using install.sh globally + +Fri Jun 4 16:09:34 1993 Ian Lance Taylor (ian@cygnus.com) + + * mh-sysv4 (INSTALL): Use cp, not /usr/ucb/install. + +Thu Apr 8 11:21:52 1993 Ian Lance Taylor (ian@cygnus.com) + + * mt-a29k, mt-ebmon29k, mt-os68k, mt-ose68000, mt-ose68k, + mt-vxworks68, mt-vxworks960: Removed obsolete, unused target + Makefile fragment files. + +Mon Mar 8 15:05:25 1993 Ken Raeburn (raeburn@cambridge.cygnus.com) + + * mh-aix386: New file; old mh-aix, plus no-op RANLIB. + +Thu Oct 1 13:50:48 1992 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * mh-solaris: INSTALL is NOT /usr/ucb/install + +Mon Aug 24 14:25:35 1992 Ian Lance Taylor (ian@cygnus.com) + + * mt-ose68000, mt-ose68k: renamed from mt-OSE*. + +Tue Jul 21 02:11:01 1992 D. V. Henkel-Wallace (gumby@cygnus.com) + + * mt-OSE68k, mt-680000: new configs. + +Thu Jul 16 17:12:09 1992 K. Richard Pixley (rich@rtl.cygnus.com) + + * mh-irix4: merged changes from progressive. + +Tue Jun 9 23:29:38 1992 Per Bothner (bothner@rtl.cygnus.com) + + * Everywhere: Change RANLIB=echo>/dev/null (which confuses + some shells - and I don't blame them) to RANLIB=true. + * mh-solaris: Use /usr/ucb/install for INSTALL. + +Sun May 31 14:45:23 1992 Mark Eichin (eichin at cygnus.com) + + * mh-solaris2: Add new configuration for Solaris 2 (sysv, no ranlib) + +Fri Apr 10 23:10:08 1992 Fred Fish (fnf@cygnus.com) + + * mh-ncr3000: Add new configuration for NCR 3000. + +Tue Dec 10 00:10:55 1991 K. Richard Pixley (rich at rtl.cygnus.com) + + * ChangeLog: fresh changelog. + diff --git a/config/mh-a68bsd b/config/mh-a68bsd new file mode 100644 index 00000000000..c991289dd5f --- /dev/null +++ b/config/mh-a68bsd @@ -0,0 +1,12 @@ +RANLIB=true + +#None of the Apollo compilers can compile gas or binutils. The preprocessor +# chokes on bfd, the compiler won't let you assign integers to enums, and +# other problems. Defining CC to gcc is a questionable way to say "don't use +# the apollo compiler" (the preferred version of GCC could be called cc, +# or whatever), but I'm not sure leaving CC as cc is any better... + +#CC=cc -A ansi -A runtype,any -A systype,any -U__STDC__ -DNO_STDARG +CC=gcc + +BISON=yacc diff --git a/config/mh-aix386 b/config/mh-aix386 new file mode 100644 index 00000000000..4accd1cddfb --- /dev/null +++ b/config/mh-aix386 @@ -0,0 +1 @@ +RANLIB = @: diff --git a/config/mh-apollo68 b/config/mh-apollo68 new file mode 100644 index 00000000000..4497ed93585 --- /dev/null +++ b/config/mh-apollo68 @@ -0,0 +1,3 @@ +HDEFINES = -DUSG +RANLIB=true +CC= cc -A ansi -A runtype,any -A systype,any -U__STDC__ -DUSG diff --git a/config/mh-cxux b/config/mh-cxux new file mode 100644 index 00000000000..54b2a16c834 --- /dev/null +++ b/config/mh-cxux @@ -0,0 +1,14 @@ +# Configuration for Harris CX/UX 7 (and maybe 6), based on sysv4 configuration. + +# Define SYSV as -DSYSV if you are using a System V operating system. +SYSV = -DSYSV -DSVR4 +RANLIB = true + +# C++ debugging is not yet supported under SVR4 (DWARF) +CXXFLAGS=-O + +# The l flag generates a warning from the SVR4 archiver, remove it. +AR_FLAGS = cq + +# Under CX/UX, we want to tell the compiler to use ANSI mode. +CC=cc -Xa diff --git a/config/mh-cygwin32 b/config/mh-cygwin32 new file mode 100644 index 00000000000..3f6c1c6cbeb --- /dev/null +++ b/config/mh-cygwin32 @@ -0,0 +1,16 @@ +# We don't want debugging info in Win32-hosted toolchains. +# Accomplish this by overriding CFLAGS. +CFLAGS=-O2 +CXXFLAGS=-O2 + +# We also need to override LIBGCC2_DEBUG_CFLAGS so libgcc2 will be +# build without debugging information + +LIBGCC2_DEBUG_CFLAGS= + +# We set MAKEINFOFLAGS to not split .info files, because the resulting +# file names don't work on DOS. +MAKEINFOFLAGS=--no-split + +# custom installation rules for cygwin32 (append .exe to binaries, etc.) +INSTALL_DOSREL=install-dosrel diff --git a/config/mh-decstation b/config/mh-decstation new file mode 100644 index 00000000000..37201926d5f --- /dev/null +++ b/config/mh-decstation @@ -0,0 +1,5 @@ +CC = cc -Wf,-XNg1000 + +# for X11, since the native DECwindows include files are really broken when +# it comes to function prototypes. +X11_EXTRA_CFLAGS = "-DNeedFunctionPrototypes=0" diff --git a/config/mh-delta88 b/config/mh-delta88 new file mode 100644 index 00000000000..bc9c45302d5 --- /dev/null +++ b/config/mh-delta88 @@ -0,0 +1,4 @@ +RANLIB = true + + + diff --git a/config/mh-dgux b/config/mh-dgux new file mode 100644 index 00000000000..e7d85d6126a --- /dev/null +++ b/config/mh-dgux @@ -0,0 +1,4 @@ +HDEFINES=-DHOST_SYS=DGUX_SYS +CC=gcc -Wall -ansi -D__using_DGUX +RANLIB=true + diff --git a/config/mh-dgux386 b/config/mh-dgux386 new file mode 100644 index 00000000000..15885c3e042 --- /dev/null +++ b/config/mh-dgux386 @@ -0,0 +1,22 @@ +# from mh-dgux +HDEFINES=-DHOST_SYS=DGUX_SYS +CC=gcc -Wall -ansi -D__using_DGUX +RANLIB = true + +# from mh-sysv4 +# Define SYSV as -DSYSV if you are using a System V operating system. +SYSV = -DSYSV -DSVR4 +RANLIB = true + +# C++ debugging is not yet supported under SVR4 (DWARF) +CXXFLAGS=-O + +# The l flag generates a warning from the SVR4 archiver, remove it. +AR_FLAGS = cr + +X11_EXTRA_LIBS = -lnsl + +# from angela +# no debugging due to broken compiler, use BSD style timeofday +CFLAGS=-O -D_BSD_TIMEOFDAY_FLAVOR + diff --git a/config/mh-go32 b/config/mh-go32 new file mode 100644 index 00000000000..f12007b0e0f --- /dev/null +++ b/config/mh-go32 @@ -0,0 +1,4 @@ +# We don't want to use debugging information on DOS. Unfortunately, +# this requires that we set CFLAGS. +# This used to set -fno-omit-frame-pointer. +CFLAGS=-O2 diff --git a/config/mh-hp300 b/config/mh-hp300 new file mode 100644 index 00000000000..761724d92de --- /dev/null +++ b/config/mh-hp300 @@ -0,0 +1,13 @@ +# Define SYSV as -DSYSV if you are using a System V operating system. +SYSV = -DSYSV +# Avoid "too much defining" errors from HPUX compiler. +CC = cc -Wp,-H256000 +# If "ar" in $PATH is GNU ar, the symbol table may need rebuilding. +# If it's HP/UX ar, this should be harmless. +RANLIB = ar ts + +# Native cc can't bootstrap gcc with -g. Defining CFLAGS here loses (a) +# for non-gcc directories, (b) if we are compiling with gcc, not +# native cc. Neither (a) nor (b) has a trivial fix though. + +CFLAGS = diff --git a/config/mh-hpux b/config/mh-hpux new file mode 100644 index 00000000000..4d71c9dc837 --- /dev/null +++ b/config/mh-hpux @@ -0,0 +1,4 @@ +# Define SYSV as -DSYSV if you are using a System V operating system. +CC = cc -Wp,-H256000 +SYSV = -DSYSV +RANLIB = true diff --git a/config/mh-hpux8 b/config/mh-hpux8 new file mode 100644 index 00000000000..4d71c9dc837 --- /dev/null +++ b/config/mh-hpux8 @@ -0,0 +1,4 @@ +# Define SYSV as -DSYSV if you are using a System V operating system. +CC = cc -Wp,-H256000 +SYSV = -DSYSV +RANLIB = true diff --git a/config/mh-irix4 b/config/mh-irix4 new file mode 100644 index 00000000000..6872145e833 --- /dev/null +++ b/config/mh-irix4 @@ -0,0 +1,7 @@ +# Makefile changes for SGI's running IRIX-4.x. +# Tell compiler to use K&R C. We can't compile under the SGI Ansi +# environment. Also bump switch table size so that cp-parse will +# compile. Bump string length limit so linker builds. + +CC = cc -cckr -Wf,-XNg1500 -Wf,-XNk1000 -Wf,-XNh2000 -Wf,-XNl8192 +SYSV = -DSYSV diff --git a/config/mh-irix5 b/config/mh-irix5 new file mode 100644 index 00000000000..8bd7c99f844 --- /dev/null +++ b/config/mh-irix5 @@ -0,0 +1,3 @@ +# Makefile changes for SGI's running IRIX-5.x. +SYSV = -DSYSV +RANLIB = true diff --git a/config/mh-irix6 b/config/mh-irix6 new file mode 100644 index 00000000000..6d25c16b2f4 --- /dev/null +++ b/config/mh-irix6 @@ -0,0 +1,7 @@ +# Makefile changes for SGI's running IRIX-6.x. +SYSV = -DSYSV +RANLIB = true +# Specify the ABI, to ensure that all Irix 6 systems will behave the same. +# Also, using -32 avoids bugs that exist in the n32/n64 support in some +# versions of the SGI compiler. +CC = cc -32 diff --git a/config/mh-lynxos b/config/mh-lynxos new file mode 100644 index 00000000000..9afcb79fca7 --- /dev/null +++ b/config/mh-lynxos @@ -0,0 +1,2 @@ +# /bin/cc is less than useful for our purposes. Always use GCC +CC = /bin/gcc diff --git a/config/mh-lynxrs6k b/config/mh-lynxrs6k new file mode 100644 index 00000000000..b2793996eff --- /dev/null +++ b/config/mh-lynxrs6k @@ -0,0 +1,8 @@ +# LynxOS running on the rs6000 doesn't have ranlib +RANLIB = true + +# /bin/cc is less than useful for our purposes. Always use GCC +CC = /usr/cygnus/progressive/bin/gcc + +# /bin/sh is too buggy, so use /bin/bash instead. +SHELL = /bin/bash diff --git a/config/mh-m68kpic b/config/mh-m68kpic new file mode 100644 index 00000000000..92e48d90fbd --- /dev/null +++ b/config/mh-m68kpic @@ -0,0 +1 @@ +PICFLAG=-fpic diff --git a/config/mh-ncr3000 b/config/mh-ncr3000 new file mode 100644 index 00000000000..5bbd8037009 --- /dev/null +++ b/config/mh-ncr3000 @@ -0,0 +1,17 @@ +# Host configuration file for an NCR 3000 (i486/SVR4) system. + +# The NCR 3000 ships with a MetaWare compiler installed as /bin/cc. +# This compiler not only emits obnoxious copyright messages every time +# you run it, but it chokes and dies on a whole bunch of GNU source +# files. Default to using the AT&T compiler installed in /usr/ccs/ATT/cc. +# Unfortunately though, the AT&T compiler sometimes generates code that +# the assembler barfs on if -g is used, so disable it by default as well. +CC = /usr/ccs/ATT/cc +CFLAGS = + +# Define SYSV as -DSYSV if you are using a System V operating system. +SYSV = -DSYSV -DSVR4 +RANLIB = true + +# The l flag generates a warning from the SVR4 archiver, remove it. +AR_FLAGS = cq diff --git a/config/mh-ncrsvr43 b/config/mh-ncrsvr43 new file mode 100644 index 00000000000..43b09912ca9 --- /dev/null +++ b/config/mh-ncrsvr43 @@ -0,0 +1,9 @@ +# Host configuration file for an NCR 3000 (i486/SVR43) system. + +# The MetaWare compiler will generate a copyright message unless you +# turn it off by adding the -Hnocopyr flag. +CC = cc -Hnocopyr + +# Define SYSV as -DSYSV if you are using a System V operating system. +SYSV = -DSYSV -DSVR4 +RANLIB = true diff --git a/config/mh-necv4 b/config/mh-necv4 new file mode 100644 index 00000000000..e887736f8be --- /dev/null +++ b/config/mh-necv4 @@ -0,0 +1,11 @@ +# Host Makefile fragment for NEC MIPS SVR4. + +# The C compiler on NEC MIPS SVR4 needs bigger tables. +CC = cc -ZXNd=5000 -ZXNg=1000 + +# Define SYSV as -DSYSV if you are using a System V operating system. +SYSV = -DSYSV -DSVR4 +RANLIB = true + +# NEC -lX11 needs some other libraries. +X11_EXTRA_LIBS = -lsocket -lnsl diff --git a/config/mh-papic b/config/mh-papic new file mode 100644 index 00000000000..35cf2c8ee4e --- /dev/null +++ b/config/mh-papic @@ -0,0 +1 @@ +PICFLAG=-fPIC diff --git a/config/mh-ppcpic b/config/mh-ppcpic new file mode 100644 index 00000000000..35cf2c8ee4e --- /dev/null +++ b/config/mh-ppcpic @@ -0,0 +1 @@ +PICFLAG=-fPIC diff --git a/config/mh-riscos b/config/mh-riscos new file mode 100644 index 00000000000..e586b30b1a9 --- /dev/null +++ b/config/mh-riscos @@ -0,0 +1,15 @@ +# This is for a MIPS running RISC/os 4.52C. + +# This is needed for GDB, but needs to be in the top-level make because +# if a library is compiled with the bsd headers and gets linked with the +# sysv system libraries all hell can break loose (e.g. a jmp_buf might be +# a different size). +# ptrace(2) apparently has problems in the BSD environment. No workaround is +# known except to select the sysv environment. Could we use /proc instead? +# These "sysv environments" and "bsd environments" often end up being a pain. +# +# This is not part of CFLAGS because perhaps not all C compilers have this +# option. +CC= cc -systype sysv + +RANLIB = true diff --git a/config/mh-sco b/config/mh-sco new file mode 100644 index 00000000000..cc337c98f93 --- /dev/null +++ b/config/mh-sco @@ -0,0 +1,10 @@ +# Define SYSV as -DSYSV if you are using a System V operating system. +SYSV = -DSYSV +RANLIB = true +# You may need this if you don't have bison. +# BISON = yacc -Sm10400 +# The native C compiler botches some simple uses of const. Unfortunately, +# it doesn't defined anything like "__sco__" for us to test for in ansidecl.h. +CC = cc -Dconst= + +X11_EXTRA_LIBS = -lsocket -lm -lintl -lmalloc diff --git a/config/mh-solaris b/config/mh-solaris new file mode 100644 index 00000000000..ddbea549b93 --- /dev/null +++ b/config/mh-solaris @@ -0,0 +1,6 @@ +# Makefile changes for Suns running Solaris 2 + +SYSV = -DSYSV +RANLIB = true + +X11_EXTRA_LIBS = -lnsl -lsocket diff --git a/config/mh-sparcpic b/config/mh-sparcpic new file mode 100644 index 00000000000..35cf2c8ee4e --- /dev/null +++ b/config/mh-sparcpic @@ -0,0 +1 @@ +PICFLAG=-fPIC diff --git a/config/mh-sun3 b/config/mh-sun3 new file mode 100644 index 00000000000..dcd5155b736 --- /dev/null +++ b/config/mh-sun3 @@ -0,0 +1,3 @@ +# Sun's C compiler needs the -J flag to be able to compile cp-parse.c +# without overflowing the jump tables (-J says to use a 32 bit table) +CC = cc -J diff --git a/config/mh-sysv b/config/mh-sysv new file mode 100644 index 00000000000..16b1187b447 --- /dev/null +++ b/config/mh-sysv @@ -0,0 +1,3 @@ +# Define SYSV as -DSYSV if you are using a System V operating system. +SYSV = -DSYSV +RANLIB = true diff --git a/config/mh-sysv4 b/config/mh-sysv4 new file mode 100644 index 00000000000..81066510600 --- /dev/null +++ b/config/mh-sysv4 @@ -0,0 +1,11 @@ +# Define SYSV as -DSYSV if you are using a System V operating system. +SYSV = -DSYSV -DSVR4 +RANLIB = true + +# C++ debugging is not yet supported under SVR4 (DWARF) +CXXFLAGS=-O + +# The l flag generates a warning from the SVR4 archiver, remove it. +AR_FLAGS = cr + +X11_EXTRA_LIBS = -lnsl diff --git a/config/mh-vaxult2 b/config/mh-vaxult2 new file mode 100644 index 00000000000..3de2dc8ffe3 --- /dev/null +++ b/config/mh-vaxult2 @@ -0,0 +1,2 @@ +# The old BSD pcc isn't up to compiling parts of gdb so use gcc +CC = gcc diff --git a/config/mh-windows b/config/mh-windows new file mode 100644 index 00000000000..a5cc5d611df --- /dev/null +++ b/config/mh-windows @@ -0,0 +1,16 @@ +CC=cc +CFLAGS= +RANLIB=true +AR_FLAGS= + +.PHONY: windows +windows: nmake.mak + @echo "Don't forget to setup setvars.mak!" + +nmake.mak: to-be-built + @echo Building nmake files + @$(srcdir)/gdb/mswin/genmakes + +to-be-built: + @echo Recording commands + @$(srcdir)/gdb/mswin/recordit diff --git a/config/mh-x86pic b/config/mh-x86pic new file mode 100644 index 00000000000..92e48d90fbd --- /dev/null +++ b/config/mh-x86pic @@ -0,0 +1 @@ +PICFLAG=-fpic diff --git a/config/mpw-mh-mpw b/config/mpw-mh-mpw new file mode 100644 index 00000000000..543ef4fb2a1 --- /dev/null +++ b/config/mpw-mh-mpw @@ -0,0 +1,157 @@ +# This is an MPW makefile fragment. + +# Since there are a multiplicity of Mac compilers and two different +# processors, this file is primarily a library of options for each +# compiler. Somebody else (such as a configure or build script) will +# make the actual choice. + +# Compiler to use for compiling. + +CC_MPW_C = C -d MPW_C -d ALMOST_STDC -d ANSI_PROTOTYPES -d MPW -mc68020 -model far -b -w + +CC_SC = SC -d ALMOST_STDC -d ANSI_PROTOTYPES -d MPW -mc68020 -model far -b -i '' -i : + +CC_MWC68K = MWC68K -d MPW -enum int -mpw_chars -sym on -w off -mc68020 -model far + +CC_PPCC = PPCC -d powerc=1 -d pascal= -d ALMOST_STDC -d ANSI_PROTOTYPES -d MPW -w + +CC_MRC = MrC -d powerc=1 -d pascal= -d ALMOST_STDC -d ANSI_PROTOTYPES -d MPW -i '' -i : -jm + +CC_SMrC = SMrC -d MPW + +# "-mpw_chars" is necessary because GNU sources often mix signed and +# unsigned casually. +# "-w off" is not a great idea, but CW7 is complaining about enum +# assignments. +# "-opt global,peep,l4,speed" is sometimes good, and sometimes bad. +# We must use {CIncludes} so that MPW tools will work; {MWCIncludes} +# defines stdout, islower, etc, in ways that are incompatible with MPW's +# runtime. However, this cannot be done via -i "{CIncludes}", since +# that does not affect how <>-type includes happen; instead, the variable +# MWCIncludes must be set to point at {CIncludes}. + +CC_MWCPPC = MWCPPC -d MPW -enum int -mpw_chars -sym on -w off + +# Note that GCC does *not* wire in a definition of "pascal", so that +# it can be handled in another way if desired. + +CC_68K_GCC = gC -Dpascal= -DANSI_PROTOTYPES -DMPW + +CC_PPC_GCC = gC -Dpowerc=1 -Dpascal= -DANSI_PROTOTYPES -DMPW + +# Nothing for the default CFLAGS. + +CFLAGS = + +# Tool to use for making libraries/archives. + +AR_LIB = Lib + +AR_MWLINK68K = MWLink68K -xm library + +AR_PPCLINK = PPCLink -xm library + +AR_MWLINKPPC = MWLinkPPC -xm library + +AR_AR = ar + +AR_FLAGS = -o + +RANLIB_NULL = null-command + +RANLIB_RANLIB = ranlib + +# Compiler and/or linker to use for linking. + +CC_LD_LINK = Link -w -d -model far {CC_LD_TOOL_FLAGS} + +CC_LD_MWLINK68K = MWLink68K -w {CC_LD_TOOL_FLAGS} -sym on -model far + +CC_LD_PPCLINK = PPCLink -main __start -outputformat xcoff + +CC_LD_MWLINKPPC = MWLinkPPC -w {CC_LD_TOOL_FLAGS} -sym on + +CC_LD_GLD = gC + +# Extension for linker output. + +PROG_EXT_68K = + +PROG_EXT_XCOFF = .xcoff + +# Nothing for the default LDFLAGS. + +LDFLAGS = -w + +CC_LD_TOOL_FLAGS = -c 'MPS ' -t MPST + +# Libraries to link against. + +# It would appear that the math libraries are not +# needed except to provide a definition for scalb, +# which is called from ldexp, which is referenced +# in the m68k opcodes library. + +EXTRALIBS_C = \Option-d + "{CLibraries}"StdClib.o \Option-d + "{CLibraries}"Math.o \Option-d + "{CLibraries}"CSANELib.o \Option-d + "{Libraries}"Stubs.o \Option-d + "{Libraries}"Runtime.o \Option-d + "{Libraries}"Interface.o \Option-d + "{Libraries}"ToolLibs.o + +EXTRALIBS_MWC68K = \Option-d + "{CLibraries}"StdClib.o \Option-d + "{CLibraries}"Math.o \Option-d + "{CLibraries}"CSANELib.o \Option-d + "{Libraries}"Stubs.o \Option-d + "{Libraries}"Runtime.o \Option-d + "{Libraries}"Interface.o \Option-d + "{Libraries}"ToolLibs.o \Option-d + "{MW68KLibraries}MPW ANSI (4i) C.68K.Lib" + +EXTRALIBS_PPC_XCOFF = \Option-d + "{PPCLibraries}"StdCRuntime.o \Option-d + "{PPCLibraries}"InterfaceLib.xcoff \Option-d + "{PPCLibraries}"MathLib.xcoff \Option-d + "{PPCLibraries}"StdCLib.xcoff \Option-d + "{PPCLibraries}"PPCToolLibs.o \Option-d + "{PPCLibraries}"PPCCRuntime.o \Option-d + "{GCCPPCLibraries}"libgcc.xcoff + +EXTRALIBS_PPC = \Option-d + "{PPCLibraries}"StdCRuntime.o \Option-d + "{SharedLibraries}"InterfaceLib \Option-d + "{SharedLibraries}"MathLib \Option-d + "{SharedLibraries}"StdCLib \Option-d + "{PPCLibraries}"PPCToolLibs.o \Option-d + "{PPCLibraries}"PPCCRuntime.o \Option-d + "{GCCPPCLibraries}"libgcc.xcoff + +EXTRALIBS_MWCPPC = \Option-d + "{MWPPCLibraries}"MWStdCRuntime.Lib \Option-d + "{MWPPCLibraries}"InterfaceLib \Option-d + "{MWPPCLibraries}"StdCLib \Option-d + "{MWPPCLibraries}"MathLib \Option-d + "{MWPPCLibraries}"PPCToolLibs.o + +# Tool to make PEF with, if needed. + +MAKEPEF_NULL = null-command + +MAKEPEF_PPC = MakePEF + +MAKEPEF_FLAGS = \Option-d + -l InterfaceLib.xcoff=InterfaceLib \Option-d + -l MathLib.xcoff=MathLib \Option-d + -l StdCLib.xcoff=StdCLib + +MAKEPEF_TOOL_FLAGS = -ft MPST -fc 'MPS ' + +# Resource compiler to use. + +REZ_68K = Rez + +REZ_PPC = Rez -d WANT_CFRG + diff --git a/config/mpw/ChangeLog b/config/mpw/ChangeLog new file mode 100644 index 00000000000..3cdefbf7a75 --- /dev/null +++ b/config/mpw/ChangeLog @@ -0,0 +1,53 @@ +Tue Nov 26 12:34:12 1996 Stan Shebs + + * g-mpw-make.sed: Fix some comments. + +Mon Sep 16 14:42:52 1996 Stan Shebs + + * g-mpw-make.sed (HLDENV): Edit out all references. + +Thu Aug 15 19:49:23 1996 Stan Shebs + + * true: New script, identical to mpw-true. + * g-mpw-make.sed: Add @DASH_C_FLAG@ and @SEGMENT_FLAG()@ + to the editors for compile commands. + +Thu Aug 1 15:01:42 1996 Stan Shebs + + * mpw-true, mpw-touch, null-command: New scripts. + * README: Describe usage in more detail. + +Tue Dec 12 14:51:51 1995 Stan Shebs + + * g-mpw-make.sed: Don't edit out "version=" occurrences. + +Fri Dec 1 11:46:18 1995 Stan Shebs + + * g-mpw-make.sed (bindir, libdir): Edit the positions of + pathname separators to work with other pathnames better. + +Tue Nov 7 15:08:07 1995 Stan Shebs + + * g-mpw-make.sed: Add comment about Duplicate vs Catenate, + add additional pattern for editing link-compile commands. + +Tue Oct 24 14:28:51 1995 Stan Shebs + + * g-mpw-make.sed: Add handling for *.tab.[hc] files. + (CHILL_FOR_TARGET, CHILL_LIB): Edit out tricky definitions + of these. + +Thu Sep 28 21:05:10 1995 Stan Shebs + + * g-mpw-make.sed: New file, generic sed commands to translate + Unix makefiles into MPW makefile syntax. + +Fri Mar 17 11:51:20 1995 Stan Shebs + + * README: Clarify instructions. + * fi: Remove. + +Wed Dec 21 15:45:53 1994 Stan Shebs + + * MoveIfChange, README, fi, forward-include, open-brace, + tr-7to8-src: New files. diff --git a/config/mpw/MoveIfChange b/config/mpw/MoveIfChange new file mode 100644 index 00000000000..0dbc12582f5 --- /dev/null +++ b/config/mpw/MoveIfChange @@ -0,0 +1,19 @@ +# Rename a file only if it is different from a previously existing +# file of the same name. This is useful for keeping make from doing +# too much work if the contents of a file haven't changed. + +# This is an MPW translation of the standard GNU sh script move-if-change. + +Set exit 0 + +If "`exists -f "{2}"`" + Compare "{1}" "{2}" >dev:null + If {status} != 0 + Rename -y "{1}" "{2}" + Else + Echo "{2}" is unchanged + Delete -i -y "{1}" + End +Else + Rename -y "{1}" "{2}" +End diff --git a/config/mpw/README b/config/mpw/README new file mode 100644 index 00000000000..554700adc81 --- /dev/null +++ b/config/mpw/README @@ -0,0 +1,23 @@ +This directory contains MPW scripts and related files that are needed to +build Cygnus GNU tools for MPW. The scripts should be somewhere on the +command path; our usual practice has been to have a separate directory +for the scripts, and put the tools (byacc, flex, and sed at least) there +also; then it's easier to drag the support bits around as a group, or to +upgrade MPW versions. The complete package of scripts and tool binaries +is usually available as pub/mac/buildtools.cpt.hqx on ftp.cygnus.com. + +"tr-7to8-src" is actually the source to an MPW script that transforms +sequences like "\Option-d" into the actual 8-bit chars that MPW needs. +It's only the source because it can't itself include any 8-bit chars. +It *can* be processed into a genuine "tr-7to8" by using itself: + + tr-7to8 tr-7to8-src | sed -e 's/Src//' >new-tr-7to8 + +Use this to verify: + + compare tr-7to8 new-tr-7to8 + +If you don't have a working tr-7to8, then you will have to manually +replace all occurrences of "\Option-d" with real Option-d (which looks +like a delta), then do similarly with all the other "\Option-..." +strings, and then change "\SrcOption-d" into the string "\Option-d". diff --git a/config/mpw/forward-include b/config/mpw/forward-include new file mode 100644 index 00000000000..ddd6bd71105 --- /dev/null +++ b/config/mpw/forward-include @@ -0,0 +1,3 @@ +Echo '#include' ¶""{1}"¶" >"{2}".tem +MoveIfChange "{2}".tem "{2}" + diff --git a/config/mpw/g-mpw-make.sed b/config/mpw/g-mpw-make.sed new file mode 100644 index 00000000000..e7d3c770736 --- /dev/null +++ b/config/mpw/g-mpw-make.sed @@ -0,0 +1,293 @@ +# Sed commands to translate Unix makefiles into MPW makefiles. +# These are nominally generic, but work best on the makefiles used +# for GNU programs. + +# Whack out any commented-out lines that are probably commands; +# they can only cause trouble later on. +/^# /d + +# Change dependency char. +/:$/s/:/ \\Option-f/g +/^[^ :#][^:]*:/s/\([ ]*\):\([ ]*\)/ \\Option-f /g + +# Change syntax of Makefile vars. +/\$/s/\${\([a-zA-Z0-9_-]*\)}/{\1}/g +/\$/s/\$(\([a-zA-Z0-9_-]*\))/{\1}/g +/ $@/s/ $@/ {Targ}/ + +# Double-$ are literals to Unix but not to MPW make. +/\$\$/s/\$\$/$/g + +# Change pathname syntax. +/\//s,\.\./\/\.\./,:::,g +/\//s,\.\./,::,g +/\.\//s,\./,:,g +/\//s,/,:,g +# Undo excess changes. +/and/s,and:or$,and/or, +/and/s,and:or ,and/or , +/want/s,want:need,want/need, +# Fixing up sed commands. +/-e/s_":\([^:]*\):d"_"/\1/d"_g +/-e/s_":\([^:]*\):,:\([^:]*\):d"_"/\1/,/\2/d"_g + +/=/s/ = \.$/ = :/ + +# Make these go away so that later edits not confused. +/HLDENV/s/{HLDENV}// + +# Comment out any explicit srcdir setting. +/srcdir/s/^srcdir/# srcdir/ + +/BASEDIR/s/^BASEDIR =.*$/BASEDIR = "{srcroot}"/ +/{BASEDIR}:/s/{BASEDIR}:/{BASEDIR}/g +/{srcdir}:/s/{srcdir}:/"{srcdir}"/g +/"{srcdir}":/s/"{srcdir}":/"{srcdir}"/g + +# Tweak some conventions that are backwards for the Mac. +/bindir/s/{exec_prefix}:bin/{exec_prefix}bin:/ +/libdir/s/{exec_prefix}:lib/{exec_prefix}lib:/ + +# Comment out settings of anything set by mpw host config. +/CC/s/^CC *=/#CC =/ +/CFLAGS/s/^CFLAGS *=/#CFLAGS =/ +/AR/s/^AR *=/#AR =/ +/AR_FLAGS/s/^AR_FLAGS *=/#AR_FLAGS =/ +/RANLIB/s/^RANLIB *=/#RANLIB =/ +/CC_LD/s/^CC_LD *=/#CC_LD =/ +/LDFLAGS/s/^LDFLAGS *=/#LDFLAGS =/ + +# Change -I usages. +/-I/s/-I\./-i :/g +/-I/s/-I::bfd/-i ::bfd:/g +/-I/s/-I::include/-i ::include:/g +/-I/s/-I/-i /g + +# Change -D usage. +/-D/s/\([ =]\)-D\([^ ]*\)/\1-d \2/g + +# Change continuation char. +/\\$/s/\\$/\\Option-d/ + +# Change wildcard char. +/\*/s/\*/\\Option-x/g + +# Change path of various types of source files. This rule does not allow +# for file names with multiple dots in the name. +/\.[chly]/s/\([ ><=]\)\([-a-zA-Z0-9_${}:"]*\)\.\([chly]\)/\1"{s}"\2.\3/g +/\.[chly]/s/^\([-a-zA-Z0-9_${}:"]*\)\.\([chly]\)/"{s}"\1.\2/ +# Allow files named *.tab.[ch] as a special case. +/\.tab\.[ch]/s/\([ ><=]\)\([-a-zA-Z0-9_${}:"]*\.tab\)\.\([ch]\)/\1"{s}"\2.\3/g +/\.tab\.[ch]/s/^\([-a-zA-Z0-9_${}:"]*\.tab\)\.\([ch]\)/"{s}"\1.\2/ +# Fix some overenthusiasms. +/{s}/s/"{s}""{srcdir}"/"{srcdir}"/g +/{s}/s/"{s}"{\([a-zA-Z0-9_]*\)dir}/"{\1dir}"/g +/{s}/s/"{s}"{\([a-zA-Z0-9_]*\)DIR}/"{\1DIR}"/g +/{s}/s/"{s}""{\([a-zA-Z0-9_]*\)dir}"/"{\1dir}"/g +/{s}/s/"{s}""{\([a-zA-Z0-9_]*\)DIR}"/"{\1DIR}"/g +/{s}/s/"{s}":/:/g +/{s}/s/^"{s}"//g +/{s}/s/"{s}""{s}"/"{s}"/g +/{s}/s/"{s}""{srcdir}"/"{s}"/g +/{s}/s/"{srcdir}""{s}"/"{s}"/g + +# The .def files are also typically source files. +/\.def/s/\([ ><]\)\([-a-zA-Z0-9_${}:"]*\)\.def/\1"{s}"\2.def/g +/\.def/s/^\([-a-zA-Z0-9_${}:"]*\)\.def/"{s}"\1.def/g + +# Change extension and path of objects. +/\.o/s/\([ =]\)\([-a-zA-Z0-9_${}:"]*\)\.o/\1"{o}"\2.c.o/g +/\.o/s/^\([-a-zA-Z0-9_${}:"]*\)\.o/"{o}"\1.c.o/ +# Allow *.tab.o files as a special case of a 2-dot-name file. +/\.o/s/\([ =]\)\([-a-zA-Z0-9_${}:"]*\)\.tab\.o/\1"{o}"\2.tab.c.o/g +/\.o/s/^\([-a-zA-Z0-9_${}:"]*\)\.tab\.o/"{o}"\1.tab.c.o/ +# Clean up. +/"{o}"/s/"{o}""{o}"/"{o}"/g +/"{o}"/s/^"{o}"\([a-zA-Z0-9_]*\)=/\1=/ + +# Change extension of libs. +/\.a/s/lib\([a-z]*\)\.a/lib\1.o/g + +# Remove non-fail option. +/-/s/^\([ ]*\)-/\1/ +# Fix overeagernesses - assumes no one-letter commands. +/^[ ]*[a-z] /s/^\([ ]*\)\([a-z]\) /\1-\2 / + +# Remove non-echo option. (watch out for autoconf things) +/@/s/^\([ ]*\)@/\1/ + +# Change cp to Duplicate. +# Catenate is perhaps more accurate, but the pattern would have to +# identify the output file and add a '>' redirection into it. +/cp/s/^\([ ]*\)cp /\1Duplicate -d -y / +# Change mv to Rename. +/mv/s/^\([ ]*\)mv /\1Rename -y / +/Rename/s/^\([ ]*\)Rename -y -f/\1Rename -y/ +# Change rm to Delete. +/rm -rf/s/^\([ ]*\)rm -rf /\1Delete -i -y / +/rm -f/s/^\([ ]*\)rm -f /\1Delete -i -y / +/rm/s/^\([ ]*\)rm /\1Delete -i -y / +# Note that we don't mess with ln - directory-specific scripts +# must decide what to do with symlinks. +# Change cat to Catenate. +/cat/s/^\([ ]*\)cat /\1Catenate / +# Change touch to mpw-touch. +/touch/s/^\([ ]*\)touch /\1mpw-touch / +# Change mkdir to NewFolder. +/mkdir/s/^\([ ]*\)mkdir /\1NewFolder / +# Change var setting to Set. +/=/s/^\([ ]*\)\([-a-zA-Z0-9_]*\)=\([^;]*\); \\Option-d/\1Set \2 \3/ + +# Change tests. +/if /s/if \[ *-f \([^ ]*\) ] *; *\\Option-d/If "`Exists "\1"`" != ""/ +/if /s/if \[ *-f \([^ ]*\) ] *; *then *\\Option-d/If "`Exists "\1"`" != ""/ +/if /s/if \[ ! *-f \([^ ]*\) ] *; *\\Option-d/If "`Exists "\1"`" == ""/ +/if /s/if \[ ! *-f \([^ ]*\) ] *; *then \\Option-d/If "`Exists "\1"`" == ""/ + +/if /s/if \[ *-d \([^ ]*\) ] *; *\\Option-d/If "`Exists "\1"`" != ""/ +/if /s/if \[ *-d \([^ ]*\) ] *; *then *\\Option-d/If "`Exists "\1"`" != ""/ +/if /s/if \[ ! *-d \([^ ]*\) ] *; *\\Option-d/If "`Exists "\1"`" == ""/ +/if /s/if \[ ! *-d \([^ ]*\) ] *; *then *\\Option-d/If "`Exists "\1"`" == ""/ + +/if /s/if \[ -d \([^ ]*\) ] *; then true *; else mkdir \([^ ;]*\) *; fi/If "`Exists "\1"`" != "" NewFolder \2 End If/ + +/if /s/if \[ \([^ ]*\) = \([^ ]*\) ] *; *\\Option-d/If "\1" == "\2"/ +/if /s/if \[ \([^ ]*\) = \([^ ]*\) ] *; *then *\\Option-d/If "\1" == "\2"/ + +/if /s/if \[ \([^ ]*\) != \([^ ]*\) ] *; *\\Option-d/If "\1" != "\2"/ +/if /s/if \[ \([^ ]*\) != \([^ ]*\) ] *; *then *\\Option-d/If "\1" != "\2"/ + +/if /s/if \[ \([^ ]*\) -eq \([^ ]*\) ] *; *\\Option-d/If "\1" != "\2"/ +/if /s/if \[ \([^ ]*\) -eq \([^ ]*\) ] *; *then *\\Option-d/If "\1" != "\2"/ + +/^[ ]*else true$/c\ + Else\ + mpw-true\ + + +/else/s/^\([ ]*\)else[ ]*$/\1Else/ +/else/s/^\([ ]*\)else[; ]*\\Option-d$/\1Else/ + +/^[ ]*else[ ]*true[ ]*$/c\ + Else\ + mpw-true + +/^[ ]*else[ ]*true[; ]*fi$/c\ + Else\ + mpw-true\ + End If + +/fi/s/^\([ ]*\)fi *$/\1End/ +/fi/s/^\([ ]*\)fi *; *\\Option-d/\1End/ + +# Change looping. +/for/s/^\([ ]*\)for \([-a-zA-Z0-9_]*\) in \([^;]*\); *do *\\Option-d/\1For \2 In \3/ +/^\([ ]*\)do *\\Option-d/d +/done/s/^\([ ]*\)done *; *\\Option-d/\1End/ +/done/s/^\([ ]*\)done$/\1End/ + +# Trailing semicolons and continued lines are unneeded sh syntax. +/; \\Option-d/s/; \\Option-d// + +# Change move-if-change to MoveIfChange. +/move-if-change/s/\([^ ]*\)move-if-change/MoveIfChange/g + +# Change $(SHELL) to the script name by itself. +/SHELL/s/^\([ ]*\){SHELL} /\1/ + +# Change syntax of default rule dependency. +/^\.c\.o/s/^\.c\.o \\Option-f$/.c.o \\Option-f .c/ + +# Change default rule's action. +/{CC} -c/s/{CC} -c \(.*\) \$<$/{CC} @DASH_C_FLAG@ {DepDir}{Default}.c \1 @SEGMENT_FLAG({Default})@ -o {TargDir}{Default}.c.o/ + +# This is pretty disgusting, but I can't seem to detect empty rules. +/Option-f$/s/Option-f$/Option-f _oldest/g + +# Remove -c from explicit compiler calls. (but should not if GCC) +# Handle the case of a source file that is "{xxx}"file.c. +/ -c /s/{\([A-Z_]*\)CC}\(.*\) -c \(.*\)"\([^"]*\)"\([-a-z_]*\)\.c/{\1CC}\2 @DASH_C_FLAG@ \3"\4"\5.c -o "{o}"\5.c.o/ +# Handle the case of a source file that is "{xxx}"dir:file.c. +/ -c /s/{\([A-Z_]*\)CC}\(.*\) -c \(.*\)"\([^"]*\)"\([-a-z_]*\):\([-a-z_]*\)\.c/{\1CC}\2 @DASH_C_FLAG@ \3"\4"\5:\6.c -o "{o}"\6.c.o/ + +# Change linking cc to linking sequence. +/-o/s/^\([ ]*\){CC} \(.*\){\([A-Z_]*\)CFLAGS} \(.*\){LDFLAGS} \(.*\)-o \([^ ]*\) \(.*\)$/\1{CC_LD} \2 {\3CFLAGS} \4 {LDFLAGS} \5 -o \6{PROG_EXT} \7\ +\1{MAKEPEF} \6{PROG_EXT} -o \6 {MAKEPEF_TOOL_FLAGS} {MAKEPEF_FLAGS}\ +\1{REZ} "{s}"\6.r -o \6 -append -d PROG_NAME='"'\6'"' -d VERSION_STRING='"'{version}'"'/ +/-o/s/^\([ ]*\){CC} \(.*\){\([A-Z_]*\)CFLAGS} \(.*\)-o \([^ ]*\) \(.*\){LDFLAGS} \(.*\)$/\1{CC_LD} \2 {\3CFLAGS} \4 {LDFLAGS} \6 -o \5{PROG_EXT} \7\ +\1{MAKEPEF} \5{PROG_EXT} -o \5 {MAKEPEF_TOOL_FLAGS} {MAKEPEF_FLAGS}\ +\1{REZ} "{s}"\5.r -o \5 -append -d PROG_NAME='"'\5'"' -d VERSION_STRING='"'{version}'"'/ +/-o/s/^\([ ]*\){HOST_CC} \(.*\)-o \([^ ]*\) \(.*\)$/\1{HOST_CC_LD} \2 -o \3{PROG_EXT} \4\ +\1{MAKEPEF} \3{PROG_EXT} -o \3 {MAKEPEF_TOOL_FLAGS} {MAKEPEF_FLAGS}\ +\1{REZ} "{s}"\3.r -o \3 -append -d PROG_NAME='"'\3'"' -d VERSION_STRING='"'{version}'"'/ + +# Comment out .NOEXPORT rules. +/\.NOEXPORT/s/^\.NOEXPORT/#\.NOEXPORT/ +# Comment out .PHONY rules. +/\.PHONY/s/^\.PHONY/#\.PHONY/ +# Comment out .PRECIOUS rules. +/\.PRECIOUS/s/^\.PRECIOUS/#\.PRECIOUS/ +# Comment out .SUFFIXES rules. +/\.SUFFIXES/s/^\.SUFFIXES/#\.SUFFIXES/ + +# Set the install program appropriately. +/INSTALL/s/^INSTALL *= *`.*`:install.sh -c/INSTALL = Duplicate -y/ + +# Don't try to decide whether to use the tree's own tools. +/bison/s/`.*bison:bison.*`/bison -y/ +/byacc/s/`.*byacc:byacc.*`/byacc/ +/flex/s/`.*flex:flex.*`/flex/ + +# Turn transformed C comments in echo commands back into comments. +/echo/s,echo '\(.*\):\\Option-x\(.*\)\\Option-x:\(.*\)',echo '\1/*\2*/\3', + +# Whack out various clever expressions that search for tools, since +# the clever code is too /bin/sh specific. + +/^AR_FOR_TARGET = `/,/`$/c\ +AR_FOR_TARGET = ::binutils:ar\ + + +/^RANLIB_FOR_TARGET = `/,/`$/c\ +RANLIB_FOR_TARGET = ::binutils:ranlib\ + + +/^RANLIB_TEST_FOR_TARGET = /,/ranlib ] )$/c\ +RANLIB_TEST_FOR_TARGET = \ + + +/^EXPECT = `/,/`$/c\ +EXPECT = \ + + +/^RUNTEST = `/,/`$/c\ +RUNTEST = \ + + +/^CC_FOR_TARGET = `/,/`$/c\ +CC_FOR_TARGET = \ + + +/^CXX_FOR_TARGET = `/,/`$/c\ +CXX_FOR_TARGET = \ + + +/^CHILL_FOR_TARGET = `/,/`$/c\ +CHILL_FOR_TARGET = \ + + +/^CHILL_LIB = `/,/`$/c\ +CHILL_LIB = \ + +/sanit/s/{start-sanit...-[a-z0-9]*}// +/sanit/s/{end-sanit...-[a-z0-9]*}// + +# Add standard defines and default rules. +/^# srcdir/a\ +\ +s = "{srcdir}"\ +\ +o = :\ +\ +"{o}" \\Option-f : "{s}" + diff --git a/config/mpw/mpw-touch b/config/mpw/mpw-touch new file mode 100644 index 00000000000..c743a5122b5 --- /dev/null +++ b/config/mpw/mpw-touch @@ -0,0 +1,7 @@ +# "Touch" command. + +If "`Exists "{1}"`" != "" + SetFile -m . "{1}" +Else + Echo ' ' > "{1}" +End If diff --git a/config/mpw/mpw-true b/config/mpw/mpw-true new file mode 100644 index 00000000000..0506530d3c6 --- /dev/null +++ b/config/mpw/mpw-true @@ -0,0 +1 @@ +Exit 0 diff --git a/config/mpw/null-command b/config/mpw/null-command new file mode 100644 index 00000000000..4844c8ec553 --- /dev/null +++ b/config/mpw/null-command @@ -0,0 +1 @@ +# This command does nothing. diff --git a/config/mpw/open-brace b/config/mpw/open-brace new file mode 100644 index 00000000000..58465dcc18c --- /dev/null +++ b/config/mpw/open-brace @@ -0,0 +1,4 @@ +# MPW makefiles seem not to have any way to get a literal open +# brace into a rule anywhere, so this does the job. + +Echo '{' diff --git a/config/mpw/tr-7to8-src b/config/mpw/tr-7to8-src new file mode 100644 index 00000000000..b20b649c895 --- /dev/null +++ b/config/mpw/tr-7to8-src @@ -0,0 +1,9 @@ +StreamEdit -e \Option-d + '/\Option-x/ \Option-d + Replace /\Option-d\SrcOption-d/ "\Option-d\Option-d" -c \Option-5 ; \Option-d + Replace /\Option-d\SrcOption-f/ "\Option-d\Option-f" -c \Option-5 ; \Option-d + Replace /\Option-d\SrcOption-8/ "\Option-d\Option-8" -c \Option-5 ; \Option-d + Replace /\Option-d\SrcOption-5/ "\Option-d\Option-5" -c \Option-5 ; \Option-d + Replace /\Option-d\SrcOption-x/ "\Option-d\Option-x" -c \Option-5 ; \Option-d + Replace /\Option-d\SrcOption-r/ "\Option-d\Option-r" -c \Option-5' \Option-d + "{1}" diff --git a/config/mpw/true b/config/mpw/true new file mode 100644 index 00000000000..0506530d3c6 --- /dev/null +++ b/config/mpw/true @@ -0,0 +1 @@ +Exit 0 diff --git a/config/mt-m68kpic b/config/mt-m68kpic new file mode 100644 index 00000000000..ff987275575 --- /dev/null +++ b/config/mt-m68kpic @@ -0,0 +1 @@ +PICFLAG_FOR_TARGET=-fpic diff --git a/config/mt-netware b/config/mt-netware new file mode 100644 index 00000000000..9482f9b36d2 --- /dev/null +++ b/config/mt-netware @@ -0,0 +1 @@ +GDB_NLM_DEPS = all-gcc all-ld diff --git a/config/mt-papic b/config/mt-papic new file mode 100644 index 00000000000..35b8c9e4dc2 --- /dev/null +++ b/config/mt-papic @@ -0,0 +1 @@ +PICFLAG_FOR_TARGET=-fPIC diff --git a/config/mt-ppcpic b/config/mt-ppcpic new file mode 100644 index 00000000000..35b8c9e4dc2 --- /dev/null +++ b/config/mt-ppcpic @@ -0,0 +1 @@ +PICFLAG_FOR_TARGET=-fPIC diff --git a/config/mt-sparcpic b/config/mt-sparcpic new file mode 100644 index 00000000000..35b8c9e4dc2 --- /dev/null +++ b/config/mt-sparcpic @@ -0,0 +1 @@ +PICFLAG_FOR_TARGET=-fPIC diff --git a/config/mt-v810 b/config/mt-v810 new file mode 100644 index 00000000000..97da6c26592 --- /dev/null +++ b/config/mt-v810 @@ -0,0 +1,4 @@ +CC_FOR_TARGET = ca732 -ansi +AS_FOR_TARGET = as732 +AR_FOR_TARGET = ar732 +RANLIB_FOR_TARGET = true diff --git a/config/mt-x86pic b/config/mt-x86pic new file mode 100644 index 00000000000..ff987275575 --- /dev/null +++ b/config/mt-x86pic @@ -0,0 +1 @@ +PICFLAG_FOR_TARGET=-fpic diff --git a/configure b/configure new file mode 100755 index 00000000000..e168e94002d --- /dev/null +++ b/configure @@ -0,0 +1,1406 @@ +#!/bin/sh + +### WARNING: this file contains embedded tabs. Do not run untabify on this file. + +# Configuration script +# Copyright (C) 1988, 90, 91, 92, 93, 94, 95, 96, 1997 +# Free Software Foundation, Inc. + +# 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. + +# This file was originally written by K. Richard Pixley. + +# +# Shell script to create proper links to machine-dependent files in +# preparation for compilation. +# +# If configure succeeds, it leaves its status in config.status. +# If configure fails after disturbing the status quo, +# config.status is removed. +# + +export PATH || (echo "OOPS, this isn't sh. Desperation time. I will feed myself to sh."; sh $0 $argv; kill $$) + +remove=rm +hard_link=ln +symbolic_link='ln -s' + +#for Test +#remove="echo rm" +#hard_link="echo ln" +#symbolic_link="echo ln -s" + +# clear some things potentially inherited from environment. + +Makefile=Makefile +Makefile_in=Makefile.in +arguments= +build_alias= +cache_file=config.cache +cache_file_option= +configdirs= +exec_prefix= +exec_prefixoption= +fatal= +floating_point=default +gas=default +host_alias=NOHOST +host_makefile_frag= +moveifchange= +norecursion= +other_options= +package_makefile_frag= +prefix=/usr/local +progname= +program_prefix= +program_prefixoption= +program_suffix= +program_suffixoption= +program_transform_name= +program_transform_nameoption= +redirect=">/dev/null" +removing= +site= +site_makefile_frag= +site_option= +srcdir= +srctrigger= +subdirs= +target_alias=NOTARGET +target_makefile_frag= +undefs=NOUNDEFS +version="$Revision: 1.244 $" +x11=default + +### we might need to use some other shell than /bin/sh for running subshells + +### If we are on Windows, search for the shell. This will permit people +### to not have /bin/sh, but to be able to see /SOME/PATH/sh configure +### without also having to set CONFIG_SHELL. This code will work when +### using bash, which sets OSTYPE. +case "${OSTYPE}" in +*win32*) + if [ x${CONFIG_SHELL} = x ]; then + if [ ! -f /bin/sh ]; then + if [ x${SHELL} != x ] && [ -f ${SHELL} ]; then + CONFIG_SHELL=${SHELL} + export CONFIG_SHELL + else + for prog in sh sh.exe bash bash.exe; do + IFS="${IFS= }"; save_ifs="$IFS"; IFS="${IFS}:" + for dir in $PATH; do + test -z "$dir" && dir=. + if test -f $dir/$prog; then + CONFIG_SHELL=$dir/$prog + export CONFIG_SHELL + break + fi + done + IFS="$save_ifs" + test -n "${CONFIG_SHELL}" && break + done + fi + fi + fi + ;; +esac + +config_shell=${CONFIG_SHELL-/bin/sh} + +NO_EDIT="This file was generated automatically by configure. Do not edit." + +## this is a little touchy and won't always work, but... +## +## if the argv[0] starts with a slash then it is an absolute name that can (and +## must) be used as is. +## +## otherwise, if argv[0] has no slash in it, we can assume that it is on the +## path. Since PATH might include "." we also add `pwd` to the end of PATH. +## + +progname=$0 +# if PWD already has a value, it is probably wrong. +if [ -n "$PWD" ]; then PWD=`pwd`; fi + +case "${progname}" in +/*) ;; +*/*) ;; +*) + PATH=$PATH:${PWD=`pwd`} ; export PATH + ;; +esac + +# Loop over all args + +while : +do + +# Break out if there are no more args + case $# in + 0) + break + ;; + esac + +# Get the first arg, and shuffle + option=$1 + shift + +# Make all options have two hyphens + orig_option=$option # Save original for error messages + case $option in + --*) ;; + -*) option=-$option ;; + esac + +# Split out the argument for options that take them + case $option in + --*=*) + optarg=`echo $option | sed -e 's/^[^=]*=//'` + arguments="$arguments $option" + ;; +# These options have mandatory values. Since we didn't find an = sign, +# the value must be in the next argument + --bu* | --cache* | --ex* | --ho* | --pre* | --program-p* | --program-s* | --program-t* | --si* | --sr* | --ta* | --tm* | --x-* | --bi* | --sb* | --li* | --da* | --sy* | --sh* | --lo* | --in* | --ol* | --ma*) + optarg=$1 + shift + arguments="$arguments $option=$optarg" + ;; + --v) + arguments="$arguments -v" + ;; + --*) + arguments="$arguments $option" + ;; + esac + +# Now, process the options + case $option in + + --build* | --bu*) + case "$build_alias" in + "") build_alias=$optarg ;; + *) echo '***' Can only configure for one build machine at a time. 1>&2 + fatal=yes + ;; + esac + ;; + --cache*) + cache_file=$optarg + ;; + --disable-*) + enableopt=`echo ${option} | sed 's:^--disable-:enable_:;s:-:_:g'` + eval $enableopt=no + disableoptions="$disableoptions $option" + ;; + --enable-*) + case "$option" in + *=*) ;; + *) optarg=yes ;; + esac + + enableopt=`echo ${option} | sed 's:^--::;s:=.*$::;s:-:_:g'` + eval "$enableopt='$optarg'" + enableoptions="$enableoptions '$option'" + ;; + --exec-prefix* | --ex*) + exec_prefix=$optarg + exec_prefixoption="--exec-prefix=$optarg" + ;; + --gas | --g*) + gas=yes + ;; + --help | --he*) + fatal=yes + ;; + --host* | --ho*) + case $host_alias in + NOHOST) host_alias=$optarg ;; + *) echo '***' Can only configure for one host at a time. 1>&2 + fatal=yes + ;; + esac + ;; + --nfp | --nf*) + floating_point=no + floating_pointoption="--nfp" + ;; + --norecursion | --no*) + norecursion=yes + ;; + --prefix* | --pre*) + prefix=$optarg + prefixoption="--prefix=$optarg" + ;; + --program-prefix* | --program-p*) + program_prefix=$optarg + program_prefixoption="--program-prefix=$optarg" + ;; + --program-suffix* | --program-s*) + program_suffix=$optarg + program_suffixoption="--program-suffix=$optarg" + ;; + --program-transform-name* | --program-t*) + # Double any backslashes or dollar signs in the argument + program_transform_name="${program_transform_name} -e `echo ${optarg} | sed -e 's/\\\\/\\\\\\\\/g' -e 's/\\\$/$$/g'`" + program_transform_nameoption="${program_transform_nameoption} --program-transform-name='$optarg'" + ;; + --rm) + removing=--rm + ;; + --silent | --sil* | --quiet | --q*) + redirect=">/dev/null" + verbose=--silent + ;; + --site* | --sit*) + site=$optarg + site_option="--site=$optarg" + ;; + --srcdir*/ | --sr*/) + # Remove trailing slashes. Otherwise, when the file name gets + # bolted into an object file as debug info, it has two slashes + # in it. Ordinarily this is ok, but emacs takes double slash + # to mean "forget the first part". + srcdir=`echo $optarg | sed -e 's:/$::'` + ;; + --srcdir* | --sr*) + srcdir=$optarg + ;; + --target* | --ta*) + case $target_alias in + NOTARGET) target_alias=$optarg ;; + *) echo '***' Can only configure for one target at a time. 1>&2 + fatal=yes + ;; + esac + ;; + --tmpdir* | --tm*) + TMPDIR=$optarg + tmpdiroption="--tmpdir=$optarg" + ;; + --verbose | --v | --verb*) + redirect= + verbose=--verbose + ;; + --version | --V | --vers*) + echo "This is Cygnus Configure version" `echo ${version} | sed 's/[ $:]//g'` + exit 0 + ;; + --with-*) + case "$option" in + *=*) ;; + *) optarg=yes ;; + esac + + withopt=`echo ${option} | sed 's:^--::;s:=.*$::;s:-:_:g'` + eval $withopt="$optarg" + withoptions="$withoptions $option" + ;; + --without-*) + withopt=`echo ${option} | sed 's:^--::;s:out::;s:-:_:g'` + eval $withopt=no + withoutoptions="$withoutoptions $option" + ;; + --x) with_x=yes + withoptions="$withoptions --with-x" + ;; + --x-i* | --x-l*) other_options="$other_options $orig_option" + ;; + --bi* | --sb* | --li* | --da* | --sy* | --sh* | --lo* | --in* | --ol* | --ma*) + # These options were added to autoconf for emacs. + ;; + --*) + echo "configure: Unrecognized option: \"$orig_option\"; use --help for usage." >&2 + exit 1 + ;; + *) + case $undefs in + NOUNDEFS) undefs=$option ;; + *) echo '***' Can only configure for one host and one target at a time. 1>&2 + fatal=yes + ;; + esac + ;; + esac +done + +# process host and target + +# Do some error checking and defaulting for the host and target type. +# The inputs are: +# configure --host=HOST --target=TARGET UNDEFS +# +# The rules are: +# 1. You aren't allowed to specify --host, --target, and undefs at the +# same time. +# 2. Host defaults to undefs. +# 3. If undefs is not specified, then host defaults to the current host, +# as determined by config.guess. +# 4. Target defaults to undefs. +# 5. If undefs is not specified, then target defaults to host. + +case "${fatal}" in +"") + # Make sure that host, target & undefs aren't all specified at the + # same time. + case $host_alias---$target_alias---$undefs in + NOHOST---*---* | *---NOTARGET---* | *---*---NOUNDEFS) + ;; + *) echo '***' Can only configure for one host and one target at a time. 1>&2 + fatal=yes + break 2 + ;; + esac + + # Now, do defaulting for host. + case $host_alias in + NOHOST) + case $undefs in + NOUNDEFS) + # Neither --host option nor undefs were present. + # Call config.guess. + guesssys=`echo ${progname} | sed 's/configure$/config.guess/'` + if host_alias=`${config_shell} ${guesssys}` + then + # If the string we are going to use for + # the target is a prefix of the string + # we just guessed for the host, then + # assume we are running native, and force + # the same string for both target and host. + case $target_alias in + NOTARGET) ;; + *) + if expr $host_alias : $target_alias >/dev/null + then + host_alias=$target_alias + fi + ;; + esac + echo "Configuring for a ${host_alias} host." 1>&2 + arguments="--host=$host_alias $arguments" + else + echo 'Config.guess failed to determine the host type. You need to specify one.' 1>&2 + fatal=yes + fi + ;; + *) + host_alias=$undefs + arguments="--host=$host_alias $arguments" + undefs=NOUNDEFS + ;; + esac + esac + + # Do defaulting for target. If --target option isn't present, default + # to undefs. If undefs isn't present, default to host. + case $target_alias in + NOTARGET) + case $undefs in + NOUNDEFS) + target_alias=$host_alias + ;; + *) + target_alias=$undefs + arguments="--target=$target_alias $arguments" + ;; + esac + esac + ;; +*) ;; +esac + +if [ -n "${fatal}" -o "${host_alias}" = "help" ] ; then + exec 1>&2 + echo Usage: configure [OPTIONS] [HOST] + echo + echo Options: [defaults in brackets] + echo ' --prefix=MYDIR install into MYDIR [/usr/local]' + echo ' --exec-prefix=MYDIR install host-dependent files into MYDIR [/usr/local]' + echo ' --help print this message [normal config]' + echo ' --build=BUILD configure for building on BUILD [BUILD=HOST]' + echo ' --host=HOST configure for HOST [determined via config.guess]' + echo ' --norecursion configure this directory only [recurse]' + echo ' --program-prefix=FOO prepend FOO to installed program names [""]' + echo ' --program-suffix=FOO append FOO to installed program names [""]' + echo ' --program-transform-name=P transform installed names by sed pattern P [""]' + echo ' --site=SITE configure with site-specific makefile for SITE' + echo ' --srcdir=DIR find the sources in DIR [. or ..]' + echo ' --target=TARGET configure for TARGET [TARGET=HOST]' + echo ' --tmpdir=TMPDIR create temporary files in TMPDIR [/tmp]' + echo ' --nfp configure for software floating point [hard float]' + echo ' --with-FOO, --with-FOO=BAR package FOO is available (parameter BAR)' + echo ' --without-FOO package FOO is NOT available' + echo ' --enable-FOO, --enable-FOO=BAR include feature FOO (parameter BAR)' + echo ' --disable-FOO do not include feature FOO' + echo + echo 'Where HOST and TARGET are something like "sparc-sunos", "mips-sgi-irix5", etc.' + echo + if [ -r config.status ] ; then + cat config.status + fi + + exit 1 +fi + +configsub=`echo ${progname} | sed 's/configure$/config.sub/'` +moveifchange=`echo ${progname} | sed 's/configure$/move-if-change/'` + +# this is a hack. sun4 must always be a valid host alias or this will fail. +if ${config_shell} ${configsub} sun4 >/dev/null 2>&1 ; then + true +else + echo '***' cannot find config.sub. 1>&2 + exit 1 +fi + +touch config.junk +if ${config_shell} ${moveifchange} config.junk config.trash ; then + true +else + echo '***' cannot find move-if-change. 1>&2 + exit 1 +fi +rm -f config.junk config.trash + +case "${srcdir}" in +"") + if [ -r configure.in ] ; then + srcdir=. + else + if [ -r ${progname}.in ] ; then + srcdir=`echo ${progname} | sed 's:/configure$::'` + else + echo '***' "Can't find configure.in. Try using --srcdir=some_dir" 1>&2 + exit 1 + fi + fi + ;; +*) + # Set srcdir to "." if that's what it is. + # This is important for multilib support. + if [ ! -d ${srcdir} ] ; then + echo "Invalid source directory ${srcdir}" >&2 + exit 1 + fi + pwd=`pwd` + srcpwd=`cd ${srcdir} ; pwd` + if [ "${pwd}" = "${srcpwd}" ] ; then + srcdir=. + fi +esac + +### warn about some conflicting configurations. + +case "${srcdir}" in +".") ;; +*) + if [ -f ${srcdir}/config.status ] ; then + echo '***' Cannot configure here in \"${PWD=`pwd`}\" when \"${srcdir}\" is currently configured. 1>&2 + exit 1 + fi +esac + +# default exec_prefix +case "${exec_prefixoption}" in +"") exec_prefix="\$(prefix)" ;; +*) ;; +esac + +### break up ${srcdir}/configure.in. +case "`grep '^# per\-host:' ${srcdir}/configure.in`" in +"") + echo '***' ${srcdir}/configure.in has no \"per-host:\" line. 1>&2 + # Check for a directory that's been converted to use autoconf since + # it was last configured. + if grep AC_OUTPUT ${srcdir}/configure.in >/dev/null ; then + echo '***' Hmm, looks like this directory has been autoconfiscated. 1>&2 + if [ -r ${srcdir}/configure ] ; then + echo '***' Running the local configure script. 1>&2 + case "${cache_file}" in + "") cache_file_option= ;; + *) cache_file_option="--cache-file=${cache_file}" ;; + esac + srcdiroption="--srcdir=${srcdir}" + case "${build_alias}" in + "") buildopt= ;; + *) buildopt="--build=${build_alias}" ;; + esac + eval exec ${config_shell} ${srcdir}/configure ${verbose} \ + ${buildopt} --host=${host_alias} --target=${target_alias} \ + ${prefixoption} ${tmpdiroption} ${exec_prefixoption} \ + ${srcdiroption} \ + ${program_prefixoption} ${program_suffixoption} \ + ${program_transform_nameoption} ${site_option} \ + ${withoptions} ${withoutoptions} \ + ${enableoptions} ${disableoptions} ${floating_pointoption} \ + ${cache_file_option} ${removing} ${other_options} ${redirect} + else + echo '***' There is no configure script present though. 1>&2 + fi + fi + exit 1 + ;; +*) ;; +esac + +case "`grep '^# per\-target:' ${srcdir}/configure.in`" in +"") + echo '***' ${srcdir}/configure.in has no \"per-target:\" line. 1>&2 + exit 1 + ;; +*) ;; +esac + +case "${TMPDIR}" in +"") TMPDIR=/tmp ; export TMPDIR ;; +*) ;; +esac + +# keep this filename short for &%*%$*# 14 char file names +tmpfile=${TMPDIR}/cONf$$ +# Note that under many versions of sh a trap handler for 0 will *override* any +# exit status you explicitly specify! At this point, the only non-error exit +# is at the end of the script; these actions are duplicated there, minus +# the "exit 1". Don't use "exit 0" anywhere after this without resetting the +# trap handler, or you'll lose. +trap "rm -f Makefile.tem ${tmpfile}.com ${tmpfile}.tgt ${tmpfile}.hst ${tmpfile}.pos; exit 1" 0 1 2 15 + +# split ${srcdir}/configure.in into common, per-host, per-target, +# and post-target parts. Post-target is optional. +sed -e '/^# per\-host:/,$d' ${srcdir}/configure.in > ${tmpfile}.com +sed -e '1,/^# per\-host:/d' -e '/^# per\-target:/,$d' ${srcdir}/configure.in > ${tmpfile}.hst +if grep '^# post-target:' ${srcdir}/configure.in >/dev/null ; then + sed -e '1,/^# per\-target:/d' -e '/^# post\-target:/,$d' ${srcdir}/configure.in > ${tmpfile}.tgt + sed -e '1,/^# post\-target:/d' ${srcdir}/configure.in > ${tmpfile}.pos +else + sed -e '1,/^# per\-target:/d' ${srcdir}/configure.in > ${tmpfile}.tgt + echo >${tmpfile}.pos +fi + +### do common part of configure.in + +. ${tmpfile}.com + +# some sanity checks on configure.in +case "${srctrigger}" in +"") + echo '***' srctrigger not set in ${PWD=`pwd`}/configure.in. 1>&2 + exit 1 + ;; +*) ;; +esac + +case "${build_alias}" in +"") + if result=`${config_shell} ${configsub} ${host_alias}` ; then + build_cpu=`echo $result | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\1/'` + build_vendor=`echo $result | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\2/'` + build_os=`echo $result | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\3/'` + build=${build_cpu}-${build_vendor}-${build_os} + build_alias=${host_alias} + fi + ;; +*) + if result=`${config_shell} ${configsub} ${build_alias}` ; then + buildopt="--build=${build_alias}" + build_cpu=`echo $result | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\1/'` + build_vendor=`echo $result | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\2/'` + build_os=`echo $result | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\3/'` + build=${build_cpu}-${build_vendor}-${build_os} + else + echo "Unrecognized build system name ${build_alias}." 1>&2 + exit 1 + fi + ;; +esac + +if result=`${config_shell} ${configsub} ${host_alias}` ; then + true +else + echo "Unrecognized host system name ${host_alias}." 1>&2 + exit 1 +fi +host_cpu=`echo $result | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\1/'` +host_vendor=`echo $result | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\2/'` +host_os=`echo $result | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\3/'` +host=${host_cpu}-${host_vendor}-${host_os} + +. ${tmpfile}.hst + +if result=`${config_shell} ${configsub} ${target_alias}` ; then + true +else + echo "Unrecognized target system name ${target_alias}." 1>&2 + exit 1 +fi +target_cpu=`echo $result | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\1/'` +target_vendor=`echo $result | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\2/'` +target_os=`echo $result | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\3/'` +target=${target_cpu}-${target_vendor}-${target_os} + +. ${tmpfile}.tgt + +# Find the source files, if location was not specified. +case "${srcdir}" in +"") + srcdirdefaulted=1 + srcdir=. + if [ ! -r ${srctrigger} ] ; then + srcdir=.. + fi + ;; +*) ;; +esac + +if [ ! -r ${srcdir}/${srctrigger} ] ; then + case "${srcdirdefaulted}" in + "") echo '***' "${progname}: Can't find ${srcname} sources in ${PWD=`pwd`}/${srcdir}" 1>&2 ;; + *) echo '***' "${progname}: Can't find ${srcname} sources in ${PWD=`pwd`}/. or ${PWD=`pwd`}/.." 1>&2 ;; + esac + + echo '***' \(At least ${srctrigger} is missing.\) 1>&2 + exit 1 +fi + +# Some systems (e.g., one of the i386-aix systems the gas testers are +# using) don't handle "\$" correctly, so don't use it here. +tooldir='$(exec_prefix)'/${target_alias} + +if [ "${host_alias}" != "${target_alias}" ] ; then + if [ "${program_prefixoption}" = "" ] ; then + if [ "${program_suffixoption}" = "" ] ; then + if [ "${program_transform_nameoption}" = "" ] ; then + program_prefix=${target_alias}- ; + fi + fi + fi +fi + +# Merge program_prefix and program_suffix onto program_transform_name. +# (program_suffix used to use $, but it's hard to preserve $ through both +# make and sh.) +if [ "${program_suffix}" != "" ] ; then + program_transform_name="-e s,\\\\(.*\\\\),\\\\1${program_suffix}, ${program_transform_name}" +fi + +if [ "${program_prefix}" != "" ] ; then + program_transform_name="-e s,^,${program_prefix}, ${program_transform_name}" +fi + +# If CC and CXX are not set in the environment, and the Makefile +# exists, try to extract them from it. This is to handle running +# ./config.status by hand. +if [ -z "${CC}" -a -r Makefile ]; then + sed -n -e ':loop +/\\$/ N +s/\\\n//g +t loop +/^CC[ ]*=/ s/CC[ ]*=[ ]*\(.*\)/\1/p' < Makefile > Makefile.cc + CC=`tail -1 Makefile.cc` + rm -f Makefile.cc +fi + +if [ -z "${CFLAGS}" -a -r Makefile ]; then + sed -n -e ':loop +/\\$/ N +s/\\\n//g +t loop +/^CFLAGS[ ]*=/ s/CFLAGS[ ]*=[ ]*\(.*\)/\1/p' < Makefile > Makefile.cc + CFLAGS=`tail -1 Makefile.cc` + rm -f Makefile.cc +fi + +if [ -z "${CXX}" -a -r Makefile ]; then + sed -n -e ':loop +/\\$/ N +s/\\\n//g +t loop +/^CXX[ ]*=/ s/CXX[ ]*=[ ]*\(.*\)/\1/p' < Makefile > Makefile.cc + CXX=`tail -1 Makefile.cc` + rm -f Makefile.cc +fi + +if [ -z "${CXXFLAGS}" -a -r Makefile ]; then + sed -n -e ':loop +/\\$/ N +s/\\\n//g +t loop +/^CXXFLAGS[ ]*=/ s/CXXFLAGS[ ]*=[ ]*\(.*\)/\1/p' < Makefile > Makefile.cc + CXXFLAGS=`tail -1 Makefile.cc` + rm -f Makefile.cc +fi + +# Generate a default definition for YACC. This is used if the makefile can't +# locate bison or byacc in objdir. + +for prog in 'bison -y' byacc yacc +do + set dummy $prog; tmp=$2 + IFS="${IFS= }"; save_ifs="$IFS"; IFS="${IFS}:" + for dir in $PATH; do + test -z "$dir" && dir=. + if test -f $dir/$tmp; then + DEFAULT_YACC="$prog" + break + fi + done + IFS="$save_ifs" + + test -n "$DEFAULT_YACC" && break +done + +# Generate a default definition for LEX. This is used if the makefile can't +# locate flex in objdir. + +for prog in flex lex +do + set dummy $prog; tmp=$2 + IFS="${IFS= }"; save_ifs="$IFS"; IFS="${IFS}:" + for dir in $PATH; do + test -z "$dir" && dir=. + if test -f $dir/$tmp; then + DEFAULT_LEX="$prog" + break + fi + done + IFS="$save_ifs" + + test -n "$DEFAULT_LEX" && break +done + +if [ "${build}" != "${host}" ]; then + # If we are doing a Canadian Cross, in which the host and build systems + # are not the same, we set reasonable default values for the tools. + + tools="AR AR_FOR_TARGET AS AS_FOR_TARGET BISON CC_FOR_BUILD" + tools="${tools} CC_FOR_TARGET CXX_FOR_TARGET" + tools="${tools} DLLTOOL DLLTOOL_FOR_TARGET GCC_FOR_TARGET HOST_PREFIX" + tools="${tools} HOST_PREFIX_1 LD LD_FOR_TARGET LEX MAKEINFO NM" + tools="${tools} NM_FOR_TARGET RANLIB RANLIB_FOR_TARGET" + tools="${tools} WINDRES WINDRES_FOR_TARGET YACC" + + for var in ${tools}; do + if [ -z "`eval 'echo $'"${var}"`" -a -r Makefile ]; then + sed -n -e ':loop +/\\$/ N +s/\\\n//g +t loop +/^'"${var}"'[ ]*=/ s/'"${var}"'[ ]*=[ ]*\(.*\)/\1/p' \ + < Makefile > Makefile.v + t=`tail -1 Makefile.v` + if [ -n "${t}" ]; then + eval "${var}='${t}'" + fi + rm -f Makefile.v + fi + done + + AR=${AR-${host_alias}-ar} + AR_FOR_TARGET=${AR_FOR_TARGET-${target_alias}-ar} + AS=${AS-${host_alias}-as} + AS_FOR_TARGET=${AS_FOR_TARGET-${target_alias}-as} + BISON=${BISON-bison} + CC=${CC-${host_alias}-gcc} + CFLAGS=${CFLAGS-"-g -O2"} + CXX=${CXX-${host_alias}-c++} + CXXFLAGS=${CXXFLAGS-"-g -O2"} + CC_FOR_BUILD=${CC_FOR_BUILD-gcc} + CC_FOR_TARGET=${CC_FOR_TARGET-${target_alias}-gcc} + CXX_FOR_TARGET=${CXX_FOR_TARGET-${target_alias}-c++} + DLLTOOL=${DLLTOOL-${host_alias}-dlltool} + DLLTOOL_FOR_TARGET=${DLLTOOL_FOR_TARGET-${target_alias}-dlltool} + GCC_FOR_TARGET=${GCC_FOR_TARGET-${CC_FOR_TARGET-${target_alias}-gcc}} + HOST_PREFIX=${build_alias}- + HOST_PREFIX_1=${build_alias}- + LD=${LD-${host_alias}-ld} + LD_FOR_TARGET=${LD_FOR_TARGET-${target_alias}-ld} + MAKEINFO=${MAKEINFO-makeinfo} + NM=${NM-${host_alias}-nm} + NM_FOR_TARGET=${NM_FOR_TARGET-${target_alias}-nm} + RANLIB=${RANLIB-${host_alias}-ranlib} + RANLIB_FOR_TARGET=${RANLIB_FOR_TARGET-${target_alias}-ranlib} + WINDRES=${WINDRES-${host_alias}-windres} + WINDRES_FOR_TARGET=${WINDRES_FOR_TARGET-${target_alias}-windres} + + if [ -z "${YACC}" ]; then + IFS="${IFS= }"; save_ifs="$IFS"; IFS="${IFS}:" + for dir in $PATH; do + test -z "$dir" && dir=. + if test -f $dir/bison; then + YACC="bison -y" + break + fi + if test -f $dir/byacc; then + YACC=byacc + break + fi + if test -f $dir/yacc; then + YACC=yacc + break + fi + done + IFS="$save_ifs" + if [ -z "${YACC}" ]; then + YACC="bison -y" + fi + fi + + if [ -z "${LEX}" ]; then + IFS="${IFS= }"; save_ifs="$IFS"; IFS="${IFS}:" + for dir in $PATH; do + test -z "$dir" && dir=. + if test -f $dir/flex; then + LEX=flex + break + fi + if test -f $dir/lex; then + LEX=lex + break + fi + done + IFS="$save_ifs" + LEX=${LEX-flex} + fi + + # Export variables which autoconf might try to set. + export AS + export AR + export CC_FOR_BUILD + export DLLTOOL + export LD + export NM + export RANLIB + export WINDRES +else + # If CC is still not set, try to get gcc. + if [ -z "${CC}" ]; then + IFS="${IFS= }"; save_ifs="$IFS"; IFS="${IFS}:" + for dir in $PATH; do + test -z "$dir" && dir=. + if test -f $dir/gcc; then + CC="gcc" + echo 'void f(){}' > conftest.c + if test -z "`${CC} -g -c conftest.c 2>&1`"; then + CFLAGS=${CFLAGS-"-g -O2"} + CXXFLAGS=${CFLAGS-"-g -O2"} + else + CFLAGS=${CFLAGS-"-O2"} + CXXFLAGS=${CFLAGS-"-O2"} + fi + rm -f conftest* + break + fi + done + IFS="$save_ifs" + CC=${CC-cc} + fi + + CXX=${CXX-"c++"} + CFLAGS=${CFLAGS-"-g"} + CXXFLAGS=${CXXFLAGS-"-g -O2"} +fi + +export CC +export CXX +export CFLAGS +export CXXFLAGS + +# FIXME: This should be in configure.in, not configure +case "$host" in + *go32*) + enable_gdbtk=no ;; + *msdosdjgpp*) + enable_gdbtk=no ;; + *cygwin32*) + enable_gdbtk=no ;; +esac + +# FIXME: This should be in configure.in, not configure +# Determine whether gdb needs tk/tcl or not. +if [ "$enable_gdbtk" != "no" ]; then + GDB_TK="all-tcl all-tk all-itcl all-tix" +else + GDB_TK="" +fi + +for subdir in . ${subdirs} ; do + + # ${subdir} is relative path from . to the directory we're currently + # configuring. + # ${invsubdir} is inverse of ${subdir), *with* trailing /, if needed. + invsubdir=`echo ${subdir}/ | sed -e 's|\./||g' -e 's|[^/]*/|../|g'` + + ### figure out what to do with srcdir + case "${srcdir}" in + ".") # no -srcdir option. We're building in place. + makesrcdir=. ;; + /*) # absolute path + makesrcdir=`echo ${srcdir}/${subdir} | sed -e 's|/\.$||'` + ;; + *) # otherwise relative + case "${subdir}" in + .) makesrcdir=${srcdir} ;; + *) makesrcdir=${invsubdir}${srcdir}/${subdir} ;; + esac + ;; + esac + + if [ "${subdir}/" != "./" ] ; then + Makefile=${subdir}/Makefile + fi + + if [ ! -d ${subdir} ] ; then + if mkdir ${subdir} ; then + true + else + echo '***' "${progname}: could not make ${PWD=`pwd`}/${subdir}" 1>&2 + exit 1 + fi + fi + + case "${removing}" in + "") + case "${subdir}" in + .) ;; + *) eval echo Building in ${subdir} ${redirect} ;; + esac + + # FIXME Should this be done recursively ??? (Useful for e.g. gdbtest) + # Set up the list of links to be made. + # ${links} is the list of link names, and ${files} is the list of names to link to. + + # Make the links. + configlinks="${links}" + if [ -r ${subdir}/config.status ] ; then + mv -f ${subdir}/config.status ${subdir}/config.back + fi + while [ -n "${files}" ] ; do + # set file to car of files, files to cdr of files + set ${files}; file=$1; shift; files=$* + set ${links}; link=$1; shift; links=$* + + if [ ! -r ${srcdir}/${file} ] ; then + echo '***' "${progname}: cannot create a link \"${link}\"," 1>&2 + echo '***' "since the file \"${srcdir}/${file}\" does not exist." 1>&2 + exit 1 + fi + + ${remove} -f ${link} + # Make a symlink if possible, otherwise try a hard link + if ${symbolic_link} ${srcdir}/${file} ${link} >/dev/null 2>&1 ; then + true + else + # We need to re-remove the file because Lynx leaves a + # very strange directory there when it fails an NFS symlink. + ${remove} -r -f ${link} + ${hard_link} ${srcdir}/${file} ${link} + fi + if [ ! -r ${link} ] ; then + echo '***' "${progname}: unable to link \"${link}\" to \"${srcdir}/${file}\"." 1>&2 + exit 1 + fi + + echo "Linked \"${link}\" to \"${srcdir}/${file}\"." + done + + # Create a .gdbinit file which runs the one in srcdir + # and tells GDB to look there for source files. + + if [ -r ${srcdir}/${subdir}/.gdbinit ] ; then + case ${srcdir} in + .) ;; + *) cat > ${subdir}/.gdbinit < ${subdir}/Makefile.tem + else + cp ${srcdir}/${subdir}/${Makefile_in} ${subdir}/Makefile.tem + site_makefile_frag= + fi + ;; + esac + # working copy now in ${subdir}/Makefile.tem + + # Conditionalize the makefile for this host. + rm -f ${Makefile} + case "${host_makefile_frag}" in + "") mv ${subdir}/Makefile.tem ${Makefile} ;; + *) + if [ ! -f ${host_makefile_frag} ] ; then + host_makefile_frag=${srcdir}/${host_makefile_frag} + fi + if [ -f ${host_makefile_frag} ] ; then + sed -e "/^####/ r ${host_makefile_frag}" ${subdir}/Makefile.tem > ${Makefile} + else + echo '***' Expected host makefile fragment \"${host_makefile_frag}\" 1>&2 + echo '***' is missing in ${PWD=`pwd`}. 1>&2 + mv ${subdir}/Makefile.tem ${Makefile} + fi + esac + # working copy now in ${Makefile} + + # Conditionalize the makefile for this target. + rm -f ${subdir}/Makefile.tem + case "${target_makefile_frag}" in + "") mv ${Makefile} ${subdir}/Makefile.tem ;; + *) + if [ ! -f ${target_makefile_frag} ] ; then + target_makefile_frag=${srcdir}/${target_makefile_frag} + fi + if [ -f ${target_makefile_frag} ] ; then + sed -e "/^####/ r ${target_makefile_frag}" ${Makefile} > ${subdir}/Makefile.tem + else + mv ${Makefile} ${subdir}/Makefile.tem + target_makefile_frag= + fi + ;; + esac + # real copy now in ${subdir}/Makefile.tem + + # Conditionalize the makefile for this package. + rm -f ${Makefile} + case "${package_makefile_frag}" in + "") mv ${subdir}/Makefile.tem ${Makefile} ;; + *) + if [ ! -f ${package_makefile_frag} ] ; then + package_makefile_frag=${srcdir}/${package_makefile_frag} + fi + if [ -f ${package_makefile_frag} ] ; then + sed -e "/^####/ r ${package_makefile_frag}" ${subdir}/Makefile.tem > ${Makefile} + rm -f ${subdir}/Makefile.tem + else + echo '***' Expected package makefile fragment \"${package_makefile_frag}\" 1>&2 + echo '***' is missing in ${PWD=`pwd`}. 1>&2 + mv ${subdir}/Makefile.tem ${Makefile} + fi + esac + # working copy now in ${Makefile} + + mv ${Makefile} ${subdir}/Makefile.tem + + # real copy now in ${subdir}/Makefile.tem + + # prepend warning about editting, and a bunch of variables. + rm -f ${Makefile} + cat > ${Makefile} <> ${Makefile} << EOF +build_alias = ${build_alias} +build_cpu = ${build_cpu} +build_vendor = ${build_vendor} +build_os = ${build_os} +build_canonical = ${build_cpu}-${build_vendor}-${build_os} +EOF + esac + + case "${package_makefile_frag}" in + "") ;; + /*) echo package_makefile_frag = ${package_makefile_frag} >>${Makefile} ;; + *) echo package_makefile_frag = ${invsubdir}${package_makefile_frag} >>${Makefile} ;; + esac + + case "${target_makefile_frag}" in + "") ;; + /*) echo target_makefile_frag = ${target_makefile_frag} >>${Makefile} ;; + *) echo target_makefile_frag = ${invsubdir}${target_makefile_frag} >>${Makefile} ;; + esac + + case "${host_makefile_frag}" in + "") ;; + /*) echo host_makefile_frag = ${host_makefile_frag} >>${Makefile} ;; + *) echo host_makefile_frag = ${invsubdir}${host_makefile_frag} >>${Makefile} ;; + esac + + if [ "${site_makefile_frag}" != "" ] ; then + echo site_makefile_frag = ${invsubdir}${site_makefile_frag} >>${Makefile} + fi + + # reset prefix, exec_prefix, srcdir, SUBDIRS, NONSUBDIRS, + # remove any form feeds. + if [ -z "${subdirs}" ]; then + rm -f ${subdir}/Makefile.tm2 + sed -e "s:^SUBDIRS[ ]*=.*$:SUBDIRS = ${configdirs}:" \ + -e "s:^NONSUBDIRS[ ]*=.*$:NONSUBDIRS = ${noconfigdirs}:" \ + ${subdir}/Makefile.tem > ${subdir}/Makefile.tm2 + rm -f ${subdir}/Makefile.tem + mv ${subdir}/Makefile.tm2 ${subdir}/Makefile.tem + fi + sed -e "s|^prefix[ ]*=.*$|prefix = ${prefix}|" \ + -e "s|^exec_prefix[ ]*=.*$|exec_prefix = ${exec_prefix}|" \ + -e "/^CC[ ]*=/{ + :loop1 + /\\\\$/ N + s/\\\\\\n//g + t loop1 + s%^CC[ ]*=.*$%CC = ${CC}% + }" \ + -e "/^CXX[ ]*=/{ + :loop2 + /\\\\$/ N + s/\\\\\\n//g + t loop2 + s%^CXX[ ]*=.*$%CXX = ${CXX}% + }" \ + -e "/^CFLAGS[ ]*=/{ + :loop3 + /\\\\$/ N + s/\\\\\\n//g + t loop3 + s%^CFLAGS[ ]*=.*$%CFLAGS = ${CFLAGS}% + }" \ + -e "/^CXXFLAGS[ ]*=/{ + :loop4 + /\\\\$/ N + s/\\\\\\n//g + t loop4 + s%^CXXFLAGS[ ]*=.*$%CXXFLAGS = ${CXXFLAGS}% + }" \ + -e "s|^SHELL[ ]*=.*$|SHELL = ${config_shell}|" \ + -e "s:^GDB_TK[ ]*=.*$:GDB_TK = ${GDB_TK}:" \ + -e "s|^srcdir[ ]*=.*$|srcdir = ${makesrcdir}|" \ + -e "s/ //" \ + -e "s:^program_prefix[ ]*=.*$:program_prefix = ${program_prefix}:" \ + -e "s:^program_suffix[ ]*=.*$:program_suffix = ${program_suffix}:" \ + -e "s:^program_transform_name[ ]*=.*$:program_transform_name = ${program_transform_name}:" \ + -e "s|^tooldir[ ]*=.*$|tooldir = ${tooldir}|" \ + -e "s:^DEFAULT_YACC[ ]*=.*$:DEFAULT_YACC = ${DEFAULT_YACC}:" \ + -e "s:^DEFAULT_LEX[ ]*=.*$:DEFAULT_LEX = ${DEFAULT_LEX}:" \ + ${subdir}/Makefile.tem >> ${Makefile} + + # If this is a Canadian Cross, preset the values of many more + # tools. + if [ "${build}" != "${host}" ]; then + for var in ${tools}; do + val=`eval 'echo $'"${var}"` + sed -e "/^${var}[ ]*=/{ + :loop1 + /\\\\$/ N + /\\\\$/ b loop1 + s/\\\\\\n//g + s%^${var}[ ]*=.*$%${var} = ${val}% + }" ${Makefile} > ${Makefile}.tem + mv -f ${Makefile}.tem ${Makefile} + done + fi + + # final copy now in ${Makefile} + + else + echo "No Makefile.in found in ${srcdir}/${subdir}, unable to configure" 1>&2 + fi + + rm -f ${subdir}/Makefile.tem + + case "${host_makefile_frag}" in + "") using= ;; + *) using="and \"${host_makefile_frag}\"" ;; + esac + + case "${target_makefile_frag}" in + "") ;; + *) using="${using} and \"${target_makefile_frag}\"" ;; + esac + + case "${site_makefile_frag}" in + "") ;; + *) using="${using} and \"${site_makefile_frag}\"" ;; + esac + + newusing=`echo "${using}" | sed 's/and/using/'` + using=${newusing} + echo "Created \"${Makefile}\" in" ${PWD=`pwd`} ${using} + + . ${tmpfile}.pos + + # describe the chosen configuration in config.status. + # Make that file a shellscript which will reestablish + # the same configuration. Used in Makefiles to rebuild + # Makefiles. + + case "${norecursion}" in + "") arguments="${arguments} --norecursion" ;; + *) ;; + esac + + if [ ${subdir} = . ] ; then + echo "#!/bin/sh +# ${NO_EDIT} +# This directory was configured as follows: +${progname}" ${arguments} " +# ${using}" > ${subdir}/config.new + else + echo "#!/bin/sh +# ${NO_EDIT} +# This directory was configured as follows: +cd ${invsubdir} +${progname}" ${arguments} " +# ${using}" > ${subdir}/config.new + fi + chmod a+x ${subdir}/config.new + if [ -r ${subdir}/config.back ] ; then + mv -f ${subdir}/config.back ${subdir}/config.status + fi + ${config_shell} ${moveifchange} ${subdir}/config.new ${subdir}/config.status + ;; + + *) rm -f ${Makefile} ${subdir}/config.status ${links} ;; + esac +done + +# If there are subdirectories, then recur. +if [ -z "${norecursion}" -a -n "${configdirs}" ] ; then + for configdir in ${configdirs} ; do + + if [ -d ${srcdir}/${configdir} ] ; then + eval echo Configuring ${configdir}... ${redirect} + case "${srcdir}" in + ".") ;; + *) + if [ ! -d ./${configdir} ] ; then + if mkdir ./${configdir} ; then + true + else + echo '***' "${progname}: could not make ${PWD=`pwd`}/${configdir}" 1>&2 + exit 1 + fi + fi + ;; + esac + + POPDIR=${PWD=`pwd`} + cd ${configdir} + +### figure out what to do with srcdir + case "${srcdir}" in + ".") newsrcdir=${srcdir} ;; # no -srcdir option. We're building in place. + /*) # absolute path + newsrcdir=${srcdir}/${configdir} + srcdiroption="--srcdir=${newsrcdir}" + ;; + ?:*) # absolute path on win32 + newsrcdir=${srcdir}/${configdir} + srcdiroption="--srcdir=${newsrcdir}" + ;; + *) # otherwise relative + newsrcdir=../${srcdir}/${configdir} + srcdiroption="--srcdir=${newsrcdir}" + ;; + esac + + # Handle --cache-file=../XXX + case "${cache_file}" in + "") # empty + ;; + /*) # absolute path + cache_file_option="--cache-file=${cache_file}" + ;; + ?:*) # absolute path on win32 + cache_file_option="--cache-file=${cache_file}" + ;; + *) # relative path + cache_file_option="--cache-file=../${cache_file}" + ;; + esac + +### check for guested configure, otherwise fix possibly relative progname + if [ -f ${newsrcdir}/configure ] ; then + recprog=${newsrcdir}/configure + elif [ -f ${newsrcdir}/configure.in ] ; then + case "${progname}" in + /*) recprog=${progname} ;; + ?:*) recprog=${progname} ;; + *) recprog=../${progname} ;; + esac + else + eval echo No configuration information in ${configdir} ${redirect} + recprog= + fi + +### The recursion line is here. + if [ ! -z "${recprog}" ] ; then + if eval ${config_shell} ${recprog} ${verbose} ${buildopt} --host=${host_alias} --target=${target_alias} \ + ${prefixoption} ${tmpdiroption} ${exec_prefixoption} \ + ${srcdiroption} ${program_prefixoption} ${program_suffixoption} ${program_transform_nameoption} ${site_option} ${withoptions} ${withoutoptions} ${enableoptions} ${disableoptions} ${floating_pointoption} ${cache_file_option} ${removing} ${other_options} ${redirect} ; then + true + else + echo Configure in `pwd` failed, exiting. 1>&2 + exit 1 + fi + fi + + cd ${POPDIR} + fi + done +fi + +# Perform the same cleanup as the trap handler, minus the "exit 1" of course, +# and reset the trap handler. +rm -f ${tmpfile}.com ${tmpfile}.tgt ${tmpfile}.hst ${tmpfile}.pos +trap 0 + +exit 0 + +# +# Local Variables: +# fill-column: 131 +# End: +# + +# end of configure diff --git a/configure.in b/configure.in new file mode 100644 index 00000000000..e251e85b424 --- /dev/null +++ b/configure.in @@ -0,0 +1,874 @@ +#! /bin/bash +############################################################################## + +## This file is a shell script fragment that supplies the information +## necessary to tailor a template configure script into the configure +## script appropriate for this directory. For more information, check +## any existing configure script. + +## Be warned, there are two types of configure.in files. There are those +## used by Autoconf, which are macros which are expanded into a configure +## script by autoconf. The other sort, of which this is one, is executed +## by Cygnus configure. + +## For more information on these two systems, check out the documentation +## for 'Autoconf' (autoconf.texi) and 'Configure' (configure.texi). + +# Copyright (C) 1992, 93, 94, 95, 96, 1997 Free Software Foundation, Inc. +# +# This file 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. + +############################################################################## + +### To add a new directory to the tree, first choose whether it is a target +### or a host dependent tool. Then put it into the appropriate list +### (library or tools, host or target), doing a dependency sort. For +### example, gdb requires that byacc (or bison) be built first, so it is in +### the ${host_tools} list after byacc and bison. + + +# these libraries are used by various programs built for the host environment +# +host_libs="mmalloc libiberty opcodes bfd readline gash db tcl tk tclX itcl tix" + +if [ "${enable_gdbgui}" = "yes" ] ; then + host_libs="${host_libs} libgui" +fi + +# these tools are built for the host environment +# Note, the powerpc-eabi build depends on sim occurring before gdb in order to +# know that we are building the simulator. +host_tools="texinfo byacc flex bison binutils ld gas gcc sim gdb make patch prms send-pr gprof gdbtest tgas etc expect dejagnu bash m4 autoconf automake ispell grep diff rcs cvs fileutils shellutils time textutils wdiff find emacs emacs19 uudecode hello tar gzip indent recode release sed utils guile perl apache inet gawk findutils sn" + +# these libraries are built for the target environment, and are built after +# the host libraries and the host tools (which may be a cross compiler) +# +target_libs="target-libiberty target-libgloss target-newlib target-libio target-librx target-libstdc++ target-libg++" + + +# these tools are built using the target libs, and are intended to run only +# in the target environment +# +# note: any program that *uses* libraries that are in the "target_libs" +# list belongs in this list. those programs are also very likely +# candidates for the "native_only" list which follows +# +target_tools="target-examples target-groff target-gperf" + +################################################################################ + +## These two lists are of directories that are to be removed from the +## ${configdirs} list for either cross-compilations or for native- +## compilations. For example, it doesn't make that much sense to +## cross-compile Emacs, nor is it terribly useful to compile target-libiberty in +## a native environment. + +# directories to be built in the native environment only +# +# This must be a single line because of the way it is searched by grep in +# the code below. +native_only="autoconf automake cvs emacs emacs19 fileutils find gawk grep gzip hello indent ispell m4 rcs recode sed shellutils tar textutils gash uudecode wdiff gprof target-groff guile perl apache inet time bash prms sn gnuserv target-gperf" + +# directories to be built in a cross environment only +# +cross_only="target-libgloss target-newlib" + +## All tools belong in one of the four categories, and are assigned above +## We assign ${configdirs} this way to remove all embedded newlines. This +## is important because configure will choke if they ever get through. +## ${configdirs} is directories we build using the host tools. +## ${target_configdirs} is directories we build using the target tools. +# +configdirs=`echo ${host_libs} ${host_tools}` +target_configdirs=`echo ${target_libs} ${target_tools}` + +################################################################################ + +srctrigger=move-if-change +srcname="gnu development package" + +# This gets set non-empty for some net releases of packages. +appdirs="" + +# per-host: + +# Work in distributions that contain no compiler tools, like Autoconf. +if [ -d ${srcdir}/config ]; then +case "${host}" in + m68k-hp-hpux*) host_makefile_frag=config/mh-hp300 ;; + m68k-apollo-sysv*) host_makefile_frag=config/mh-apollo68 ;; + m68k-apollo-bsd*) host_makefile_frag=config/mh-a68bsd ;; + m88k-dg-dgux*) host_makefile_frag=config/mh-dgux ;; + m88k-harris-cxux*) host_makefile_frag=config/mh-cxux ;; + m88k-motorola-sysv*) host_makefile_frag=config/mh-delta88;; + mips*-dec-ultrix*) host_makefile_frag=config/mh-decstation ;; + mips*-nec-sysv4*) host_makefile_frag=config/mh-necv4 ;; + mips*-sgi-irix6*) host_makefile_frag=config/mh-irix6 ;; + mips*-sgi-irix5*) host_makefile_frag=config/mh-irix5 ;; + mips*-sgi-irix4*) host_makefile_frag=config/mh-irix4 ;; + mips*-sgi-irix3*) host_makefile_frag=config/mh-sysv ;; + mips*-*-sysv4*) host_makefile_frag=config/mh-sysv4 ;; + mips*-*-sysv*) host_makefile_frag=config/mh-riscos ;; + i[3456]86-*-dgux*) host_makefile_frag=config/mh-dgux386 ;; + i[3456]86-ncr-sysv4.3) host_makefile_frag=config/mh-ncrsvr43 ;; + i[3456]86-ncr-sysv4*) host_makefile_frag=config/mh-ncr3000 ;; + i[3456]86-*-sco3.2v5*) host_makefile_frag=config/mh-sysv ;; + i[3456]86-*-sco*) host_makefile_frag=config/mh-sco ;; + i[3456]86-*-isc*) host_makefile_frag=config/mh-sysv ;; + i[3456]86-*-solaris2*) host_makefile_frag=config/mh-sysv4 ;; + i[3456]86-*-aix*) host_makefile_frag=config/mh-aix386 ;; + i[3456]86-*-go32*) host_makefile_frag=config/mh-go32 ;; + i[3456]86-*-msdosdjgpp*) host_makefile_frag=config/mh-go32 ;; + *-cygwin32*) host_makefile_frag=config/mh-cygwin32 ;; + *-windows*) host_makefile_frag=config/mh-windows ;; + vax-*-ultrix2*) host_makefile_frag=config/mh-vaxult2 ;; + *-*-solaris2*) host_makefile_frag=config/mh-solaris ;; + m68k-sun-sunos*) host_makefile_frag=config/mh-sun3 ;; + *-hp-hpux[78]*) host_makefile_frag=config/mh-hpux8 ;; + *-hp-hpux*) host_makefile_frag=config/mh-hpux ;; + *-*-hiux*) host_makefile_frag=config/mh-hpux ;; + rs6000-*-lynxos*) host_makefile_frag=config/mh-lynxrs6k ;; + *-*-lynxos*) host_makefile_frag=config/mh-lynxos ;; + *-*-sysv4*) host_makefile_frag=config/mh-sysv4 ;; + *-*-sysv*) host_makefile_frag=config/mh-sysv ;; +esac +fi + +# If we aren't going to be using gcc, see if we can extract a definition +# of CC from the fragment. +if [ -z "${CC}" -a "${build}" = "${host}" ]; then + IFS="${IFS= }"; save_ifs="$IFS"; IFS="${IFS}:" + found= + for dir in $PATH; do + test -z "$dir" && dir=. + if test -f $dir/gcc; then + found=yes + break + fi + done + IFS="$save_ifs" + if [ -z "${found}" -a -n "${host_makefile_frag}" -a -f "${srcdir}/${host_makefile_frag}" ]; then + xx=`sed -n -e 's/^[ ]*CC[ ]*=[ ]*\(.*\)$/\1/p' < ${srcdir}/${host_makefile_frag}` + if [ -n "${xx}" ] ; then + CC=$xx + fi + fi +fi + +# We default to --with-shared on platforms where -fpic is meaningless. +# Well, we don't yet, but we will. +if false && [ "${host}" = "${target}" ] && [ x${enable_shared} = x ]; then + case "${target}" in + alpha-dec-osf*) enable_shared=yes ;; + alpha-*-linux*) enable_shared=yes ;; + mips-sgi-irix5*) enable_shared=yes ;; + *) enable_shared=no ;; + esac +fi + +case "${enable_shared}" in + yes) shared=yes ;; + no) shared=no ;; + "") shared=no ;; + *) shared=yes ;; +esac + +if [ x${shared} = xyes ]; then + waugh= + case "${host}" in + hppa*) waugh=config/mh-papic ;; + i[3456]86-*) waugh=config/mh-x86pic ;; + sparc64-*) waugh=config/mh-sparcpic ;; + powerpc*-*) waugh=config/mh-ppcpic ;; + *) waugh=config/mh-${host_cpu}pic ;; + esac + if [ -f ${srcdir}/${waugh} ]; then + if [ -n "${host_makefile_frag}" ] ; then + cat ${srcdir}/${host_makefile_frag} > mh-frag + cat ${srcdir}/${waugh} >> mh-frag + host_makefile_frag=mh-frag + else + host_makefile_frag=${waugh} + fi + fi +fi + +# per-target: + +case "${target}" in + v810*) target_makefile_frag=config/mt-v810 ;; + i[3456]86-*-netware*) target_makefile_frag=config/mt-netware ;; + powerpc-*-netware*) target_makefile_frag=config/mt-netware ;; +esac + +skipdirs= +gasdir=gas +use_gnu_ld= +use_gnu_as= + +# some tools are so dependent upon X11 that if we're not building with X, +# it's not even worth trying to configure, much less build, that tool. + +case ${with_x} in + yes | "") # the default value for this tree is that X11 is available + ;; + no) + skipdirs="${skipdirs} tk gash" + ;; + *) + echo "*** bad value \"${with_x}\" for -with-x flag; ignored" 1>&2 + ;; +esac + +# Some tools are only suitable for building in a "native" situation. +# Those are added when we have a host==target configuration. For cross +# toolchains, we add some directories that should only be useful in a +# cross-compiler. + +is_cross_compiler= + +if [ x"${host}" = x"${target}" ] ; then + # when doing a native toolchain, don't build the targets + # that are in the 'cross only' list + skipdirs="${skipdirs} ${cross_only}" + is_cross_compiler=no + target_subdir=. + case "${host}" in + # We need multilib support for irix6, to get libiberty built + # properly for o32 and n32. + mips-sgi-irix6*) target_subdir=${host} ;; + esac +else + # similarly, don't build the targets in the 'native only' + # list when building a cross compiler + skipdirs="${skipdirs} ${native_only}" + is_cross_compiler=yes + target_subdir=${target_alias} +fi + +if [ ! -d ${target_subdir} ] ; then + if mkdir ${target_subdir} ; then true + else + echo "'*** could not make ${PWD=`pwd`}/${target_subdir}" 1>&2 + exit 1 + fi +fi + +copy_dirs= + +# Handle --with-headers=XXX. The contents of the named directory are +# copied to $(tooldir)/sys-include. +if [ x"${with_headers}" != x ]; then + if [ x${is_cross_compiler} = xno ]; then + echo 1>&2 '***' --with-headers is only supported when cross compiling + exit 1 + fi + case "${exec_prefixoption}" in + "") x=${prefix} ;; + *) x=${exec_prefix} ;; + esac + copy_dirs="${copy_dirs} ${with_headers} $x/${target_alias}/sys-include" +fi + +# Handle --with-libs=XXX. Multiple directories are permitted. The +# contents are copied to $(tooldir)/lib. +if [ x"${with_libs}" != x ]; then + if [ x${is_cross_compiler} = xno ]; then + echo 1>&2 '***' --with-libs is only supported when cross compiling + exit 1 + fi + # Copy the libraries in reverse order, so that files in the first named + # library override files in subsequent libraries. + case "${exec_prefixoption}" in + "") x=${prefix} ;; + *) x=${exec_prefix} ;; + esac + for l in ${with_libs}; do + copy_dirs="$l $x/${target_alias}/lib ${copy_dirs}" + done +fi + +# If both --with-headers and --with-libs are specified, default to +# --without-newlib. +if [ x"${with_headers}" != x ] && [ x"${with_libs}" != x ]; then + if [ x"${with_newlib}" = x ]; then + with_newlib=no + fi +fi + +# Recognize --with-newlib/--without-newlib. +if [ x${with_newlib} = xno ]; then + skipdirs="${skipdirs} target-newlib" +elif [ x${with_newlib} = xyes ]; then + skipdirs=`echo " ${skipdirs} " | sed -e 's/ target-newlib / /'` +fi + +# Default to using --with-stabs for certain targets. +if [ x${with_stabs} = x ]; then + case "${target}" in + mips*-*-irix6*) + ;; + mips*-*-* | alpha*-*-osf* | i[3456]86*-*-sysv4* | i[3456]86*-*-unixware*) + with_stabs=yes; + withoptions="${withoptions} --with-stabs" + ;; + esac +fi + +# Handle ${copy_dirs} +set fnord ${copy_dirs} +shift +while [ $# != 0 ]; do + if [ -f $2/COPIED ] && [ x"`cat $2/COPIED`" = x"$1" ]; then + : + else + echo Copying $1 to $2 + + # Use the install script to create the directory and all required + # parent directories. + if [ -d $2 ]; then + : + else + echo >config.temp + ${srcdir}/install-sh -c -m 644 config.temp $2/COPIED + fi + + # Copy the directory, assuming we have tar. + # FIXME: Should we use B in the second tar? Not all systems support it. + (cd $1; tar -cf - .) | (cd $2; tar -xpf -) + + # It is the responsibility of the user to correctly adjust all + # symlinks. If somebody can figure out how to handle them correctly + # here, feel free to add the code. + + echo $1 > $2/COPIED + fi + shift; shift +done + +# Configure extra directories which are host specific + +case "${host}" in + i[3456]86-*-go32*) + configdirs="$configdirs dosrel" ;; + *-cygwin32*) + configdirs="$configdirs dosrel" ;; +esac + +# Remove more programs from consideration, based on the host or +# target this usually means that a port of the program doesn't +# exist yet. + +noconfigdirs="" + +case "${host}" in + i[3456]86-*-vsta) + noconfigdirs="tcl expect dejagnu make texinfo bison patch flex byacc send-pr gprof uudecode dejagnu diff guile perl apache inet itcl tix db sn gnuserv" + ;; + i[3456]86-*-go32* | i[3456]86-*-msdosdjgpp*) + noconfigdirs="tcl tk expect dejagnu make texinfo bison patch flex byacc send-pr uudecode dejagnu diff guile perl apache inet itcl tix db sn gnuserv" + ;; + *-*-cygwin32) + noconfigdirs="expect dejagnu cvs autoconf automake bison send-pr gprof rcs guile perl texinfo apache inet" + ;; + *-*-windows*) +# This is only used to build WinGDB... +# note that powerpc-eabi depends on sim configured before gdb. + configdirs="bfd libiberty opcodes readline sim gdb" + target_configdirs= + ;; + ppc*-*-pe) + noconfigdirs="patch diff make tk tcl expect dejagnu cvs autoconf automake texinfo bison send-pr gprof rcs guile perl apache inet itcl tix db sn gnuserv" + ;; +esac + + +case "${target}" in + *-*-netware) + noconfigdirs="$noconfigdirs target-libg++ target-libstdc++ target-librx target-newlib target-libiberty target-libgloss" + ;; + *-*-vxworks*) + noconfigdirs="$noconfigdirs target-newlib target-libgloss" + ;; + alpha-dec-osf*) + # ld works, but does not support shared libraries. emacs doesn't + # work. newlib is not 64 bit ready. I'm not sure about fileutils. + # gas doesn't generate exception information. + noconfigdirs="$noconfigdirs gas ld emacs fileutils target-newlib target-libgloss" + ;; + alpha*-*-*vms*) + noconfigdirs="$noconfigdirs gdb ld target-newlib target-libgloss" + ;; + alpha*-*-*) + # newlib is not 64 bit ready + noconfigdirs="$noconfigdirs target-newlib target-libgloss" + ;; + arc-*-*) + noconfigdirs="$noconfigdirs target-libgloss" + ;; + arm-*-pe*) + noconfigdirs="$noconfigdirs target-libgloss" + ;; + arm-*-coff*) + noconfigdirs="$noconfigdirs target-libgloss" + ;; + arm-*-riscix*) + noconfigdirs="$noconfigdirs ld target-libgloss" + ;; + d10v-*-*) + noconfigdirs="$noconfigdirs target-librx target-libg++ target-libstdc++ target-libio target-libgloss" + ;; + h8300*-*-* | \ + h8500-*-*) + noconfigdirs="$noconfigdirs target-libg++ target-libstdc++ target-libio target-librx target-libgloss" + ;; + hppa*-*-*elf* | \ + hppa*-*-lites* | \ + hppa*-*-rtems* ) + # Do configure ld/binutils/gas for this case. + ;; + hppa*-*-*) + # HP's C compiler doesn't handle Emacs correctly (but on BSD and Mach + # cc is gcc, and on any system a user should be able to link cc to + # whatever they want. FIXME, emacs emacs19). + case "${CC}" in + "" | cc*) noconfigdirs="$noconfigdirs emacs emacs19" ;; + *) ;; + esac + noconfigdirs="$noconfigdirs ld shellutils" + ;; + i[3456]86-*-go32* | i[3456]-*-msdosdjgpp*) + # but don't build gdb + noconfigdirs="$noconfigdirs gdb target-libg++ target-libstdc++ target-libio target-librx" + ;; + *-*-cygwin32) + target_configdirs="$target_configdirs target-winsup" + noconfigdirs="$noconfigdirs expect target-libgloss" + # always build newlib. + skipdirs=`echo " ${skipdirs} " | sed -e 's/ target-newlib / /'` + + # Can't build gdb for cygwin32 if not native. + case "${host}" in + *-*-cygwin32) ;; # keep gdb tcl tk expect etc. + *) noconfigdirs="$noconfigdirs gdb tcl tk expect itcl tix db sn gnuserv" + ;; + esac + ;; + i[3456]86-*-pe) + noconfigdirs="$noconfigdirs target-libg++ target-libstdc++ target-libio target-librx target-libgloss" + ;; + i[3456]86-*-sco3.2v5*) + # The linker does not yet know about weak symbols in COFF, + # and is not configured to handle mixed ELF and COFF. + noconfigdirs="$noconfigdirs gprof ld target-libgloss" + ;; + i[3456]86-*-sco*) + noconfigdirs="$noconfigdirs gprof target-libgloss" + ;; + i[3456]86-*-solaris2*) + # The linker does static linking correctly, but the Solaris C library + # has bugs such that some important functions won't work when statically + # linked. (See man pages for getpwuid, for example.) + noconfigdirs="$noconfigdirs ld target-libgloss" + ;; + i[3456]86-*-sysv4*) + # The SYSV4 C compiler doesn't handle Emacs correctly + case "${CC}" in + "" | cc*) noconfigdirs="$noconfigdirs emacs emacs19" ;; + *) ;; + esac + # but that's okay since emacs doesn't work anyway + noconfigdirs="$noconfigdirs emacs emacs19 target-libgloss" + ;; + mn10200-*-*) + noconfigdirs="$noconfigdirs target-libgloss" + ;; + mn10300-*-*) + noconfigdirs="$noconfigdirs target-libgloss" + ;; + powerpc-*-aix*) + # copied from rs6000-*-* entry + noconfigdirs="$noconfigdirs gprof cvs target-libgloss" + # This is needed until gcc and ld are fixed to work together. + use_gnu_ld=no + ;; + powerpc*-*-winnt* | powerpc*-*-pe* | ppc*-*-pe) + target_configdirs="$target_configdirs target-winsup" + noconfigdirs="$noconfigdirs gdb tcl tk make expect target-libgloss itcl tix db sn gnuserv" + # always build newlib. + skipdirs=`echo " ${skipdirs} " | sed -e 's/ target-newlib / /'` + ;; + # This is temporary until we can link against shared libraries + powerpcle-*-solaris*) + noconfigdirs="$noconfigdirs gdb sim make tcl tk expect itcl tix db sn gnuserv" + ;; + rs6000-*-lynxos*) + # The CVS server code doesn't work on the RS/6000 + # Newlib makes problems for libg++ in crosses. + noconfigdirs="$noconfigdirs target-newlib gprof cvs" + ;; + rs6000-*-aix*) + noconfigdirs="$noconfigdirs gprof" + # This is needed until gcc and ld are fixed to work together. + use_gnu_ld=no + ;; + rs6000-*-*) + noconfigdirs="$noconfigdirs gprof" + ;; + m68k-apollo-*) + noconfigdirs="$noconfigdirs ld binutils gprof target-libgloss" + ;; + mips*-*-irix5*) + # The GNU linker does not support shared libraries. + # emacs is emacs 18, which does not work on Irix 5 (emacs19 does work) + noconfigdirs="$noconfigdirs ld gprof emacs target-libgloss" + ;; + mips*-*-irix6*) + # The GNU assembler and linker do not support IRIX 6. + # emacs is emacs 18, which does not work on Irix 5 (emacs19 does work) + noconfigdirs="$noconfigdirs ld gas gprof emacs target-libgloss" + ;; + mips*-dec-bsd*) + noconfigdirs="$noconfigdirs gprof target-libgloss" + ;; + mips*-*-bsd*) + noconfigdirs="$noconfigdirs gprof target-libgloss" + ;; + mips*-*-*) + noconfigdirs="$noconfigdirs gprof" + ;; + romp-*-*) + noconfigdirs="$noconfigdirs bfd binutils ld gas opcodes target-libgloss" + ;; + sh-*-*) + case "${host}" in + i[3456]86-*-vsta) ;; # don't add gprof back in + i[3456]86-*-go32*) ;; # don't add gprof back in + i[3456]86-*-msdosdjgpp*) ;; # don't add gprof back in + *) skipdirs=`echo " ${skipdirs} " | sed -e 's/ gprof / /'` ;; + esac + noconfigdirs="$noconfigdirs target-libgloss" + ;; + sparc-*-sunos4*) + if [ x${is_cross_compiler} != xno ] ; then + noconfigdirs="$noconfigdirs gdb gdbtest target-newlib target-libgloss" + else + use_gnu_ld=no + fi + ;; + v810-*-*) + noconfigdirs="$noconfigdirs bfd binutils gas gcc gdb ld target-libio target-libg++ target-libstdc++ opcodes target-libgloss" + ;; + vax-*-vms) + noconfigdirs="$noconfigdirs bfd binutils gdb ld target-newlib opcodes target-libgloss" + ;; + vax-*-*) + noconfigdirs="$noconfigdirs target-newlib target-libgloss" + ;; + *-*-lynxos*) + # Newlib makes problems for libg++ in crosses. + noconfigdirs="$noconfigdirs target-newlib target-libgloss" + ;; + *-*-macos* | \ + *-*-mpw*) + # Macs want a resource compiler. + configdirs="$configdirs grez" + ;; +esac + +# targets that need a second pass +case "${target}" in + *-gm-magic*) + noconfigdirs="$noconfigdirs target-libgloss" + ;; +esac + +# If we aren't building newlib, then don't build libgloss, since libgloss +# depends upon some newlib header files. +case "${noconfigdirs}" in + *target-libgloss*) ;; + *target-newlib*) noconfigdirs="$noconfigdirs target-libgloss" ;; +esac + +# If we are building a Canadian Cross, discard tools that can not be built +# using a cross compiler. FIXME: These tools should be fixed. +if [ "${build}" != "${host}" ]; then + noconfigdirs="$noconfigdirs expect dejagnu" +fi + +# Make sure we don't let GNU ld be added if we didn't want it. +if [ x$with_gnu_ld = xno ]; then + use_gnu_ld=no + noconfigdirs="$noconfigdirs ld" +fi + +# Make sure we don't let GNU as be added if we didn't want it. +if [ x$with_gnu_as = xno ]; then + use_gnu_as=no + noconfigdirs="$noconfigdirs gas" +fi + +# Remove the entries in $skipdirs and $noconfigdirs from $configdirs and +# $target_configdirs. +# If we have the source for $noconfigdirs entries, add them to $notsupp. + +notsupp="" +for dir in . $skipdirs $noconfigdirs ; do + dirname=`echo $dir | sed -e s/target-//g` + if [ $dir != . ] && echo " ${configdirs} " | grep " ${dir} " >/dev/null 2>&1; then + configdirs=`echo " ${configdirs} " | sed -e "s/ ${dir} / /"` + if [ -r $srcdir/$dirname/configure ] \ + || [ -r $srcdir/$dirname/configure.in ]; then + if echo " ${skipdirs} " | grep " ${dir} " >/dev/null 2>&1; then + true + else + notsupp="$notsupp $dir" + fi + fi + fi + if [ $dir != . ] && echo " ${target_configdirs} " | grep " ${dir} " >/dev/null 2>&1; then + target_configdirs=`echo " ${target_configdirs} " | sed -e "s/ ${dir} / /"` + if [ -r $srcdir/$dirname/configure ] \ + || [ -r $srcdir/$dirname/configure.in ]; then + if echo " ${skipdirs} " | grep " ${dir} " >/dev/null 2>&1; then + true + else + notsupp="$notsupp $dir" + fi + fi + fi +done + +# Sometimes the tools are distributed with libiberty but with no other +# libraries. In that case, we don't want to build target-libiberty. +if [ -n "${target_configdirs}" ]; then + others= + for i in `echo ${target_configdirs} | sed -e s/target-//g` ; do + if [ "$i" != "libiberty" ]; then + if [ -r $srcdir/$i/configure ] || [ -r $srcdir/$i/configure.in ]; then + others=yes; + break; + fi + fi + done + if [ -z "${others}" ]; then + target_configdirs= + fi +fi + +# Deconfigure all subdirectories, in case we are changing the +# configuration from one where a subdirectory is supported to one where it +# is not. +if [ -z "${norecursion}" -a -n "${configdirs}" ]; then + for i in `echo ${configdirs} | sed -e s/target-//g` ; do + rm -f $i/Makefile + done +fi +if [ -z "${norecursion}" -a -n "${target_configdirs}" ]; then + for i in `echo ${target_configdirs} | sed -e s/target-//g` ; do + rm -f ${target_subdir}/$i/Makefile + done +fi + +# Produce a warning message for the subdirs we can't configure. +# This isn't especially interesting in the Cygnus tree, but in the individual +# FSF releases, it's important to let people know when their machine isn't +# supported by the one or two programs in a package. + +if [ -n "${notsupp}" ] && [ -z "${norecursion}" ]; then + # If $appdirs is non-empty, at least one of those directories must still + # be configured, or we error out. (E.g., if the gas release supports a + # specified target in some subdirs but not the gas subdir, we shouldn't + # pretend that all is well.) + if [ -n "$appdirs" ]; then + for dir in $appdirs ; do + if [ -r $dir/Makefile.in ]; then + if echo " ${configdirs} " | grep " ${dir} " >/dev/null 2>&1; then + appdirs="" + break + fi + if echo " ${target_configdirs} " | grep " ${dir} " >/dev/null 2>&1; then + appdirs="" + break + fi + fi + done + if [ -n "$appdirs" ]; then + echo "*** This configuration is not supported by this package." 1>&2 + exit 1 + fi + fi + # Okay, some application will build, or we don't care to check. Still + # notify of subdirs not getting built. + echo "*** This configuration is not supported in the following subdirectories:" 1>&2 + echo " ${notsupp}" 1>&2 + echo " (Any other directories should still work fine.)" 1>&2 +fi + +# Set with_gnu_as and with_gnu_ld as appropriate. +# +# This is done by determining whether or not the appropriate directory +# is available, and by checking whether or not specific configurations +# have requested that this magic not happen. +# +# The command line options always override the explicit settings in +# configure.in, and the settings in configure.in override this magic. +# +# If the default for a toolchain is to use GNU as and ld, and you don't +# want to do that, then you should use the --without-gnu-as and +# --without-gnu-ld options for the configure script. + +if [ x${use_gnu_as} = x ] ; then + if [ x${with_gnu_as} != xno ] && echo " ${configdirs} " | grep " ${gasdir} " > /dev/null 2>&1 && [ -d ${srcdir}/${gasdir} ] ; then + with_gnu_as=yes + withoptions="$withoptions --with-gnu-as" + fi +fi + +if [ x${use_gnu_ld} = x ] ; then + if [ x${with_gnu_ld} != xno ] && echo " ${configdirs} " | grep " ld " > /dev/null 2>&1 && [ -d ${srcdir}/ld ] ; then + with_gnu_ld=yes + withoptions="$withoptions --with-gnu-ld" + fi +fi + +# If using newlib, add --with-newlib to the withoptions so that gcc/configure +# can detect this case. + +if [ x${with_newlib} != xno ] && echo " ${target_configdirs} " | grep " target-newlib " > /dev/null 2>&1 && [ -d ${srcdir}/newlib ] ; then + with_newlib=yes + withoptions="$withoptions --with-newlib" +fi + +if [ x${shared} = xyes ]; then + case "${target}" in + hppa*) target_makefile_frag=config/mt-papic ;; + i[3456]86-*) target_makefile_frag=config/mt-x86pic ;; + powerpc*-*) target_makefile_frag=config/mt-ppcpic ;; + *) target_makefile_frag=config/mt-${target_cpu}pic ;; + esac +fi + +# post-target: + +# Make sure that the compiler is able to generate an executable. If it +# can't, we are probably in trouble. We don't care whether we can run the +# executable--we might be using a cross compiler--we only care whether it +# can be created. At this point the main configure script has set CC. +echo "int main () { return 0; }" > conftest.c +${CC} -o conftest ${CFLAGS} ${CPPFLAGS} ${LDFLAGS} conftest.c +if [ $? = 0 ] && [ -s conftest ]; then + : +else + echo 1>&2 "*** The command '${CC} -o conftest ${CFLAGS} ${CPPFLAGS} ${LDFLAGS} conftest.c' failed." + echo 1>&2 "*** You must set the environment variable CC to a working compiler." + rm -f conftest* + exit 1 +fi +rm -f conftest* + +# The Solaris /usr/ucb/cc compiler does not appear to work. +case "${host}" in + sparc-sun-solaris2*) + CCBASE="`echo ${CC-cc} | sed 's/ .*$//'`" + if [ "`/usr/bin/which $CCBASE`" = "/usr/ucb/cc" ] ; then + could_use= + [ -d /opt/SUNWspro/bin ] && could_use="/opt/SUNWspro/bin" + if [ -d /opt/cygnus/bin ] ; then + if [ "$could_use" = "" ] ; then + could_use="/opt/cygnus/bin" + else + could_use="$could_use or /opt/cygnus/bin" + fi + fi + if [ "$could_use" = "" ] ; then + echo "Warning: compilation may fail because you're using" + echo "/usr/ucb/cc. You should change your PATH or CC " + echo "variable and rerun configure." + else + echo "Warning: compilation may fail because you're using" + echo "/usr/ucb/cc, when you should use the C compiler from" + echo "$could_use. You should change your" + echo "PATH or CC variable and rerun configure." + fi + fi + ;; +esac + +# If --enable-shared was set, we must set LD_LIBRARY_PATH so that the +# binutils tools will find libbfd.so. +if [ "${shared}" = "yes" ]; then + sed -e 's/^SET_LIB_PATH[ ]*=.*$/SET_LIB_PATH = $(REALLY_SET_LIB_PATH)/' \ + Makefile > Makefile.tem + rm -f Makefile + mv -f Makefile.tem Makefile + + case "${host}" in + *-*-hpux*) + sed -e 's/RPATH_ENVVAR[ ]*=.*$/RPATH_ENVVAR = SHLIB_PATH/' \ + Makefile > Makefile.tem + rm -f Makefile + mv -f Makefile.tem Makefile + ;; + esac +fi + +# If we are building for a cygwin32 host, then set INSTALL_PROGRAM_ARGS to +# -x. This will cause programs to be installed with .exe extensions. +case "${host}" in +*-*-cygwin32*) + sed -e 's/^INSTALL_PROGRAM_ARGS[ ]*=.*$/INSTALL_PROGRAM_ARGS = -x/' \ + Makefile > Makefile.tem + rm -f Makefile + mv -f Makefile.tem Makefile + ;; +esac + +# Record target_configdirs and the configure arguments in Makefile. +target_configdirs=`echo "${target_configdirs}" | sed -e 's/target-//g'` +targargs=`echo "${arguments}" | \ + sed -e 's/--norecursion//' \ + -e 's/--cache[a-z-]*=[^ ]*//' \ + -e 's/--ho[a-z-]*=[^ ]*//' \ + -e 's/--bu[a-z-]*=[^ ]*//' \ + -e 's/--ta[a-z-]*=[^ ]*//'` + +# Passing a --with-cross-host argument lets the target libraries know +# whether they are being built with a cross-compiler or being built +# native. However, it would be better to use other mechanisms to make the +# sorts of decisions they want to make on this basis. Please consider +# this option to be deprecated. FIXME. +if [ x${is_cross_compiler} = xyes ]; then + targargs="--with-cross-host=${host_alias} ${targargs}" +fi + +# Default to --enable-multilib. +if [ x${enable_multilib} = x ]; then + targargs="--enable-multilib ${targargs}" +fi + +targargs="--host=${target_alias} --build=${build_alias} ${targargs}" +sed -e "s:^TARGET_CONFIGDIRS[ ]*=.*$:TARGET_CONFIGDIRS = ${target_configdirs}:" \ + -e "s%^CONFIG_ARGUMENTS[ ]*=.*$%CONFIG_ARGUMENTS = ${targargs}%" \ + -e "s%^TARGET_SUBDIR[ ]*=.*$%TARGET_SUBDIR = ${target_subdir}%" \ + Makefile > Makefile.tem +rm -f Makefile +mv -f Makefile.tem Makefile + +# +# Local Variables: +# fill-column: 131 +# End: +# diff --git a/etc/ChangeLog b/etc/ChangeLog new file mode 100644 index 00000000000..54c1a44f24a --- /dev/null +++ b/etc/ChangeLog @@ -0,0 +1,392 @@ +Tue Jun 17 15:50:23 1997 Angela Marie Thomas (angela@cygnus.com) + + * Install.in: Add /usr/bsd to PATH for Irix (home of compress) + +Thu Jun 12 13:47:00 1997 Angela Marie Thomas (angela@cygnus.com) + + * Install.in (show_exec_prefix_msg): fix quoting + +Wed Jun 4 15:31:43 1997 Jason Molenda (crash@godzilla.cygnus.co.jp) + + * rebuilding.texi: Removed. + +Sat May 24 18:02:20 1997 Angela Marie Thomas (angela@cygnus.com) + + * cross-tools-fix: Remove host check since it doesn't matter + for this case. + * Install.in (guess_system): clean up more unused hosts. + * Install.in, cross-tools-fix, comp-tools-fix, comp-tools-verify: + Hack for host check to not warn the user for certain cases. + +Fri May 23 23:46:10 1997 Angela Marie Thomas (angela@cygnus.com) + + * subst-strings: Remove a lot of unused code + * Install.in: Remove reference to TAPEdflt, use variables instead of + string substitution when able. + +Fri Apr 11 17:25:52 1997 Ian Lance Taylor + + * configure.in: Change file named in AC_INIT to Makefile.in. + * configure: Rebuild. + +Fri Apr 11 18:12:42 1997 Jason Molenda (crash@godzilla.cygnus.co.jp) + + * Install.in (guess_system): Back out change to INSTALLHOST to + call all IRIX systems "mips-sgi-irix4" + + * Makefile.in: Remove references to configure.texi and cfg-paper.texi. + +Thu Apr 10 23:26:45 1997 Jason Molenda (crash@godzilla.cygnus.co.jp) + + * srctree.texi, emacs-relnotes.texi, cfg-paper.texi: Remove. + * Install.in: Remove Ultrix-specific hacks. + Update Cygnus phone numbers. + (guess_system): Remove some old systems (Ultrix, OSF1 v1 & 2, + m68k-HPUX, m68k SunOS, etc.) + (show_gnu_root_msg): Remove. + Removed all the remove option code. + +Thu Apr 10 23:23:33 1997 Jason Molenda (crash@godzilla.cygnus.co.jp) + + * configure.man, configure.texi: Remote. + +Mon Apr 7 18:15:00 1997 Brendan Kehoe + + * Fix the version string for OSF1 4.0 to recognize either + V4.* or X4.* + +Mon Apr 7 15:34:47 1997 Ian Lance Taylor + + * standards.texi, make-stds.texi: Update to current FSF versions. + +Tue Apr 1 16:19:31 1997 Jason Molenda (crash@godzilla.cygnus.co.jp) + + * Install.in (show_exec_prefix_msg): GDBTK_FILENAME to + GDBTK_LIBRARY, also update TCL_LIBRARY and TK_LIBRARY. + +Tue Nov 19 15:36:14 1996 Doug Evans + + * make-rel-sym-tree: New file. + +Wed Oct 23 00:34:07 1996 Angela Marie Thomas (angela@cygnus.com) + + * Lots of patches from progressive... + * Install.in: restore DDOPTS for AIX 4.x + * Install.in, subst-strings: add case for DG Aviion + * subst-strings: fix typo in INSTALLdir var setting + * comp-tools-verify: set SHLIB_PATH for shared libs + * Install.in, subst-strings: add case for solaris2.5 + * Install.in: fix regression for hppa1.1 check + * comp-tools-fix: set LD_LIBRARY_PATH + * comp-tools-fix: If fixincludes fixes /usr/include/limits.h, + install it as syslimits.h. + +Wed Oct 16 19:20:42 1996 Michael Meissner + + * Install.in (guess_system): Treat powerpc-ibm-aix4.1 the same as + rs6000-ibm-aix4.1, since the compiler now uses common mode by + default. + +Wed Oct 2 15:39:07 1996 Jason Molenda (crash@godzilla.cygnus.co.jp) + + * configure.in (AC_PROG_INSTALL): Added. + * Makefile.in (distclean): Remove config.cache. + +Wed Oct 2 14:33:58 1996 Jason Molenda (crash@godzilla.cygnus.co.jp) + + * configure.in: Switch to autoconf configure.in. + * configure: New. + * Makefile.in: Use autoconf-substituted values. + +Tue Jun 25 18:56:08 1996 Jason Molenda (crash@godzilla.cygnus.co.jp) + + * Makefile.in (datadir): Changed to $(prefix)/share. + +Fri Mar 29 11:38:01 1996 J.T. Conklin (jtc@lisa.cygnus.com) + + * configure.man: Changed to be recognized by catman -w on Solaris. + +Wed Dec 6 15:40:28 1995 Doug Evans + + * comp-tools-fix (fixincludes): Define FIXPROTO_DEFINES from + .../install-tools/fixproto-defines. + +Sun Nov 12 19:31:27 1995 Jason Molenda (crash@phydeaux.cygnus.com) + + * comp-tools-verify (verify_cxx_initializers): delete argv, + argc declarations, add -static to compile line. + (verify_cxx_hello_world): delete argv, argc declarations, add + -static to compile line. + +Wed Sep 20 13:21:52 1995 Ian Lance Taylor + + * Makefile.in (maintainer-clean): New target, synonym for + realclean. + +Thu Sep 14 17:19:58 1995 Jason Molenda (crash@phydeaux.cygnus.com) + + * Install.in (show_exec_prefix_msg): print out paths for + TCL_LIBRARY, TK_LIBRARY and GDBTK_FILENAME. + +Mon Aug 28 17:25:49 1995 Jason Molenda (crash@phydeaux.cygnus.com) + + * Install.in (PATH): add /usr/ucb to $PATH (for SunOS 4.1.x). + +Tue Aug 15 21:51:58 1995 Jason Molenda (crash@phydeaux.cygnus.com) + + * Install.in (guess_system): Match OSF/1 v3.x as the same as + v2.x--v2.x binaries are upward compatible. + +Tue Aug 15 21:46:54 1995 Jason Molenda (crash@phydeaux.cygnus.com) + + * Install.in (guess_system): recognize HP 9000/800 systems as the + same as HP 9000/700 systems. + +Tue Aug 8 13:11:56 1995 Brendan Kehoe + + * Install.in: For emacs, run show_emacs_alternate_msg and exit. + (show_emacs_alternate_msg): New message saying how emacs can't be + installed in an alternate prefix. + +Thu Jun 8 00:42:56 1995 Angela Marie Thomas + + * subst-strings: change du commands to $BINDIR/. & $SRCDIR/. just + in case they are symlinks. + +Tue Apr 18 14:23:10 1995 J.T. Conklin + + * cdk-fix: Extracted table of targets that don't need their + headers fixed from gcc's configure script. + + * cdk-fix, cdk-verify: Use ${HOST} instead of ||HOSTstr|| + + * cdk-fix, cdk-verify: New files, install script fragments used + for Cygnus Developer's Kit. + + * Install.in (do_mkdir): New function. + + * Install.in: Added support for --with and --without options. + Changed so that tape commands are not run when extracting + from a file. + (do_mt): Changed to take only one argument. + +Wed Mar 29 11:16:38 1995 Jason Molenda (crash@phydeaux.cygnus.com) + + * Install.in: catch UNAME==alpha-dec-osf2.x and correct entry for + alpha-dec-osf1.x + +Fri Jan 27 12:04:29 1995 J.T. Conklin + + * subst-strings (mips-sgi-irix5): New entry in table. + +Thu Jan 19 12:15:44 1995 J.T. Conklin + + * Install.in: Major rewrite, bundle dependent code (for example, + fixincludes for comp-tools) will be inserted into the Install + script when it is generated. + +Tue Jan 17 16:51:32 1995 Ian Lance Taylor + + * Makefile.in (Makefile): Rebuild using $(SHELL). + +Thu Nov 3 19:30:33 1994 Ken Raeburn + + * Makefile.in (install-info): Depend on info. + +Fri Aug 19 16:16:38 1994 Jason Molenda (crash@phydeaux.cygnus.com) + + * Install.in: set $FIX_HEADER so fixproto can find fix-header. + +Fri May 6 16:18:58 1994 Jason Molenda (crash@sendai.cygnus.com) + + * Makefile.in (install-info): add a semicolon in the if statement. + +Fri Apr 29 16:56:07 1994 David J. Mackenzie (djm@rtl.cygnus.com) + + * cfg-paper.texi: Update some outdated information. + + * Makefile.in (install-info): Pass file, not directory, as last + arg to INSTALL_DATA. + (uninstall): New target. + +Thu Apr 28 14:42:22 1994 David J. Mackenzie (djm@rtl.cygnus.com) + + * configure.texi: Comment out @smallbook. + + * Makefile.in: Define TEXI2DVI and TEXIDIR, and use the latter. + Remove info files in realclean, not clean, per coding standards. + Remove TeX output in clean. + +Tue Apr 26 17:18:03 1994 Jason Molenda (crash@sendai.cygnus.com) + + * Install.in: fixincludes output is actually put in fixincludes.log, + but echo'ed messages claim it is fixinc.log. This is the same + messages as I logged in March 4 1994, but for some reason we found + the change hadn't been done. I'll have to dig through the logs + and find out what I really did do that day. :) + +Mon Apr 25 20:28:19 1994 Jason Molenda (crash@sendai.cygnus.com) + + * Install.in: use eval to call do_mt() for Ultrix brokenness. + +Mon Apr 25 20:00:00 1994 Jason Molenda (crash@sendai.cygnus.com) + + * Install.in(do_mt): exit with error status 1 if # of parameters + != 3. + +Mon Apr 25 19:42:36 1994 Jason Molenda (crash@sendai.cygnus.com) + + * Install.in: lose TAPE_FORWARD and TAPE_REWIND, add do_mt() + to do all tape movement operations. Currently untested. Addresses + PR # 4886 from bull. + + * Install.in: add 1994 to the copyright thing. + +Fri Apr 22 19:05:13 1994 David J. Mackenzie (djm@rtl.cygnus.com) + + * standards.texi: Update from FSF. + +Fri Apr 22 15:46:10 1994 Jason Molenda (crash@cygnus.com) + + * Install.in: Add $DDOPTS, has ``bs=124b'' for all systems except + AIX (some versions of AIX don't understand bs=124b. Silly OS). + +Mon Apr 4 22:55:05 1994 Jason Molenda (crash@sendai.cygnus.com) + + * Install.in: null out $TOOLS before adding stuff to it + non-destructively. + +Wed Mar 30 21:45:35 1994 David J. Mackenzie (djm@rtl.cygnus.com) + + * standards.texi: Fix typo. + + * configure.texi, configure.man: Document --disable-. + +Mon Mar 28 13:22:15 1994 David J. Mackenzie (djm@rtl.cygnus.com) + + * standards.texi: Update from FSF. + +Sat Mar 26 09:21:44 1994 David J. Mackenzie (djm@rtl.cygnus.com) + + * standards.texi, make-stds.texi: Update from FSF. + +Fri Mar 25 22:59:45 1994 David J. Mackenzie (djm@rtl.cygnus.com) + + * configure.texi, configure.man: Document --enable-* options. + +Wed Mar 23 23:38:24 1994 Jason Molenda (crash@sendai.cygnus.com) + + * Install.in: set CPP to be gcc -E for fixincludes. + +Wed Mar 23 13:42:48 1994 Jason Molenda (crash@sendai.cygnus.com) + + * Install.in: set PATH to $PATH:/bin:/usr/bin so we can pick + up native tools even if the user doesn't have them in his + path. + + * Install.in: ``hppa-1.1-hp-hpux'' -> ``hppa1.1-hp-hpux''. + +Tue Mar 15 22:09:20 1994 Jason Molenda (crash@sendai.cygnus.com) + + * Install.in: TAPE_REWIND and TAPE_FORWARD variables for Unixunaware, + added switch statement to detect if system is Unixunaware. + +Fri Mar 4 12:10:30 1994 Jason Molenda (crash@sendai.cygnus.com) + + * Install.in: fixincludes output is actually put in fixincludes.log, + but echo'ed messages claim it is fixinc.log. + +Wed Nov 3 02:58:02 1993 Jeffrey Osier (jeffrey@thepub.cygnus.com) + + * subst-strings: output TEXBUNDLE for more install notes matching + * install-texi.in: PRMS info now exists + +Tue Oct 26 16:57:12 1993 K. Richard Pixley (rich@sendai.cygnus.com) + + * subst-strings: match solaris*. Also, add default case to catch + and error out for unrecognized systems. + +Thu Aug 19 18:21:31 1993 david d `zoo' zuhn (zoo@rtl.cygnus.com) + + * Install.in: handle the new fixproto work + +Mon Jul 19 12:05:41 1993 david d `zoo' zuhn (zoo@cirdan.cygnus.com) + + * Install.in: remove "MT=tctl" for AIX (not needed, and barely + worked anyway) + +Mon Jun 14 19:09:22 1993 Jeffrey Osier (jeffrey@cygnus.com) + + * subst-strings: changed HOST to recognize Solaris for install notes + +Thu Jun 10 16:01:25 1993 Jeffrey Osier (jeffrey@cygnus.com) + + * dos-inst.texi: new file. + +Wed Jun 9 19:23:59 1993 Jeffrey Osier (jeffrey@rtl.cygnus.com) + + * install-texi.in: added conditionals (nearly complete) + cleaned up + added support for other releases (not done) + +Wed Jun 9 15:53:58 1993 Jim Kingdon (kingdon@cygnus.com) + + * Makefile.in (install-info): Use INSTALL_DATA. + ({dist,real}clean): Also delete Makefile and config.status. + +Fri Jun 4 17:09:56 1993 Jeffrey Osier (jeffrey@cygnus.com) + + * subst-strings: added data for OS_STRING + + * subst-strings: added support for OS_STRING + +Thu Jun 3 00:37:01 1993 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * Install.in: pull COPYING and COPYING.LIB off of the tape + +Tue Jun 1 16:52:08 1993 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * subst-strings: replace RELEASE_DIR too + +Mon Mar 22 23:55:27 1993 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * Makefile.in: add installcheck target + +Wed Mar 17 02:21:15 1993 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * Install.in: fix 'source only' extraction bug where it looked for + the src dir under H-/src instead of src; also remove stray + reference to EMACSHIBIN + +Mon Mar 15 01:25:45 1993 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * make-stds.texi: added 'installcheck' to the standard targets + +Tue Mar 9 19:48:28 1993 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * standards.texi: added INFO-DIR-ENTRY, updated version from the FSF + +Tue Feb 9 12:40:23 1993 Ian Lance Taylor (ian@cygnus.com) + + * Makefile.in (standards.info): Added -I$(srcdir) to find + make-stds.texi. + +Mon Feb 1 16:32:56 1993 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * standards.texi: updated to latest FSF version, which includes: + + * make-stds.texi: new file + +Mon Nov 30 01:31:40 1992 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * install-texi.in, relnotes.texi, intro.texi: changed Cygnus phone + numbers from the old Palo Alto ones to the new Mtn. View numbers + +Mon Nov 16 16:50:43 1992 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * Makefile.in: define $(RM) to "rm -f" + +Sun Oct 11 16:05:48 1992 david d `zoo' zuhn (zoo at cirdan.cygnus.com) + + * intro.texi: added INFO-DIR-ENTRY + diff --git a/etc/Makefile.in b/etc/Makefile.in new file mode 100644 index 00000000000..a5d59d6efdb --- /dev/null +++ b/etc/Makefile.in @@ -0,0 +1,88 @@ +# +# Makefile.in for etc +# + +prefix = @prefix@ +exec_prefix = @exec_prefix@ + +srcdir = @srcdir@ +VPATH = @srcdir@ + +bindir = @bindir@ +libdir = @libdir@ +tooldir = $(libdir) +datadir = @datadir@ + +mandir = @mandir@ +man1dir = $(mandir)/man1 +man2dir = $(mandir)/man2 +man3dir = $(mandir)/man3 +man4dir = $(mandir)/man4 +man5dir = $(mandir)/man5 +man6dir = $(mandir)/man6 +man7dir = $(mandir)/man7 +man8dir = $(mandir)/man8 +man9dir = $(mandir)/man9 +infodir = @infodir@ + +SHELL = /bin/sh + +INSTALL = @INSTALL@ +INSTALL_PROGRAM = @INSTALL_PROGRAM@ +INSTALL_DATA = @INSTALL_DATA@ + +MAKEINFO = makeinfo +TEXI2DVI = texi2dvi + +# Where to find texinfo.tex to format documentation with TeX. +TEXIDIR = $(srcdir)/../texinfo + +#### Host, target, and site specific Makefile fragments come in here. +### + +INFOFILES = standards.info +DVIFILES = standards.dvi + +all: + +install: + +uninstall: + +info: $(INFOFILES) + +install-info: info + if test ! -f standards.info ; then cd $(srcdir); fi; \ + for i in standards.info*; do \ + $(INSTALL_DATA) $$i $(infodir)/$$i; \ + done + +dvi: $(DVIFILES) + +standards.info: $(srcdir)/standards.texi + $(MAKEINFO) -I$(srcdir) -o standards.info $(srcdir)/standards.texi + +standards.dvi: $(srcdir)/standards.texi + TEXINPUTS=$(TEXIDIR):$$TEXINPUTS $(TEXI2DVI) $(srcdir)/standards.texi + + +clean: + rm -f *.aux *.cp *.cps *.dvi *.fn *.fns *.ky *.kys *.log + rm -f *.pg *.pgs *.toc *.tp *.tps *.vr *.vrs + +mostlyclean: clean + +distclean: clean + rm -f Makefile config.status config.cache + +maintainer-clean realclean: distclean + rm -f *.info* + +Makefile: $(srcdir)/Makefile.in $(host_makefile_frag) $(target_makefile_frag) + $(SHELL) ./config.status + +## these last targets are for standards.texi conformance +dist: +check: +installcheck: +TAGS: diff --git a/etc/configure b/etc/configure new file mode 100755 index 00000000000..c4a76356c46 --- /dev/null +++ b/etc/configure @@ -0,0 +1,858 @@ +#! /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=Makefile.in + +# 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 + + + +ac_aux_dir= +for ac_dir in $srcdir $srcdir/.. $srcdir/../..; do + if test -f $ac_dir/install-sh; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/install-sh -c" + break + elif test -f $ac_dir/install.sh; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/install.sh -c" + break + fi +done +if test -z "$ac_aux_dir"; then + { echo "configure: error: can not find install-sh or install.sh in $srcdir $srcdir/.. $srcdir/../.." 1>&2; exit 1; } +fi +ac_config_guess=$ac_aux_dir/config.guess +ac_config_sub=$ac_aux_dir/config.sub +ac_configure=$ac_aux_dir/configure # This should be Cygnus configure. + +# Find a good install program. We prefer a C program (faster), +# so one script is as good as another. But avoid the broken or +# incompatible versions: +# SysV /etc/install, /usr/sbin/install +# SunOS /usr/etc/install +# IRIX /sbin/install +# AIX /bin/install +# AFS /usr/afsws/bin/install, which mishandles nonexistent args +# SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff" +# ./install, which can be erroneously created by make from ./install.sh. +echo $ac_n "checking for a BSD compatible install""... $ac_c" 1>&6 +echo "configure:553: checking for a BSD compatible install" >&5 +if test -z "$INSTALL"; then +if eval "test \"`echo '$''{'ac_cv_path_install'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + IFS="${IFS= }"; ac_save_IFS="$IFS"; IFS="${IFS}:" + for ac_dir in $PATH; do + # Account for people who put trailing slashes in PATH elements. + case "$ac_dir/" in + /|./|.//|/etc/*|/usr/sbin/*|/usr/etc/*|/sbin/*|/usr/afsws/bin/*|/usr/ucb/*) ;; + *) + # OSF1 and SCO ODT 3.0 have their own names for install. + for ac_prog in ginstall installbsd scoinst install; do + if test -f $ac_dir/$ac_prog; then + if test $ac_prog = install && + grep dspmsg $ac_dir/$ac_prog >/dev/null 2>&1; then + # AIX install. It has an incompatible calling convention. + # OSF/1 installbsd also uses dspmsg, but is usable. + : + else + ac_cv_path_install="$ac_dir/$ac_prog -c" + break 2 + fi + fi + done + ;; + esac + done + IFS="$ac_save_IFS" + +fi + if test "${ac_cv_path_install+set}" = set; then + INSTALL="$ac_cv_path_install" + else + # As a last resort, use the slow shell script. We don't cache a + # path for INSTALL within a source directory, because that will + # break other packages using the cache if that directory is + # removed, or if the path is relative. + INSTALL="$ac_install_sh" + fi +fi +echo "$ac_t""$INSTALL" 1>&6 + +# Use test -z because SunOS4 sh mishandles braces in ${var-val}. +# It thinks the first close brace ends the variable substitution. +test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}' + +test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644' + + +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 +ac_given_INSTALL="$INSTALL" + +trap 'rm -fr `echo "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%@INSTALL_PROGRAM@%$INSTALL_PROGRAM%g +s%@INSTALL_DATA@%$INSTALL_DATA%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 + + case "$ac_given_INSTALL" in + [/$]*) INSTALL="$ac_given_INSTALL" ;; + *) INSTALL="$ac_dots$ac_given_INSTALL" ;; + 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 +s%@INSTALL@%$INSTALL%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/etc/configure.in b/etc/configure.in new file mode 100644 index 00000000000..b785068009e --- /dev/null +++ b/etc/configure.in @@ -0,0 +1,7 @@ +dnl Process this file with autoconf to produce a configure script. +AC_PREREQ(2.5) +AC_INIT(Makefile.in) + +AC_PROG_INSTALL + +AC_OUTPUT(Makefile) diff --git a/etc/make-stds.texi b/etc/make-stds.texi new file mode 100644 index 00000000000..e7c9cf98217 --- /dev/null +++ b/etc/make-stds.texi @@ -0,0 +1,893 @@ +@comment This file is included by both standards.texi and make.texinfo. +@comment It was broken out of standards.texi on 1/6/93 by roland. + +@node Makefile Conventions +@chapter Makefile Conventions +@comment standards.texi does not print an index, but make.texinfo does. +@cindex makefile, conventions for +@cindex conventions for makefiles +@cindex standards for makefiles + +This +@ifinfo +node +@end ifinfo +@iftex +@ifset CODESTD +section +@end ifset +@ifclear CODESTD +chapter +@end ifclear +@end iftex +describes conventions for writing the Makefiles for GNU programs. + +@menu +* Makefile Basics:: General Conventions for Makefiles +* Utilities in Makefiles:: Utilities in Makefiles +* Command Variables:: Variables for Specifying Commands +* Directory Variables:: Variables for Installation Directories +* Standard Targets:: Standard Targets for Users +* Install Command Categories:: Three categories of commands in the `install' + rule: normal, pre-install and post-install. +@end menu + +@node Makefile Basics +@section General Conventions for Makefiles + +Every Makefile should contain this line: + +@example +SHELL = /bin/sh +@end example + +@noindent +to avoid trouble on systems where the @code{SHELL} variable might be +inherited from the environment. (This is never a problem with GNU +@code{make}.) + +Different @code{make} programs have incompatible suffix lists and +implicit rules, and this sometimes creates confusion or misbehavior. So +it is a good idea to set the suffix list explicitly using only the +suffixes you need in the particular Makefile, like this: + +@example +.SUFFIXES: +.SUFFIXES: .c .o +@end example + +@noindent +The first line clears out the suffix list, the second introduces all +suffixes which may be subject to implicit rules in this Makefile. + +Don't assume that @file{.} is in the path for command execution. When +you need to run programs that are a part of your package during the +make, please make sure that it uses @file{./} if the program is built as +part of the make or @file{$(srcdir)/} if the file is an unchanging part +of the source code. Without one of these prefixes, the current search +path is used. + +The distinction between @file{./} (the @dfn{build directory}) and +@file{$(srcdir)/} (the @dfn{source directory}) is important because +users can build in a separate directory using the @samp{--srcdir} option +to @file{configure}. A rule of the form: + +@smallexample +foo.1 : foo.man sedscript + sed -e sedscript foo.man > foo.1 +@end smallexample + +@noindent +will fail when the build directory is not the source directory, because +@file{foo.man} and @file{sedscript} are in the the source directory. + +When using GNU @code{make}, relying on @samp{VPATH} to find the source +file will work in the case where there is a single dependency file, +since the @code{make} automatic variable @samp{$<} will represent the +source file wherever it is. (Many versions of @code{make} set @samp{$<} +only in implicit rules.) A Makefile target like + +@smallexample +foo.o : bar.c + $(CC) -I. -I$(srcdir) $(CFLAGS) -c bar.c -o foo.o +@end smallexample + +@noindent +should instead be written as + +@smallexample +foo.o : bar.c + $(CC) -I. -I$(srcdir) $(CFLAGS) -c $< -o $@@ +@end smallexample + +@noindent +in order to allow @samp{VPATH} to work correctly. When the target has +multiple dependencies, using an explicit @samp{$(srcdir)} is the easiest +way to make the rule work well. For example, the target above for +@file{foo.1} is best written as: + +@smallexample +foo.1 : foo.man sedscript + sed -e $(srcdir)/sedscript $(srcdir)/foo.man > $@@ +@end smallexample + +GNU distributions usually contain some files which are not source +files---for example, Info files, and the output from Autoconf, Automake, +Bison or Flex. Since these files normally appear in the source +directory, they should always appear in the source directory, not in the +build directory. So Makefile rules to update them should put the +updated files in the source directory. + +However, if a file does not appear in the distribution, then the +Makefile should not put it in the source directory, because building a +program in ordinary circumstances should not modify the source directory +in any way. + +Try to make the build and installation targets, at least (and all their +subtargets) work correctly with a parallel @code{make}. + +@node Utilities in Makefiles +@section Utilities in Makefiles + +Write the Makefile commands (and any shell scripts, such as +@code{configure}) to run in @code{sh}, not in @code{csh}. Don't use any +special features of @code{ksh} or @code{bash}. + +The @code{configure} script and the Makefile rules for building and +installation should not use any utilities directly except these: + +@c dd find +@c gunzip gzip md5sum +@c mkfifo mknod tee uname + +@example +cat cmp cp diff echo egrep expr false grep install-info +ln ls mkdir mv pwd rm rmdir sed sleep sort tar test touch true +@end example + +The compression program @code{gzip} can be used in the @code{dist} rule. + +Stick to the generally supported options for these programs. For +example, don't use @samp{mkdir -p}, convenient as it may be, because +most systems don't support it. + +It is a good idea to avoid creating symbolic links in makefiles, since a +few systems don't support them. + +The Makefile rules for building and installation can also use compilers +and related programs, but should do so via @code{make} variables so that the +user can substitute alternatives. Here are some of the programs we +mean: + +@example +ar bison cc flex install ld ldconfig lex +make makeinfo ranlib texi2dvi yacc +@end example + +Use the following @code{make} variables to run those programs: + +@example +$(AR) $(BISON) $(CC) $(FLEX) $(INSTALL) $(LD) $(LDCONFIG) $(LEX) +$(MAKE) $(MAKEINFO) $(RANLIB) $(TEXI2DVI) $(YACC) +@end example + +When you use @code{ranlib} or @code{ldconfig}, you should make sure +nothing bad happens if the system does not have the program in question. +Arrange to ignore an error from that command, and print a message before +the command to tell the user that failure of this command does not mean +a problem. (The Autoconf @samp{AC_PROG_RANLIB} macro can help with +this.) + +If you use symbolic links, you should implement a fallback for systems +that don't have symbolic links. + +Additional utilities that can be used via Make variables are: + +@example +chgrp chmod chown mknod +@end example + +It is ok to use other utilities in Makefile portions (or scripts) +intended only for particular systems where you know those utilities +exist. + +@node Command Variables +@section Variables for Specifying Commands + +Makefiles should provide variables for overriding certain commands, options, +and so on. + +In particular, you should run most utility programs via variables. +Thus, if you use Bison, have a variable named @code{BISON} whose default +value is set with @samp{BISON = bison}, and refer to it with +@code{$(BISON)} whenever you need to use Bison. + +File management utilities such as @code{ln}, @code{rm}, @code{mv}, and +so on, need not be referred to through variables in this way, since users +don't need to replace them with other programs. + +Each program-name variable should come with an options variable that is +used to supply options to the program. Append @samp{FLAGS} to the +program-name variable name to get the options variable name---for +example, @code{BISONFLAGS}. (The name @code{CFLAGS} is an exception to +this rule, but we keep it because it is standard.) Use @code{CPPFLAGS} +in any compilation command that runs the preprocessor, and use +@code{LDFLAGS} in any compilation command that does linking as well as +in any direct use of @code{ld}. + +If there are C compiler options that @emph{must} be used for proper +compilation of certain files, do not include them in @code{CFLAGS}. +Users expect to be able to specify @code{CFLAGS} freely themselves. +Instead, arrange to pass the necessary options to the C compiler +independently of @code{CFLAGS}, by writing them explicitly in the +compilation commands or by defining an implicit rule, like this: + +@smallexample +CFLAGS = -g +ALL_CFLAGS = -I. $(CFLAGS) +.c.o: + $(CC) -c $(CPPFLAGS) $(ALL_CFLAGS) $< +@end smallexample + +Do include the @samp{-g} option in @code{CFLAGS}, because that is not +@emph{required} for proper compilation. You can consider it a default +that is only recommended. If the package is set up so that it is +compiled with GCC by default, then you might as well include @samp{-O} +in the default value of @code{CFLAGS} as well. + +Put @code{CFLAGS} last in the compilation command, after other variables +containing compiler options, so the user can use @code{CFLAGS} to +override the others. + +Every Makefile should define the variable @code{INSTALL}, which is the +basic command for installing a file into the system. + +Every Makefile should also define the variables @code{INSTALL_PROGRAM} +and @code{INSTALL_DATA}. (The default for each of these should be +@code{$(INSTALL)}.) Then it should use those variables as the commands +for actual installation, for executables and nonexecutables +respectively. Use these variables as follows: + +@example +$(INSTALL_PROGRAM) foo $(bindir)/foo +$(INSTALL_DATA) libfoo.a $(libdir)/libfoo.a +@end example + +@noindent +Always use a file name, not a directory name, as the second argument of +the installation commands. Use a separate command for each file to be +installed. + +@node Directory Variables +@section Variables for Installation Directories + +Installation directories should always be named by variables, so it is +easy to install in a nonstandard place. The standard names for these +variables are described below. They are based on a standard filesystem +layout; variants of it are used in SVR4, 4.4BSD, Linux, Ultrix v4, and +other modern operating systems. + +These two variables set the root for the installation. All the other +installation directories should be subdirectories of one of these two, +and nothing should be directly installed into these two directories. + +@table @samp +@item prefix +A prefix used in constructing the default values of the variables listed +below. The default value of @code{prefix} should be @file{/usr/local}. +When building the complete GNU system, the prefix will be empty and +@file{/usr} will be a symbolic link to @file{/}. +(If you are using Autoconf, write it as @samp{@@prefix@@}.) + +@item exec_prefix +A prefix used in constructing the default values of some of the +variables listed below. The default value of @code{exec_prefix} should +be @code{$(prefix)}. +(If you are using Autoconf, write it as @samp{@@exec_prefix@@}.) + +Generally, @code{$(exec_prefix)} is used for directories that contain +machine-specific files (such as executables and subroutine libraries), +while @code{$(prefix)} is used directly for other directories. +@end table + +Executable programs are installed in one of the following directories. + +@table @samp +@item bindir +The directory for installing executable programs that users can run. +This should normally be @file{/usr/local/bin}, but write it as +@file{$(exec_prefix)/bin}. +(If you are using Autoconf, write it as @samp{@@bindir@@}.) + +@item sbindir +The directory for installing executable programs that can be run from +the shell, but are only generally useful to system administrators. This +should normally be @file{/usr/local/sbin}, but write it as +@file{$(exec_prefix)/sbin}. +(If you are using Autoconf, write it as @samp{@@sbindir@@}.) + +@item libexecdir +@comment This paragraph adjusted to avoid overfull hbox --roland 5jul94 +The directory for installing executable programs to be run by other +programs rather than by users. This directory should normally be +@file{/usr/local/libexec}, but write it as @file{$(exec_prefix)/libexec}. +(If you are using Autoconf, write it as @samp{@@libexecdir@@}.) +@end table + +Data files used by the program during its execution are divided into +categories in two ways. + +@itemize @bullet +@item +Some files are normally modified by programs; others are never normally +modified (though users may edit some of these). + +@item +Some files are architecture-independent and can be shared by all +machines at a site; some are architecture-dependent and can be shared +only by machines of the same kind and operating system; others may never +be shared between two machines. +@end itemize + +This makes for six different possibilities. However, we want to +discourage the use of architecture-dependent files, aside from object +files and libraries. It is much cleaner to make other data files +architecture-independent, and it is generally not hard. + +Therefore, here are the variables Makefiles should use to specify +directories: + +@table @samp +@item datadir +The directory for installing read-only architecture independent data +files. This should normally be @file{/usr/local/share}, but write it as +@file{$(prefix)/share}. +(If you are using Autoconf, write it as @samp{@@datadir@@}.) +As a special exception, see @file{$(infodir)} +and @file{$(includedir)} below. + +@item sysconfdir +The directory for installing read-only data files that pertain to a +single machine--that is to say, files for configuring a host. Mailer +and network configuration files, @file{/etc/passwd}, and so forth belong +here. All the files in this directory should be ordinary ASCII text +files. This directory should normally be @file{/usr/local/etc}, but +write it as @file{$(prefix)/etc}. +(If you are using Autoconf, write it as @samp{@@sysconfdir@@}.) + +@c rewritten to avoid overfull hbox --tower +Do not install executables +@c here +in this directory (they probably +belong in @file{$(libexecdir)} or @file{$(sbindir)}). Also do not +install files that are modified in the normal course of their use +(programs whose purpose is to change the configuration of the system +excluded). Those probably belong in @file{$(localstatedir)}. + +@item sharedstatedir +The directory for installing architecture-independent data files which +the programs modify while they run. This should normally be +@file{/usr/local/com}, but write it as @file{$(prefix)/com}. +(If you are using Autoconf, write it as @samp{@@sharedstatedir@@}.) + +@item localstatedir +The directory for installing data files which the programs modify while +they run, and that pertain to one specific machine. Users should never +need to modify files in this directory to configure the package's +operation; put such configuration information in separate files that go +in @file{$(datadir)} or @file{$(sysconfdir)}. @file{$(localstatedir)} +should normally be @file{/usr/local/var}, but write it as +@file{$(prefix)/var}. +(If you are using Autoconf, write it as @samp{@@localstatedir@@}.) + +@item libdir +The directory for object files and libraries of object code. Do not +install executables here, they probably ought to go in @file{$(libexecdir)} +instead. The value of @code{libdir} should normally be +@file{/usr/local/lib}, but write it as @file{$(exec_prefix)/lib}. +(If you are using Autoconf, write it as @samp{@@libdir@@}.) + +@item infodir +The directory for installing the Info files for this package. By +default, it should be @file{/usr/local/info}, but it should be written +as @file{$(prefix)/info}. +(If you are using Autoconf, write it as @samp{@@infodir@@}.) + +@item lispdir +The directory for installing any Emacs Lisp files in this package. By +default, it should be @file{/usr/local/share/emacs/site-lisp}, but it +should be written as @file{$(prefix)/share/emacs/site-lisp}. + +If you are using Autoconf, write the default as @samp{@@lispdir@@}. +In order to make @samp{@@lispdir@@} work, you need the following lines +in your @file{configure.in} file: + +@example +lispdir='$@{datadir@}/emacs/site-lisp' +AC_SUBST(lispdir) +@end example + +@item includedir +@c rewritten to avoid overfull hbox --roland +The directory for installing header files to be included by user +programs with the C @samp{#include} preprocessor directive. This +should normally be @file{/usr/local/include}, but write it as +@file{$(prefix)/include}. +(If you are using Autoconf, write it as @samp{@@includedir@@}.) + +Most compilers other than GCC do not look for header files in +@file{/usr/local/include}. So installing the header files this way is +only useful with GCC. Sometimes this is not a problem because some +libraries are only really intended to work with GCC. But some libraries +are intended to work with other compilers. They should install their +header files in two places, one specified by @code{includedir} and one +specified by @code{oldincludedir}. + +@item oldincludedir +The directory for installing @samp{#include} header files for use with +compilers other than GCC. This should normally be @file{/usr/include}. +(If you are using Autoconf, you can write it as @samp{@@oldincludedir@@}.) + +The Makefile commands should check whether the value of +@code{oldincludedir} is empty. If it is, they should not try to use +it; they should cancel the second installation of the header files. + +A package should not replace an existing header in this directory unless +the header came from the same package. Thus, if your Foo package +provides a header file @file{foo.h}, then it should install the header +file in the @code{oldincludedir} directory if either (1) there is no +@file{foo.h} there or (2) the @file{foo.h} that exists came from the Foo +package. + +To tell whether @file{foo.h} came from the Foo package, put a magic +string in the file---part of a comment---and @code{grep} for that string. +@end table + +Unix-style man pages are installed in one of the following: + +@table @samp +@item mandir +The top-level directory for installing the man pages (if any) for this +package. It will normally be @file{/usr/local/man}, but you should +write it as @file{$(prefix)/man}. +(If you are using Autoconf, write it as @samp{@@mandir@@}.) + +@item man1dir +The directory for installing section 1 man pages. Write it as +@file{$(mandir)/man1}. +@item man2dir +The directory for installing section 2 man pages. Write it as +@file{$(mandir)/man2} +@item @dots{} + +@strong{Don't make the primary documentation for any GNU software be a +man page. Write a manual in Texinfo instead. Man pages are just for +the sake of people running GNU software on Unix, which is a secondary +application only.} + +@item manext +The file name extension for the installed man page. This should contain +a period followed by the appropriate digit; it should normally be @samp{.1}. + +@item man1ext +The file name extension for installed section 1 man pages. +@item man2ext +The file name extension for installed section 2 man pages. +@item @dots{} +Use these names instead of @samp{manext} if the package needs to install man +pages in more than one section of the manual. +@end table + +And finally, you should set the following variable: + +@table @samp +@item srcdir +The directory for the sources being compiled. The value of this +variable is normally inserted by the @code{configure} shell script. +(If you are using Autconf, use @samp{srcdir = @@srcdir@@}.) +@end table + +For example: + +@smallexample +@c I have changed some of the comments here slightly to fix an overfull +@c hbox, so the make manual can format correctly. --roland +# Common prefix for installation directories. +# NOTE: This directory must exist when you start the install. +prefix = /usr/local +exec_prefix = $(prefix) +# Where to put the executable for the command `gcc'. +bindir = $(exec_prefix)/bin +# Where to put the directories used by the compiler. +libexecdir = $(exec_prefix)/libexec +# Where to put the Info files. +infodir = $(prefix)/info +@end smallexample + +If your program installs a large number of files into one of the +standard user-specified directories, it might be useful to group them +into a subdirectory particular to that program. If you do this, you +should write the @code{install} rule to create these subdirectories. + +Do not expect the user to include the subdirectory name in the value of +any of the variables listed above. The idea of having a uniform set of +variable names for installation directories is to enable the user to +specify the exact same values for several different GNU packages. In +order for this to be useful, all the packages must be designed so that +they will work sensibly when the user does so. + +@node Standard Targets +@section Standard Targets for Users + +All GNU programs should have the following targets in their Makefiles: + +@table @samp +@item all +Compile the entire program. This should be the default target. This +target need not rebuild any documentation files; Info files should +normally be included in the distribution, and DVI files should be made +only when explicitly asked for. + +By default, the Make rules should compile and link with @samp{-g}, so +that executable programs have debugging symbols. Users who don't mind +being helpless can strip the executables later if they wish. + +@item install +Compile the program and copy the executables, libraries, and so on to +the file names where they should reside for actual use. If there is a +simple test to verify that a program is properly installed, this target +should run that test. + +Do not strip executables when installing them. Devil-may-care users can +use the @code{install-strip} target to do that. + +If possible, write the @code{install} target rule so that it does not +modify anything in the directory where the program was built, provided +@samp{make all} has just been done. This is convenient for building the +program under one user name and installing it under another. + +The commands should create all the directories in which files are to be +installed, if they don't already exist. This includes the directories +specified as the values of the variables @code{prefix} and +@code{exec_prefix}, as well as all subdirectories that are needed. +One way to do this is by means of an @code{installdirs} target +as described below. + +Use @samp{-} before any command for installing a man page, so that +@code{make} will ignore any errors. This is in case there are systems +that don't have the Unix man page documentation system installed. + +The way to install Info files is to copy them into @file{$(infodir)} +with @code{$(INSTALL_DATA)} (@pxref{Command Variables}), and then run +the @code{install-info} program if it is present. @code{install-info} +is a program that edits the Info @file{dir} file to add or update the +menu entry for the given Info file; it is part of the Texinfo package. +Here is a sample rule to install an Info file: + +@comment This example has been carefully formatted for the Make manual. +@comment Please do not reformat it without talking to roland@gnu.ai.mit.edu. +@smallexample +$(infodir)/foo.info: foo.info + $(POST_INSTALL) +# There may be a newer info file in . than in srcdir. + -if test -f foo.info; then d=.; \ + else d=$(srcdir); fi; \ + $(INSTALL_DATA) $$d/foo.info $@@; \ +# Run install-info only if it exists. +# Use `if' instead of just prepending `-' to the +# line so we notice real errors from install-info. +# We use `$(SHELL) -c' because some shells do not +# fail gracefully when there is an unknown command. + if $(SHELL) -c 'install-info --version' \ + >/dev/null 2>&1; then \ + install-info --dir-file=$(infodir)/dir \ + $(infodir)/foo.info; \ + else true; fi +@end smallexample + +When writing the @code{install} target, you must classify all the +commands into three categories: normal ones, @dfn{pre-installation} +commands and @dfn{post-installation} commands. @xref{Install Command +Categories}. + +@item uninstall +Delete all the installed files---the copies that the @samp{install} +target creates. + +This rule should not modify the directories where compilation is done, +only the directories where files are installed. + +The uninstallation commands are divided into three categories, just like +the installation commands. @xref{Install Command Categories}. + +@item install-strip +Like @code{install}, but strip the executable files while installing +them. In many cases, the definition of this target can be very simple: + +@smallexample +install-strip: + $(MAKE) INSTALL_PROGRAM='$(INSTALL_PROGRAM) -s' \ + install +@end smallexample + +Normally we do not recommend stripping an executable unless you are sure +the program has no bugs. However, it can be reasonable to install a +stripped executable for actual execution while saving the unstripped +executable elsewhere in case there is a bug. + +@comment The gratuitous blank line here is to make the table look better +@comment in the printed Make manual. Please leave it in. +@item clean + +Delete all files from the current directory that are normally created by +building the program. Don't delete the files that record the +configuration. Also preserve files that could be made by building, but +normally aren't because the distribution comes with them. + +Delete @file{.dvi} files here if they are not part of the distribution. + +@item distclean +Delete all files from the current directory that are created by +configuring or building the program. If you have unpacked the source +and built the program without creating any other files, @samp{make +distclean} should leave only the files that were in the distribution. + +@item mostlyclean +Like @samp{clean}, but may refrain from deleting a few files that people +normally don't want to recompile. For example, the @samp{mostlyclean} +target for GCC does not delete @file{libgcc.a}, because recompiling it +is rarely necessary and takes a lot of time. + +@item maintainer-clean +Delete almost everything from the current directory that can be +reconstructed with this Makefile. This typically includes everything +deleted by @code{distclean}, plus more: C source files produced by +Bison, tags tables, Info files, and so on. + +The reason we say ``almost everything'' is that running the command +@samp{make maintainer-clean} should not delete @file{configure} even if +@file{configure} can be remade using a rule in the Makefile. More generally, +@samp{make maintainer-clean} should not delete anything that needs to +exist in order to run @file{configure} and then begin to build the +program. This is the only exception; @code{maintainer-clean} should +delete everything else that can be rebuilt. + +The @samp{maintainer-clean} target is intended to be used by a maintainer of +the package, not by ordinary users. You may need special tools to +reconstruct some of the files that @samp{make maintainer-clean} deletes. +Since these files are normally included in the distribution, we don't +take care to make them easy to reconstruct. If you find you need to +unpack the full distribution again, don't blame us. + +To help make users aware of this, the commands for the special +@code{maintainer-clean} target should start with these two: + +@smallexample +@@echo 'This command is intended for maintainers to use; it' +@@echo 'deletes files that may need special tools to rebuild.' +@end smallexample + +@item TAGS +Update a tags table for this program. +@c ADR: how? + +@item info +Generate any Info files needed. The best way to write the rules is as +follows: + +@smallexample +info: foo.info + +foo.info: foo.texi chap1.texi chap2.texi + $(MAKEINFO) $(srcdir)/foo.texi +@end smallexample + +@noindent +You must define the variable @code{MAKEINFO} in the Makefile. It should +run the @code{makeinfo} program, which is part of the Texinfo +distribution. + +Normally a GNU distribution comes with Info files, and that means the +Info files are present in the source directory. Therefore, the Make +rule for an info file should update it in the source directory. When +users build the package, ordinarily Make will not update the Info files +because they will already be up to date. + +@item dvi +Generate DVI files for all Texinfo documentation. +For example: + +@smallexample +dvi: foo.dvi + +foo.dvi: foo.texi chap1.texi chap2.texi + $(TEXI2DVI) $(srcdir)/foo.texi +@end smallexample + +@noindent +You must define the variable @code{TEXI2DVI} in the Makefile. It should +run the program @code{texi2dvi}, which is part of the Texinfo +distribution.@footnote{@code{texi2dvi} uses @TeX{} to do the real work +of formatting. @TeX{} is not distributed with Texinfo.} Alternatively, +write just the dependencies, and allow GNU @code{make} to provide the command. + +@item dist +Create a distribution tar file for this program. The tar file should be +set up so that the file names in the tar file start with a subdirectory +name which is the name of the package it is a distribution for. This +name can include the version number. + +For example, the distribution tar file of GCC version 1.40 unpacks into +a subdirectory named @file{gcc-1.40}. + +The easiest way to do this is to create a subdirectory appropriately +named, use @code{ln} or @code{cp} to install the proper files in it, and +then @code{tar} that subdirectory. + +Compress the tar file file with @code{gzip}. For example, the actual +distribution file for GCC version 1.40 is called @file{gcc-1.40.tar.gz}. + +The @code{dist} target should explicitly depend on all non-source files +that are in the distribution, to make sure they are up to date in the +distribution. +@ifset CODESTD +@xref{Releases, , Making Releases}. +@end ifset +@ifclear CODESTD +@xref{Releases, , Making Releases, standards, GNU Coding Standards}. +@end ifclear + +@item check +Perform self-tests (if any). The user must build the program before +running the tests, but need not install the program; you should write +the self-tests so that they work when the program is built but not +installed. +@end table + +The following targets are suggested as conventional names, for programs +in which they are useful. + +@table @code +@item installcheck +Perform installation tests (if any). The user must build and install +the program before running the tests. You should not assume that +@file{$(bindir)} is in the search path. + +@item installdirs +It's useful to add a target named @samp{installdirs} to create the +directories where files are installed, and their parent directories. +There is a script called @file{mkinstalldirs} which is convenient for +this; you can find it in the Texinfo package. +@c It's in /gd/gnu/lib/mkinstalldirs. +You can use a rule like this: + +@comment This has been carefully formatted to look decent in the Make manual. +@comment Please be sure not to make it extend any further to the right.--roland +@smallexample +# Make sure all installation directories (e.g. $(bindir)) +# actually exist by making them if necessary. +installdirs: mkinstalldirs + $(srcdir)/mkinstalldirs $(bindir) $(datadir) \ + $(libdir) $(infodir) \ + $(mandir) +@end smallexample + +This rule should not modify the directories where compilation is done. +It should do nothing but create installation directories. +@end table + +@node Install Command Categories +@section Install Command Categories + +@cindex pre-installation commands +@cindex post-installation commands +When writing the @code{install} target, you must classify all the +commands into three categories: normal ones, @dfn{pre-installation} +commands and @dfn{post-installation} commands. + +Normal commands move files into their proper places, and set their +modes. They may not alter any files except the ones that come entirely +from the package they belong to. + +Pre-installation and post-installation commands may alter other files; +in particular, they can edit global configuration files or data bases. + +Pre-installation commands are typically executed before the normal +commands, and post-installation commands are typically run after the +normal commands. + +The most common use for a post-installation command is to run +@code{install-info}. This cannot be done with a normal command, since +it alters a file (the Info directory) which does not come entirely and +solely from the package being installed. It is a post-installation +command because it needs to be done after the normal command which +installs the package's Info files. + +Most programs don't need any pre-installation commands, but we have the +feature just in case it is needed. + +To classify the commands in the @code{install} rule into these three +categories, insert @dfn{category lines} among them. A category line +specifies the category for the commands that follow. + +A category line consists of a tab and a reference to a special Make +variable, plus an optional comment at the end. There are three +variables you can use, one for each category; the variable name +specifies the category. Category lines are no-ops in ordinary execution +because these three Make variables are normally undefined (and you +@emph{should not} define them in the makefile). + +Here are the three possible category lines, each with a comment that +explains what it means: + +@smallexample + $(PRE_INSTALL) # @r{Pre-install commands follow.} + $(POST_INSTALL) # @r{Post-install commands follow.} + $(NORMAL_INSTALL) # @r{Normal commands follow.} +@end smallexample + +If you don't use a category line at the beginning of the @code{install} +rule, all the commands are classified as normal until the first category +line. If you don't use any category lines, all the commands are +classified as normal. + +These are the category lines for @code{uninstall}: + +@smallexample + $(PRE_UNINSTALL) # @r{Pre-uninstall commands follow.} + $(POST_UNINSTALL) # @r{Post-uninstall commands follow.} + $(NORMAL_UNINSTALL) # @r{Normal commands follow.} +@end smallexample + +Typically, a pre-uninstall command would be used for deleting entries +from the Info directory. + +If the @code{install} or @code{uninstall} target has any dependencies +which act as subroutines of installation, then you should start +@emph{each} dependency's commands with a category line, and start the +main target's commands with a category line also. This way, you can +ensure that each command is placed in the right category regardless of +which of the dependencies actually run. + +Pre-installation and post-installation commands should not run any +programs except for these: + +@example +[ basename bash cat chgrp chmod chown cmp cp dd diff echo +egrep expand expr false fgrep find getopt grep gunzip gzip +hostname install install-info kill ldconfig ln ls md5sum +mkdir mkfifo mknod mv printenv pwd rm rmdir sed sort tee +test touch true uname xargs yes +@end example + +@cindex binary packages +The reason for distinguishing the commands in this way is for the sake +of making binary packages. Typically a binary package contains all the +executables and other files that need to be installed, and has its own +method of installing them---so it does not need to run the normal +installation commands. But installing the binary package does need to +execute the pre-installation and post-installation commands. + +Programs to build binary packages work by extracting the +pre-installation and post-installation commands. Here is one way of +extracting the pre-installation commands: + +@smallexample +make -n install -o all \ + PRE_INSTALL=pre-install \ + POST_INSTALL=post-install \ + NORMAL_INSTALL=normal-install \ + | gawk -f pre-install.awk +@end smallexample + +@noindent +where the file @file{pre-install.awk} could contain this: + +@smallexample +$0 ~ /^\t[ \t]*(normal_install|post_install)[ \t]*$/ @{on = 0@} +on @{print $0@} +$0 ~ /^\t[ \t]*pre_install[ \t]*$/ @{on = 1@} +@end smallexample + +The resulting file of pre-installation commands is executed as a shell +script as part of installing the binary package. diff --git a/etc/standards.texi b/etc/standards.texi new file mode 100644 index 00000000000..4170093c65f --- /dev/null +++ b/etc/standards.texi @@ -0,0 +1,3061 @@ +\input texinfo @c -*-texinfo-*- +@c %**start of header +@setfilename standards.info +@settitle GNU Coding Standards +@c UPDATE THIS DATE WHENEVER YOU MAKE CHANGES! +@set lastupdate 16 January 1997 +@c %**end of header + +@ifinfo +@format +START-INFO-DIR-ENTRY +* Standards: (standards). GNU coding standards. +END-INFO-DIR-ENTRY +@end format +@end ifinfo + +@c @setchapternewpage odd +@setchapternewpage off + +@c This is used by a cross ref in make-stds.texi +@set CODESTD 1 +@iftex +@set CHAPTER chapter +@end iftex +@ifinfo +@set CHAPTER node +@end ifinfo + +@ifinfo +GNU Coding Standards +Copyright (C) 1992, 1993, 1994, 1995, 1996 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 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 this permission notice may be stated in a translation approved +by the Free Software Foundation. +@end ifinfo + +@titlepage +@title GNU Coding Standards +@author Richard Stallman +@author last updated @value{lastupdate} +@page + +@vskip 0pt plus 1filll +Copyright @copyright{} 1992, 1993, 1994, 1995, 1996 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. + +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. + +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 stated in a translation approved +by the Free Software Foundation. +@end titlepage + +@ifinfo +@node Top, Preface, (dir), (dir) +@top Version + +Last updated @value{lastupdate}. +@end ifinfo + +@menu +* Preface:: About the GNU Coding Standards +* Intellectual Property:: Keeping Free Software Free +* Design Advice:: General Program Design +* Program Behavior:: Program Behavior for All Programs +* Writing C:: Making The Best Use of C +* Documentation:: Documenting Programs +* Managing Releases:: The Release Process +@end menu + +@node Preface +@chapter About the GNU Coding Standards + +The GNU Coding Standards were written by Richard Stallman and other GNU +Project volunteers. Their purpose is to make the GNU system clean, +consistent, and easy to install. This document can also be read as a +guide to writing portable, robust and reliable programs. It focuses on +programs written in C, but many of the rules and principles are useful +even if you write in another programming language. The rules often +state reasons for writing in a certain way. + +Corrections or suggestions regarding this document should be sent to +@code{gnu@@prep.ai.mit.edu}. If you make a suggestion, please include a +suggested new wording for it; our time is limited. We prefer a context +diff to the @file{standards.texi} or @file{make-stds.texi} files, but if +you don't have those files, please mail your suggestion anyway. + +This release of the GNU Coding Standards was last updated +@value{lastupdate}. + +@node Intellectual Property +@chapter Keeping Free Software Free + +This @value{CHAPTER} discusses how you can make sure that GNU software +remains unencumbered. + +@menu +* Reading Non-Free Code:: Referring to Proprietary Programs +* Contributions:: Accepting Contributions +@end menu + +@node Reading Non-Free Code +@section Referring to Proprietary Programs + +Don't in any circumstances refer to Unix source code for or during +your work on GNU! (Or to any other proprietary programs.) + +If you have a vague recollection of the internals of a Unix program, +this does not absolutely mean you can't write an imitation of it, but +do try to organize the imitation internally along different lines, +because this is likely to make the details of the Unix version +irrelevant and dissimilar to your results. + +For example, Unix utilities were generally optimized to minimize +memory use; if you go for speed instead, your program will be very +different. You could keep the entire input file in core and scan it +there instead of using stdio. Use a smarter algorithm discovered more +recently than the Unix program. Eliminate use of temporary files. Do +it in one pass instead of two (we did this in the assembler). + +Or, on the contrary, emphasize simplicity instead of speed. For some +applications, the speed of today's computers makes simpler algorithms +adequate. + +Or go for generality. For example, Unix programs often have static +tables or fixed-size strings, which make for arbitrary limits; use +dynamic allocation instead. Make sure your program handles NULs and +other funny characters in the input files. Add a programming language +for extensibility and write part of the program in that language. + +Or turn some parts of the program into independently usable libraries. +Or use a simple garbage collector instead of tracking precisely when +to free memory, or use a new GNU facility such as obstacks. + + +@node Contributions +@section Accepting Contributions + +If someone else sends you a piece of code to add to the program you are +working on, we need legal papers to use it---the same sort of legal +papers we will need to get from you. @emph{Each} significant +contributor to a program must sign some sort of legal papers in order +for us to have clear title to the program. The main author alone is not +enough. + +So, before adding in any contributions from other people, tell us +so we can arrange to get the papers. Then wait until we tell you +that we have received the signed papers, before you actually use the +contribution. + +This applies both before you release the program and afterward. If +you receive diffs to fix a bug, and they make significant changes, we +need legal papers for it. + +You don't need papers for changes of a few lines here or there, since +they are not significant for copyright purposes. Also, you don't need +papers if all you get from the suggestion is some ideas, not actual code +which you use. For example, if you write a different solution to the +problem, you don't need to get papers. + +We know this is frustrating; it's frustrating for us as well. But if +you don't wait, you are going out on a limb---for example, what if the +contributor's employer won't sign a disclaimer? You might have to take +that code out again! + +The very worst thing is if you forget to tell us about the other +contributor. We could be very embarrassed in court some day as a +result. + +@node Design Advice +@chapter General Program Design + +This @value{CHAPTER} discusses some of the issues you should take into +account when designing your program. + +@menu +* Compatibility:: Compatibility with other implementations +* Using Extensions:: Using non-standard features +* ANSI C:: Using ANSI C features +* Source Language:: Using languages other than C +@end menu + +@node Compatibility +@section Compatibility with Other Implementations + +With occasional exceptions, utility programs and libraries for GNU +should be upward compatible with those in Berkeley Unix, and upward +compatible with @sc{ansi} C if @sc{ansi} C specifies their behavior, and +upward compatible with @sc{POSIX} if @sc{POSIX} specifies their +behavior. + +When these standards conflict, it is useful to offer compatibility +modes for each of them. + +@sc{ansi} C and @sc{POSIX} prohibit many kinds of extensions. Feel free +to make the extensions anyway, and include a @samp{--ansi}, +@samp{--posix}, or @samp{--compatible} option to turn them off. +However, if the extension has a significant chance of breaking any real +programs or scripts, then it is not really upward compatible. Try to +redesign its interface. + +Many GNU programs suppress extensions that conflict with POSIX if the +environment variable @code{POSIXLY_CORRECT} is defined (even if it is +defined with a null value). Please make your program recognize this +variable if appropriate. + +When a feature is used only by users (not by programs or command +files), and it is done poorly in Unix, feel free to replace it +completely with something totally different and better. (For example, +@code{vi} is replaced with Emacs.) But it is nice to offer a compatible +feature as well. (There is a free @code{vi} clone, so we offer it.) + +Additional useful features not in Berkeley Unix are welcome. +Additional programs with no counterpart in Unix may be useful, +but our first priority is usually to duplicate what Unix already +has. + +@node Using Extensions +@section Using Non-standard Features + +Many GNU facilities that already exist support a number of convenient +extensions over the comparable Unix facilities. Whether to use these +extensions in implementing your program is a difficult question. + +On the one hand, using the extensions can make a cleaner program. +On the other hand, people will not be able to build the program +unless the other GNU tools are available. This might cause the +program to work on fewer kinds of machines. + +With some extensions, it might be easy to provide both alternatives. +For example, you can define functions with a ``keyword'' @code{INLINE} +and define that as a macro to expand into either @code{inline} or +nothing, depending on the compiler. + +In general, perhaps it is best not to use the extensions if you can +straightforwardly do without them, but to use the extensions if they +are a big improvement. + +An exception to this rule are the large, established programs (such as +Emacs) which run on a great variety of systems. Such programs would +be broken by use of GNU extensions. + +Another exception is for programs that are used as part of +compilation: anything that must be compiled with other compilers in +order to bootstrap the GNU compilation facilities. If these require +the GNU compiler, then no one can compile them without having them +installed already. That would be no good. + +@node ANSI C +@section @sc{ansi} C and pre-@sc{ansi} C + +Do not ever use the ``trigraph'' feature of @sc{ansi} C. + +@sc{ansi} C is widespread enough now that it is ok to write new programs +that use @sc{ansi} C features (and therefore will not work in +non-@sc{ansi} compilers). And if a program is already written in +@sc{ansi} C, there's no need to convert it to support non-@sc{ansi} +compilers. + +However, it is easy to support non-@sc{ansi} compilers in most programs, +so you might still consider doing so when you write a program. Instead +of writing function definitions in @sc{ansi} prototype form, + +@example +int +foo (int x, int y) +@dots{} +@end example + +@noindent +write the definition in pre-@sc{ansi} style like this, + +@example +int +foo (x, y) + int x, y; +@dots{} +@end example + +@noindent +and use a separate declaration to specify the argument prototype: + +@example +int foo (int, int); +@end example + +You need such a declaration anyway, in a header file, to get the benefit +of @sc{ansi} C prototypes in all the files where the function is called. +And once you have it, you lose nothing by writing the function +definition in the pre-@sc{ansi} style. + +If you don't know non-@sc{ansi} C, there's no need to learn it; just +write in @sc{ansi} C. + +@node Source Language +@section Using Languages Other Than C + +Using a language other than C is like using a non-standard feature: it +will cause trouble for users. Even if GCC supports the other language, +users may find it inconvenient to have to install the compiler for that +other language in order to build your program. So please write in C. + +There are three exceptions for this rule: + +@itemize @bullet +@item +It is okay to use a special language if the same program contains an +interpreter for that language. + +For example, if your program links with GUILE, it is ok to write part of +the program in Scheme or another language supported by GUILE. + +@item +It is okay to use another language in a tool specifically intended for +use with that language. + +This is okay because the only people who want to build the tool will be +those who have installed the other language anyway. + +@item +If an application is not of extremely widespread interest, then perhaps +it's not important if the application is inconvenient to install. +@end itemize + +@node Program Behavior +@chapter Program Behavior for All Programs + +This @value{CHAPTER} describes how to write robust software. It also +describes general standards for error messages, the command line interface, +and how libraries should behave. + +@menu +* Semantics:: Writing robust programs +* Libraries:: Library behavior +* Errors:: Formatting error messages +* User Interfaces:: Standards for command line interfaces +* Option Table:: Table of long options. +* Memory Usage:: When and how to care about memory needs +@end menu + +@node Semantics +@section Writing Robust Programs + +Avoid arbitrary limits on the length or number of @emph{any} data +structure, including file names, lines, files, and symbols, by allocating +all data structures dynamically. In most Unix utilities, ``long lines +are silently truncated''. This is not acceptable in a GNU utility. + +Utilities reading files should not drop NUL characters, or any other +nonprinting characters @emph{including those with codes above 0177}. The +only sensible exceptions would be utilities specifically intended for +interface to certain types of printers that can't handle those characters. + +Check every system call for an error return, unless you know you wish to +ignore errors. Include the system error text (from @code{perror} or +equivalent) in @emph{every} error message resulting from a failing +system call, as well as the name of the file if any and the name of the +utility. Just ``cannot open foo.c'' or ``stat failed'' is not +sufficient. + +Check every call to @code{malloc} or @code{realloc} to see if it +returned zero. Check @code{realloc} even if you are making the block +smaller; in a system that rounds block sizes to a power of 2, +@code{realloc} may get a different block if you ask for less space. + +In Unix, @code{realloc} can destroy the storage block if it returns +zero. GNU @code{realloc} does not have this bug: if it fails, the +original block is unchanged. Feel free to assume the bug is fixed. If +you wish to run your program on Unix, and wish to avoid lossage in this +case, you can use the GNU @code{malloc}. + +You must expect @code{free} to alter the contents of the block that was +freed. Anything you want to fetch from the block, you must fetch before +calling @code{free}. + +If @code{malloc} fails in a noninteractive program, make that a fatal +error. In an interactive program (one that reads commands from the +user), it is better to abort the command and return to the command +reader loop. This allows the user to kill other processes to free up +virtual memory, and then try the command again. + +Use @code{getopt_long} to decode arguments, unless the argument syntax +makes this unreasonable. + +When static storage is to be written in during program execution, use +explicit C code to initialize it. Reserve C initialized declarations +for data that will not be changed. +@c ADR: why? + +Try to avoid low-level interfaces to obscure Unix data structures (such +as file directories, utmp, or the layout of kernel memory), since these +are less likely to work compatibly. If you need to find all the files +in a directory, use @code{readdir} or some other high-level interface. +These will be supported compatibly by GNU. + +By default, the GNU system will provide the signal handling functions of +@sc{BSD} and of @sc{POSIX}. So GNU software should be written to use +these. + +In error checks that detect ``impossible'' conditions, just abort. +There is usually no point in printing any message. These checks +indicate the existence of bugs. Whoever wants to fix the bugs will have +to read the source code and run a debugger. So explain the problem with +comments in the source. The relevant data will be in variables, which +are easy to examine with the debugger, so there is no point moving them +elsewhere. + +Do not use a count of errors as the exit status for a program. +@emph{That does not work}, because exit status values are limited to 8 +bits (0 through 255). A single run of the program might have 256 +errors; if you try to return 256 as the exit status, the parent process +will see 0 as the status, and it will appear that the program succeeded. + +If you make temporary files, check the @code{TMPDIR} environment +variable; if that variable is defined, use the specified directory +instead of @file{/tmp}. + +@node Libraries +@section Library Behavior + +Try to make library functions reentrant. If they need to do dynamic +storage allocation, at least try to avoid any nonreentrancy aside from +that of @code{malloc} itself. + +Here are certain name conventions for libraries, to avoid name +conflicts. + +Choose a name prefix for the library, more than two characters long. +All external function and variable names should start with this +prefix. In addition, there should only be one of these in any given +library member. This usually means putting each one in a separate +source file. + +An exception can be made when two external symbols are always used +together, so that no reasonable program could use one without the +other; then they can both go in the same file. + +External symbols that are not documented entry points for the user +should have names beginning with @samp{_}. They should also contain +the chosen name prefix for the library, to prevent collisions with +other libraries. These can go in the same files with user entry +points if you like. + +Static functions and variables can be used as you like and need not +fit any naming convention. + +@node Errors +@section Formatting Error Messages + +Error messages from compilers should look like this: + +@example +@var{source-file-name}:@var{lineno}: @var{message} +@end example + +Error messages from other noninteractive programs should look like this: + +@example +@var{program}:@var{source-file-name}:@var{lineno}: @var{message} +@end example + +@noindent +when there is an appropriate source file, or like this: + +@example +@var{program}: @var{message} +@end example + +@noindent +when there is no relevant source file. + +In an interactive program (one that is reading commands from a +terminal), it is better not to include the program name in an error +message. The place to indicate which program is running is in the +prompt or with the screen layout. (When the same program runs with +input from a source other than a terminal, it is not interactive and +would do best to print error messages using the noninteractive style.) + +The string @var{message} should not begin with a capital letter when +it follows a program name and/or file name. Also, it should not end +with a period. + +Error messages from interactive programs, and other messages such as +usage messages, should start with a capital letter. But they should not +end with a period. + +@node User Interfaces +@section Standards for Command Line Interfaces + +Please don't make the behavior of a utility depend on the name used +to invoke it. It is useful sometimes to make a link to a utility +with a different name, and that should not change what it does. + +Instead, use a run time option or a compilation switch or both +to select among the alternate behaviors. + +Likewise, please don't make the behavior of the program depend on the +type of output device it is used with. Device independence is an +important principle of the system's design; do not compromise it +merely to save someone from typing an option now and then. + +If you think one behavior is most useful when the output is to a +terminal, and another is most useful when the output is a file or a +pipe, then it is usually best to make the default behavior the one that +is useful with output to a terminal, and have an option for the other +behavior. + +Compatibility requires certain programs to depend on the type of output +device. It would be disastrous if @code{ls} or @code{sh} did not do so +in the way all users expect. In some of these cases, we supplement the +program with a preferred alternate version that does not depend on the +output device type. For example, we provide a @code{dir} program much +like @code{ls} except that its default output format is always +multi-column format. + +It is a good idea to follow the @sc{POSIX} guidelines for the +command-line options of a program. The easiest way to do this is to use +@code{getopt} to parse them. Note that the GNU version of @code{getopt} +will normally permit options anywhere among the arguments unless the +special argument @samp{--} is used. This is not what @sc{POSIX} +specifies; it is a GNU extension. + +Please define long-named options that are equivalent to the +single-letter Unix-style options. We hope to make GNU more user +friendly this way. This is easy to do with the GNU function +@code{getopt_long}. + +One of the advantages of long-named options is that they can be +consistent from program to program. For example, users should be able +to expect the ``verbose'' option of any GNU program which has one, to be +spelled precisely @samp{--verbose}. To achieve this uniformity, look at +the table of common long-option names when you choose the option names +for your program (@pxref{Option Table}). + +It is usually a good idea for file names given as ordinary arguments to +be input files only; any output files would be specified using options +(preferably @samp{-o} or @samp{--output}). Even if you allow an output +file name as an ordinary argument for compatibility, try to provide an +option as another way to specify it. This will lead to more consistency +among GNU utilities, and fewer idiosyncracies for users to remember. + +All programs should support two standard options: @samp{--version} +and @samp{--help}. + +@table @code +@item --version +This option should direct the program to information about its name, +version, origin and legal status, all on standard output, and then exit +successfully. Other options and arguments should be ignored once this +is seen, and the program should not perform its normal function. + +The first line is meant to be easy for a program to parse; the version +number proper starts after the last space. In addition, it contains +the canonical name for this program, in this format: + +@example +GNU Emacs 19.30 +@end example + +@noindent +The program's name should be a constant string; @emph{don't} compute it +from @code{argv[0]}. The idea is to state the standard or canonical +name for the program, not its file name. There are other ways to find +out the precise file name where a command is found in @code{PATH}. + +If the program is a subsidiary part of a larger package, mention the +package name in parentheses, like this: + +@example +emacsserver (GNU Emacs) 19.30 +@end example + +@noindent +If the package has a version number which is different from this +program's version number, you can mention the package version number +just before the close-parenthesis. + +If you @strong{need} to mention the version numbers of libraries which +are distributed separately from the package which contains this program, +you can do so by printing an additional line of version info for each +library you want to mention. Use the same format for these lines as for +the first line. + +Please don't mention all the libraries that the program uses ``just for +completeness''---that would produce a lot of unhelpful clutter. Please +mention library version numbers only if you find in practice that they +are very important to you in debugging. + +The following line, after the version number line or lines, should be a +copyright notice. If more than one copyright notice is called for, put +each on a separate line. + +Next should follow a brief statement that the program is free software, +and that users are free to copy and change it on certain conditions. If +the program is covered by the GNU GPL, say so here. Also mention that +there is no warranty, to the extent permitted by law. + +It is ok to finish the output with a list of the major authors of the +program, as a way of giving credit. + +Here's an example of output that follows these rules: + +@smallexample +GNU Emacs 19.34.5 +Copyright (C) 1996 Free Software Foundation, Inc. +GNU Emacs comes with NO WARRANTY, to the extent permitted by law. +You may redistribute copies of GNU Emacs +under the terms of the GNU General Public License. +For more information about these matters, see the files named COPYING. +@end smallexample + +You should adapt this to your program, of course, filling in the proper +year, copyright holder, name of program, and the references to +distribution terms, and changing the rest of the wording as necessary. + +This copyright notice only needs to mention the most recent year in +which changes were made---there's no need to list the years for previous +versions' changes. You don't have to mention the name of the program in +these notices, if that is inconvenient, since it appeared in the first +line. + +@item --help +This option should output brief documentation for how to invoke the +program, on standard output, then exit successfully. Other options and +arguments should be ignored once this is seen, and the program should +not perform its normal function. + +Near the end of the @samp{--help} option's output there should be a line +that says where to mail bug reports. It should have this format: + +@example +Report bugs to @var{mailing-address}. +@end example +@end table + +@node Option Table +@section Table of Long Options + +Here is a table of long options used by GNU programs. It is surely +incomplete, but we aim to list all the options that a new program might +want to be compatible with. If you use names not already in the table, +please send @samp{gnu@@prep.ai.mit.edu} a list of them, with their +meanings, so we can update the table. + +@c Please leave newlines between items in this table; it's much easier +@c to update when it isn't completely squashed together and unreadable. +@c When there is more than one short option for a long option name, put +@c a semicolon between the lists of the programs that use them, not a +@c period. --friedman + +@table @samp +@item after-date +@samp{-N} in @code{tar}. + +@item all +@samp{-a} in @code{du}, @code{ls}, @code{nm}, @code{stty}, @code{uname}, +and @code{unexpand}. + +@item all-text +@samp{-a} in @code{diff}. + +@item almost-all +@samp{-A} in @code{ls}. + +@item append +@samp{-a} in @code{etags}, @code{tee}, @code{time}; +@samp{-r} in @code{tar}. + +@item archive +@samp{-a} in @code{cp}. + +@item archive-name +@samp{-n} in @code{shar}. + +@item arglength +@samp{-l} in @code{m4}. + +@item ascii +@samp{-a} in @code{diff}. + +@item assign +@samp{-v} in @code{gawk}. + +@item assume-new +@samp{-W} in Make. + +@item assume-old +@samp{-o} in Make. + +@item auto-check +@samp{-a} in @code{recode}. + +@item auto-pager +@samp{-a} in @code{wdiff}. + +@item auto-reference +@samp{-A} in @code{ptx}. + +@item avoid-wraps +@samp{-n} in @code{wdiff}. + +@item backward-search +@samp{-B} in @code{ctags}. + +@item basename +@samp{-f} in @code{shar}. + +@item batch +Used in GDB. + +@item baud +Used in GDB. + +@item before +@samp{-b} in @code{tac}. + +@item binary +@samp{-b} in @code{cpio} and @code{diff}. + +@item bits-per-code +@samp{-b} in @code{shar}. + +@item block-size +Used in @code{cpio} and @code{tar}. + +@item blocks +@samp{-b} in @code{head} and @code{tail}. + +@item break-file +@samp{-b} in @code{ptx}. + +@item brief +Used in various programs to make output shorter. + +@item bytes +@samp{-c} in @code{head}, @code{split}, and @code{tail}. + +@item c@t{++} +@samp{-C} in @code{etags}. + +@item catenate +@samp{-A} in @code{tar}. + +@item cd +Used in various programs to specify the directory to use. + +@item changes +@samp{-c} in @code{chgrp} and @code{chown}. + +@item classify +@samp{-F} in @code{ls}. + +@item colons +@samp{-c} in @code{recode}. + +@item command +@samp{-c} in @code{su}; +@samp{-x} in GDB. + +@item compare +@samp{-d} in @code{tar}. + +@item compat +Used in @code{gawk}. + +@item compress +@samp{-Z} in @code{tar} and @code{shar}. + +@item concatenate +@samp{-A} in @code{tar}. + +@item confirmation +@samp{-w} in @code{tar}. + +@item context +Used in @code{diff}. + +@item copyleft +@samp{-W copyleft} in @code{gawk}. + +@item copyright +@samp{-C} in @code{ptx}, @code{recode}, and @code{wdiff}; +@samp{-W copyright} in @code{gawk}. + +@item core +Used in GDB. + +@item count +@samp{-q} in @code{who}. + +@item count-links +@samp{-l} in @code{du}. + +@item create +Used in @code{tar} and @code{cpio}. + +@item cut-mark +@samp{-c} in @code{shar}. + +@item cxref +@samp{-x} in @code{ctags}. + +@item date +@samp{-d} in @code{touch}. + +@item debug +@samp{-d} in Make and @code{m4}; +@samp{-t} in Bison. + +@item define +@samp{-D} in @code{m4}. + +@item defines +@samp{-d} in Bison and @code{ctags}. + +@item delete +@samp{-D} in @code{tar}. + +@item dereference +@samp{-L} in @code{chgrp}, @code{chown}, @code{cpio}, @code{du}, +@code{ls}, and @code{tar}. + +@item dereference-args +@samp{-D} in @code{du}. + +@item diacritics +@samp{-d} in @code{recode}. + +@item dictionary-order +@samp{-d} in @code{look}. + +@item diff +@samp{-d} in @code{tar}. + +@item digits +@samp{-n} in @code{csplit}. + +@item directory +Specify the directory to use, in various programs. In @code{ls}, it +means to show directories themselves rather than their contents. In +@code{rm} and @code{ln}, it means to not treat links to directories +specially. + +@item discard-all +@samp{-x} in @code{strip}. + +@item discard-locals +@samp{-X} in @code{strip}. + +@item dry-run +@samp{-n} in Make. + +@item ed +@samp{-e} in @code{diff}. + +@item elide-empty-files +@samp{-z} in @code{csplit}. + +@item end-delete +@samp{-x} in @code{wdiff}. + +@item end-insert +@samp{-z} in @code{wdiff}. + +@item entire-new-file +@samp{-N} in @code{diff}. + +@item environment-overrides +@samp{-e} in Make. + +@item eof +@samp{-e} in @code{xargs}. + +@item epoch +Used in GDB. + +@item error-limit +Used in @code{makeinfo}. + +@item error-output +@samp{-o} in @code{m4}. + +@item escape +@samp{-b} in @code{ls}. + +@item exclude-from +@samp{-X} in @code{tar}. + +@item exec +Used in GDB. + +@item exit +@samp{-x} in @code{xargs}. + +@item exit-0 +@samp{-e} in @code{unshar}. + +@item expand-tabs +@samp{-t} in @code{diff}. + +@item expression +@samp{-e} in @code{sed}. + +@item extern-only +@samp{-g} in @code{nm}. + +@item extract +@samp{-i} in @code{cpio}; +@samp{-x} in @code{tar}. + +@item faces +@samp{-f} in @code{finger}. + +@item fast +@samp{-f} in @code{su}. + +@item fatal-warnings +@samp{-E} in @code{m4}. + +@item file +@samp{-f} in @code{info}, @code{gawk}, Make, @code{mt}, and @code{tar}; +@samp{-n} in @code{sed}; +@samp{-r} in @code{touch}. + +@item field-separator +@samp{-F} in @code{gawk}. + +@item file-prefix +@samp{-b} in Bison. + +@item file-type +@samp{-F} in @code{ls}. + +@item files-from +@samp{-T} in @code{tar}. + +@item fill-column +Used in @code{makeinfo}. + +@item flag-truncation +@samp{-F} in @code{ptx}. + +@item fixed-output-files +@samp{-y} in Bison. + +@item follow +@samp{-f} in @code{tail}. + +@item footnote-style +Used in @code{makeinfo}. + +@item force +@samp{-f} in @code{cp}, @code{ln}, @code{mv}, and @code{rm}. + +@item force-prefix +@samp{-F} in @code{shar}. + +@item format +Used in @code{ls}, @code{time}, and @code{ptx}. + +@item freeze-state +@samp{-F} in @code{m4}. + +@item fullname +Used in GDB. + +@item gap-size +@samp{-g} in @code{ptx}. + +@item get +@samp{-x} in @code{tar}. + +@item graphic +@samp{-i} in @code{ul}. + +@item graphics +@samp{-g} in @code{recode}. + +@item group +@samp{-g} in @code{install}. + +@item gzip +@samp{-z} in @code{tar} and @code{shar}. + +@item hashsize +@samp{-H} in @code{m4}. + +@item header +@samp{-h} in @code{objdump} and @code{recode} + +@item heading +@samp{-H} in @code{who}. + +@item help +Used to ask for brief usage information. + +@item here-delimiter +@samp{-d} in @code{shar}. + +@item hide-control-chars +@samp{-q} in @code{ls}. + +@item idle +@samp{-u} in @code{who}. + +@item ifdef +@samp{-D} in @code{diff}. + +@item ignore +@samp{-I} in @code{ls}; +@samp{-x} in @code{recode}. + +@item ignore-all-space +@samp{-w} in @code{diff}. + +@item ignore-backups +@samp{-B} in @code{ls}. + +@item ignore-blank-lines +@samp{-B} in @code{diff}. + +@item ignore-case +@samp{-f} in @code{look} and @code{ptx}; +@samp{-i} in @code{diff} and @code{wdiff}. + +@item ignore-errors +@samp{-i} in Make. + +@item ignore-file +@samp{-i} in @code{ptx}. + +@item ignore-indentation +@samp{-I} in @code{etags}. + +@item ignore-init-file +@samp{-f} in Oleo. + +@item ignore-interrupts +@samp{-i} in @code{tee}. + +@item ignore-matching-lines +@samp{-I} in @code{diff}. + +@item ignore-space-change +@samp{-b} in @code{diff}. + +@item ignore-zeros +@samp{-i} in @code{tar}. + +@item include +@samp{-i} in @code{etags}; +@samp{-I} in @code{m4}. + +@item include-dir +@samp{-I} in Make. + +@item incremental +@samp{-G} in @code{tar}. + +@item info +@samp{-i}, @samp{-l}, and @samp{-m} in Finger. + +@item initial +@samp{-i} in @code{expand}. + +@item initial-tab +@samp{-T} in @code{diff}. + +@item inode +@samp{-i} in @code{ls}. + +@item interactive +@samp{-i} in @code{cp}, @code{ln}, @code{mv}, @code{rm}; +@samp{-e} in @code{m4}; +@samp{-p} in @code{xargs}; +@samp{-w} in @code{tar}. + +@item intermix-type +@samp{-p} in @code{shar}. + +@item jobs +@samp{-j} in Make. + +@item just-print +@samp{-n} in Make. + +@item keep-going +@samp{-k} in Make. + +@item keep-files +@samp{-k} in @code{csplit}. + +@item kilobytes +@samp{-k} in @code{du} and @code{ls}. + +@item language +@samp{-l} in @code{etags}. + +@item less-mode +@samp{-l} in @code{wdiff}. + +@item level-for-gzip +@samp{-g} in @code{shar}. + +@item line-bytes +@samp{-C} in @code{split}. + +@item lines +Used in @code{split}, @code{head}, and @code{tail}. + +@item link +@samp{-l} in @code{cpio}. + +@item lint +@itemx lint-old +Used in @code{gawk}. + +@item list +@samp{-t} in @code{cpio}; +@samp{-l} in @code{recode}. + +@item list +@samp{-t} in @code{tar}. + +@item literal +@samp{-N} in @code{ls}. + +@item load-average +@samp{-l} in Make. + +@item login +Used in @code{su}. + +@item machine +No listing of which programs already use this; +someone should check to +see if any actually do and tell @code{gnu@@prep.ai.mit.edu}. + +@item macro-name +@samp{-M} in @code{ptx}. + +@item mail +@samp{-m} in @code{hello} and @code{uname}. + +@item make-directories +@samp{-d} in @code{cpio}. + +@item makefile +@samp{-f} in Make. + +@item mapped +Used in GDB. + +@item max-args +@samp{-n} in @code{xargs}. + +@item max-chars +@samp{-n} in @code{xargs}. + +@item max-lines +@samp{-l} in @code{xargs}. + +@item max-load +@samp{-l} in Make. + +@item max-procs +@samp{-P} in @code{xargs}. + +@item mesg +@samp{-T} in @code{who}. + +@item message +@samp{-T} in @code{who}. + +@item minimal +@samp{-d} in @code{diff}. + +@item mixed-uuencode +@samp{-M} in @code{shar}. + +@item mode +@samp{-m} in @code{install}, @code{mkdir}, and @code{mkfifo}. + +@item modification-time +@samp{-m} in @code{tar}. + +@item multi-volume +@samp{-M} in @code{tar}. + +@item name-prefix +@samp{-a} in Bison. + +@item nesting-limit +@samp{-L} in @code{m4}. + +@item net-headers +@samp{-a} in @code{shar}. + +@item new-file +@samp{-W} in Make. + +@item no-builtin-rules +@samp{-r} in Make. + +@item no-character-count +@samp{-w} in @code{shar}. + +@item no-check-existing +@samp{-x} in @code{shar}. + +@item no-common +@samp{-3} in @code{wdiff}. + +@item no-create +@samp{-c} in @code{touch}. + +@item no-defines +@samp{-D} in @code{etags}. + +@item no-deleted +@samp{-1} in @code{wdiff}. + +@item no-dereference +@samp{-d} in @code{cp}. + +@item no-inserted +@samp{-2} in @code{wdiff}. + +@item no-keep-going +@samp{-S} in Make. + +@item no-lines +@samp{-l} in Bison. + +@item no-piping +@samp{-P} in @code{shar}. + +@item no-prof +@samp{-e} in @code{gprof}. + +@item no-regex +@samp{-R} in @code{etags}. + +@item no-sort +@samp{-p} in @code{nm}. + +@item no-split +Used in @code{makeinfo}. + +@item no-static +@samp{-a} in @code{gprof}. + +@item no-time +@samp{-E} in @code{gprof}. + +@item no-timestamp +@samp{-m} in @code{shar}. + +@item no-validate +Used in @code{makeinfo}. + +@item no-wait +Used in @code{emacsclient}. + +@item no-warn +Used in various programs to inhibit warnings. + +@item node +@samp{-n} in @code{info}. + +@item nodename +@samp{-n} in @code{uname}. + +@item nonmatching +@samp{-f} in @code{cpio}. + +@item nstuff +@samp{-n} in @code{objdump}. + +@item null +@samp{-0} in @code{xargs}. + +@item number +@samp{-n} in @code{cat}. + +@item number-nonblank +@samp{-b} in @code{cat}. + +@item numeric-sort +@samp{-n} in @code{nm}. + +@item numeric-uid-gid +@samp{-n} in @code{cpio} and @code{ls}. + +@item nx +Used in GDB. + +@item old-archive +@samp{-o} in @code{tar}. + +@item old-file +@samp{-o} in Make. + +@item one-file-system +@samp{-l} in @code{tar}, @code{cp}, and @code{du}. + +@item only-file +@samp{-o} in @code{ptx}. + +@item only-prof +@samp{-f} in @code{gprof}. + +@item only-time +@samp{-F} in @code{gprof}. + +@item output +In various programs, specify the output file name. + +@item output-prefix +@samp{-o} in @code{shar}. + +@item override +@samp{-o} in @code{rm}. + +@item overwrite +@samp{-c} in @code{unshar}. + +@item owner +@samp{-o} in @code{install}. + +@item paginate +@samp{-l} in @code{diff}. + +@item paragraph-indent +Used in @code{makeinfo}. + +@item parents +@samp{-p} in @code{mkdir} and @code{rmdir}. + +@item pass-all +@samp{-p} in @code{ul}. + +@item pass-through +@samp{-p} in @code{cpio}. + +@item port +@samp{-P} in @code{finger}. + +@item portability +@samp{-c} in @code{cpio} and @code{tar}. + +@item posix +Used in @code{gawk}. + +@item prefix-builtins +@samp{-P} in @code{m4}. + +@item prefix +@samp{-f} in @code{csplit}. + +@item preserve +Used in @code{tar} and @code{cp}. + +@item preserve-environment +@samp{-p} in @code{su}. + +@item preserve-modification-time +@samp{-m} in @code{cpio}. + +@item preserve-order +@samp{-s} in @code{tar}. + +@item preserve-permissions +@samp{-p} in @code{tar}. + +@item print +@samp{-l} in @code{diff}. + +@item print-chars +@samp{-L} in @code{cmp}. + +@item print-data-base +@samp{-p} in Make. + +@item print-directory +@samp{-w} in Make. + +@item print-file-name +@samp{-o} in @code{nm}. + +@item print-symdefs +@samp{-s} in @code{nm}. + +@item printer +@samp{-p} in @code{wdiff}. + +@item prompt +@samp{-p} in @code{ed}. + +@item query-user +@samp{-X} in @code{shar}. + +@item question +@samp{-q} in Make. + +@item quiet +Used in many programs to inhibit the usual output. @strong{Note:} every +program accepting @samp{--quiet} should accept @samp{--silent} as a +synonym. + +@item quiet-unshar +@samp{-Q} in @code{shar} + +@item quote-name +@samp{-Q} in @code{ls}. + +@item rcs +@samp{-n} in @code{diff}. + +@item re-interval +Used in @code{gawk}. + +@item read-full-blocks +@samp{-B} in @code{tar}. + +@item readnow +Used in GDB. + +@item recon +@samp{-n} in Make. + +@item record-number +@samp{-R} in @code{tar}. + +@item recursive +Used in @code{chgrp}, @code{chown}, @code{cp}, @code{ls}, @code{diff}, +and @code{rm}. + +@item reference-limit +Used in @code{makeinfo}. + +@item references +@samp{-r} in @code{ptx}. + +@item regex +@samp{-r} in @code{tac} and @code{etags}. + +@item release +@samp{-r} in @code{uname}. + +@item reload-state +@samp{-R} in @code{m4}. + +@item relocation +@samp{-r} in @code{objdump}. + +@item rename +@samp{-r} in @code{cpio}. + +@item replace +@samp{-i} in @code{xargs}. + +@item report-identical-files +@samp{-s} in @code{diff}. + +@item reset-access-time +@samp{-a} in @code{cpio}. + +@item reverse +@samp{-r} in @code{ls} and @code{nm}. + +@item reversed-ed +@samp{-f} in @code{diff}. + +@item right-side-defs +@samp{-R} in @code{ptx}. + +@item same-order +@samp{-s} in @code{tar}. + +@item same-permissions +@samp{-p} in @code{tar}. + +@item save +@samp{-g} in @code{stty}. + +@item se +Used in GDB. + +@item sentence-regexp +@samp{-S} in @code{ptx}. + +@item separate-dirs +@samp{-S} in @code{du}. + +@item separator +@samp{-s} in @code{tac}. + +@item sequence +Used by @code{recode} to chose files or pipes for sequencing passes. + +@item shell +@samp{-s} in @code{su}. + +@item show-all +@samp{-A} in @code{cat}. + +@item show-c-function +@samp{-p} in @code{diff}. + +@item show-ends +@samp{-E} in @code{cat}. + +@item show-function-line +@samp{-F} in @code{diff}. + +@item show-tabs +@samp{-T} in @code{cat}. + +@item silent +Used in many programs to inhibit the usual output. +@strong{Note:} every program accepting +@samp{--silent} should accept @samp{--quiet} as a synonym. + +@item size +@samp{-s} in @code{ls}. + +@item sort +Used in @code{ls}. + +@item source +@samp{-W source} in @code{gawk}. + +@item sparse +@samp{-S} in @code{tar}. + +@item speed-large-files +@samp{-H} in @code{diff}. + +@item split-at +@samp{-E} in @code{unshar}. + +@item split-size-limit +@samp{-L} in @code{shar}. + +@item squeeze-blank +@samp{-s} in @code{cat}. + +@item start-delete +@samp{-w} in @code{wdiff}. + +@item start-insert +@samp{-y} in @code{wdiff}. + +@item starting-file +Used in @code{tar} and @code{diff} to specify which file within +a directory to start processing with. + +@item statistics +@samp{-s} in @code{wdiff}. + +@item stdin-file-list +@samp{-S} in @code{shar}. + +@item stop +@samp{-S} in Make. + +@item strict +@samp{-s} in @code{recode}. + +@item strip +@samp{-s} in @code{install}. + +@item strip-all +@samp{-s} in @code{strip}. + +@item strip-debug +@samp{-S} in @code{strip}. + +@item submitter +@samp{-s} in @code{shar}. + +@item suffix +@samp{-S} in @code{cp}, @code{ln}, @code{mv}. + +@item suffix-format +@samp{-b} in @code{csplit}. + +@item sum +@samp{-s} in @code{gprof}. + +@item summarize +@samp{-s} in @code{du}. + +@item symbolic +@samp{-s} in @code{ln}. + +@item symbols +Used in GDB and @code{objdump}. + +@item synclines +@samp{-s} in @code{m4}. + +@item sysname +@samp{-s} in @code{uname}. + +@item tabs +@samp{-t} in @code{expand} and @code{unexpand}. + +@item tabsize +@samp{-T} in @code{ls}. + +@item terminal +@samp{-T} in @code{tput} and @code{ul}. +@samp{-t} in @code{wdiff}. + +@item text +@samp{-a} in @code{diff}. + +@item text-files +@samp{-T} in @code{shar}. + +@item time +Used in @code{ls} and @code{touch}. + +@item to-stdout +@samp{-O} in @code{tar}. + +@item total +@samp{-c} in @code{du}. + +@item touch +@samp{-t} in Make, @code{ranlib}, and @code{recode}. + +@item trace +@samp{-t} in @code{m4}. + +@item traditional +@samp{-t} in @code{hello}; +@samp{-W traditional} in @code{gawk}; +@samp{-G} in @code{ed}, @code{m4}, and @code{ptx}. + +@item tty +Used in GDB. + +@item typedefs +@samp{-t} in @code{ctags}. + +@item typedefs-and-c++ +@samp{-T} in @code{ctags}. + +@item typeset-mode +@samp{-t} in @code{ptx}. + +@item uncompress +@samp{-z} in @code{tar}. + +@item unconditional +@samp{-u} in @code{cpio}. + +@item undefine +@samp{-U} in @code{m4}. + +@item undefined-only +@samp{-u} in @code{nm}. + +@item update +@samp{-u} in @code{cp}, @code{ctags}, @code{mv}, @code{tar}. + +@item usage +Used in @code{gawk}; same as @samp{--help}. + +@item uuencode +@samp{-B} in @code{shar}. + +@item vanilla-operation +@samp{-V} in @code{shar}. + +@item verbose +Print more information about progress. Many programs support this. + +@item verify +@samp{-W} in @code{tar}. + +@item version +Print the version number. + +@item version-control +@samp{-V} in @code{cp}, @code{ln}, @code{mv}. + +@item vgrind +@samp{-v} in @code{ctags}. + +@item volume +@samp{-V} in @code{tar}. + +@item what-if +@samp{-W} in Make. + +@item whole-size-limit +@samp{-l} in @code{shar}. + +@item width +@samp{-w} in @code{ls} and @code{ptx}. + +@item word-regexp +@samp{-W} in @code{ptx}. + +@item writable +@samp{-T} in @code{who}. + +@item zeros +@samp{-z} in @code{gprof}. +@end table + +@node Memory Usage +@section Memory Usage + +If it typically uses just a few meg of memory, don't bother making any +effort to reduce memory usage. For example, if it is impractical for +other reasons to operate on files more than a few meg long, it is +reasonable to read entire input files into core to operate on them. + +However, for programs such as @code{cat} or @code{tail}, that can +usefully operate on very large files, it is important to avoid using a +technique that would artificially limit the size of files it can handle. +If a program works by lines and could be applied to arbitrary +user-supplied input files, it should keep only a line in memory, because +this is not very hard and users will want to be able to operate on input +files that are bigger than will fit in core all at once. + +If your program creates complicated data structures, just make them in +core and give a fatal error if @code{malloc} returns zero. + +@node Writing C +@chapter Making The Best Use of C + +This @value{CHAPTER} provides advice on how best to use the C language +when writing GNU software. + +@menu +* Formatting:: Formatting Your Source Code +* Comments:: Commenting Your Work +* Syntactic Conventions:: Clean Use of C Constructs +* Names:: Naming Variables and Functions +* System Portability:: Portability between different operating systems +* CPU Portability:: Supporting the range of CPU types +* System Functions:: Portability and ``standard'' library functions +* Internationalization:: Techniques for internationalization +* Mmap:: How you can safely use @code{mmap}. +@end menu + +@node Formatting +@section Formatting Your Source Code + +It is important to put the open-brace that starts the body of a C +function in column zero, and avoid putting any other open-brace or +open-parenthesis or open-bracket in column zero. Several tools look +for open-braces in column zero to find the beginnings of C functions. +These tools will not work on code not formatted that way. + +It is also important for function definitions to start the name of the +function in column zero. This helps people to search for function +definitions, and may also help certain tools recognize them. Thus, +the proper format is this: + +@example +static char * +concat (s1, s2) /* Name starts in column zero here */ + char *s1, *s2; +@{ /* Open brace in column zero here */ + @dots{} +@} +@end example + +@noindent +or, if you want to use @sc{ansi} C, format the definition like this: + +@example +static char * +concat (char *s1, char *s2) +@{ + @dots{} +@} +@end example + +In @sc{ansi} C, if the arguments don't fit nicely on one line, +split it like this: + +@example +int +lots_of_args (int an_integer, long a_long, short a_short, + double a_double, float a_float) +@dots{} +@end example + +For the body of the function, we prefer code formatted like this: + +@example +if (x < foo (y, z)) + haha = bar[4] + 5; +else + @{ + while (z) + @{ + haha += foo (z, z); + z--; + @} + return ++x + bar (); + @} +@end example + +We find it easier to read a program when it has spaces before the +open-parentheses and after the commas. Especially after the commas. + +When you split an expression into multiple lines, split it +before an operator, not after one. Here is the right way: + +@example +if (foo_this_is_long && bar > win (x, y, z) + && remaining_condition) +@end example + +Try to avoid having two operators of different precedence at the same +level of indentation. For example, don't write this: + +@example +mode = (inmode[j] == VOIDmode + || GET_MODE_SIZE (outmode[j]) > GET_MODE_SIZE (inmode[j]) + ? outmode[j] : inmode[j]); +@end example + +Instead, use extra parentheses so that the indentation shows the nesting: + +@example +mode = ((inmode[j] == VOIDmode + || (GET_MODE_SIZE (outmode[j]) > GET_MODE_SIZE (inmode[j]))) + ? outmode[j] : inmode[j]); +@end example + +Insert extra parentheses so that Emacs will indent the code properly. +For example, the following indentation looks nice if you do it by hand, +but Emacs would mess it up: + +@example +v = rup->ru_utime.tv_sec*1000 + rup->ru_utime.tv_usec/1000 + + rup->ru_stime.tv_sec*1000 + rup->ru_stime.tv_usec/1000; +@end example + +But adding a set of parentheses solves the problem: + +@example +v = (rup->ru_utime.tv_sec*1000 + rup->ru_utime.tv_usec/1000 + + rup->ru_stime.tv_sec*1000 + rup->ru_stime.tv_usec/1000); +@end example + +Format do-while statements like this: + +@example +do + @{ + a = foo (a); + @} +while (a > 0); +@end example + +Please use formfeed characters (control-L) to divide the program into +pages at logical places (but not within a function). It does not matter +just how long the pages are, since they do not have to fit on a printed +page. The formfeeds should appear alone on lines by themselves. + + +@node Comments +@section Commenting Your Work + +Every program should start with a comment saying briefly what it is for. +Example: @samp{fmt - filter for simple filling of text}. + +Please write the comments in a GNU program in English, because English +is the one language that nearly all programmers in all countries can +read. If you do not write English well, please write comments in +English as well as you can, then ask other people to help rewrite them. +If you can't write comments in English, please find someone to work with +you and translate your comments into English. + +Please put a comment on each function saying what the function does, +what sorts of arguments it gets, and what the possible values of +arguments mean and are used for. It is not necessary to duplicate in +words the meaning of the C argument declarations, if a C type is being +used in its customary fashion. If there is anything nonstandard about +its use (such as an argument of type @code{char *} which is really the +address of the second character of a string, not the first), or any +possible values that would not work the way one would expect (such as, +that strings containing newlines are not guaranteed to work), be sure +to say so. + +Also explain the significance of the return value, if there is one. + +Please put two spaces after the end of a sentence in your comments, so +that the Emacs sentence commands will work. Also, please write +complete sentences and capitalize the first word. If a lower-case +identifier comes at the beginning of a sentence, don't capitalize it! +Changing the spelling makes it a different identifier. If you don't +like starting a sentence with a lower case letter, write the sentence +differently (e.g., ``The identifier lower-case is @dots{}''). + +The comment on a function is much clearer if you use the argument +names to speak about the argument values. The variable name itself +should be lower case, but write it in upper case when you are speaking +about the value rather than the variable itself. Thus, ``the inode +number NODE_NUM'' rather than ``an inode''. + +There is usually no purpose in restating the name of the function in +the comment before it, because the reader can see that for himself. +There might be an exception when the comment is so long that the function +itself would be off the bottom of the screen. + +There should be a comment on each static variable as well, like this: + +@example +/* Nonzero means truncate lines in the display; + zero means continue them. */ +int truncate_lines; +@end example + +Every @samp{#endif} should have a comment, except in the case of short +conditionals (just a few lines) that are not nested. The comment should +state the condition of the conditional that is ending, @emph{including +its sense}. @samp{#else} should have a comment describing the condition +@emph{and sense} of the code that follows. For example: + +@example +@group +#ifdef foo + @dots{} +#else /* not foo */ + @dots{} +#endif /* not foo */ +@end group +@end example + +@noindent +but, by contrast, write the comments this way for a @samp{#ifndef}: + +@example +@group +#ifndef foo + @dots{} +#else /* foo */ + @dots{} +#endif /* foo */ +@end group +@end example + + +@node Syntactic Conventions +@section Clean Use of C Constructs + +Please explicitly declare all arguments to functions. +Don't omit them just because they are @code{int}s. + +Declarations of external functions and functions to appear later in the +source file should all go in one place near the beginning of the file +(somewhere before the first function definition in the file), or else +should go in a header file. Don't put @code{extern} declarations inside +functions. + +It used to be common practice to use the same local variables (with +names like @code{tem}) over and over for different values within one +function. Instead of doing this, it is better declare a separate local +variable for each distinct purpose, and give it a name which is +meaningful. This not only makes programs easier to understand, it also +facilitates optimization by good compilers. You can also move the +declaration of each local variable into the smallest scope that includes +all its uses. This makes the program even cleaner. + +Don't use local variables or parameters that shadow global identifiers. + +Don't declare multiple variables in one declaration that spans lines. +Start a new declaration on each line, instead. For example, instead +of this: + +@example +@group +int foo, + bar; +@end group +@end example + +@noindent +write either this: + +@example +int foo, bar; +@end example + +@noindent +or this: + +@example +int foo; +int bar; +@end example + +@noindent +(If they are global variables, each should have a comment preceding it +anyway.) + +When you have an @code{if}-@code{else} statement nested in another +@code{if} statement, always put braces around the @code{if}-@code{else}. +Thus, never write like this: + +@example +if (foo) + if (bar) + win (); + else + lose (); +@end example + +@noindent +always like this: + +@example +if (foo) + @{ + if (bar) + win (); + else + lose (); + @} +@end example + +If you have an @code{if} statement nested inside of an @code{else} +statement, either write @code{else if} on one line, like this, + +@example +if (foo) + @dots{} +else if (bar) + @dots{} +@end example + +@noindent +with its @code{then}-part indented like the preceding @code{then}-part, +or write the nested @code{if} within braces like this: + +@example +if (foo) + @dots{} +else + @{ + if (bar) + @dots{} + @} +@end example + +Don't declare both a structure tag and variables or typedefs in the +same declaration. Instead, declare the structure tag separately +and then use it to declare the variables or typedefs. + +Try to avoid assignments inside @code{if}-conditions. For example, +don't write this: + +@example +if ((foo = (char *) malloc (sizeof *foo)) == 0) + fatal ("virtual memory exhausted"); +@end example + +@noindent +instead, write this: + +@example +foo = (char *) malloc (sizeof *foo); +if (foo == 0) + fatal ("virtual memory exhausted"); +@end example + +Don't make the program ugly to placate @code{lint}. Please don't insert any +casts to @code{void}. Zero without a cast is perfectly fine as a null +pointer constant, except when calling a varargs function. + +@node Names +@section Naming Variables and Functions + +The names of global variables and functions in a program serve as +comments of a sort. So don't choose terse names---instead, look for +names that give useful information about the meaning of the variable or +function. In a GNU program, names should be English, like other +comments. + +Local variable names can be shorter, because they are used only within +one context, where (presumably) comments explain their purpose. + +Please use underscores to separate words in a name, so that the Emacs +word commands can be useful within them. Stick to lower case; reserve +upper case for macros and @code{enum} constants, and for name-prefixes +that follow a uniform convention. + +For example, you should use names like @code{ignore_space_change_flag}; +don't use names like @code{iCantReadThis}. + +Variables that indicate whether command-line options have been +specified should be named after the meaning of the option, not after +the option-letter. A comment should state both the exact meaning of +the option and its letter. For example, + +@example +@group +/* Ignore changes in horizontal whitespace (-b). */ +int ignore_space_change_flag; +@end group +@end example + +When you want to define names with constant integer values, use +@code{enum} rather than @samp{#define}. GDB knows about enumeration +constants. + +Use file names of 14 characters or less, to avoid creating gratuitous +problems on older System V systems. You can use the program +@code{doschk} to test for this. @code{doschk} also tests for potential +name conflicts if the files were loaded onto an MS-DOS file +system---something you may or may not care about. + +@node System Portability +@section Portability between System Types + +In the Unix world, ``portability'' refers to porting to different Unix +versions. For a GNU program, this kind of portability is desirable, but +not paramount. + +The primary purpose of GNU software is to run on top of the GNU kernel, +compiled with the GNU C compiler, on various types of @sc{cpu}. The +amount and kinds of variation among GNU systems on different @sc{cpu}s +will be comparable to the variation among Linux-based GNU systems or +among BSD systems today. So the kinds of portability that are absolutely +necessary are quite limited. + +But many users do run GNU software on non-GNU Unix or Unix-like systems. +So supporting a variety of Unix-like systems is desirable, although not +paramount. + +The easiest way to achieve portability to most Unix-like systems is to +use Autoconf. It's unlikely that your program needs to know more +information about the host platform than Autoconf can provide, simply +because most of the programs that need such knowledge have already been +written. + +Avoid using the format of semi-internal data bases (e.g., directories) +when there is a higher-level alternative (@code{readdir}). + +As for systems that are not like Unix, such as MSDOS, Windows, the +Macintosh, VMS, and MVS, supporting them is usually so much work that it +is better if you don't. + +The planned GNU kernel is not finished yet, but you can tell which +facilities it will provide by looking at the GNU C Library Manual. The +GNU kernel is based on Mach, so the features of Mach will also be +available. However, if you use Mach features, you'll probably have +trouble debugging your program today. + +@node CPU Portability +@section Portability between @sc{cpu}s + +Even GNU systems will differ because of differences among @sc{cpu} +types---for example, difference in byte ordering and alignment +requirements. It is absolutely essential to handle these differences. +However, don't make any effort to cater to the possibility that an +@code{int} will be less than 32 bits. We don't support 16-bit machines +in GNU. + +Don't assume that the address of an @code{int} object is also the +address of its least-significant byte. This is false on big-endian +machines. Thus, don't make the following mistake: + +@example +int c; +@dots{} +while ((c = getchar()) != EOF) + write(file_descriptor, &c, 1); +@end example + +When calling functions, you need not worry about the difference between +pointers of various types, or between pointers and integers. On most +machines, there's no difference anyway. As for the few machines where +there is a difference, all of them support @sc{ansi} C, so you can use +prototypes (conditionalized to be active only in @sc{ansi} C) to make +the code work on those systems. + +In certain cases, it is ok to pass integer and pointer arguments +indiscriminately to the same function, and use no prototype on any +system. For example, many GNU programs have error-reporting functions +that pass their arguments along to @code{printf} and friends: + +@example +error (s, a1, a2, a3) + char *s; + int a1, a2, a3; +@{ + fprintf (stderr, "error: "); + fprintf (stderr, s, a1, a2, a3); +@} +@end example + +@noindent +In practice, this works on all machines, and it is much simpler than any +``correct'' alternative. Be sure @emph{not} to use a prototype +for such functions. + +However, avoid casting pointers to integers unless you really need to. +These assumptions really reduce portability, and in most programs they +are easy to avoid. In the cases where casting pointers to integers is +essential---such as, a Lisp interpreter which stores type information as +well as an address in one word---it is ok to do so, but you'll have to +make explicit provisions to handle different word sizes. + +@node System Functions +@section Calling System Functions + +C implementations differ substantially. @sc{ansi} C reduces but does not +eliminate the incompatibilities; meanwhile, many users wish to compile +GNU software with pre-@sc{ansi} compilers. This chapter gives +recommendations for how to use the more or less standard C library +functions to avoid unnecessary loss of portability. + +@itemize @bullet +@item +Don't use the value of @code{sprintf}. It returns the number of +characters written on some systems, but not on all systems. + +@item +@code{main} should be declared to return type @code{int}. It should +terminate either by calling @code{exit} or by returning the integer +status code; make sure it cannot ever return an undefined value. + +@item +Don't declare system functions explicitly. + +Almost any declaration for a system function is wrong on some system. +To minimize conflicts, leave it to the system header files to declare +system functions. If the headers don't declare a function, let it +remain undeclared. + +While it may seem unclean to use a function without declaring it, in +practice this works fine for most system library functions on the +systems where this really happens; thus, the disadvantage is only +theoretical. By contrast, actual declarations have frequently caused +actual conflicts. + +@item +If you must declare a system function, don't specify the argument types. +Use an old-style declaration, not an @sc{ansi} prototype. The more you +specify about the function, the more likely a conflict. + +@item +In particular, don't unconditionally declare @code{malloc} or +@code{realloc}. + +Most GNU programs use those functions just once, in functions +conventionally named @code{xmalloc} and @code{xrealloc}. These +functions call @code{malloc} and @code{realloc}, respectively, and +check the results. + +Because @code{xmalloc} and @code{xrealloc} are defined in your program, +you can declare them in other files without any risk of type conflict. + +On most systems, @code{int} is the same length as a pointer; thus, the +calls to @code{malloc} and @code{realloc} work fine. For the few +exceptional systems (mostly 64-bit machines), you can use +@strong{conditionalized} declarations of @code{malloc} and +@code{realloc}---or put these declarations in configuration files +specific to those systems. + +@item +The string functions require special treatment. Some Unix systems have +a header file @file{string.h}; others have @file{strings.h}. Neither +file name is portable. There are two things you can do: use Autoconf to +figure out which file to include, or don't include either file. + +@item +If you don't include either strings file, you can't get declarations for +the string functions from the header file in the usual way. + +That causes less of a problem than you might think. The newer @sc{ansi} +string functions should be avoided anyway because many systems still +don't support them. The string functions you can use are these: + +@example +strcpy strncpy strcat strncat +strlen strcmp strncmp +strchr strrchr +@end example + +The copy and concatenate functions work fine without a declaration as +long as you don't use their values. Using their values without a +declaration fails on systems where the width of a pointer differs from +the width of @code{int}, and perhaps in other cases. It is trivial to +avoid using their values, so do that. + +The compare functions and @code{strlen} work fine without a declaration +on most systems, possibly all the ones that GNU software runs on. +You may find it necessary to declare them @strong{conditionally} on a +few systems. + +The search functions must be declared to return @code{char *}. Luckily, +there is no variation in the data type they return. But there is +variation in their names. Some systems give these functions the names +@code{index} and @code{rindex}; other systems use the names +@code{strchr} and @code{strrchr}. Some systems support both pairs of +names, but neither pair works on all systems. + +You should pick a single pair of names and use it throughout your +program. (Nowadays, it is better to choose @code{strchr} and +@code{strrchr} for new programs, since those are the standard @sc{ansi} +names.) Declare both of those names as functions returning @code{char +*}. On systems which don't support those names, define them as macros +in terms of the other pair. For example, here is what to put at the +beginning of your file (or in a header) if you want to use the names +@code{strchr} and @code{strrchr} throughout: + +@example +#ifndef HAVE_STRCHR +#define strchr index +#endif +#ifndef HAVE_STRRCHR +#define strrchr rindex +#endif + +char *strchr (); +char *strrchr (); +@end example +@end itemize + +Here we assume that @code{HAVE_STRCHR} and @code{HAVE_STRRCHR} are +macros defined in systems where the corresponding functions exist. +One way to get them properly defined is to use Autoconf. + +@node Internationalization +@section Internationalization + +GNU has a library called GNU gettext that makes it easy to translate the +messages in a program into various languages. You should use this +library in every program. Use English for the messages as they appear +in the program, and let gettext provide the way to translate them into +other languages. + +Using GNU gettext involves putting a call to the @code{gettext} macro +around each string that might need translation---like this: + +@example +printf (gettext ("Processing file `%s'...")); +@end example + +@noindent +This permits GNU gettext to replace the string @code{"Processing file +`%s'..."} with a translated version. + +Once a program uses gettext, please make a point of writing calls to +@code{gettext} when you add new strings that call for translation. + +Using GNU gettext in a package involves specifying a @dfn{text domain +name} for the package. The text domain name is used to separate the +translations for this package from the translations for other packages. +Normally, the text domain name should be the same as the name of the +package---for example, @samp{fileutils} for the GNU file utilities. + +To enable gettext to work well, avoid writing code that makes +assumptions about the structure of words or sentences. When you want +the precise text of a sentence to vary depending on the data, use two or +more alternative string constants each containing a complete sentences, +rather than inserting conditionalized words or phrases into a single +sentence framework. + +Here is an example of what not to do: + +@example +printf ("%d file%s processed", nfiles, + nfiles != 1 ? "s" : ""); +@end example + +@noindent +The problem with that example is that it assumes that plurals are made +by adding `s'. If you apply gettext to the format string, like this, + +@example +printf (gettext ("%d file%s processed"), nfiles, + nfiles != 1 ? "s" : ""); +@end example + +@noindent +the message can use different words, but it will still be forced to use +`s' for the plural. Here is a better way: + +@example +printf ((nfiles != 1 ? "%d files processed" + : "%d file processed"), + nfiles); +@end example + +@noindent +This way, you can apply gettext to each of the two strings +independently: + +@example +printf ((nfiles != 1 ? gettext ("%d files processed") + : gettext ("%d file processed")), + nfiles); +@end example + +@noindent +This can any method of forming the plural of the word for ``file'', and +also handles languages that require agreement in the word for +``processed''. + +A similar problem appears at the level of sentence structure with this +code: + +@example +printf ("# Implicit rule search has%s been done.\n", + f->tried_implicit ? "" : " not"); +@end example + +@noindent +Adding @code{gettext} calls to this code cannot give correct results for +all languages, because negation in some languages requires adding words +at more than one place in the sentence. By contrast, adding +@code{gettext} calls does the job straightfowardly if the code starts +out like this: + +@example +printf (f->tried_implicit + ? "# Implicit rule search has been done.\n", + : "# Implicit rule search has not been done.\n"); +@end example + +@node Mmap +@section Mmap + +Don't assume that @code{mmap} either works on all files or fails +for all files. It may work on some files and fail on others. + +The proper way to use @code{mmap} is to try it on the specific file for +which you want to use it---and if @code{mmap} doesn't work, fall back on +doing the job in another way using @code{read} and @code{write}. + +The reason this precaution is needed is that the GNU kernel (the HURD) +provides a user-extensible file system, in which there can be many +different kinds of ``ordinary files.'' Many of them support +@code{mmap}, but some do not. It is important to make programs handle +all these kinds of files. + +@node Documentation +@chapter Documenting Programs + +@menu +* GNU Manuals:: Writing proper manuals. +* Manual Structure Details:: Specific structure conventions. +* NEWS File:: NEWS files supplement manuals. +* Change Logs:: Recording Changes +* Man Pages:: Man pages are secondary. +* Reading other Manuals:: How far you can go in learning + from other manuals. +@end menu + +@node GNU Manuals +@section GNU Manuals + +The preferred way to document part of the GNU system is to write a +manual in the Texinfo formatting language. See the Texinfo manual, +either the hardcopy, or the on-line version available through +@code{info} or the Emacs Info subsystem (@kbd{C-h i}). + +Programmers often find it most natural to structure the documentation +following the structure of the implementation, which they know. But +this structure is not necessarily good for explaining how to use the +program; it may be irrelevant and confusing for a user. + +At every level, from the sentences in a paragraph to the grouping of +topics into separate manuals, the right way to structure documentation +is according to the concepts and questions that a user will have in mind +when reading it. Sometimes this structure of ideas matches the +structure of the implementation of the software being documented---but +often they are different. Often the most important part of learning to +write good documentation is learning to notice when you are structuring +the documentation like the implementation, and think about better +alternatives. + +For example, each program in the GNU system probably ought to be +documented in one manual; but this does not mean each program should +have its own manual. That would be following the structure of the +implementation, rather than the structure that helps the user +understand. + +Instead, each manual should cover a coherent @emph{topic}. For example, +instead of a manual for @code{diff} and a manual for @code{diff3}, we +have one manual for ``comparison of files'' which covers both of those +programs, as well as @code{cmp}. By documenting these programs +together, we can make the whole subject clearer. + +The manual which discusses a program should document all of the +program's command-line options and all of its commands. It should give +examples of their use. But don't organize the manual as a list of +features. Instead, organize it logically, by subtopics. Address the +questions that a user will ask when thinking about the job that the +program does. + +In general, a GNU manual should serve both as tutorial and reference. +It should be set up for convenient access to each topic through Info, +and for reading straight through (appendixes aside). A GNU manual +should give a good introduction to a beginner reading through from the +start, and should also provide all the details that hackers want. + +That is not as hard as it first sounds. Arrange each chapter as a +logical breakdown of its topic, but order the sections, and write their +text, so that reading the chapter straight through makes sense. Do +likewise when structuring the book into chapters, and when structuring a +section into paragraphs. The watchword is, @emph{at each point, address +the most fundamental and important issue raised by the preceding text.} + +If necessary, add extra chapters at the beginning of the manual which +are purely tutorial and cover the basics of the subject. These provide +the framework for a beginner to understand the rest of the manual. The +Bison manual provides a good example of how to do this. + +Don't use Unix man pages as a model for how to write GNU documentation; +most of them are terse, badly structured, and give inadequate +explanation of the underlying concepts. (There are, of course +exceptions.) Also Unix man pages use a particular format which is +different from what we use in GNU manuals. + +Please do not use the term ``pathname'' that is used in Unix +documentation; use ``file name'' (two words) instead. We use the term +``path'' only for search paths, which are lists of file names. + +Please do not use the term ``illegal'' to refer to erroneous input to a +computer program. Please use ``invalid'' for this, and reserve the term +``illegal'' for violations of law. + +@node Manual Structure Details +@section Manual Structure Details + +The title page of the manual should state the version of the programs or +packages documented in the manual. The Top node of the manual should +also contain this information. If the manual is changing more +frequently than or independent of the program, also state a version +number for the manual in both of these places. + +Each program documented in the manual should should have a node named +@samp{@var{program} Invocation} or @samp{Invoking @var{program}}. This +node (together with its subnodes, if any) should describe the program's +command line arguments and how to run it (the sort of information people +would look in a man page for). Start with an @samp{@@example} +containing a template for all the options and arguments that the program +uses. + +Alternatively, put a menu item in some menu whose item name fits one of +the above patterns. This identifies the node which that item points to +as the node for this purpose, regardless of the node's actual name. + +There will be automatic features for specifying a program name and +quickly reading just this part of its manual. + +If one manual describes several programs, it should have such a node for +each program described. + +@node NEWS File +@section The NEWS File + +In addition to its manual, the package should have a file named +@file{NEWS} which contains a list of user-visible changes worth +mentioning. In each new release, add items to the front of the file and +identify the version they pertain to. Don't discard old items; leave +them in the file after the newer items. This way, a user upgrading from +any previous version can see what is new. + +If the @file{NEWS} file gets very long, move some of the older items +into a file named @file{ONEWS} and put a note at the end referring the +user to that file. + +@node Change Logs +@section Change Logs + +Keep a change log to describe all the changes made to program source +files. The purpose of this is so that people investigating bugs in the +future will know about the changes that might have introduced the bug. +Often a new bug can be found by looking at what was recently changed. +More importantly, change logs can help you eliminate conceptual +inconsistencies between different parts of a program, by giving you a +history of how the conflicting concepts arose and who they came from. + +@menu +* Change Log Concepts:: +* Style of Change Logs:: +* Simple Changes:: +* Conditional Changes:: +@end menu + +@node Change Log Concepts +@subsection Change Log Concepts + +You can think of the change log as a conceptual ``undo list'' which +explains how earlier versions were different from the current version. +People can see the current version; they don't need the change log +to tell them what is in it. What they want from a change log is a +clear explanation of how the earlier version differed. + +The change log file is normally called @file{ChangeLog} and covers an +entire directory. Each directory can have its own change log, or a +directory can use the change log of its parent directory--it's up to +you. + +Another alternative is to record change log information with a version +control system such as RCS or CVS. This can be converted automatically +to a @file{ChangeLog} file. + +There's no need to describe the full purpose of the changes or how they +work together. If you think that a change calls for explanation, you're +probably right. Please do explain it---but please put the explanation +in comments in the code, where people will see it whenever they see the +code. For example, ``New function'' is enough for the change log when +you add a function, because there should be a comment before the +function definition to explain what it does. + +However, sometimes it is useful to write one line to describe the +overall purpose of a batch of changes. + +The easiest way to add an entry to @file{ChangeLog} is with the Emacs +command @kbd{M-x add-change-log-entry}. An entry should have an +asterisk, the name of the changed file, and then in parentheses the name +of the changed functions, variables or whatever, followed by a colon. +Then describe the changes you made to that function or variable. + +@node Style of Change Logs +@subsection Style of Change Logs + +Here are some examples of change log entries: + +@example +* register.el (insert-register): Return nil. +(jump-to-register): Likewise. + +* sort.el (sort-subr): Return nil. + +* tex-mode.el (tex-bibtex-file, tex-file, tex-region): +Restart the tex shell if process is gone or stopped. +(tex-shell-running): New function. + +* expr.c (store_one_arg): Round size up for move_block_to_reg. +(expand_call): Round up when emitting USE insns. +* stmt.c (assign_parms): Round size up for move_block_from_reg. +@end example + +It's important to name the changed function or variable in full. Don't +abbreviate function or variable names, and don't combine them. +Subsequent maintainers will often search for a function name to find all +the change log entries that pertain to it; if you abbreviate the name, +they won't find it when they search. + +For example, some people are tempted to abbreviate groups of function +names by writing @samp{* register.el (@{insert,jump-to@}-register)}; +this is not a good idea, since searching for @code{jump-to-register} or +@code{insert-register} would not find that entry. + +Separate unrelated change log entries with blank lines. When two +entries represent parts of the same change, so that they work together, +then don't put blank lines between them. Then you can omit the file +name and the asterisk when successive entries are in the same file. + +@node Simple Changes +@subsection Simple Changes + +Certain simple kinds of changes don't need much detail in the change +log. + +When you change the calling sequence of a function in a simple fashion, +and you change all the callers of the function, there is no need to make +individual entries for all the callers that you changed. Just write in +the entry for the function being called, ``All callers changed.'' + +@example +* keyboard.c (Fcommand_execute): New arg SPECIAL. +All callers changed. +@end example + +When you change just comments or doc strings, it is enough to write an +entry for the file, without mentioning the functions. Just ``Doc +fixes'' is enough for the change log. + +There's no need to make change log entries for documentation files. +This is because documentation is not susceptible to bugs that are hard +to fix. Documentation does not consist of parts that must interact in a +precisely engineered fashion. To correct an error, you need not know +the history of the erroneous passage; it is enough to compare what the +documentation says with the way the program actually works. + +@node Conditional Changes +@subsection Conditional Changes + +C programs often contain compile-time @code{#if} conditionals. Many +changes are conditional; sometimes you add a new definition which is +entirely contained in a conditional. It is very useful to indicate in +the change log the conditions for which the change applies. + +Our convention for indicating conditional changes is to use square +brackets around the name of the condition. + +Here is a simple example, describing a change which is conditional but +does not have a function or entity name associated with it: + +@example +* xterm.c [SOLARIS2]: Include string.h. +@end example + +Here is an entry describing a new definition which is entirely +conditional. This new definition for the macro @code{FRAME_WINDOW_P} is +used only when @code{HAVE_X_WINDOWS} is defined: + +@example +* frame.h [HAVE_X_WINDOWS] (FRAME_WINDOW_P): Macro defined. +@end example + +Here is an entry for a change within the function @code{init_display}, +whose definition as a whole is unconditional, but the changes themselves +are contained in a @samp{#ifdef HAVE_LIBNCURSES} conditional: + +@example +* dispnew.c (init_display) [HAVE_LIBNCURSES]: If X, call tgetent. +@end example + +Here is an entry for a change that takes affect only when +a certain macro is @emph{not} defined: + +@example +(gethostname) [!HAVE_SOCKETS]: Replace with winsock version. +@end example + +@node Man Pages +@section Man Pages + +In the GNU project, man pages are secondary. It is not necessary or +expected for every GNU program to have a man page, but some of them do. +It's your choice whether to include a man page in your program. + +When you make this decision, consider that supporting a man page +requires continual effort each time the program is changed. The time +you spend on the man page is time taken away from more useful work. + +For a simple program which changes little, updating the man page may be +a small job. Then there is little reason not to include a man page, if +you have one. + +For a large program that changes a great deal, updating a man page may +be a substantial burden. If a user offers to donate a man page, you may +find this gift costly to accept. It may be better to refuse the man +page unless the same person agrees to take full responsibility for +maintaining it---so that you can wash your hands of it entirely. If +this volunteer later ceases to do the job, then don't feel obliged to +pick it up yourself; it may be better to withdraw the man page from the +distribution until someone else agrees to update it. + +When a program changes only a little, you may feel that the +discrepancies are small enough that the man page remains useful without +updating. If so, put a prominent note near the beginning of the man +page explaining that you don't maintain it and that the Texinfo manual +is more authoritative. The note should say how to access the Texinfo +documentation. + +@node Reading other Manuals +@section Reading other Manuals + +There may be non-free books or documentation files that describe the +program you are documenting. + +It is ok to use these documents for reference, just as the author of a +new algebra textbook can read other books on algebra. A large portion +of any non-fiction book consists of facts, in this case facts about how +a certain program works, and these facts are necessarily the same for +everyone who writes about the subject. But be careful not to copy your +outline structure, wording, tables or examples from preexisting non-free +documentation. Copying from free documentation may be ok; please check +with the FSF about the individual case. + +@node Managing Releases +@chapter The Release Process + +Making a release is more than just bundling up your source files in a +tar file and putting it up for FTP. You should set up your software so +that it can be configured to run on a variety of systems. Your Makefile +should conform to the GNU standards described below, and your directory +layout should also conform to the standards discussed below. Doing so +makes it easy to include your package into the larger framework of +all GNU software. + +@menu +* Configuration:: How Configuration Should Work +* Makefile Conventions:: Makefile Conventions +* Releases:: Making Releases +@end menu + +@node Configuration +@section How Configuration Should Work + +Each GNU distribution should come with a shell script named +@code{configure}. This script is given arguments which describe the +kind of machine and system you want to compile the program for. + +The @code{configure} script must record the configuration options so +that they affect compilation. + +One way to do this is to make a link from a standard name such as +@file{config.h} to the proper configuration file for the chosen system. +If you use this technique, the distribution should @emph{not} contain a +file named @file{config.h}. This is so that people won't be able to +build the program without configuring it first. + +Another thing that @code{configure} can do is to edit the Makefile. If +you do this, the distribution should @emph{not} contain a file named +@file{Makefile}. Instead, it should include a file @file{Makefile.in} which +contains the input used for editing. Once again, this is so that people +won't be able to build the program without configuring it first. + +If @code{configure} does write the @file{Makefile}, then @file{Makefile} +should have a target named @file{Makefile} which causes @code{configure} +to be rerun, setting up the same configuration that was set up last +time. The files that @code{configure} reads should be listed as +dependencies of @file{Makefile}. + +All the files which are output from the @code{configure} script should +have comments at the beginning explaining that they were generated +automatically using @code{configure}. This is so that users won't think +of trying to edit them by hand. + +The @code{configure} script should write a file named @file{config.status} +which describes which configuration options were specified when the +program was last configured. This file should be a shell script which, +if run, will recreate the same configuration. + +The @code{configure} script should accept an option of the form +@samp{--srcdir=@var{dirname}} to specify the directory where sources are found +(if it is not the current directory). This makes it possible to build +the program in a separate directory, so that the actual source directory +is not modified. + +If the user does not specify @samp{--srcdir}, then @code{configure} should +check both @file{.} and @file{..} to see if it can find the sources. If +it finds the sources in one of these places, it should use them from +there. Otherwise, it should report that it cannot find the sources, and +should exit with nonzero status. + +Usually the easy way to support @samp{--srcdir} is by editing a +definition of @code{VPATH} into the Makefile. Some rules may need to +refer explicitly to the specified source directory. To make this +possible, @code{configure} can add to the Makefile a variable named +@code{srcdir} whose value is precisely the specified directory. + +The @code{configure} script should also take an argument which specifies the +type of system to build the program for. This argument should look like +this: + +@example +@var{cpu}-@var{company}-@var{system} +@end example + +For example, a Sun 3 might be @samp{m68k-sun-sunos4.1}. + +The @code{configure} script needs to be able to decode all plausible +alternatives for how to describe a machine. Thus, @samp{sun3-sunos4.1} +would be a valid alias. For many programs, @samp{vax-dec-ultrix} would +be an alias for @samp{vax-dec-bsd}, simply because the differences +between Ultrix and @sc{BSD} are rarely noticeable, but a few programs +might need to distinguish them. +@c Real 4.4BSD now runs on some Suns. + +There is a shell script called @file{config.sub} that you can use +as a subroutine to validate system types and canonicalize aliases. + +Other options are permitted to specify in more detail the software +or hardware present on the machine, and include or exclude optional +parts of the package: + +@table @samp +@item --enable-@var{feature}@r{[}=@var{parameter}@r{]} +Configure the package to build and install an optional user-level +facility called @var{feature}. This allows users to choose which +optional features to include. Giving an optional @var{parameter} of +@samp{no} should omit @var{feature}, if it is built by default. + +No @samp{--enable} option should @strong{ever} cause one feature to +replace another. No @samp{--enable} option should ever substitute one +useful behavior for another useful behavior. The only proper use for +@samp{--enable} is for questions of whether to build part of the program +or exclude it. + +@item --with-@var{package} +@c @r{[}=@var{parameter}@r{]} +The package @var{package} will be installed, so configure this package +to work with @var{package}. + +@c Giving an optional @var{parameter} of +@c @samp{no} should omit @var{package}, if it is used by default. + +Possible values of @var{package} include @samp{x}, @samp{x-toolkit}, +@samp{gnu-as} (or @samp{gas}), @samp{gnu-ld}, @samp{gnu-libc}, and +@samp{gdb}. + +Do not use a @samp{--with} option to specify the file name to use to +find certain files. That is outside the scope of what @samp{--with} +options are for. + +@item --nfp +The target machine has no floating point processor. + +@item --gas +The target machine assembler is GAS, the GNU assembler. +This is obsolete; users should use @samp{--with-gnu-as} instead. + +@item --x +The target machine has the X Window System installed. +This is obsolete; users should use @samp{--with-x} instead. +@end table + +All @code{configure} scripts should accept all of these ``detail'' +options, whether or not they make any difference to the particular +package at hand. In particular, they should accept any option that +starts with @samp{--with-} or @samp{--enable-}. This is so users will +be able to configure an entire GNU source tree at once with a single set +of options. + +You will note that the categories @samp{--with-} and @samp{--enable-} +are narrow: they @strong{do not} provide a place for any sort of option +you might think of. That is deliberate. We want to limit the possible +configuration options in GNU software. We do not want GNU programs to +have idiosyncratic configuration options. + +Packages that perform part of the compilation process may support cross-compilation. +In such a case, the host and target machines for the program may be +different. The @code{configure} script should normally treat the +specified type of system as both the host and the target, thus producing +a program which works for the same type of machine that it runs on. + +The way to build a cross-compiler, cross-assembler, or what have you, is +to specify the option @samp{--host=@var{hosttype}} when running +@code{configure}. This specifies the host system without changing the +type of target system. The syntax for @var{hosttype} is the same as +described above. + +Bootstrapping a cross-compiler requires compiling it on a machine other +than the host it will run on. Compilation packages accept a +configuration option @samp{--build=@var{hosttype}} for specifying the +configuration on which you will compile them, in case that is different +from the host. + +Programs for which cross-operation is not meaningful need not accept the +@samp{--host} option, because configuring an entire operating system for +cross-operation is not a meaningful thing. + +Some programs have ways of configuring themselves automatically. If +your program is set up to do this, your @code{configure} script can simply +ignore most of its arguments. + +@comment The makefile standards are in a separate file that is also +@comment included by make.texinfo. Done by roland@gnu.ai.mit.edu on 1/6/93. +@comment For this document, turn chapters into sections, etc. +@lowersections +@include make-stds.texi +@raisesections + +@node Releases +@section Making Releases + +Package the distribution of Foo version 69.96 in a gzipped tar file +named @file{foo-69.96.tar.gz}. It should unpack into a subdirectory +named @file{foo-69.96}. + +Building and installing the program should never modify any of the files +contained in the distribution. This means that all the files that form +part of the program in any way must be classified into @dfn{source +files} and @dfn{non-source files}. Source files are written by humans +and never changed automatically; non-source files are produced from +source files by programs under the control of the Makefile. + +Naturally, all the source files must be in the distribution. It is okay +to include non-source files in the distribution, provided they are +up-to-date and machine-independent, so that building the distribution +normally will never modify them. We commonly include non-source files +produced by Bison, @code{lex}, @TeX{}, and @code{makeinfo}; this helps avoid +unnecessary dependencies between our distributions, so that users can +install whichever packages they want to install. + +Non-source files that might actually be modified by building and +installing the program should @strong{never} be included in the +distribution. So if you do distribute non-source files, always make +sure they are up to date when you make a new distribution. + +Make sure that the directory into which the distribution unpacks (as +well as any subdirectories) are all world-writable (octal mode 777). +This is so that old versions of @code{tar} which preserve the +ownership and permissions of the files from the tar archive will be +able to extract all the files even if the user is unprivileged. + +Make sure that all the files in the distribution are world-readable. + +Make sure that no file name in the distribution is more than 14 +characters long. Likewise, no file created by building the program +should have a name longer than 14 characters. The reason for this is +that some systems adhere to a foolish interpretation of the POSIX +standard, and refuse to open a longer name, rather than truncating as +they did in the past. + +Don't include any symbolic links in the distribution itself. If the tar +file contains symbolic links, then people cannot even unpack it on +systems that don't support symbolic links. Also, don't use multiple +names for one file in different directories, because certain file +systems cannot handle this and that prevents unpacking the +distribution. + +Try to make sure that all the file names will be unique on MS-DOS. A +name on MS-DOS consists of up to 8 characters, optionally followed by a +period and up to three characters. MS-DOS will truncate extra +characters both before and after the period. Thus, +@file{foobarhacker.c} and @file{foobarhacker.o} are not ambiguous; they +are truncated to @file{foobarha.c} and @file{foobarha.o}, which are +distinct. + +Include in your distribution a copy of the @file{texinfo.tex} you used +to test print any @file{*.texinfo} or @file{*.texi} files. + +Likewise, if your program uses small GNU software packages like regex, +getopt, obstack, or termcap, include them in the distribution file. +Leaving them out would make the distribution file a little smaller at +the expense of possible inconvenience to a user who doesn't know what +other files to get. + +@contents + +@bye diff --git a/gcc/config/alpha/vms-tramp.asm b/gcc/config/alpha/vms-tramp.asm deleted file mode 100644 index fce9ec539ca..00000000000 --- a/gcc/config/alpha/vms-tramp.asm +++ /dev/null @@ -1,22 +0,0 @@ -;# New Alpha OpenVMS trampoline -;# - .set noreorder - .set volatile - .set noat - .file 1 "tramp.s" -.text - .align 3 - .globl __tramp - .ent __tramp -__tramp..en: - -.link - .align 3 -__tramp: - .pdesc __tramp..en,null -.text - ldq $1,24($27) - ldq $27,16($27) - ldq $28,8($27) - jmp $31,($28),0 - .end __tramp diff --git a/gcc/config/float-i128.h b/gcc/config/float-i128.h deleted file mode 100644 index 6a9dd48b1a3..00000000000 --- a/gcc/config/float-i128.h +++ /dev/null @@ -1,96 +0,0 @@ -/* float.h for target with IEEE 32, 64 and 128 bit floating point formats */ -#ifndef _FLOAT_H_ -#define _FLOAT_H_ -/* Produced by enquire version 4.3, CWI, Amsterdam */ - - /* Radix of exponent representation */ -#undef FLT_RADIX -#define FLT_RADIX 2 - /* Number of base-FLT_RADIX digits in the significand of a float */ -#undef FLT_MANT_DIG -#define FLT_MANT_DIG 24 - /* Number of decimal digits of precision in a float */ -#undef FLT_DIG -#define FLT_DIG 6 - /* Addition rounds to 0: zero, 1: nearest, 2: +inf, 3: -inf, -1: unknown */ -#undef FLT_ROUNDS -#define FLT_ROUNDS 1 - /* Difference between 1.0 and the minimum float greater than 1.0 */ -#undef FLT_EPSILON -#define FLT_EPSILON 1.19209290e-07F - /* Minimum int x such that FLT_RADIX**(x-1) is a normalised float */ -#undef FLT_MIN_EXP -#define FLT_MIN_EXP (-125) - /* Minimum normalised float */ -#undef FLT_MIN -#define FLT_MIN 1.17549435e-38F - /* Minimum int x such that 10**x is a normalised float */ -#undef FLT_MIN_10_EXP -#define FLT_MIN_10_EXP (-37) - /* Maximum int x such that FLT_RADIX**(x-1) is a representable float */ -#undef FLT_MAX_EXP -#define FLT_MAX_EXP 128 - /* Maximum float */ -#undef FLT_MAX -#define FLT_MAX 3.40282347e+38F - /* Maximum int x such that 10**x is a representable float */ -#undef FLT_MAX_10_EXP -#define FLT_MAX_10_EXP 38 - - /* Number of base-FLT_RADIX digits in the significand of a double */ -#undef DBL_MANT_DIG -#define DBL_MANT_DIG 53 - /* Number of decimal digits of precision in a double */ -#undef DBL_DIG -#define DBL_DIG 15 - /* Difference between 1.0 and the minimum double greater than 1.0 */ -#undef DBL_EPSILON -#define DBL_EPSILON 2.2204460492503131e-16 - /* Minimum int x such that FLT_RADIX**(x-1) is a normalised double */ -#undef DBL_MIN_EXP -#define DBL_MIN_EXP (-1021) - /* Minimum normalised double */ -#undef DBL_MIN -#define DBL_MIN 2.2250738585072014e-308 - /* Minimum int x such that 10**x is a normalised double */ -#undef DBL_MIN_10_EXP -#define DBL_MIN_10_EXP (-307) - /* Maximum int x such that FLT_RADIX**(x-1) is a representable double */ -#undef DBL_MAX_EXP -#define DBL_MAX_EXP 1024 - /* Maximum double */ -#undef DBL_MAX -#define DBL_MAX 1.7976931348623157e+308 - /* Maximum int x such that 10**x is a representable double */ -#undef DBL_MAX_10_EXP -#define DBL_MAX_10_EXP 308 - - /* Number of base-FLT_RADIX digits in the significand of a long double */ -#undef LDBL_MANT_DIG -#define LDBL_MANT_DIG 113 - /* Number of decimal digits of precision in a long double */ -#undef LDBL_DIG -#define LDBL_DIG 33 - /* Difference between 1.0 and the minimum long double greater than 1.0 */ -#undef LDBL_EPSILON -#define LDBL_EPSILON 1.925929944387235853055977942584927319E-34L - /* Minimum int x such that FLT_RADIX**(x-1) is a normalised long double */ -#undef LDBL_MIN_EXP -#define LDBL_MIN_EXP (-16381) - /* Minimum normalised long double */ -#undef LDBL_MIN -#define LDBL_MIN 3.362103143112093506262677817321752603E-4932L - /* Minimum int x such that 10**x is a normalised long double */ -#undef LDBL_MIN_10_EXP -#define LDBL_MIN_10_EXP (-4931) - /* Maximum int x such that FLT_RADIX**(x-1) is a representable long double */ -#undef LDBL_MAX_EXP -#define LDBL_MAX_EXP 16384 - /* Maximum long double */ -#undef LDBL_MAX -#define LDBL_MAX 1.189731495357231765085759326628007016E+4932L - /* Maximum int x such that 10**x is a representable long double */ -#undef LDBL_MAX_10_EXP -#define LDBL_MAX_10_EXP 4932 - -#endif /* _FLOAT_H_ */ diff --git a/gcc/f/BUGS b/gcc/f/BUGS new file mode 100644 index 00000000000..ebeaedb7b46 --- /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 00000000000..38546900343 --- /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 00000000000..97423be1498 --- /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 00000000000..7e59b6100c3 --- /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 00000000000..79eba82a3a9 --- /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 00000000000..40fea330e5d --- /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 00000000000..fdebfdca176 --- /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 00000000000..fe95676ea53 --- /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 00000000000..3db782f9259 --- /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 00000000000..507bfed55b0 --- /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 00000000000..cdbf32c007c --- /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 00000000000..864d601665b --- /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 00000000000..cb7357fa1bb --- /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 00000000000..adaec06673c --- /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 00000000000..3a95727adc1 --- /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 00000000000..a9dbe9f2e03 --- /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 00000000000..692e1b3a12f --- /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 00000000000..e8f6d22e339 --- /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 00000000000..eb2fed5f530 --- /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 00000000000..65a6ea9c282 --- /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 00000000000..477e0860f40 --- /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 00000000000..74626241d8c --- /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 00000000000..b70c3c07b34 --- /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 00000000000..c2e1e4f85d9 --- /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 00000000000..15bf3b00cbb --- /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 00000000000..a17aa2f8b27 --- /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 00000000000..7dd2344cecb --- /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 00000000000..225cafded1b --- /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 00000000000..057293b0eef --- /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 00000000000..db7d9fa78e7 --- /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 00000000000..6e324b64602 --- /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 00000000000..67966b9448e --- /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 00000000000..fe8b897266f --- /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 00000000000..0d6f07fae30 --- /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 00000000000..134deb56ceb --- /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 00000000000..e99ba671741 --- /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 00000000000..f03069048da --- /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 00000000000..9a30bdbfba1 --- /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 00000000000..033448deaa4 --- /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 00000000000..fe0be038d21 --- /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 00000000000..b777b68b92d --- /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 00000000000..292f88f7410 --- /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 00000000000..2c03ab2cde1 --- /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 00000000000..0084f7afc99 --- /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 00000000000..46e32b27e50 --- /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 00000000000..14e8a583a68 --- /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 00000000000..7c1ca9b0155 --- /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 00000000000..33f1aa9e61e --- /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 00000000000..c7ec5b690ff --- /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 00000000000..f6f403ddfdd --- /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 00000000000..cfb59bf0219 --- /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 00000000000..ff9a6f9bb4f --- /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 00000000000..58b4007f7d5 --- /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 00000000000..1d961d83d92 --- /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 00000000000..16f36fbdb3c --- /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 00000000000..66ca3c0a215 --- /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 00000000000..c19b0fd85dd --- /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 00000000000..772553105cc --- /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 00000000000..d79e35b85ce --- /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 00000000000..a0e5c80596d --- /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 00000000000..1e07aaf42f5 --- /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 00000000000..acb439157af --- /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 00000000000..bae1147dcc5 --- /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 00000000000..3b394ead563 --- /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 00000000000..3d3cd50c404 --- /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 00000000000..0d85863611f --- /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 00000000000..e73d9504aa1 --- /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 00000000000..efb599645aa --- /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 00000000000..8fb85f456da --- /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 00000000000..7a48fbb58f5 --- /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 00000000000..0e1ef2e8bcd --- /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 00000000000..205130a49d1 --- /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 00000000000..646e1f6a404 --- /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 00000000000..f5f79c899f7 --- /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 00000000000..1a20476bd26 --- /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 00000000000..9419af77189 --- /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 00000000000..a44d1ed7f23 --- /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 00000000000..0edfba3a854 --- /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 00000000000..dcc60b6e656 --- /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 00000000000..d2bcebae865 --- /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 00000000000..a11108f83db --- /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 00000000000..90374678100 --- /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 00000000000..199440975d4 --- /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 00000000000..8754fe2ef70 --- /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 00000000000..208626cb4a0 --- /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 00000000000..261b719bc57 --- /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 00000000000..76682152551 --- /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 00000000000..5d14f2a3f1d --- /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 00000000000..8efdc42f970 --- /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 00000000000..041fbd3d8bb --- /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 00000000000..9e833c168b3 --- /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 00000000000..9568354bd53 --- /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 00000000000..8d3d33d0fe3 --- /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 00000000000..6715131ad1d --- /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 00000000000..7bf3e392bed --- /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 00000000000..775977a87f7 --- /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 00000000000..2fad044e884 --- /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 00000000000..cb157e067b7 --- /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 00000000000..33da5369db2 --- /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 00000000000..79b33ca1bd6 --- /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 00000000000..caea4a406e0 --- /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 00000000000..6748a55d56f --- /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 00000000000..1afa3bc4061 --- /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 00000000000..fa4d6ca406f --- /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 00000000000..edc0ebc1092 --- /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 00000000000..1d0ecb7bbb6 --- /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 00000000000..be12fd70551 --- /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 00000000000..793a3f9c405 --- /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 00000000000..beff1e7d378 --- /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 00000000000..c0892bd512a --- /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 00000000000..592015b2821 --- /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 00000000000..23f19299168 --- /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 00000000000..064beff669c --- /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 00000000000..3d4cef7835c --- /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 00000000000..514ff0bbff8 --- /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 00000000000..fdd699eede5 --- /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 00000000000..77f36904f8e --- /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 00000000000..b5cf83b946f --- /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 00000000000..af94a053223 --- /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 00000000000..92a02d4fd6b --- /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 00000000000..fba6b6b11f3 --- /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 00000000000..ae1ac740302 --- /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 00000000000..2e775c6b84e --- /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 00000000000..a922a1d9ba9 --- /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 00000000000..f471172935f --- /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 00000000000..1ba4350ad05 --- /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 00000000000..f44b1d49d84 --- /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 00000000000..0fb658af43c --- /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 00000000000..4c0582add12 --- /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 00000000000..a2acc17a159 --- /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 00000000000..eaded2e4c9b --- /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 00000000000..ceff660e26c --- /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 00000000000..9d0aa25f1d3 --- /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 00000000000..a211cc7fa0f --- /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 00000000000..00a2151bfa1 --- /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 00000000000..43431c1c503 --- /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 00000000000..0af3735da42 --- /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 00000000000..7b06c157a74 --- /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 00000000000..4c29527065a --- /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 00000000000..c4f345a0859 --- /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 00000000000..a9cce596c71 --- /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 00000000000..162d919c3b4 --- /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 00000000000..be21295aaa1 --- /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 00000000000..6e1b1707b55 --- /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 00000000000..8fcecb68200 --- /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 00000000000..96e7bc51ba8 --- /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 00000000000..4020fee4618 --- /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 00000000000..6937c421357 --- /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 00000000000..c0f6795171f --- /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 00000000000..94009b86e6f --- /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 00000000000..7ce5e08d306 --- /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 00000000000..86b4a1f5a7f --- /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 00000000000..c4b52f5bf7d --- /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 00000000000..f2740a23814 --- /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 00000000000..c48dc946f9a --- /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 00000000000..75e9f9c603f --- /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 00000000000..81b0fdbeaba --- /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 00000000000..469a64bdcb3 --- /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 00000000000..230ca7e9f93 --- /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 00000000000..37e2ce0f2eb --- /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 00000000000..d0dd0ff2744 --- /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 00000000000..affed625a91 --- /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 00000000000..24a019734da --- /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 00000000000..84d1c7e0b5e --- /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 00000000000..3bc80e05f7f --- /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 00000000000..6e5816bbf10 --- /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 00000000000..898ea6be917 --- /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 00000000000..20faf29cfb8 --- /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 00000000000..ad4ac963ce2 --- /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 00000000000..87fffb91ff8 --- /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 00000000000..7b222961d16 --- /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 00000000000..330f88a3092 --- /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 00000000000..45ece4b749e --- /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 00000000000..36479c915b0 --- /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 00000000000..9347e1f13a9 --- /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 00000000000..b6175eedfd7 --- /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 00000000000..5bda158cee9 --- /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 00000000000..7ae72cc0cef --- /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 00000000000..baca95cd9e4 --- /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 00000000000..d1dea75563f --- /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 00000000000..d51252bbb79 --- /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 00000000000..8378e775726 --- /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 00000000000..51f84201711 --- /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 00000000000..4873fb418e8 --- /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 00000000000..faea344a7b7 --- /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 00000000000..f5382af660a --- /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 00000000000..df6d02af00a --- /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 00000000000..095b9510de9 --- /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 00000000000..3bf4bb138be --- /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 00000000000..d0203d3d19b --- /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 00000000000..fc0009e4774 --- /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 00000000000..818c6a8451b --- /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 00000000000..f462fd24945 --- /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 00000000000..1e052f28642 --- /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 00000000000..d1673510c62 --- /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 00000000000..1317008cb73 --- /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 00000000000..189b5247ced --- /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 00000000000..2e3f1035b30 --- /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 00000000000..b559211e8e4 --- /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 00000000000..8800a18d77b --- /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 00000000000..1ac81391aef --- /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 00000000000..ed024a14ded --- /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 00000000000..7e67ad2957f --- /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 00000000000..a811bbecc65 --- /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 00000000000..4a987ab255a --- /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 00000000000..85fb63e4209 --- /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 00000000000..48afca63d6d --- /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 00000000000..94456c9c30a --- /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 00000000000..f5db5651991 --- /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 00000000000..34bc5fa3997 --- /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 00000000000..261b719bc57 --- /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 00000000000..30dd5b5223d --- /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 00000000000..36d4043c056 --- /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 00000000000..8413d5f6821 --- /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 00000000000..40e15c175f4 --- /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 00000000000..4b5a2ca6588 --- /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 00000000000..dec58657b50 --- /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 00000000000..6050d1e3b30 --- /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 00000000000..1d0188737be --- /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 00000000000..a2acc17a159 --- /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 00000000000..769d360a626 --- /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 00000000000..a82f82153f6 --- /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 00000000000..509746e13b9 --- /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 00000000000..91483fc5290 --- /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 00000000000..40743d79f74 --- /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 00000000000..1bd03be325a --- /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 00000000000..680524f6c1a --- /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 00000000000..08ea2be7831 --- /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 00000000000..963d4c3e5e8 --- /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 00000000000..012317206aa --- /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 00000000000..3f0642c24cd --- /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 00000000000..5da7dfbb972 --- /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 00000000000..edba1fe8569 --- /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 00000000000..b08302b5b2c --- /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 00000000000..cc5cab8b7bb --- /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 00000000000..0d8c2b4d9ca --- /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 00000000000..9ba4b239f32 --- /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 00000000000..02a9e6d4680 --- /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 00000000000..baf2ba54873 --- /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 00000000000..86bb2164f12 --- /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 00000000000..1bb10d9052d --- /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 00000000000..8f2ea314f30 --- /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 00000000000..1cb20ff2863 --- /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 00000000000..ea733cec06c --- /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 00000000000..a24932533c1 --- /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 00000000000..e14efa85833 --- /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 00000000000..5adb1a49f08 --- /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 00000000000..d13f78f650b --- /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 00000000000..0febd52634f --- /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 00000000000..71f6f1d5da5 --- /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 00000000000..eb685a5ec98 --- /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 00000000000..2e6846b23de --- /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 00000000000..0cf1383cbf9 --- /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 00000000000..9033a495f1b --- /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 00000000000..3251491815d --- /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 00000000000..1699ef065f2 --- /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 00000000000..c5ffdce59a3 --- /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 00000000000..500be54fbe6 --- /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 00000000000..9797b80f3f5 --- /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 00000000000..45ada20e236 --- /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 00000000000..63fb0e7844e --- /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 00000000000..d50fa118e93 --- /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 00000000000..af5813772af --- /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 00000000000..8426edc4fb0 --- /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 00000000000..2330b50489b --- /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 00000000000..e04ada1eca2 --- /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 00000000000..36e68133a24 --- /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 00000000000..afe8b24fc44 --- /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 00000000000..49f39830d2c --- /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 00000000000..451915debac --- /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 00000000000..0a3ba013e06 --- /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 00000000000..5a1109e8d4f --- /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 00000000000..da5434ad0b7 --- /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 00000000000..6f5943c1dce --- /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 00000000000..e01b22c698d --- /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 00000000000..02e8a4e4895 --- /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 00000000000..a2c5f20f28b --- /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 00000000000..fa484785957 --- /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 00000000000..421bb4c9362 --- /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 00000000000..5f6f8ec6a0b --- /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 00000000000..2a7b590a358 --- /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 00000000000..c4075767a4c --- /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 00000000000..557b53a4664 --- /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 00000000000..2bf14ccee26 --- /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 00000000000..92c33468f53 --- /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 00000000000..50378d54426 --- /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 00000000000..32afddf1e46 --- /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 00000000000..6892dcb7694 --- /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 00000000000..806eca293f1 --- /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 00000000000..17f0c1a6b3a --- /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 00000000000..151ac6c9b55 --- /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 00000000000..6b7e81b1e04 --- /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 00000000000..26d8582dbcc --- /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 00000000000..e8a4bf6523c --- /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 00000000000..64eb76e2fb9 --- /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 00000000000..a984cf9e3d2 --- /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 00000000000..36e1b8d9a7b --- /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 00000000000..8edc62e4fe0 --- /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 00000000000..b24f3892221 --- /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 00000000000..d15e4528758 --- /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 00000000000..d5cbaac0608 --- /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 00000000000..73894b0b413 --- /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 00000000000..f69aa43f564 --- /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 00000000000..11c5ecae449 --- /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 00000000000..203acfa916f --- /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 00000000000..5e7edf213bc --- /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 00000000000..c517f29419e --- /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 00000000000..054bb45a89a --- /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 00000000000..261b719bc57 --- /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 00000000000..22efbfe801e --- /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 00000000000..095c0481af9 --- /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 00000000000..02279154d28 --- /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 00000000000..5406acdb5a7 --- /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 00000000000..d762f6c9253 --- /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 00000000000..328bfd0f662 --- /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 00000000000..132d0e84d4b --- /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 00000000000..90ecc5f8f47 --- /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 00000000000..a3385d9a596 --- /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 00000000000..ef91d7188dd --- /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