From 1f03b21eefb95dd4ed21da580f482ef19c0bc59c Mon Sep 17 00:00:00 2001 From: Hasso Tepper Date: Wed, 14 May 2008 15:02:48 +0000 Subject: [PATCH] Remove fortran from base. --- Makefile.inc1 | 8 +- Makefile_upgrade.inc | 13 +- contrib/gcc-3.4/gcc/doc/g77.1 | 1735 -- contrib/gcc-3.4/gcc/f/ansify.c | 190 - contrib/gcc-3.4/gcc/f/bad.c | 537 - contrib/gcc-3.4/gcc/f/bad.def | 1103 -- contrib/gcc-3.4/gcc/f/bad.h | 106 - contrib/gcc-3.4/gcc/f/bit.c | 200 - contrib/gcc-3.4/gcc/f/bit.h | 84 - contrib/gcc-3.4/gcc/f/bld-op.def | 69 - contrib/gcc-3.4/gcc/f/bld.c | 3135 --- contrib/gcc-3.4/gcc/f/bld.h | 748 - contrib/gcc-3.4/gcc/f/bugs.texi | 260 - contrib/gcc-3.4/gcc/f/bugs0.texi | 9 - contrib/gcc-3.4/gcc/f/com-rt.def | 289 - contrib/gcc-3.4/gcc/f/com.c | 16525 ---------------- contrib/gcc-3.4/gcc/f/com.h | 290 - contrib/gcc-3.4/gcc/f/data.c | 1877 -- contrib/gcc-3.4/gcc/f/data.h | 74 - contrib/gcc-3.4/gcc/f/equiv.c | 1484 -- contrib/gcc-3.4/gcc/f/equiv.h | 100 - contrib/gcc-3.4/gcc/f/expr.c | 18571 ------------------ contrib/gcc-3.4/gcc/f/expr.h | 194 - contrib/gcc-3.4/gcc/f/ffe.texi | 2063 -- contrib/gcc-3.4/gcc/f/fini.c | 772 - contrib/gcc-3.4/gcc/f/g77.texi | 11849 ----------- contrib/gcc-3.4/gcc/f/g77spec.c | 541 - contrib/gcc-3.4/gcc/f/global.c | 1586 -- contrib/gcc-3.4/gcc/f/global.h | 193 - contrib/gcc-3.4/gcc/f/implic.c | 383 - contrib/gcc-3.4/gcc/f/implic.h | 74 - contrib/gcc-3.4/gcc/f/info-b.def | 36 - contrib/gcc-3.4/gcc/f/info-k.def | 41 - contrib/gcc-3.4/gcc/f/info-w.def | 41 - contrib/gcc-3.4/gcc/f/info.c | 303 - contrib/gcc-3.4/gcc/f/info.h | 186 - contrib/gcc-3.4/gcc/f/intdoc.c | 1325 -- contrib/gcc-3.4/gcc/f/intdoc.in | 2705 --- contrib/gcc-3.4/gcc/f/intdoc.texi | 10931 ----------- contrib/gcc-3.4/gcc/f/intrin.c | 2119 -- contrib/gcc-3.4/gcc/f/intrin.def | 3358 ---- contrib/gcc-3.4/gcc/f/intrin.h | 135 - contrib/gcc-3.4/gcc/f/invoke.texi | 2233 --- contrib/gcc-3.4/gcc/f/lab.c | 157 - contrib/gcc-3.4/gcc/f/lab.h | 152 - contrib/gcc-3.4/gcc/f/lang-specs.h | 47 - contrib/gcc-3.4/gcc/f/lang.opt | 402 - contrib/gcc-3.4/gcc/f/lex.c | 4571 ----- contrib/gcc-3.4/gcc/f/lex.h | 200 - contrib/gcc-3.4/gcc/f/malloc.c | 559 - contrib/gcc-3.4/gcc/f/malloc.h | 183 - contrib/gcc-3.4/gcc/f/name.c | 241 - contrib/gcc-3.4/gcc/f/name.h | 109 - contrib/gcc-3.4/gcc/f/news.texi | 3177 --- contrib/gcc-3.4/gcc/f/news0.texi | 9 - contrib/gcc-3.4/gcc/f/parse.c | 49 - contrib/gcc-3.4/gcc/f/proj.h | 52 - contrib/gcc-3.4/gcc/f/root.texi | 14 - contrib/gcc-3.4/gcc/f/src.c | 427 - contrib/gcc-3.4/gcc/f/src.h | 140 - contrib/gcc-3.4/gcc/f/st.c | 554 - contrib/gcc-3.4/gcc/f/st.h | 81 - contrib/gcc-3.4/gcc/f/sta.c | 1722 -- contrib/gcc-3.4/gcc/f/sta.h | 117 - contrib/gcc-3.4/gcc/f/stb.c | 17812 ----------------- contrib/gcc-3.4/gcc/f/stb.h | 177 - contrib/gcc-3.4/gcc/f/stc.c | 10459 ---------- contrib/gcc-3.4/gcc/f/stc.h | 234 - contrib/gcc-3.4/gcc/f/std.c | 3623 ---- contrib/gcc-3.4/gcc/f/std.h | 194 - contrib/gcc-3.4/gcc/f/ste.c | 4475 ----- contrib/gcc-3.4/gcc/f/ste.h | 144 - contrib/gcc-3.4/gcc/f/storag.c | 570 - contrib/gcc-3.4/gcc/f/storag.h | 165 - contrib/gcc-3.4/gcc/f/stp.c | 59 - contrib/gcc-3.4/gcc/f/stp.h | 508 - contrib/gcc-3.4/gcc/f/str-1t.fin | 135 - contrib/gcc-3.4/gcc/f/str-2t.fin | 60 - contrib/gcc-3.4/gcc/f/str-fo.fin | 55 - contrib/gcc-3.4/gcc/f/str-io.fin | 43 - contrib/gcc-3.4/gcc/f/str-nq.fin | 55 - contrib/gcc-3.4/gcc/f/str-op.fin | 57 - contrib/gcc-3.4/gcc/f/str-ot.fin | 50 - contrib/gcc-3.4/gcc/f/str.c | 217 - contrib/gcc-3.4/gcc/f/str.h | 80 - contrib/gcc-3.4/gcc/f/sts.c | 179 - contrib/gcc-3.4/gcc/f/sts.h | 85 - contrib/gcc-3.4/gcc/f/stt.c | 892 - contrib/gcc-3.4/gcc/f/stt.h | 212 - contrib/gcc-3.4/gcc/f/stu.c | 1162 -- contrib/gcc-3.4/gcc/f/stu.h | 69 - contrib/gcc-3.4/gcc/f/stv.c | 66 - contrib/gcc-3.4/gcc/f/stv.h | 165 - contrib/gcc-3.4/gcc/f/stw.c | 428 - contrib/gcc-3.4/gcc/f/stw.h | 185 - contrib/gcc-3.4/gcc/f/symbol.c | 1253 -- contrib/gcc-3.4/gcc/f/symbol.def | 654 - contrib/gcc-3.4/gcc/f/symbol.h | 287 - contrib/gcc-3.4/gcc/f/target.c | 2583 --- contrib/gcc-3.4/gcc/f/target.h | 1433 -- contrib/gcc-3.4/gcc/f/top.c | 994 - contrib/gcc-3.4/gcc/f/top.h | 262 - contrib/gcc-3.4/gcc/f/type.c | 104 - contrib/gcc-3.4/gcc/f/type.h | 64 - contrib/gcc-3.4/gcc/f/where.c | 520 - contrib/gcc-3.4/gcc/f/where.h | 136 - contrib/gcc-3.4/libf2c/ChangeLog | 2467 --- contrib/gcc-3.4/libf2c/README | 109 - contrib/gcc-3.4/libf2c/TODO | 14 - contrib/gcc-3.4/libf2c/changes.netlib | 3026 --- contrib/gcc-3.4/libf2c/disclaimer.netlib | 15 - contrib/gcc-3.4/libf2c/f2c.h | 64 - contrib/gcc-3.4/libf2c/f2cext.c | 582 - contrib/gcc-3.4/libf2c/g2c.hin | 234 - contrib/gcc-3.4/libf2c/libF77/F77_aloc.c | 24 - contrib/gcc-3.4/libf2c/libF77/Notice | 23 - contrib/gcc-3.4/libf2c/libF77/README.netlib | 112 - contrib/gcc-3.4/libf2c/libF77/Version.c | 94 - contrib/gcc-3.4/libf2c/libF77/abort_.c | 11 - contrib/gcc-3.4/libf2c/libF77/c_abs.c | 9 - contrib/gcc-3.4/libf2c/libF77/c_cos.c | 12 - contrib/gcc-3.4/libf2c/libF77/c_div.c | 43 - contrib/gcc-3.4/libf2c/libF77/c_exp.c | 14 - contrib/gcc-3.4/libf2c/libF77/c_log.c | 13 - contrib/gcc-3.4/libf2c/libF77/c_sin.c | 12 - contrib/gcc-3.4/libf2c/libF77/c_sqrt.c | 30 - contrib/gcc-3.4/libf2c/libF77/cabs.c | 24 - contrib/gcc-3.4/libf2c/libF77/d_abs.c | 9 - contrib/gcc-3.4/libf2c/libF77/d_acos.c | 9 - contrib/gcc-3.4/libf2c/libF77/d_asin.c | 9 - contrib/gcc-3.4/libf2c/libF77/d_atan.c | 9 - contrib/gcc-3.4/libf2c/libF77/d_atn2.c | 9 - contrib/gcc-3.4/libf2c/libF77/d_cnjg.c | 9 - contrib/gcc-3.4/libf2c/libF77/d_cos.c | 9 - contrib/gcc-3.4/libf2c/libF77/d_cosh.c | 9 - contrib/gcc-3.4/libf2c/libF77/d_dim.c | 7 - contrib/gcc-3.4/libf2c/libF77/d_exp.c | 9 - contrib/gcc-3.4/libf2c/libF77/d_imag.c | 7 - contrib/gcc-3.4/libf2c/libF77/d_int.c | 9 - contrib/gcc-3.4/libf2c/libF77/d_lg10.c | 11 - contrib/gcc-3.4/libf2c/libF77/d_log.c | 9 - contrib/gcc-3.4/libf2c/libF77/d_mod.c | 33 - contrib/gcc-3.4/libf2c/libF77/d_nint.c | 9 - contrib/gcc-3.4/libf2c/libF77/d_prod.c | 7 - contrib/gcc-3.4/libf2c/libF77/d_sign.c | 9 - contrib/gcc-3.4/libf2c/libF77/d_sin.c | 9 - contrib/gcc-3.4/libf2c/libF77/d_sinh.c | 9 - contrib/gcc-3.4/libf2c/libF77/d_sqrt.c | 9 - contrib/gcc-3.4/libf2c/libF77/d_tan.c | 9 - contrib/gcc-3.4/libf2c/libF77/d_tanh.c | 9 - contrib/gcc-3.4/libf2c/libF77/derf_.c | 8 - contrib/gcc-3.4/libf2c/libF77/derfc_.c | 9 - contrib/gcc-3.4/libf2c/libF77/ef1asc_.c | 15 - contrib/gcc-3.4/libf2c/libF77/ef1cmc_.c | 10 - contrib/gcc-3.4/libf2c/libF77/erf_.c | 8 - contrib/gcc-3.4/libf2c/libF77/erfc_.c | 8 - contrib/gcc-3.4/libf2c/libF77/exit_.c | 25 - contrib/gcc-3.4/libf2c/libF77/getarg_.c | 25 - contrib/gcc-3.4/libf2c/libF77/getenv_.c | 49 - contrib/gcc-3.4/libf2c/libF77/h_abs.c | 9 - contrib/gcc-3.4/libf2c/libF77/h_dim.c | 7 - contrib/gcc-3.4/libf2c/libF77/h_dnnt.c | 9 - contrib/gcc-3.4/libf2c/libF77/h_indx.c | 23 - contrib/gcc-3.4/libf2c/libF77/h_len.c | 7 - contrib/gcc-3.4/libf2c/libF77/h_mod.c | 7 - contrib/gcc-3.4/libf2c/libF77/h_nint.c | 9 - contrib/gcc-3.4/libf2c/libF77/h_sign.c | 9 - contrib/gcc-3.4/libf2c/libF77/hl_ge.c | 8 - contrib/gcc-3.4/libf2c/libF77/hl_gt.c | 8 - contrib/gcc-3.4/libf2c/libF77/hl_le.c | 8 - contrib/gcc-3.4/libf2c/libF77/hl_lt.c | 8 - contrib/gcc-3.4/libf2c/libF77/i_abs.c | 9 - contrib/gcc-3.4/libf2c/libF77/i_dim.c | 7 - contrib/gcc-3.4/libf2c/libF77/i_dnnt.c | 9 - contrib/gcc-3.4/libf2c/libF77/i_indx.c | 23 - contrib/gcc-3.4/libf2c/libF77/i_len.c | 7 - contrib/gcc-3.4/libf2c/libF77/i_mod.c | 7 - contrib/gcc-3.4/libf2c/libF77/i_nint.c | 9 - contrib/gcc-3.4/libf2c/libF77/i_sign.c | 9 - contrib/gcc-3.4/libf2c/libF77/iargc_.c | 8 - contrib/gcc-3.4/libf2c/libF77/l_ge.c | 8 - contrib/gcc-3.4/libf2c/libF77/l_gt.c | 8 - contrib/gcc-3.4/libf2c/libF77/l_le.c | 8 - contrib/gcc-3.4/libf2c/libF77/l_lt.c | 8 - contrib/gcc-3.4/libf2c/libF77/lbitbits.c | 58 - contrib/gcc-3.4/libf2c/libF77/lbitshft.c | 7 - contrib/gcc-3.4/libf2c/libF77/main.c | 35 - contrib/gcc-3.4/libf2c/libF77/pow_ci.c | 16 - contrib/gcc-3.4/libf2c/libF77/pow_dd.c | 9 - contrib/gcc-3.4/libf2c/libF77/pow_di.c | 32 - contrib/gcc-3.4/libf2c/libF77/pow_hh.c | 31 - contrib/gcc-3.4/libf2c/libF77/pow_ii.c | 31 - contrib/gcc-3.4/libf2c/libF77/pow_qq.c | 31 - contrib/gcc-3.4/libf2c/libF77/pow_ri.c | 32 - contrib/gcc-3.4/libf2c/libF77/pow_zi.c | 50 - contrib/gcc-3.4/libf2c/libF77/pow_zz.c | 25 - contrib/gcc-3.4/libf2c/libF77/qbitbits.c | 62 - contrib/gcc-3.4/libf2c/libF77/qbitshft.c | 7 - contrib/gcc-3.4/libf2c/libF77/r_abs.c | 9 - contrib/gcc-3.4/libf2c/libF77/r_acos.c | 9 - contrib/gcc-3.4/libf2c/libF77/r_asin.c | 9 - contrib/gcc-3.4/libf2c/libF77/r_atan.c | 9 - contrib/gcc-3.4/libf2c/libF77/r_atn2.c | 9 - contrib/gcc-3.4/libf2c/libF77/r_cnjg.c | 9 - contrib/gcc-3.4/libf2c/libF77/r_cos.c | 9 - contrib/gcc-3.4/libf2c/libF77/r_cosh.c | 9 - contrib/gcc-3.4/libf2c/libF77/r_dim.c | 7 - contrib/gcc-3.4/libf2c/libF77/r_exp.c | 9 - contrib/gcc-3.4/libf2c/libF77/r_imag.c | 7 - contrib/gcc-3.4/libf2c/libF77/r_int.c | 9 - contrib/gcc-3.4/libf2c/libF77/r_lg10.c | 11 - contrib/gcc-3.4/libf2c/libF77/r_log.c | 9 - contrib/gcc-3.4/libf2c/libF77/r_mod.c | 33 - contrib/gcc-3.4/libf2c/libF77/r_nint.c | 9 - contrib/gcc-3.4/libf2c/libF77/r_sign.c | 9 - contrib/gcc-3.4/libf2c/libF77/r_sin.c | 9 - contrib/gcc-3.4/libf2c/libF77/r_sinh.c | 9 - contrib/gcc-3.4/libf2c/libF77/r_sqrt.c | 9 - contrib/gcc-3.4/libf2c/libF77/r_tan.c | 9 - contrib/gcc-3.4/libf2c/libF77/r_tanh.c | 9 - contrib/gcc-3.4/libf2c/libF77/s_cat.c | 70 - contrib/gcc-3.4/libf2c/libF77/s_cmp.c | 49 - contrib/gcc-3.4/libf2c/libF77/s_copy.c | 50 - contrib/gcc-3.4/libf2c/libF77/s_paus.c | 71 - contrib/gcc-3.4/libf2c/libF77/s_rnge.c | 22 - contrib/gcc-3.4/libf2c/libF77/s_stop.c | 32 - contrib/gcc-3.4/libf2c/libF77/setarg.c | 14 - contrib/gcc-3.4/libf2c/libF77/setsig.c | 86 - contrib/gcc-3.4/libf2c/libF77/sig_die.c | 37 - contrib/gcc-3.4/libf2c/libF77/signal1.h | 5 - contrib/gcc-3.4/libf2c/libF77/signal1.h0 | 26 - contrib/gcc-3.4/libf2c/libF77/signal_.c | 11 - contrib/gcc-3.4/libf2c/libF77/system_.c | 28 - contrib/gcc-3.4/libf2c/libF77/z_abs.c | 8 - contrib/gcc-3.4/libf2c/libF77/z_cos.c | 11 - contrib/gcc-3.4/libf2c/libF77/z_div.c | 41 - contrib/gcc-3.4/libf2c/libF77/z_exp.c | 13 - contrib/gcc-3.4/libf2c/libF77/z_log.c | 59 - contrib/gcc-3.4/libf2c/libF77/z_sin.c | 11 - contrib/gcc-3.4/libf2c/libF77/z_sqrt.c | 25 - contrib/gcc-3.4/libf2c/libI77/Notice | 23 - contrib/gcc-3.4/libf2c/libI77/README.netlib | 225 - contrib/gcc-3.4/libf2c/libI77/Version.c | 324 - contrib/gcc-3.4/libf2c/libI77/backspace.c | 81 - contrib/gcc-3.4/libf2c/libI77/close.c | 101 - contrib/gcc-3.4/libf2c/libI77/dfe.c | 156 - contrib/gcc-3.4/libf2c/libI77/dolio.c | 10 - contrib/gcc-3.4/libf2c/libI77/due.c | 80 - contrib/gcc-3.4/libf2c/libI77/endfile.c | 130 - contrib/gcc-3.4/libf2c/libI77/err.c | 285 - contrib/gcc-3.4/libf2c/libI77/fio.h | 104 - contrib/gcc-3.4/libf2c/libI77/fmt.c | 602 - contrib/gcc-3.4/libf2c/libI77/fmt.h | 92 - contrib/gcc-3.4/libf2c/libI77/fmtlib.c | 46 - contrib/gcc-3.4/libf2c/libI77/fp.h | 28 - contrib/gcc-3.4/libf2c/libI77/ftell_.c | 35 - contrib/gcc-3.4/libf2c/libI77/iio.c | 157 - contrib/gcc-3.4/libf2c/libI77/ilnw.c | 70 - contrib/gcc-3.4/libf2c/libI77/inquire.c | 143 - contrib/gcc-3.4/libf2c/libI77/lio.h | 64 - contrib/gcc-3.4/libf2c/libI77/lread.c | 845 - contrib/gcc-3.4/libf2c/libI77/lwrite.c | 277 - contrib/gcc-3.4/libf2c/libI77/open.c | 301 - contrib/gcc-3.4/libf2c/libI77/rdfmt.c | 615 - contrib/gcc-3.4/libf2c/libI77/rewind.c | 25 - contrib/gcc-3.4/libf2c/libI77/rsfe.c | 97 - contrib/gcc-3.4/libf2c/libI77/rsli.c | 99 - contrib/gcc-3.4/libf2c/libI77/rsne.c | 604 - contrib/gcc-3.4/libf2c/libI77/sfe.c | 44 - contrib/gcc-3.4/libf2c/libI77/sue.c | 93 - contrib/gcc-3.4/libf2c/libI77/typesize.c | 14 - contrib/gcc-3.4/libf2c/libI77/uio.c | 60 - contrib/gcc-3.4/libf2c/libI77/util.c | 52 - contrib/gcc-3.4/libf2c/libI77/wref.c | 306 - contrib/gcc-3.4/libf2c/libI77/wrtfmt.c | 407 - contrib/gcc-3.4/libf2c/libI77/wsfe.c | 79 - contrib/gcc-3.4/libf2c/libI77/wsle.c | 38 - contrib/gcc-3.4/libf2c/libI77/wsne.c | 22 - contrib/gcc-3.4/libf2c/libI77/xwsne.c | 71 - contrib/gcc-3.4/libf2c/libU77/COPYING.LIB | 504 - contrib/gcc-3.4/libf2c/libU77/PROJECTS | 10 - contrib/gcc-3.4/libf2c/libU77/README | 40 - contrib/gcc-3.4/libf2c/libU77/Version.c | 1 - contrib/gcc-3.4/libf2c/libU77/access_.c | 84 - contrib/gcc-3.4/libf2c/libU77/alarm_.c | 57 - contrib/gcc-3.4/libf2c/libU77/chdir_.c | 50 - contrib/gcc-3.4/libf2c/libU77/chmod_.c | 82 - contrib/gcc-3.4/libf2c/libU77/ctime_.c | 51 - contrib/gcc-3.4/libf2c/libU77/date_.c | 56 - contrib/gcc-3.4/libf2c/libU77/datetime_.c | 109 - contrib/gcc-3.4/libf2c/libU77/dtime_.c | 174 - contrib/gcc-3.4/libf2c/libU77/etime_.c | 163 - contrib/gcc-3.4/libf2c/libU77/fdate_.c | 55 - contrib/gcc-3.4/libf2c/libU77/fgetc_.c | 63 - contrib/gcc-3.4/libf2c/libU77/flush1_.c | 40 - contrib/gcc-3.4/libf2c/libU77/fnum_.c | 38 - contrib/gcc-3.4/libf2c/libU77/fputc_.c | 56 - contrib/gcc-3.4/libf2c/libU77/fstat_.c | 66 - contrib/gcc-3.4/libf2c/libU77/gerror_.c | 44 - contrib/gcc-3.4/libf2c/libU77/getcwd_.c | 88 - contrib/gcc-3.4/libf2c/libU77/getgid_.c | 38 - contrib/gcc-3.4/libf2c/libU77/getlog_.c | 69 - contrib/gcc-3.4/libf2c/libU77/getpid_.c | 32 - contrib/gcc-3.4/libf2c/libU77/getuid_.c | 38 - contrib/gcc-3.4/libf2c/libU77/gmtime_.c | 52 - contrib/gcc-3.4/libf2c/libU77/hostnm_.c | 51 - contrib/gcc-3.4/libf2c/libU77/idate_.c | 54 - contrib/gcc-3.4/libf2c/libU77/ierrno_.c | 29 - contrib/gcc-3.4/libf2c/libU77/irand_.c | 48 - contrib/gcc-3.4/libf2c/libU77/isatty_.c | 39 - contrib/gcc-3.4/libf2c/libU77/itime_.c | 48 - contrib/gcc-3.4/libf2c/libU77/kill_.c | 38 - contrib/gcc-3.4/libf2c/libU77/link_.c | 63 - contrib/gcc-3.4/libf2c/libU77/lnblnk_.c | 38 - contrib/gcc-3.4/libf2c/libU77/lstat_.c | 78 - contrib/gcc-3.4/libf2c/libU77/ltime_.c | 52 - contrib/gcc-3.4/libf2c/libU77/mclock_.c | 44 - contrib/gcc-3.4/libf2c/libU77/perror_.c | 44 - contrib/gcc-3.4/libf2c/libU77/rand_.c | 51 - contrib/gcc-3.4/libf2c/libU77/rename_.c | 53 - contrib/gcc-3.4/libf2c/libU77/secnds_.c | 51 - contrib/gcc-3.4/libf2c/libU77/second_.c | 28 - contrib/gcc-3.4/libf2c/libU77/sleep_.c | 33 - contrib/gcc-3.4/libf2c/libU77/srand_.c | 33 - contrib/gcc-3.4/libf2c/libU77/stat_.c | 71 - contrib/gcc-3.4/libf2c/libU77/symlnk_.c | 61 - contrib/gcc-3.4/libf2c/libU77/sys_clock_.c | 79 - contrib/gcc-3.4/libf2c/libU77/time_.c | 43 - contrib/gcc-3.4/libf2c/libU77/ttynam_.c | 61 - contrib/gcc-3.4/libf2c/libU77/umask_.c | 30 - contrib/gcc-3.4/libf2c/libU77/unlink_.c | 51 - contrib/gcc-3.4/libf2c/libU77/vxtidate_.c | 65 - contrib/gcc-3.4/libf2c/libU77/vxttime_.c | 51 - contrib/gcc-3.4/libf2c/permission.netlib | 23 - contrib/gcc-3.4/libf2c/readme.netlib | 791 - etc/defaults/make.conf | 3 +- gnu/lib/gcc34/Makefile | 6 +- gnu/lib/gcc34/libfrtbegin/Makefile | 19 - gnu/lib/gcc34/libg2c/Makefile | 92 - gnu/usr.bin/cc34/Makefile | 5 +- gnu/usr.bin/cc34/Makefile.langs | 20 +- gnu/usr.bin/cc34/cc_tools/Makefile | 4 +- gnu/usr.bin/cc34/doc/Makefile | 27 +- gnu/usr.bin/cc34/f771/Makefile | 74 - gnu/usr.bin/cc34/g77/Makefile | 28 - gnu/usr.bin/cc41/Makefile | 5 +- gnu/usr.bin/cc41/Makefile.langs | 13 +- gnu/usr.bin/cc41/cc_tools/Makefile | 6 +- gnu/usr.bin/cc41/cc_tools/fini/Makefile | 10 - share/man/man5/make.conf.5 | 7 +- usr.bin/objformat/Makefile | 4 +- usr.bin/objformat/objformat.c | 4 +- 352 files changed, 26 insertions(+), 172573 deletions(-) delete mode 100644 contrib/gcc-3.4/gcc/doc/g77.1 delete mode 100644 contrib/gcc-3.4/gcc/f/ansify.c delete mode 100644 contrib/gcc-3.4/gcc/f/bad.c delete mode 100644 contrib/gcc-3.4/gcc/f/bad.def delete mode 100644 contrib/gcc-3.4/gcc/f/bad.h delete mode 100644 contrib/gcc-3.4/gcc/f/bit.c delete mode 100644 contrib/gcc-3.4/gcc/f/bit.h delete mode 100644 contrib/gcc-3.4/gcc/f/bld-op.def delete mode 100644 contrib/gcc-3.4/gcc/f/bld.c delete mode 100644 contrib/gcc-3.4/gcc/f/bld.h delete mode 100644 contrib/gcc-3.4/gcc/f/bugs.texi delete mode 100644 contrib/gcc-3.4/gcc/f/bugs0.texi delete mode 100644 contrib/gcc-3.4/gcc/f/com-rt.def delete mode 100644 contrib/gcc-3.4/gcc/f/com.c delete mode 100644 contrib/gcc-3.4/gcc/f/com.h delete mode 100644 contrib/gcc-3.4/gcc/f/data.c delete mode 100644 contrib/gcc-3.4/gcc/f/data.h delete mode 100644 contrib/gcc-3.4/gcc/f/equiv.c delete mode 100644 contrib/gcc-3.4/gcc/f/equiv.h delete mode 100644 contrib/gcc-3.4/gcc/f/expr.c delete mode 100644 contrib/gcc-3.4/gcc/f/expr.h delete mode 100644 contrib/gcc-3.4/gcc/f/ffe.texi delete mode 100644 contrib/gcc-3.4/gcc/f/fini.c delete mode 100644 contrib/gcc-3.4/gcc/f/g77.texi delete mode 100644 contrib/gcc-3.4/gcc/f/g77spec.c delete mode 100644 contrib/gcc-3.4/gcc/f/global.c delete mode 100644 contrib/gcc-3.4/gcc/f/global.h delete mode 100644 contrib/gcc-3.4/gcc/f/implic.c delete mode 100644 contrib/gcc-3.4/gcc/f/implic.h delete mode 100644 contrib/gcc-3.4/gcc/f/info-b.def delete mode 100644 contrib/gcc-3.4/gcc/f/info-k.def delete mode 100644 contrib/gcc-3.4/gcc/f/info-w.def delete mode 100644 contrib/gcc-3.4/gcc/f/info.c delete mode 100644 contrib/gcc-3.4/gcc/f/info.h delete mode 100644 contrib/gcc-3.4/gcc/f/intdoc.c delete mode 100644 contrib/gcc-3.4/gcc/f/intdoc.in delete mode 100644 contrib/gcc-3.4/gcc/f/intdoc.texi delete mode 100644 contrib/gcc-3.4/gcc/f/intrin.c delete mode 100644 contrib/gcc-3.4/gcc/f/intrin.def delete mode 100644 contrib/gcc-3.4/gcc/f/intrin.h delete mode 100644 contrib/gcc-3.4/gcc/f/invoke.texi delete mode 100644 contrib/gcc-3.4/gcc/f/lab.c delete mode 100644 contrib/gcc-3.4/gcc/f/lab.h delete mode 100644 contrib/gcc-3.4/gcc/f/lang-specs.h delete mode 100644 contrib/gcc-3.4/gcc/f/lang.opt delete mode 100644 contrib/gcc-3.4/gcc/f/lex.c delete mode 100644 contrib/gcc-3.4/gcc/f/lex.h delete mode 100644 contrib/gcc-3.4/gcc/f/malloc.c delete mode 100644 contrib/gcc-3.4/gcc/f/malloc.h delete mode 100644 contrib/gcc-3.4/gcc/f/name.c delete mode 100644 contrib/gcc-3.4/gcc/f/name.h delete mode 100644 contrib/gcc-3.4/gcc/f/news.texi delete mode 100644 contrib/gcc-3.4/gcc/f/news0.texi delete mode 100644 contrib/gcc-3.4/gcc/f/parse.c delete mode 100644 contrib/gcc-3.4/gcc/f/proj.h delete mode 100644 contrib/gcc-3.4/gcc/f/root.texi delete mode 100644 contrib/gcc-3.4/gcc/f/src.c delete mode 100644 contrib/gcc-3.4/gcc/f/src.h delete mode 100644 contrib/gcc-3.4/gcc/f/st.c delete mode 100644 contrib/gcc-3.4/gcc/f/st.h delete mode 100644 contrib/gcc-3.4/gcc/f/sta.c delete mode 100644 contrib/gcc-3.4/gcc/f/sta.h delete mode 100644 contrib/gcc-3.4/gcc/f/stb.c delete mode 100644 contrib/gcc-3.4/gcc/f/stb.h delete mode 100644 contrib/gcc-3.4/gcc/f/stc.c delete mode 100644 contrib/gcc-3.4/gcc/f/stc.h delete mode 100644 contrib/gcc-3.4/gcc/f/std.c delete mode 100644 contrib/gcc-3.4/gcc/f/std.h delete mode 100644 contrib/gcc-3.4/gcc/f/ste.c delete mode 100644 contrib/gcc-3.4/gcc/f/ste.h delete mode 100644 contrib/gcc-3.4/gcc/f/storag.c delete mode 100644 contrib/gcc-3.4/gcc/f/storag.h delete mode 100644 contrib/gcc-3.4/gcc/f/stp.c delete mode 100644 contrib/gcc-3.4/gcc/f/stp.h delete mode 100644 contrib/gcc-3.4/gcc/f/str-1t.fin delete mode 100644 contrib/gcc-3.4/gcc/f/str-2t.fin delete mode 100644 contrib/gcc-3.4/gcc/f/str-fo.fin delete mode 100644 contrib/gcc-3.4/gcc/f/str-io.fin delete mode 100644 contrib/gcc-3.4/gcc/f/str-nq.fin delete mode 100644 contrib/gcc-3.4/gcc/f/str-op.fin delete mode 100644 contrib/gcc-3.4/gcc/f/str-ot.fin delete mode 100644 contrib/gcc-3.4/gcc/f/str.c delete mode 100644 contrib/gcc-3.4/gcc/f/str.h delete mode 100644 contrib/gcc-3.4/gcc/f/sts.c delete mode 100644 contrib/gcc-3.4/gcc/f/sts.h delete mode 100644 contrib/gcc-3.4/gcc/f/stt.c delete mode 100644 contrib/gcc-3.4/gcc/f/stt.h delete mode 100644 contrib/gcc-3.4/gcc/f/stu.c delete mode 100644 contrib/gcc-3.4/gcc/f/stu.h delete mode 100644 contrib/gcc-3.4/gcc/f/stv.c delete mode 100644 contrib/gcc-3.4/gcc/f/stv.h delete mode 100644 contrib/gcc-3.4/gcc/f/stw.c delete mode 100644 contrib/gcc-3.4/gcc/f/stw.h delete mode 100644 contrib/gcc-3.4/gcc/f/symbol.c delete mode 100644 contrib/gcc-3.4/gcc/f/symbol.def delete mode 100644 contrib/gcc-3.4/gcc/f/symbol.h delete mode 100644 contrib/gcc-3.4/gcc/f/target.c delete mode 100644 contrib/gcc-3.4/gcc/f/target.h delete mode 100644 contrib/gcc-3.4/gcc/f/top.c delete mode 100644 contrib/gcc-3.4/gcc/f/top.h delete mode 100644 contrib/gcc-3.4/gcc/f/type.c delete mode 100644 contrib/gcc-3.4/gcc/f/type.h delete mode 100644 contrib/gcc-3.4/gcc/f/where.c delete mode 100644 contrib/gcc-3.4/gcc/f/where.h delete mode 100644 contrib/gcc-3.4/libf2c/ChangeLog delete mode 100644 contrib/gcc-3.4/libf2c/README delete mode 100644 contrib/gcc-3.4/libf2c/TODO delete mode 100644 contrib/gcc-3.4/libf2c/changes.netlib delete mode 100644 contrib/gcc-3.4/libf2c/disclaimer.netlib delete mode 100644 contrib/gcc-3.4/libf2c/f2c.h delete mode 100644 contrib/gcc-3.4/libf2c/f2cext.c delete mode 100644 contrib/gcc-3.4/libf2c/g2c.hin delete mode 100644 contrib/gcc-3.4/libf2c/libF77/F77_aloc.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/Notice delete mode 100644 contrib/gcc-3.4/libf2c/libF77/README.netlib delete mode 100644 contrib/gcc-3.4/libf2c/libF77/Version.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/abort_.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/c_abs.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/c_cos.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/c_div.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/c_exp.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/c_log.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/c_sin.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/c_sqrt.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/cabs.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/d_abs.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/d_acos.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/d_asin.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/d_atan.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/d_atn2.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/d_cnjg.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/d_cos.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/d_cosh.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/d_dim.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/d_exp.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/d_imag.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/d_int.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/d_lg10.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/d_log.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/d_mod.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/d_nint.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/d_prod.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/d_sign.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/d_sin.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/d_sinh.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/d_sqrt.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/d_tan.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/d_tanh.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/derf_.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/derfc_.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/ef1asc_.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/ef1cmc_.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/erf_.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/erfc_.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/exit_.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/getarg_.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/getenv_.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/h_abs.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/h_dim.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/h_dnnt.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/h_indx.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/h_len.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/h_mod.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/h_nint.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/h_sign.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/hl_ge.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/hl_gt.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/hl_le.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/hl_lt.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/i_abs.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/i_dim.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/i_dnnt.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/i_indx.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/i_len.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/i_mod.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/i_nint.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/i_sign.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/iargc_.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/l_ge.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/l_gt.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/l_le.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/l_lt.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/lbitbits.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/lbitshft.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/main.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/pow_ci.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/pow_dd.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/pow_di.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/pow_hh.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/pow_ii.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/pow_qq.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/pow_ri.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/pow_zi.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/pow_zz.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/qbitbits.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/qbitshft.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/r_abs.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/r_acos.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/r_asin.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/r_atan.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/r_atn2.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/r_cnjg.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/r_cos.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/r_cosh.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/r_dim.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/r_exp.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/r_imag.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/r_int.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/r_lg10.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/r_log.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/r_mod.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/r_nint.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/r_sign.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/r_sin.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/r_sinh.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/r_sqrt.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/r_tan.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/r_tanh.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/s_cat.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/s_cmp.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/s_copy.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/s_paus.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/s_rnge.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/s_stop.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/setarg.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/setsig.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/sig_die.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/signal1.h delete mode 100644 contrib/gcc-3.4/libf2c/libF77/signal1.h0 delete mode 100644 contrib/gcc-3.4/libf2c/libF77/signal_.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/system_.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/z_abs.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/z_cos.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/z_div.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/z_exp.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/z_log.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/z_sin.c delete mode 100644 contrib/gcc-3.4/libf2c/libF77/z_sqrt.c delete mode 100644 contrib/gcc-3.4/libf2c/libI77/Notice delete mode 100644 contrib/gcc-3.4/libf2c/libI77/README.netlib delete mode 100644 contrib/gcc-3.4/libf2c/libI77/Version.c delete mode 100644 contrib/gcc-3.4/libf2c/libI77/backspace.c delete mode 100644 contrib/gcc-3.4/libf2c/libI77/close.c delete mode 100644 contrib/gcc-3.4/libf2c/libI77/dfe.c delete mode 100644 contrib/gcc-3.4/libf2c/libI77/dolio.c delete mode 100644 contrib/gcc-3.4/libf2c/libI77/due.c delete mode 100644 contrib/gcc-3.4/libf2c/libI77/endfile.c delete mode 100644 contrib/gcc-3.4/libf2c/libI77/err.c delete mode 100644 contrib/gcc-3.4/libf2c/libI77/fio.h delete mode 100644 contrib/gcc-3.4/libf2c/libI77/fmt.c delete mode 100644 contrib/gcc-3.4/libf2c/libI77/fmt.h delete mode 100644 contrib/gcc-3.4/libf2c/libI77/fmtlib.c delete mode 100644 contrib/gcc-3.4/libf2c/libI77/fp.h delete mode 100644 contrib/gcc-3.4/libf2c/libI77/ftell_.c delete mode 100644 contrib/gcc-3.4/libf2c/libI77/iio.c delete mode 100644 contrib/gcc-3.4/libf2c/libI77/ilnw.c delete mode 100644 contrib/gcc-3.4/libf2c/libI77/inquire.c delete mode 100644 contrib/gcc-3.4/libf2c/libI77/lio.h delete mode 100644 contrib/gcc-3.4/libf2c/libI77/lread.c delete mode 100644 contrib/gcc-3.4/libf2c/libI77/lwrite.c delete mode 100644 contrib/gcc-3.4/libf2c/libI77/open.c delete mode 100644 contrib/gcc-3.4/libf2c/libI77/rdfmt.c delete mode 100644 contrib/gcc-3.4/libf2c/libI77/rewind.c delete mode 100644 contrib/gcc-3.4/libf2c/libI77/rsfe.c delete mode 100644 contrib/gcc-3.4/libf2c/libI77/rsli.c delete mode 100644 contrib/gcc-3.4/libf2c/libI77/rsne.c delete mode 100644 contrib/gcc-3.4/libf2c/libI77/sfe.c delete mode 100644 contrib/gcc-3.4/libf2c/libI77/sue.c delete mode 100644 contrib/gcc-3.4/libf2c/libI77/typesize.c delete mode 100644 contrib/gcc-3.4/libf2c/libI77/uio.c delete mode 100644 contrib/gcc-3.4/libf2c/libI77/util.c delete mode 100644 contrib/gcc-3.4/libf2c/libI77/wref.c delete mode 100644 contrib/gcc-3.4/libf2c/libI77/wrtfmt.c delete mode 100644 contrib/gcc-3.4/libf2c/libI77/wsfe.c delete mode 100644 contrib/gcc-3.4/libf2c/libI77/wsle.c delete mode 100644 contrib/gcc-3.4/libf2c/libI77/wsne.c delete mode 100644 contrib/gcc-3.4/libf2c/libI77/xwsne.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/COPYING.LIB delete mode 100644 contrib/gcc-3.4/libf2c/libU77/PROJECTS delete mode 100644 contrib/gcc-3.4/libf2c/libU77/README delete mode 100644 contrib/gcc-3.4/libf2c/libU77/Version.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/access_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/alarm_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/chdir_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/chmod_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/ctime_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/date_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/datetime_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/dtime_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/etime_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/fdate_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/fgetc_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/flush1_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/fnum_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/fputc_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/fstat_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/gerror_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/getcwd_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/getgid_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/getlog_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/getpid_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/getuid_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/gmtime_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/hostnm_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/idate_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/ierrno_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/irand_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/isatty_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/itime_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/kill_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/link_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/lnblnk_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/lstat_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/ltime_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/mclock_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/perror_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/rand_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/rename_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/secnds_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/second_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/sleep_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/srand_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/stat_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/symlnk_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/sys_clock_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/time_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/ttynam_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/umask_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/unlink_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/vxtidate_.c delete mode 100644 contrib/gcc-3.4/libf2c/libU77/vxttime_.c delete mode 100644 contrib/gcc-3.4/libf2c/permission.netlib delete mode 100644 contrib/gcc-3.4/libf2c/readme.netlib delete mode 100644 gnu/lib/gcc34/libfrtbegin/Makefile delete mode 100644 gnu/lib/gcc34/libg2c/Makefile delete mode 100644 gnu/usr.bin/cc34/f771/Makefile delete mode 100644 gnu/usr.bin/cc34/g77/Makefile delete mode 100644 gnu/usr.bin/cc41/cc_tools/fini/Makefile diff --git a/Makefile.inc1 b/Makefile.inc1 index 9c82dd3583..4aa6bccff4 100644 --- a/Makefile.inc1 +++ b/Makefile.inc1 @@ -1,6 +1,6 @@ # # $FreeBSD: src/Makefile.inc1,v 1.141.2.62 2003/04/06 19:54:00 dwmalone Exp $ -# $DragonFly: src/Makefile.inc1,v 1.115 2008/05/01 19:44:37 tgen Exp $ +# $DragonFly: src/Makefile.inc1,v 1.116 2008/05/14 15:02:44 hasso Exp $ # # Build-time options are documented in make.conf(5). # @@ -833,10 +833,6 @@ _gcc41_cross= gnu/usr.bin/cc41 _gcc41_tools= gnu/usr.bin/cc41/cc_prep gnu/usr.bin/cc41/cc_tools _binutils= gnu/usr.bin/binutils217 -.if !defined(NO_FORTRAN) -_fortran= gnu/usr.bin/cc34/f771 -.endif - .if exists(${.CURDIR}/kerberos5) && exists(${.CURDIR}/crypto) && \ !defined(NO_CRYPT) && defined(WANT_KERBEROS) _libkrb5= kerberos5/tools kerberos5/lib/libroken kerberos5/lib/libvers \ @@ -844,7 +840,7 @@ _libkrb5= kerberos5/tools kerberos5/lib/libroken kerberos5/lib/libvers \ .endif build-tools: -.for _tool in ${_gcc34_tools} ${_gcc41_tools} ${_fortran} ${_libkrb5} ${_share} +.for _tool in ${_gcc34_tools} ${_gcc41_tools} ${_libkrb5} ${_share} ${ECHODIR} "===> ${_tool} (build-tools)"; \ cd ${.CURDIR}/${_tool}; \ ${MAKE} DIRPRFX=${_tool}/ obj; \ diff --git a/Makefile_upgrade.inc b/Makefile_upgrade.inc index d18d43e24b..e1aa9e07ae 100644 --- a/Makefile_upgrade.inc +++ b/Makefile_upgrade.inc @@ -1,4 +1,4 @@ -# $DragonFly: src/Makefile_upgrade.inc,v 1.24 2008/05/04 04:17:11 swildner Exp $ +# $DragonFly: src/Makefile_upgrade.inc,v 1.25 2008/05/14 15:02:44 hasso Exp $ # # Append all obsolete files to this file # Avoid constructs like {foo,bar}. It is parsed by /bin/sh @@ -617,3 +617,14 @@ TO_REMOVE+=/usr/share/man/cat5/pam.d.5.gz TO_REMOVE+=/usr/share/man/man5/pam.d.5.gz TO_REMOVE+=/usr/share/man/cat8/pam.8.gz TO_REMOVE+=/usr/share/man/man8/pam.8.gz +TO_REMOVE+=/usr/bin/f77 +TO_REMOVE+=/usr/bin/g77 +TO_REMOVE+=/usr/libexec/gcc34/f77 +TO_REMOVE+=/usr/libexec/gcc34/f771 +TO_REMOVE+=/usr/libexec/gcc34/g77 +TO_REMOVE+=/usr/lib/gcc34/libfrtbegin.a +TO_REMOVE+=/usr/lib/gcc34/libfrtbegin.so +TO_REMOVE+=/usr/lib/gcc34/libfrtbegin.so.1 +TO_REMOVE+=/usr/lib/gcc34/libg2c.a +TO_REMOVE+=/usr/lib/gcc34/libg2c.so +TO_REMOVE+=/usr/lib/gcc34/libg2c.so.3 diff --git a/contrib/gcc-3.4/gcc/doc/g77.1 b/contrib/gcc-3.4/gcc/doc/g77.1 deleted file mode 100644 index 955628d3ab..0000000000 --- a/contrib/gcc-3.4/gcc/doc/g77.1 +++ /dev/null @@ -1,1735 +0,0 @@ -.\" Automatically generated by Pod::Man v1.37, Pod::Parser v1.14 -.\" -.\" Standard preamble: -.\" ======================================================================== -.de Sh \" Subsection heading -.br -.if t .Sp -.ne 5 -.PP -\fB\\$1\fR -.PP -.. -.de Sp \" Vertical space (when we can't use .PP) -.if t .sp .5v -.if n .sp -.. -.de Vb \" Begin verbatim text -.ft CW -.nf -.ne \\$1 -.. -.de Ve \" End verbatim text -.ft R -.fi -.. -.\" Set up some character translations and predefined strings. \*(-- will -.\" give an unbreakable dash, \*(PI will give pi, \*(L" will give a left -.\" double quote, and \*(R" will give a right double quote. | will give a -.\" real vertical bar. \*(C+ will give a nicer C++. Capital omega is used to -.\" do unbreakable dashes and therefore won't be available. \*(C` and \*(C' -.\" expand to `' in nroff, nothing in troff, for use with C<>. -.tr \(*W-|\(bv\*(Tr -.ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p' -.ie n \{\ -. ds -- \(*W- -. ds PI pi -. if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch -. if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch -. ds L" "" -. ds R" "" -. ds C` "" -. ds C' "" -'br\} -.el\{\ -. ds -- \|\(em\| -. ds PI \(*p -. ds L" `` -. ds R" '' -'br\} -.\" -.\" If the F register is turned on, we'll generate index entries on stderr for -.\" titles (.TH), headers (.SH), subsections (.Sh), items (.Ip), and index -.\" entries marked with X<> in POD. Of course, you'll have to process the -.\" output yourself in some meaningful fashion. -.if \nF \{\ -. de IX -. tm Index:\\$1\t\\n%\t"\\$2" -.. -. nr % 0 -. rr F -.\} -.\" -.\" For nroff, turn off justification. Always turn off hyphenation; it makes -.\" way too many mistakes in technical documents. -.hy 0 -.if n .na -.\" -.\" Accent mark definitions (@(#)ms.acc 1.5 88/02/08 SMI; from UCB 4.2). -.\" Fear. Run. Save yourself. No user-serviceable parts. -. \" fudge factors for nroff and troff -.if n \{\ -. ds #H 0 -. ds #V .8m -. ds #F .3m -. ds #[ \f1 -. ds #] \fP -.\} -.if t \{\ -. ds #H ((1u-(\\\\n(.fu%2u))*.13m) -. ds #V .6m -. ds #F 0 -. ds #[ \& -. ds #] \& -.\} -. \" simple accents for nroff and troff -.if n \{\ -. ds ' \& -. ds ` \& -. ds ^ \& -. ds , \& -. ds ~ ~ -. ds / -.\} -.if t \{\ -. ds ' \\k:\h'-(\\n(.wu*8/10-\*(#H)'\'\h"|\\n:u" -. ds ` \\k:\h'-(\\n(.wu*8/10-\*(#H)'\`\h'|\\n:u' -. ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'^\h'|\\n:u' -. ds , \\k:\h'-(\\n(.wu*8/10)',\h'|\\n:u' -. ds ~ \\k:\h'-(\\n(.wu-\*(#H-.1m)'~\h'|\\n:u' -. ds / \\k:\h'-(\\n(.wu*8/10-\*(#H)'\z\(sl\h'|\\n:u' -.\} -. \" troff and (daisy-wheel) nroff accents -.ds : \\k:\h'-(\\n(.wu*8/10-\*(#H+.1m+\*(#F)'\v'-\*(#V'\z.\h'.2m+\*(#F'.\h'|\\n:u'\v'\*(#V' -.ds 8 \h'\*(#H'\(*b\h'-\*(#H' -.ds o \\k:\h'-(\\n(.wu+\w'\(de'u-\*(#H)/2u'\v'-.3n'\*(#[\z\(de\v'.3n'\h'|\\n:u'\*(#] -.ds d- \h'\*(#H'\(pd\h'-\w'~'u'\v'-.25m'\f2\(hy\fP\v'.25m'\h'-\*(#H' -.ds D- D\\k:\h'-\w'D'u'\v'-.11m'\z\(hy\v'.11m'\h'|\\n:u' -.ds th \*(#[\v'.3m'\s+1I\s-1\v'-.3m'\h'-(\w'I'u*2/3)'\s-1o\s+1\*(#] -.ds Th \*(#[\s+2I\s-2\h'-\w'I'u*3/5'\v'-.3m'o\v'.3m'\*(#] -.ds ae a\h'-(\w'a'u*4/10)'e -.ds Ae A\h'-(\w'A'u*4/10)'E -. \" corrections for vroff -.if v .ds ~ \\k:\h'-(\\n(.wu*9/10-\*(#H)'\s-2\u~\d\s+2\h'|\\n:u' -.if v .ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'\v'-.4m'^\v'.4m'\h'|\\n:u' -. \" for low resolution devices (crt and lpr) -.if \n(.H>23 .if \n(.V>19 \ -\{\ -. ds : e -. ds 8 ss -. ds o a -. ds d- d\h'-1'\(ga -. ds D- D\h'-1'\(hy -. ds th \o'bp' -. ds Th \o'LP' -. ds ae ae -. ds Ae AE -.\} -.rm #[ #] #H #V #F C -.\" ======================================================================== -.\" -.IX Title "G77 1" -.TH G77 1 "2006-03-06" "gcc-3.4.6" "GNU" -.SH "NAME" -g77 \- GNU project Fortran 77 compiler -.SH "SYNOPSIS" -.IX Header "SYNOPSIS" -g77 [\fB\-c\fR|\fB\-S\fR|\fB\-E\fR] - [\fB\-g\fR] [\fB\-pg\fR] [\fB\-O\fR\fIlevel\fR] - [\fB\-W\fR\fIwarn\fR...] [\fB\-pedantic\fR] - [\fB\-I\fR\fIdir\fR...] [\fB\-L\fR\fIdir\fR...] - [\fB\-D\fR\fImacro\fR[=\fIdefn\fR]...] [\fB\-U\fR\fImacro\fR] - [\fB\-f\fR\fIoption\fR...] [\fB\-m\fR\fImachine-option\fR...] - [\fB\-o\fR \fIoutfile\fR] \fIinfile\fR... -.PP -Only the most useful options are listed here; see below for the -remainder. -.SH "DESCRIPTION" -.IX Header "DESCRIPTION" -The \fBg77\fR command supports all the options supported by the -\&\fBgcc\fR command. -.PP -All \fBgcc\fR and \fBg77\fR options -are accepted both by \fBg77\fR and by \fBgcc\fR -(as well as any other drivers built at the same time, -such as \fBg++\fR), -since adding \fBg77\fR to the \fBgcc\fR distribution -enables acceptance of \fBg77\fR options -by all of the relevant drivers. -.PP -In some cases, options have positive and negative forms; -the negative form of \fB\-ffoo\fR would be \fB\-fno\-foo\fR. -This manual documents only one of these two forms, whichever -one is not the default. -.SH "OPTIONS" -.IX Header "OPTIONS" -Here is a summary of all the options specific to \s-1GNU\s0 Fortran, grouped -by type. Explanations are in the following sections. -.IP "\fIOverall Options\fR" 4 -.IX Item "Overall Options" -\&\fB\-fversion \-fset\-g77\-defaults \-fno\-silent\fR -.IP "\fIShorthand Options\fR" 4 -.IX Item "Shorthand Options" -\&\fB\-ff66 \-fno\-f66 \-ff77 \-fno\-f77 \-fno\-ugly\fR -.IP "\fIFortran Language Options\fR" 4 -.IX Item "Fortran Language Options" -\&\fB\-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 -\&\-fbadu77\-intrinsics\-delete \-fbadu77\-intrinsics\-hide -\&\-fbadu77\-intrinsics\-disable \-fbadu77\-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\-\fR\fIn\fR \fB\-ffixed\-line\-length\-none\fR -.IP "\fIWarning Options\fR" 4 -.IX Item "Warning Options" -\&\fB\-fsyntax\-only \-pedantic \-pedantic\-errors \-fpedantic -\&\-w \-Wno\-globals \-Wimplicit \-Wunused \-Wuninitialized -\&\-Wall \-Wsurprising -\&\-Werror \-W\fR -.IP "\fIDebugging Options\fR" 4 -.IX Item "Debugging Options" -\&\fB\-g\fR -.IP "\fIOptimization Options\fR" 4 -.IX Item "Optimization Options" -\&\fB\-malign\-double -\&\-ffloat\-store \-fforce\-mem \-fforce\-addr \-fno\-inline -\&\-ffast\-math \-fstrength\-reduce \-frerun\-cse\-after\-loop -\&\-funsafe\-math\-optimizations \-ffinite\-math\-only \-fno\-trapping\-math -\&\-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\fR -.IP "\fIDirectory Options\fR" 4 -.IX Item "Directory Options" -\&\fB\-I\fR\fIdir\fR \fB\-I\-\fR -.IP "\fICode Generation Options\fR" 4 -.IX Item "Code Generation Options" -\&\fB\-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 -\&\-femulate\-complex -\&\-falias\-check \-fargument\-alias -\&\-fargument\-noalias \-fno\-argument\-noalias\-global -\&\-fno\-globals \-fflatten\-arrays -\&\-fbounds\-check \-ffortran\-bounds\-check\fR -.PP -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. -.PP -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 \s-1GNU\s0 Fortran are listed below. -.IP "\fIfile\fR\fB.f\fR" 4 -.IX Item "file.f" -.PD 0 -.IP "\fIfile\fR\fB.for\fR" 4 -.IX Item "file.for" -.IP "\fIfile\fR\fB.FOR\fR" 4 -.IX Item "file.FOR" -.PD -Fortran source code that should not be preprocessed. -.Sp -Such source code cannot contain any preprocessor directives, such -as \f(CW\*(C`#include\*(C'\fR, \f(CW\*(C`#define\*(C'\fR, \f(CW\*(C`#if\*(C'\fR, and so on. -.Sp -You can force \fB.f\fR files to be preprocessed by \fBcpp\fR by using -\&\fB\-x f77\-cpp\-input\fR. -.IP "\fIfile\fR\fB.F\fR" 4 -.IX Item "file.F" -.PD 0 -.IP "\fIfile\fR\fB.fpp\fR" 4 -.IX Item "file.fpp" -.IP "\fIfile\fR\fB.FPP\fR" 4 -.IX Item "file.FPP" -.PD -Fortran source code that must be preprocessed (by the C preprocessor -\&\fBcpp\fR, which is part of \s-1GCC\s0). -.Sp -Note that preprocessing is not extended to the contents of -files included by the \f(CW\*(C`INCLUDE\*(C'\fR directive\-\-\-the \f(CW\*(C`#include\*(C'\fR -preprocessor directive must be used instead. -.IP "\fIfile\fR\fB.r\fR" 4 -.IX Item "file.r" -Ratfor source code, which must be preprocessed by the \fBratfor\fR -command, which is available separately (as it is not yet part of the \s-1GNU\s0 -Fortran distribution). -A public domain version in C is at -<\fBhttp://sepwww.stanford.edu/sep/prof/ratfor.shar.2\fR>. -.PP -\&\s-1UNIX\s0 users typically use the \fI\fIfile\fI.f\fR and \fI\fIfile\fI.F\fR -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 \fI\fIfile\fI.for\fR and \fI\fIfile\fI.fpp\fR nomenclature. -.PP -Use of the preprocessor \fBcpp\fR allows use of C\-like -constructs such as \f(CW\*(C`#define\*(C'\fR and \f(CW\*(C`#include\*(C'\fR, 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 \f(CW\*(C`#include\*(C'\fR and, in -conjunction with \f(CW\*(C`#define\*(C'\fR, only \f(CW\*(C`#if\*(C'\fR 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. -.PP -Another example of a problem that results from using the C preprocessor -is that a Fortran comment line that happens to contain any -characters ``interesting'' to the C preprocessor, -such as a backslash at the end of the line, -is not recognized by the preprocessor as a comment line, -so instead of being passed through ``raw'', -the line is edited according to the rules for the preprocessor. -For example, the backslash at the end of the line is removed, -along with the subsequent newline, resulting in the next -line being effectively commented out\-\-\-unfortunate if that -line is a non-comment line of important code! -.PP -\&\fINote:\fR The \fB\-traditional\fR and \fB\-undef\fR flags are supplied -to \fBcpp\fR by default, to help avoid unpleasant surprises. -.PP -This means that \s-1ANSI\s0 C preprocessor features (such as the \fB#\fR -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, \fB#ifdef _\|_linux_\|_\fR rather than \fB#ifdef linux\fR. -Use the \fB\-v\fR option to see exactly how the preprocessor is invoked. -.PP -Unfortunately, the \fB\-traditional\fR flag will not avoid an error from -anything that \fBcpp\fR sees as an unterminated C comment, such as: -.PP -.Vb 2 -\& C Some Fortran compilers accept /* as starting -\& C an inline comment. -.Ve -.PP -The following options that affect overall processing are recognized -by the \fBg77\fR and \fBgcc\fR commands in a \s-1GNU\s0 Fortran installation: -.IP "\fB\-fversion\fR" 4 -.IX Item "-fversion" -Ensure that the \fBg77\fR version of the compiler phase is reported, -if run, -and, starting in \f(CW\*(C`egcs\*(C'\fR version 1.1, -that internal consistency checks in the \fIf771\fR program are run. -.Sp -This option is supplied automatically when \fB\-v\fR or \fB\-\-verbose\fR -is specified as a command-line option for \fBg77\fR or \fBgcc\fR -and when the resulting commands compile Fortran source files. -.Sp -In \s-1GCC\s0 3.1, this is changed back to the behavior \fBgcc\fR displays -for \fB.c\fR files. -.IP "\fB\-fset\-g77\-defaults\fR" 4 -.IX Item "-fset-g77-defaults" -\&\fIVersion info:\fR -This option was obsolete as of \f(CW\*(C`egcs\*(C'\fR -version 1.1. -The effect is instead achieved -by the \f(CW\*(C`lang_init_options\*(C'\fR routine -in \fIgcc/gcc/f/com.c\fR. -.Sp -Set up whatever \fBgcc\fR options are to apply to Fortran -compilations, and avoid running internal consistency checks -that might take some time. -.Sp -This option is supplied automatically when compiling Fortran code -via the \fBg77\fR or \fBgcc\fR command. -The description of this option is provided so that users seeing -it in the output of, say, \fBg77 \-v\fR understand why it is -there. -.Sp -Also, developers who run \f(CW\*(C`f771\*(C'\fR directly might want to specify it -by hand to get the same defaults as they would running \f(CW\*(C`f771\*(C'\fR -via \fBg77\fR or \fBgcc\fR -However, such developers should, after linking a new \f(CW\*(C`f771\*(C'\fR -executable, invoke it without this option once, -e.g. via \f(CW\*(C`./f771 \-quiet < /dev/null\*(C'\fR, -to ensure that they have not introduced any -internal inconsistencies (such as in the table of -intrinsics) before proceeding\-\-\-\fBg77\fR will crash -with a diagnostic if it detects an inconsistency. -.IP "\fB\-fno\-silent\fR" 4 -.IX Item "-fno-silent" -Print (to \f(CW\*(C`stderr\*(C'\fR) the names of the program units as -they are compiled, in a form similar to that used by popular -\&\s-1UNIX\s0 \fBf77\fR implementations and \fBf2c\fR -.Sh "Shorthand Options" -.IX Subsection "Shorthand Options" -The following options serve as ``shorthand'' -for other options accepted by the compiler: -.IP "\fB\-fugly\fR" 4 -.IX Item "-fugly" -\&\fINote:\fR This option is no longer supported. -The information, below, is provided to aid -in the conversion of old scripts. -.Sp -Specify that certain ``ugly'' constructs are to be quietly accepted. -Same as: -.Sp -.Vb 3 -\& -fugly-args -fugly-assign -fugly-assumed -\& -fugly-comma -fugly-complex -fugly-init -\& -fugly-logint -.Ve -.Sp -These constructs are considered inappropriate to use in new -or well-maintained portable Fortran code, but widely used -in old code. -.IP "\fB\-fno\-ugly\fR" 4 -.IX Item "-fno-ugly" -Specify that all ``ugly'' constructs are to be noisily rejected. -Same as: -.Sp -.Vb 3 -\& -fno-ugly-args -fno-ugly-assign -fno-ugly-assumed -\& -fno-ugly-comma -fno-ugly-complex -fno-ugly-init -\& -fno-ugly-logint -.Ve -.IP "\fB\-ff66\fR" 4 -.IX Item "-ff66" -Specify that the program is written in idiomatic \s-1FORTRAN\s0 66. -Same as \fB\-fonetrip \-fugly\-assumed\fR. -.Sp -The \fB\-fno\-f66\fR option is the inverse of \fB\-ff66\fR. -As such, it is the same as \fB\-fno\-onetrip \-fno\-ugly\-assumed\fR. -.Sp -The meaning of this option is likely to be refined as future -versions of \fBg77\fR provide more compatibility with other -existing and obsolete Fortran implementations. -.IP "\fB\-ff77\fR" 4 -.IX Item "-ff77" -Specify that the program is written in idiomatic \s-1UNIX\s0 \s-1FORTRAN\s0 77 -and/or the dialect accepted by the \fBf2c\fR product. -Same as \fB\-fbackslash \-fno\-typeless\-boz\fR. -.Sp -The meaning of this option is likely to be refined as future -versions of \fBg77\fR provide more compatibility with other -existing and obsolete Fortran implementations. -.IP "\fB\-fno\-f77\fR" 4 -.IX Item "-fno-f77" -The \fB\-fno\-f77\fR option is \fInot\fR the inverse -of \fB\-ff77\fR. -It specifies that the program is not written in idiomatic \s-1UNIX\s0 -\&\s-1FORTRAN\s0 77 or \fBf2c\fR but in a more widely portable dialect. -\&\fB\-fno\-f77\fR is the same as \fB\-fno\-backslash\fR. -.Sp -The meaning of this option is likely to be refined as future -versions of \fBg77\fR provide more compatibility with other -existing and obsolete Fortran implementations. -.Sh "Options Controlling Fortran Dialect" -.IX Subsection "Options Controlling Fortran Dialect" -The following options control the dialect of Fortran -that the compiler accepts: -.IP "\fB\-ffree\-form\fR" 4 -.IX Item "-ffree-form" -.PD 0 -.IP "\fB\-fno\-fixed\-form\fR" 4 -.IX Item "-fno-fixed-form" -.PD -Specify that the source file is written in free form -(introduced in Fortran 90) instead of the more-traditional fixed form. -.IP "\fB\-ff90\fR" 4 -.IX Item "-ff90" -Allow certain Fortran\-90 constructs. -.Sp -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 -\&\fB\-fvxt\fR, \fB\-ff90\-intrinsics\-enable\fR, and the -current level of support for Fortran 90.) -.IP "\fB\-fvxt\fR" 4 -.IX Item "-fvxt" -Specify the treatment of certain constructs that have different -meanings depending on whether the code is written in -\&\s-1GNU\s0 Fortran (based on \s-1FORTRAN\s0 77 and akin to Fortran 90) -or \s-1VXT\s0 Fortran (more like \s-1VAX\s0 \s-1FORTRAN\s0). -.Sp -The default is \fB\-fno\-vxt\fR. -\&\fB\-fvxt\fR specifies that the \s-1VXT\s0 Fortran interpretations -for those constructs are to be chosen. -.IP "\fB\-fdollar\-ok\fR" 4 -.IX Item "-fdollar-ok" -Allow \fB$\fR as a valid character in a symbol name. -.IP "\fB\-fno\-backslash\fR" 4 -.IX Item "-fno-backslash" -Specify that \fB\e\fR is not to be specially interpreted in character -and Hollerith constants a la C and many \s-1UNIX\s0 Fortran compilers. -.Sp -For example, with \fB\-fbackslash\fR in effect, \fBA\enB\fR specifies -three characters, with the second one being newline. -With \fB\-fno\-backslash\fR, it specifies four characters, -\&\fBA\fR, \fB\e\fR, \fBn\fR, and \fBB\fR. -.Sp -Note that \fBg77\fR implements a fairly general form of backslash -processing that is incompatible with the narrower forms supported -by some other compilers. -For example, \fB'A\e003B'\fR is a three-character string in \fBg77\fR -whereas other compilers that support backslash might not support -the three-octal-digit form, and thus treat that string as longer -than three characters. -.IP "\fB\-fno\-ugly\-args\fR" 4 -.IX Item "-fno-ugly-args" -Disallow passing Hollerith and typeless constants as actual -arguments (for example, \fB\s-1CALL\s0 \s-1FOO\s0(4HABCD)\fR). -.IP "\fB\-fugly\-assign\fR" 4 -.IX 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 \fB\s-1ASSIGN\s0 10 \s-1TO\s0 I\fR) or used to hold numeric data -(as in \fBI = 3\fR). -.IP "\fB\-fugly\-assumed\fR" 4 -.IX Item "-fugly-assumed" -Assume any dummy array with a final dimension specified as \fB1\fR -is really an assumed-size array, as if \fB*\fR had been specified -for the final dimension instead of \fB1\fR. -.Sp -For example, \fB\s-1DIMENSION\s0 X(1)\fR is treated as if it -had read \fB\s-1DIMENSION\s0 X(*)\fR. -.IP "\fB\-fugly\-comma\fR" 4 -.IX Item "-fugly-comma" -In an external-procedure invocation, -treat a trailing comma in the argument list -as specification of a trailing null argument, -and treat an empty argument list -as specification of a single null argument. -.Sp -For example, \fB\s-1CALL\s0 \s-1FOO\s0(,)\fR is treated as -\&\fB\s-1CALL\s0 \s-1FOO\s0(%\f(BIVAL\fB\|(0), %\f(BIVAL\fB\|(0))\fR. -That is, \fItwo\fR null arguments are specified -by the procedure call when \fB\-fugly\-comma\fR is in force. -And \fBF = \s-1\f(BIFUNC\s0()\fB\fR is treated as \fBF = \s-1FUNC\s0(%\f(BIVAL\fB\|(0))\fR. -.Sp -The default behavior, \fB\-fno\-ugly\-comma\fR, is to ignore -a single trailing comma in an argument list. -So, by default, \fB\s-1CALL\s0 \s-1FOO\s0(X,)\fR is treated -exactly the same as \fB\s-1CALL\s0 \s-1FOO\s0(X)\fR. -.IP "\fB\-fugly\-complex\fR" 4 -.IX Item "-fugly-complex" -Do not complain about \fB\s-1REAL\s0(\fR\fIexpr\fR\fB)\fR or -\&\fB\s-1AIMAG\s0(\fR\fIexpr\fR\fB)\fR when \fIexpr\fR is a \f(CW\*(C`COMPLEX\*(C'\fR -type other than \f(CW\*(C`COMPLEX(KIND=1)\*(C'\fR\-\-\-usually -this is used to permit \f(CW\*(C`COMPLEX(KIND=2)\*(C'\fR -(\f(CW\*(C`DOUBLE COMPLEX\*(C'\fR) operands. -.Sp -The \fB\-ff90\fR option controls the interpretation -of this construct. -.IP "\fB\-fno\-ugly\-init\fR" 4 -.IX Item "-fno-ugly-init" -Disallow use of Hollerith and typeless constants as initial -values (in \f(CW\*(C`PARAMETER\*(C'\fR and \f(CW\*(C`DATA\*(C'\fR statements), and -use of character constants to -initialize numeric types and vice versa. -.Sp -For example, \fB\s-1DATA\s0 I/'F'/, \s-1CHRVAR/65/\s0, J/4HABCD/\fR is disallowed by -\&\fB\-fno\-ugly\-init\fR. -.IP "\fB\-fugly\-logint\fR" 4 -.IX Item "-fugly-logint" -Treat \f(CW\*(C`INTEGER\*(C'\fR and \f(CW\*(C`LOGICAL\*(C'\fR variables and -expressions as potential stand-ins for each other. -.Sp -For example, automatic conversion between \f(CW\*(C`INTEGER\*(C'\fR and -\&\f(CW\*(C`LOGICAL\*(C'\fR is enabled, for many contexts, via this option. -.IP "\fB\-fonetrip\fR" 4 -.IX Item "-fonetrip" -Executable iterative \f(CW\*(C`DO\*(C'\fR loops are to be executed at -least once each time they are reached. -.Sp -\&\s-1ANSI\s0 \s-1FORTRAN\s0 77 and more recent versions of the Fortran standard -specify that the body of an iterative \f(CW\*(C`DO\*(C'\fR loop is not executed -if the number of iterations calculated from the parameters of the -loop is less than 1. -(For example, \fB\s-1DO\s0 10 I = 1, 0\fR.) -Such a loop is called a \fIzero-trip loop\fR. -.Sp -Prior to \s-1ANSI\s0 \s-1FORTRAN\s0 77, many compilers implemented \f(CW\*(C`DO\*(C'\fR 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 -\&\fIone-trip loops\fR. -For example, some code written to the \s-1FORTRAN\s0 66 standard -expects this behavior from its \f(CW\*(C`DO\*(C'\fR loops, although that -standard did not specify this behavior. -.Sp -The \fB\-fonetrip\fR option specifies that the source file(s) being -compiled require one-trip loops. -.Sp -This option affects only those loops specified by the (iterative) \f(CW\*(C`DO\*(C'\fR -statement and by implied\-\f(CW\*(C`DO\*(C'\fR lists in I/O statements. -Loops specified by implied\-\f(CW\*(C`DO\*(C'\fR lists in \f(CW\*(C`DATA\*(C'\fR and -specification (non\-executable) statements are not affected. -.IP "\fB\-ftypeless\-boz\fR" 4 -.IX Item "-ftypeless-boz" -Specifies that prefix-radix non-decimal constants, such as -\&\fBZ'\s-1ABCD\s0'\fR, are typeless instead of \f(CW\*(C`INTEGER(KIND=1)\*(C'\fR. -.Sp -You can test for yourself whether a particular compiler treats -the prefix form as \f(CW\*(C`INTEGER(KIND=1)\*(C'\fR or typeless by running the -following program: -.Sp -.Vb 6 -\& 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 -.Ve -.Sp -Reports indicate that many compilers process this form as -\&\f(CW\*(C`INTEGER(KIND=1)\*(C'\fR, though a few as typeless, and at least one -based on a command-line option specifying some kind of -compatibility. -.IP "\fB\-fintrin\-case\-initcap\fR" 4 -.IX Item "-fintrin-case-initcap" -.PD 0 -.IP "\fB\-fintrin\-case\-upper\fR" 4 -.IX Item "-fintrin-case-upper" -.IP "\fB\-fintrin\-case\-lower\fR" 4 -.IX Item "-fintrin-case-lower" -.IP "\fB\-fintrin\-case\-any\fR" 4 -.IX Item "-fintrin-case-any" -.PD -Specify expected case for intrinsic names. -\&\fB\-fintrin\-case\-lower\fR is the default. -.IP "\fB\-fmatch\-case\-initcap\fR" 4 -.IX Item "-fmatch-case-initcap" -.PD 0 -.IP "\fB\-fmatch\-case\-upper\fR" 4 -.IX Item "-fmatch-case-upper" -.IP "\fB\-fmatch\-case\-lower\fR" 4 -.IX Item "-fmatch-case-lower" -.IP "\fB\-fmatch\-case\-any\fR" 4 -.IX Item "-fmatch-case-any" -.PD -Specify expected case for keywords. -\&\fB\-fmatch\-case\-lower\fR is the default. -.IP "\fB\-fsource\-case\-upper\fR" 4 -.IX Item "-fsource-case-upper" -.PD 0 -.IP "\fB\-fsource\-case\-lower\fR" 4 -.IX Item "-fsource-case-lower" -.IP "\fB\-fsource\-case\-preserve\fR" 4 -.IX Item "-fsource-case-preserve" -.PD -Specify whether source text other than character and Hollerith constants -is to be translated to uppercase, to lowercase, or preserved as is. -\&\fB\-fsource\-case\-lower\fR is the default. -.IP "\fB\-fsymbol\-case\-initcap\fR" 4 -.IX Item "-fsymbol-case-initcap" -.PD 0 -.IP "\fB\-fsymbol\-case\-upper\fR" 4 -.IX Item "-fsymbol-case-upper" -.IP "\fB\-fsymbol\-case\-lower\fR" 4 -.IX Item "-fsymbol-case-lower" -.IP "\fB\-fsymbol\-case\-any\fR" 4 -.IX Item "-fsymbol-case-any" -.PD -Specify valid cases for user-defined symbol names. -\&\fB\-fsymbol\-case\-any\fR is the default. -.IP "\fB\-fcase\-strict\-upper\fR" 4 -.IX Item "-fcase-strict-upper" -Same as \fB\-fintrin\-case\-upper \-fmatch\-case\-upper \-fsource\-case\-preserve -\&\-fsymbol\-case\-upper\fR. -(Requires all pertinent source to be in uppercase.) -.IP "\fB\-fcase\-strict\-lower\fR" 4 -.IX Item "-fcase-strict-lower" -Same as \fB\-fintrin\-case\-lower \-fmatch\-case\-lower \-fsource\-case\-preserve -\&\-fsymbol\-case\-lower\fR. -(Requires all pertinent source to be in lowercase.) -.IP "\fB\-fcase\-initcap\fR" 4 -.IX Item "-fcase-initcap" -Same as \fB\-fintrin\-case\-initcap \-fmatch\-case\-initcap \-fsource\-case\-preserve -\&\-fsymbol\-case\-initcap\fR. -(Requires all pertinent source to be in initial capitals, -as in \fBPrint *,SqRt(Value)\fR.) -.IP "\fB\-fcase\-upper\fR" 4 -.IX Item "-fcase-upper" -Same as \fB\-fintrin\-case\-any \-fmatch\-case\-any \-fsource\-case\-upper -\&\-fsymbol\-case\-any\fR. -(Maps all pertinent source to uppercase.) -.IP "\fB\-fcase\-lower\fR" 4 -.IX Item "-fcase-lower" -Same as \fB\-fintrin\-case\-any \-fmatch\-case\-any \-fsource\-case\-lower -\&\-fsymbol\-case\-any\fR. -(Maps all pertinent source to lowercase.) -.IP "\fB\-fcase\-preserve\fR" 4 -.IX Item "-fcase-preserve" -Same as \fB\-fintrin\-case\-any \-fmatch\-case\-any \-fsource\-case\-preserve -\&\-fsymbol\-case\-any\fR. -(Preserves all case in user-defined symbols, -while allowing any-case matching of intrinsics and keywords. -For example, \fBcall Foo(i,I)\fR would pass two \fIdifferent\fR -variables named \fBi\fR and \fBI\fR to a procedure named \fBFoo\fR.) -.IP "\fB\-fbadu77\-intrinsics\-delete\fR" 4 -.IX Item "-fbadu77-intrinsics-delete" -.PD 0 -.IP "\fB\-fbadu77\-intrinsics\-hide\fR" 4 -.IX Item "-fbadu77-intrinsics-hide" -.IP "\fB\-fbadu77\-intrinsics\-disable\fR" 4 -.IX Item "-fbadu77-intrinsics-disable" -.IP "\fB\-fbadu77\-intrinsics\-enable\fR" 4 -.IX Item "-fbadu77-intrinsics-enable" -.PD -Specify status of \s-1UNIX\s0 intrinsics having inappropriate forms. -\&\fB\-fbadu77\-intrinsics\-enable\fR is the default. -.IP "\fB\-ff2c\-intrinsics\-delete\fR" 4 -.IX Item "-ff2c-intrinsics-delete" -.PD 0 -.IP "\fB\-ff2c\-intrinsics\-hide\fR" 4 -.IX Item "-ff2c-intrinsics-hide" -.IP "\fB\-ff2c\-intrinsics\-disable\fR" 4 -.IX Item "-ff2c-intrinsics-disable" -.IP "\fB\-ff2c\-intrinsics\-enable\fR" 4 -.IX Item "-ff2c-intrinsics-enable" -.PD -Specify status of f2c\-specific intrinsics. -\&\fB\-ff2c\-intrinsics\-enable\fR is the default. -.IP "\fB\-ff90\-intrinsics\-delete\fR" 4 -.IX Item "-ff90-intrinsics-delete" -.PD 0 -.IP "\fB\-ff90\-intrinsics\-hide\fR" 4 -.IX Item "-ff90-intrinsics-hide" -.IP "\fB\-ff90\-intrinsics\-disable\fR" 4 -.IX Item "-ff90-intrinsics-disable" -.IP "\fB\-ff90\-intrinsics\-enable\fR" 4 -.IX Item "-ff90-intrinsics-enable" -.PD -Specify status of F90\-specific intrinsics. -\&\fB\-ff90\-intrinsics\-enable\fR is the default. -.IP "\fB\-fgnu\-intrinsics\-delete\fR" 4 -.IX Item "-fgnu-intrinsics-delete" -.PD 0 -.IP "\fB\-fgnu\-intrinsics\-hide\fR" 4 -.IX Item "-fgnu-intrinsics-hide" -.IP "\fB\-fgnu\-intrinsics\-disable\fR" 4 -.IX Item "-fgnu-intrinsics-disable" -.IP "\fB\-fgnu\-intrinsics\-enable\fR" 4 -.IX Item "-fgnu-intrinsics-enable" -.PD -Specify status of Digital's COMPLEX-related intrinsics. -\&\fB\-fgnu\-intrinsics\-enable\fR is the default. -.IP "\fB\-fmil\-intrinsics\-delete\fR" 4 -.IX Item "-fmil-intrinsics-delete" -.PD 0 -.IP "\fB\-fmil\-intrinsics\-hide\fR" 4 -.IX Item "-fmil-intrinsics-hide" -.IP "\fB\-fmil\-intrinsics\-disable\fR" 4 -.IX Item "-fmil-intrinsics-disable" -.IP "\fB\-fmil\-intrinsics\-enable\fR" 4 -.IX Item "-fmil-intrinsics-enable" -.PD -Specify status of MIL\-STD\-1753\-specific intrinsics. -\&\fB\-fmil\-intrinsics\-enable\fR is the default. -.IP "\fB\-funix\-intrinsics\-delete\fR" 4 -.IX Item "-funix-intrinsics-delete" -.PD 0 -.IP "\fB\-funix\-intrinsics\-hide\fR" 4 -.IX Item "-funix-intrinsics-hide" -.IP "\fB\-funix\-intrinsics\-disable\fR" 4 -.IX Item "-funix-intrinsics-disable" -.IP "\fB\-funix\-intrinsics\-enable\fR" 4 -.IX Item "-funix-intrinsics-enable" -.PD -Specify status of \s-1UNIX\s0 intrinsics. -\&\fB\-funix\-intrinsics\-enable\fR is the default. -.IP "\fB\-fvxt\-intrinsics\-delete\fR" 4 -.IX Item "-fvxt-intrinsics-delete" -.PD 0 -.IP "\fB\-fvxt\-intrinsics\-hide\fR" 4 -.IX Item "-fvxt-intrinsics-hide" -.IP "\fB\-fvxt\-intrinsics\-disable\fR" 4 -.IX Item "-fvxt-intrinsics-disable" -.IP "\fB\-fvxt\-intrinsics\-enable\fR" 4 -.IX Item "-fvxt-intrinsics-enable" -.PD -Specify status of \s-1VXT\s0 intrinsics. -\&\fB\-fvxt\-intrinsics\-enable\fR is the default. -.IP "\fB\-ffixed\-line\-length\-\fR\fIn\fR" 4 -.IX Item "-ffixed-line-length-n" -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. -.Sp -Popular values for \fIn\fR include 72 (the -standard and the default), 80 (card image), and 132 (corresponds -to ``extended\-source'' options in some popular compilers). -\&\fIn\fR may be \fBnone\fR, meaning that the entire line is meaningful -and that continued character constants never have implicit spaces appended -to them to fill out the line. -\&\fB\-ffixed\-line\-length\-0\fR means the same thing as -\&\fB\-ffixed\-line\-length\-none\fR. -.Sh "Options to Request or Suppress Warnings" -.IX Subsection "Options to Request or Suppress 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. -.PP -You can request many specific warnings with options beginning \fB\-W\fR, -for example \fB\-Wimplicit\fR to request warnings on implicit -declarations. Each of these specific warning options also has a -negative form beginning \fB\-Wno\-\fR to turn off warnings; -for example, \fB\-Wno\-implicit\fR. This manual lists only one of the -two forms, whichever is not the default. -.PP -These options control the amount and kinds of warnings produced by \s-1GNU\s0 -Fortran: -.IP "\fB\-fsyntax\-only\fR" 4 -.IX Item "-fsyntax-only" -Check the code for syntax errors, but don't do anything beyond that. -.IP "\fB\-pedantic\fR" 4 -.IX Item "-pedantic" -Issue warnings for uses of extensions to \s-1ANSI\s0 \s-1FORTRAN\s0 77. -\&\fB\-pedantic\fR also applies to C\-language constructs where they -occur in \s-1GNU\s0 Fortran source files, such as use of \fB\ee\fR in a -character constant within a directive like \fB#include\fR. -.Sp -Valid \s-1ANSI\s0 \s-1FORTRAN\s0 77 programs should compile properly with or without -this option. -However, without this option, certain \s-1GNU\s0 extensions and traditional -Fortran features are supported as well. -With this option, many of them are rejected. -.Sp -Some users try to use \fB\-pedantic\fR to check programs for strict \s-1ANSI\s0 -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 \fBg77\fR in this area are welcome. -.IP "\fB\-pedantic\-errors\fR" 4 -.IX Item "-pedantic-errors" -Like \fB\-pedantic\fR, except that errors are produced rather than -warnings. -.IP "\fB\-fpedantic\fR" 4 -.IX Item "-fpedantic" -Like \fB\-pedantic\fR, but applies only to Fortran constructs. -.IP "\fB\-w\fR" 4 -.IX Item "-w" -Inhibit all warning messages. -.IP "\fB\-Wno\-globals\fR" 4 -.IX Item "-Wno-globals" -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. -.Sp -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. -.IP "\fB\-Wimplicit\fR" 4 -.IX Item "-Wimplicit" -Warn whenever a variable, array, or function is implicitly -declared. -Has an effect similar to using the \f(CW\*(C`IMPLICIT NONE\*(C'\fR statement -in every program unit. -(Some Fortran compilers provide this feature by an option -named \fB\-u\fR or \fB/WARNINGS=DECLARATIONS\fR.) -.IP "\fB\-Wunused\fR" 4 -.IX Item "-Wunused" -Warn whenever a variable is unused aside from its declaration. -.IP "\fB\-Wuninitialized\fR" 4 -.IX Item "-Wuninitialized" -Warn whenever an automatic variable is used without first being initialized. -.Sp -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 \fB\-O\fR, you simply won't -get these warnings. -.Sp -These warnings occur only for variables that are candidates for -register allocation. Therefore, they do not occur for a variable -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. -.Sp -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. -.Sp -These warnings are made optional because \s-1GNU\s0 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: -.Sp -.Vb 6 -\& 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 -.Ve -.Sp -If the value of \f(CW\*(C`J\*(C'\fR is always 1, 2 or 3, then \f(CW\*(C`I\*(C'\fR is -always initialized, but \s-1GNU\s0 Fortran doesn't know this. Here is -another common case: -.Sp -.Vb 6 -\& SUBROUTINE MAYBE(FLAG) -\& LOGICAL FLAG -\& IF (FLAG) VALUE = 9.4 -\& ... -\& IF (FLAG) PRINT *, VALUE -\& END -.Ve -.Sp -This has no bug because \f(CW\*(C`VALUE\*(C'\fR is used only if it is set. -.IP "\fB\-Wall\fR" 4 -.IX Item "-Wall" -The \fB\-Wunused\fR and \fB\-Wuninitialized\fR 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 \fBg77\fR some might -be added to the list enabled by \fB\-Wall\fR.) -.PP -The remaining \fB\-W...\fR options are not implied by \fB\-Wall\fR -because they warn about constructions that we consider reasonable to -use, on occasion, in clean programs. -.IP "\fB\-Wsurprising\fR" 4 -.IX 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: -.RS 4 -.IP "*" 4 -Expressions having two arithmetic operators in a row, such -as \fBX*\-Y\fR. -Such a construct is nonstandard, and can produce -unexpected results in more complicated situations such -as \fBX**\-Y*Z\fR. -\&\fBg77\fR along with many other compilers, interprets -this example differently than many programmers, and a few -other compilers. -Specifically, \fBg77\fR interprets \fBX**\-Y*Z\fR as -\&\fB(X**(\-Y))*Z\fR, while others might think it should -be interpreted as \fBX**(\-(Y*Z))\fR. -.Sp -A revealing example is the constant expression \fB2**\-2*1.\fR, -which \fBg77\fR evaluates to .25, while others might evaluate -it to 0., the difference resulting from the way precedence affects -type promotion. -.Sp -(The \fB\-fpedantic\fR option also warns about expressions -having two arithmetic operators in a row.) -.IP "*" 4 -Expressions with a unary minus followed by an operand and then -a binary operator other than plus or minus. -For example, \fB\-2**2\fR produces a warning, because -the precedence is \fB\-(2**2)\fR, yielding \-4, not -\&\fB(\-2)**2\fR, which yields 4, and which might represent -what a programmer expects. -.Sp -An example of an expression producing different results -in a surprising way is \fB\-I*S\fR, where \fII\fR holds -the value \fB\-2147483648\fR and \fIS\fR holds \fB0.5\fR. -On many systems, negating \fII\fR results in the same -value, not a positive number, because it is already the -lower bound of what an \f(CW\*(C`INTEGER(KIND=1)\*(C'\fR variable can hold. -So, the expression evaluates to a positive number, while -the ``expected'' interpretation, \fB(\-I)*S\fR, would -evaluate to a negative number. -.Sp -Even cases such as \fB\-I*J\fR 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. -.IP "*" 4 -\&\f(CW\*(C`DO\*(C'\fR loops with \f(CW\*(C`DO\*(C'\fR variables that are not -of integral type\-\-\-that is, using \f(CW\*(C`REAL\*(C'\fR -variables as loop control variables. -Although such loops can be written to work in the -``obvious'' way, the way \fBg77\fR 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 \f(CW\*(C`DO\*(C'\fR loops, but the differences -are pronounced for non-integral loop control variables.) -.RE -.RS 4 -.RE -.IP "\fB\-Werror\fR" 4 -.IX Item "-Werror" -Make all warnings into errors. -.IP "\fB\-W\fR" 4 -.IX Item "-W" -Turns on ``extra warnings'' and, if optimization is specified -via \fB\-O\fR, the \fB\-Wuninitialized\fR option. -(This might change in future versions of \fBg77\fR -.Sp -``Extra warnings'' are issued for: -.RS 4 -.IP "*" 4 -Unused parameters to a procedure (when \fB\-Wunused\fR also is -specified). -.IP "*" 4 -Overflows involving floating-point constants (not available -for certain configurations). -.RE -.RS 4 -.RE -.PP -Some of these have no effect when compiling programs written in Fortran: -.IP "\fB\-Wcomment\fR" 4 -.IX Item "-Wcomment" -.PD 0 -.IP "\fB\-Wformat\fR" 4 -.IX Item "-Wformat" -.IP "\fB\-Wparentheses\fR" 4 -.IX Item "-Wparentheses" -.IP "\fB\-Wswitch\fR" 4 -.IX Item "-Wswitch" -.IP "\fB\-Wswitch\-default\fR" 4 -.IX Item "-Wswitch-default" -.IP "\fB\-Wswitch\-enum\fR" 4 -.IX Item "-Wswitch-enum" -.IP "\fB\-Wtraditional\fR" 4 -.IX Item "-Wtraditional" -.IP "\fB\-Wshadow\fR" 4 -.IX Item "-Wshadow" -.IP "\fB\-Wid\-clash\-\fR\fIlen\fR" 4 -.IX Item "-Wid-clash-len" -.IP "\fB\-Wlarger\-than\-\fR\fIlen\fR" 4 -.IX Item "-Wlarger-than-len" -.IP "\fB\-Wconversion\fR" 4 -.IX Item "-Wconversion" -.IP "\fB\-Waggregate\-return\fR" 4 -.IX Item "-Waggregate-return" -.IP "\fB\-Wredundant\-decls\fR" 4 -.IX Item "-Wredundant-decls" -.PD -These options all could have some relevant meaning for -\&\s-1GNU\s0 Fortran programs, but are not yet supported. -.Sh "Options for Debugging Your Program or \s-1GNU\s0 Fortran" -.IX Subsection "Options for Debugging Your Program or GNU Fortran" -\&\s-1GNU\s0 Fortran has various special options that are used for debugging -either your program or \fBg77\fR -.IP "\fB\-g\fR" 4 -.IX Item "-g" -Produce debugging information in the operating system's native format -(stabs, \s-1COFF\s0, \s-1XCOFF\s0, or \s-1DWARF\s0). \s-1GDB\s0 can work with this debugging -information. -.Sp -A sample debugging session looks like this (note the use of the breakpoint): -.Sp -.Vb 24 -\& $ cat gdb.f -\& PROGRAM PROG -\& DIMENSION A(10) -\& DATA A /1.,2.,3.,4.,5.,6.,7.,8.,9.,10./ -\& A(5) = 4. -\& PRINT*,A -\& END -\& $ g77 -g -O gdb.f -\& $ gdb a.out -\& ... -\& (gdb) break MAIN__ -\& Breakpoint 1 at 0x8048e96: file gdb.f, line 4. -\& (gdb) run -\& Starting program: /home/toon/g77-bugs/./a.out -\& Breakpoint 1, MAIN__ () at gdb.f:4 -\& 4 A(5) = 4. -\& Current language: auto; currently fortran -\& (gdb) print a(5) -\& $1 = 5 -\& (gdb) step -\& 5 PRINT*,A -\& (gdb) print a(5) -\& $2 = 4 -\& ... -.Ve -.Sp -One could also add the setting of the breakpoint and the first run command -to the file \fI.gdbinit\fR in the current directory, to simplify the debugging -session. -.Sh "Options That Control Optimization" -.IX Subsection "Options That Control Optimization" -Most Fortran users will want to use no optimization when -developing and testing programs, and use \fB\-O\fR or \fB\-O2\fR when -compiling programs for late-cycle testing and for production use. -However, note that certain diagnostics\-\-\-such as for uninitialized -variables\-\-\-depend on the flow analysis done by \fB\-O\fR, i.e. you -must use \fB\-O\fR or \fB\-O2\fR to get such diagnostics. -.PP -The following flags have particular applicability when -compiling Fortran programs: -.IP "\fB\-malign\-double\fR" 4 -.IX Item "-malign-double" -(Intel x86 architecture only.) -.Sp -Noticeably improves performance of \fBg77\fR programs making -heavy use of \f(CW\*(C`REAL(KIND=2)\*(C'\fR (\f(CW\*(C`DOUBLE PRECISION\*(C'\fR) data -on some systems. -In particular, systems using Pentium, Pentium Pro, 586, and -686 implementations -of the i386 architecture execute programs faster when -\&\f(CW\*(C`REAL(KIND=2)\*(C'\fR (\f(CW\*(C`DOUBLE PRECISION\*(C'\fR) data are -aligned on 64\-bit boundaries -in memory. -.Sp -This option can, at least, make benchmark results more consistent -across various system configurations, versions of the program, -and data sets. -.Sp -\&\fINote:\fR The warning in the \fBgcc\fR documentation about -this option does not apply, generally speaking, to Fortran -code compiled by \fBg77\fR -.Sp -\&\fIAlso also note:\fR The negative form of \fB\-malign\-double\fR -is \fB\-mno\-align\-double\fR, not \fB\-benign\-double\fR. -.IP "\fB\-ffloat\-store\fR" 4 -.IX Item "-ffloat-store" -Might help a Fortran program that depends on exact \s-1IEEE\s0 conformance on -some machines, but might slow down a program that doesn't. -.Sp -This option is effective when the floating-point unit is set to work in -\&\s-1IEEE\s0 854 `extended precision'\-\-\-as it typically is on x86 and m68k \s-1GNU\s0 -systems\-\-\-rather than \s-1IEEE\s0 754 double precision. \fB\-ffloat\-store\fR -tries to remove the extra precision by spilling data from floating-point -registers into memory and this typically involves a big performance -hit. However, it doesn't affect intermediate results, so that it is -only partially effective. `Excess precision' is avoided in code like: -.Sp -.Vb 2 -\& a = b + c -\& d = a * e -.Ve -.Sp -but not in code like: -.Sp -.Vb 1 -\& d = (b + c) * e -.Ve -.Sp -For another, potentially better, way of controlling the precision, -see \fBFloating-point precision\fR. -.IP "\fB\-fforce\-mem\fR" 4 -.IX Item "-fforce-mem" -.PD 0 -.IP "\fB\-fforce\-addr\fR" 4 -.IX Item "-fforce-addr" -.PD -Might improve optimization of loops. -.IP "\fB\-fno\-inline\fR" 4 -.IX Item "-fno-inline" -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. -.IP "\fB\-ffast\-math\fR" 4 -.IX Item "-ffast-math" -Might allow some programs designed to not be too dependent -on \s-1IEEE\s0 behavior for floating-point to run faster, or die trying. -Sets \fB\-funsafe\-math\-optimizations\fR, \fB\-ffinite\-math\-only\fR, -and \fB\-fno\-trapping\-math\fR. -.IP "\fB\-funsafe\-math\-optimizations\fR" 4 -.IX Item "-funsafe-math-optimizations" -Allow optimizations that may be give incorrect results -for certain \s-1IEEE\s0 inputs. -.IP "\fB\-ffinite\-math\-only\fR" 4 -.IX Item "-ffinite-math-only" -Allow optimizations for floating-point arithmetic that assume -that arguments and results are not NaNs or +\-Infs. -.Sp -This option should never be turned on by any \fB\-O\fR option since -it can result in incorrect output for programs which depend on -an exact implementation of \s-1IEEE\s0 or \s-1ISO\s0 rules/specifications. -.Sp -The default is \fB\-fno\-finite\-math\-only\fR. -.IP "\fB\-fno\-trapping\-math\fR" 4 -.IX Item "-fno-trapping-math" -Allow the compiler to assume that floating-point arithmetic -will not generate traps on any inputs. This is useful, for -example, when running a program using \s-1IEEE\s0 \*(L"non\-stop\*(R" -floating-point arithmetic. -.IP "\fB\-fstrength\-reduce\fR" 4 -.IX Item "-fstrength-reduce" -Might make some loops run faster. -.IP "\fB\-frerun\-cse\-after\-loop\fR" 4 -.IX Item "-frerun-cse-after-loop" -.PD 0 -.IP "\fB\-fexpensive\-optimizations\fR" 4 -.IX Item "-fexpensive-optimizations" -.IP "\fB\-fdelayed\-branch\fR" 4 -.IX Item "-fdelayed-branch" -.IP "\fB\-fschedule\-insns\fR" 4 -.IX Item "-fschedule-insns" -.IP "\fB\-fschedule\-insns2\fR" 4 -.IX Item "-fschedule-insns2" -.IP "\fB\-fcaller\-saves\fR" 4 -.IX Item "-fcaller-saves" -.PD -Might improve performance on some code. -.IP "\fB\-funroll\-loops\fR" 4 -.IX Item "-funroll-loops" -Typically improves performance on code using iterative \f(CW\*(C`DO\*(C'\fR loops by -unrolling them and is probably generally appropriate for Fortran, though -it is not turned on at any optimization level. -Note that outer loop unrolling isn't done specifically; decisions about -whether to unroll a loop are made on the basis of its instruction count. -.Sp -Also, no `loop discovery'[1] is done, so only loops written with \f(CW\*(C`DO\*(C'\fR -benefit from loop optimizations, including\-\-\-but not limited -to\-\-\-unrolling. Loops written with \f(CW\*(C`IF\*(C'\fR and \f(CW\*(C`GOTO\*(C'\fR are not -currently recognized as such. This option unrolls only iterative -\&\f(CW\*(C`DO\*(C'\fR loops, not \f(CW\*(C`DO WHILE\*(C'\fR loops. -.IP "\fB\-funroll\-all\-loops\fR" 4 -.IX Item "-funroll-all-loops" -Probably improves performance on code using \f(CW\*(C`DO WHILE\*(C'\fR loops by -unrolling them in addition to iterative \f(CW\*(C`DO\*(C'\fR loops. In the absence -of \f(CW\*(C`DO WHILE\*(C'\fR, this option is equivalent to \fB\-funroll\-loops\fR -but possibly slower. -.IP "\fB\-fno\-move\-all\-movables\fR" 4 -.IX Item "-fno-move-all-movables" -.PD 0 -.IP "\fB\-fno\-reduce\-all\-givs\fR" 4 -.IX Item "-fno-reduce-all-givs" -.IP "\fB\-fno\-rerun\-loop\-opt\fR" 4 -.IX Item "-fno-rerun-loop-opt" -.PD -In general, the optimizations enabled with these options will lead to -faster code being generated by \s-1GNU\s0 Fortran; hence they are enabled by default -when issuing the \fBg77\fR command. -.Sp -\&\fB\-fmove\-all\-movables\fR and \fB\-freduce\-all\-givs\fR will enable -loop optimization to move all loop-invariant index computations in nested -loops over multi-rank array dummy arguments out of these loops. -.Sp -\&\fB\-frerun\-loop\-opt\fR will move offset calculations resulting -from the fact that Fortran arrays by default have a lower bound of 1 -out of the loops. -.Sp -These three options are intended to be removed someday, once -loop optimization is sufficiently advanced to perform all those -transformations without help from these options. -.Sh "Options Controlling the Preprocessor" -.IX Subsection "Options Controlling the Preprocessor" -These options control the C preprocessor, which is run on each C source -file before actual compilation. -.PP -Some of these options also affect how \fBg77\fR processes the -\&\f(CW\*(C`INCLUDE\*(C'\fR directive. -Since this directive is processed even when preprocessing -is not requested, it is not described in this section. -.PP -However, the \f(CW\*(C`INCLUDE\*(C'\fR directive does not apply -preprocessing to the contents of the included file itself. -.PP -Therefore, any file that contains preprocessor directives -(such as \f(CW\*(C`#include\*(C'\fR, \f(CW\*(C`#define\*(C'\fR, and \f(CW\*(C`#if\*(C'\fR) -must be included via the \f(CW\*(C`#include\*(C'\fR directive, not -via the \f(CW\*(C`INCLUDE\*(C'\fR directive. -Therefore, any file containing preprocessor directives, -if included, is necessarily included by a file that itself -contains preprocessor directives. -.Sh "Options for Directory Search" -.IX Subsection "Options for Directory Search" -These options affect how the \fBcpp\fR preprocessor searches -for files specified via the \f(CW\*(C`#include\*(C'\fR directive. -Therefore, when compiling Fortran programs, they are meaningful -when the preprocessor is used. -.PP -Some of these options also affect how \fBg77\fR searches -for files specified via the \f(CW\*(C`INCLUDE\*(C'\fR directive, -although files included by that directive are not, -themselves, preprocessed. -These options are: -.IP "\fB\-I\-\fR" 4 -.IX Item "-I-" -.PD 0 -.IP "\fB\-I\fR\fIdir\fR" 4 -.IX Item "-Idir" -.PD -These affect interpretation of the \f(CW\*(C`INCLUDE\*(C'\fR directive -(as well as of the \f(CW\*(C`#include\*(C'\fR directive of the \fBcpp\fR -preprocessor). -.Sp -Note that \fB\-I\fR\fIdir\fR must be specified \fIwithout\fR any -spaces between \fB\-I\fR and the directory name\-\-\-that is, -\&\fB\-Ifoo/bar\fR is valid, but \fB\-I foo/bar\fR -is rejected by the \fBg77\fR compiler (though the preprocessor supports -the latter form). -Also note that the general behavior of \fB\-I\fR and -\&\f(CW\*(C`INCLUDE\*(C'\fR is pretty much the same as of \fB\-I\fR with -\&\f(CW\*(C`#include\*(C'\fR in the \fBcpp\fR preprocessor, with regard to -looking for \fIheader.gcc\fR files and other such things. -.Sh "Options for Code Generation Conventions" -.IX Subsection "Options for Code Generation Conventions" -These machine-independent options control the interface conventions -used in code generation. -.PP -Most of them have both positive and negative forms; the negative form -of \fB\-ffoo\fR would be \fB\-fno\-foo\fR. 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 \fBno\-\fR or adding -it. -.IP "\fB\-fno\-automatic\fR" 4 -.IX Item "-fno-automatic" -Treat each program unit as if the \f(CW\*(C`SAVE\*(C'\fR 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 \fB\-static\fR.) -.IP "\fB\-finit\-local\-zero\fR" 4 -.IX Item "-finit-local-zero" -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. -.Sp -Since there is a run-time penalty for initialization of variables -that are not given the \f(CW\*(C`SAVE\*(C'\fR attribute, it might be a -good idea to also use \fB\-fno\-automatic\fR with \fB\-finit\-local\-zero\fR. -.IP "\fB\-fno\-f2c\fR" 4 -.IX Item "-fno-f2c" -Do not generate code designed to be compatible with code generated -by \fBf2c\fR use the \s-1GNU\s0 calling conventions instead. -.Sp -The \fBf2c\fR calling conventions require functions that return -type \f(CW\*(C`REAL(KIND=1)\*(C'\fR to actually return the C type \f(CW\*(C`double\*(C'\fR, -and functions that return type \f(CW\*(C`COMPLEX\*(C'\fR to return the -values via an extra argument in the calling sequence that points -to where to store the return value. -Under the \s-1GNU\s0 calling conventions, such functions simply return -their results as they would in \s-1GNU\s0 C\-\-\-\f(CW\*(C`REAL(KIND=1)\*(C'\fR functions -return the C type \f(CW\*(C`float\*(C'\fR, and \f(CW\*(C`COMPLEX\*(C'\fR functions -return the \s-1GNU\s0 C type \f(CW\*(C`complex\*(C'\fR (or its \f(CW\*(C`struct\*(C'\fR -equivalent). -.Sp -This does not affect the generation of code that interfaces with the -\&\f(CW\*(C`libg2c\*(C'\fR library. -.Sp -However, because the \f(CW\*(C`libg2c\*(C'\fR library uses \fBf2c\fR -calling conventions, \fBg77\fR rejects attempts to pass -intrinsics implemented by routines in this library as actual -arguments when \fB\-fno\-f2c\fR is used, to avoid bugs when -they are actually called by code expecting the \s-1GNU\s0 calling -conventions to work. -.Sp -For example, \fB\s-1INTRINSIC\s0 \s-1ABS\s0;CALL \s-1FOO\s0(\s-1ABS\s0)\fR is -rejected when \fB\-fno\-f2c\fR is in force. -(Future versions of the \fBg77\fR run-time library might -offer routines that provide GNU-callable versions of the -routines that implement the \fBf2c\fR intrinsics -that may be passed as actual arguments, so that -valid programs need not be rejected when \fB\-fno\-f2c\fR -is used.) -.Sp -\&\fBCaution:\fR If \fB\-fno\-f2c\fR is used when compiling any -source file used in a program, it must be used when compiling -\&\fIall\fR Fortran source files used in that program. -.IP "\fB\-ff2c\-library\fR" 4 -.IX Item "-ff2c-library" -Specify that use of \f(CW\*(C`libg2c\*(C'\fR (or the original \f(CW\*(C`libf2c\*(C'\fR) -is required. -This is the default for the current version of \fBg77\fR -.Sp -Currently it is not -valid to specify \fB\-fno\-f2c\-library\fR. -This option is provided so users can specify it in shell -scripts that build programs and libraries that require the -\&\f(CW\*(C`libf2c\*(C'\fR library, even when being compiled by future -versions of \fBg77\fR that might otherwise default to -generating code for an incompatible library. -.IP "\fB\-fno\-underscoring\fR" 4 -.IX Item "-fno-underscoring" -Do not transform names of entities specified in the Fortran -source file by appending underscores to them. -.Sp -With \fB\-funderscoring\fR in effect, \fBg77\fR appends two underscores -to names with underscores and one underscore to external names with -no underscores. (\fBg77\fR also appends two underscores to internal -names with underscores to avoid naming collisions with external names. -The \fB\-fno\-second\-underscore\fR option disables appending of the -second underscore in all cases.) -.Sp -This is done to ensure compatibility with code produced by many -\&\s-1UNIX\s0 Fortran compilers, including \fBf2c\fR which perform the -same transformations. -.Sp -Use of \fB\-fno\-underscoring\fR is not recommended unless you are -experimenting with issues such as integration of (\s-1GNU\s0) Fortran into -existing system environments (vis\-a\-vis existing libraries, tools, and -so on). -.Sp -For example, with \fB\-funderscoring\fR, and assuming other defaults like -\&\fB\-fcase\-lower\fR and that \fBj()\fR and \fB\f(BImax_count()\fB\fR are -external functions while \fBmy_var\fR and \fBlvar\fR are local variables, -a statement like -.Sp -.Vb 1 -\& I = J() + MAX_COUNT (MY_VAR, LVAR) -.Ve -.Sp -is implemented as something akin to: -.Sp -.Vb 1 -\& i = j_() + max_count__(&my_var__, &lvar); -.Ve -.Sp -With \fB\-fno\-underscoring\fR, the same statement is implemented as: -.Sp -.Vb 1 -\& i = j() + max_count(&my_var, &lvar); -.Ve -.Sp -Use of \fB\-fno\-underscoring\fR allows direct specification of -user-defined names while debugging and when interfacing \fBg77\fR -code with other languages. -.Sp -Note that just because the names match does \fInot\fR mean that the -interface implemented by \fBg77\fR for an external name matches the -interface implemented by some other language for that same name. -That is, getting code produced by \fBg77\fR 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. -.Sp -Also, note that with \fB\-fno\-underscoring\fR, 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. -.Sp -In future versions of \fBg77\fR 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. -.IP "\fB\-fno\-second\-underscore\fR" 4 -.IX Item "-fno-second-underscore" -Do not append a second underscore to names of entities specified -in the Fortran source file. -.Sp -This option has no effect if \fB\-fno\-underscoring\fR is -in effect. -.Sp -Otherwise, with this option, an external name such as \fB\s-1MAX_COUNT\s0\fR -is implemented as a reference to the link-time external symbol -\&\fBmax_count_\fR, instead of \fBmax_count_\|_\fR. -.IP "\fB\-fno\-ident\fR" 4 -.IX Item "-fno-ident" -Ignore the \fB#ident\fR directive. -.IP "\fB\-fzeros\fR" 4 -.IX Item "-fzeros" -Treat initial values of zero as if they were any other value. -.Sp -As of version 0.5.18, \fBg77\fR normally treats \f(CW\*(C`DATA\*(C'\fR 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. -.Sp -This is done to speed up compiling of programs that initialize -large arrays to zeros. -.Sp -Use \fB\-fzeros\fR to revert to the simpler, slower behavior -that can catch multiple initializations by keeping track of -all initializations, zero or otherwise. -.Sp -\&\fICaution:\fR Future versions of \fBg77\fR 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. -.IP "\fB\-femulate\-complex\fR" 4 -.IX Item "-femulate-complex" -Implement \f(CW\*(C`COMPLEX\*(C'\fR arithmetic via emulation, -instead of using the facilities of -the \fBgcc\fR back end that provide direct support of -\&\f(CW\*(C`complex\*(C'\fR arithmetic. -.Sp -(\fBgcc\fR had some bugs in its back-end support -for \f(CW\*(C`complex\*(C'\fR arithmetic, due primarily to the support not being -completed as of version 2.8.1 and \f(CW\*(C`egcs\*(C'\fR 1.1.2.) -.Sp -Use \fB\-femulate\-complex\fR if you suspect code-generation bugs, -or experience compiler crashes, -that might result from \fBg77\fR using the \f(CW\*(C`COMPLEX\*(C'\fR support -in the \fBgcc\fR back end. -If using that option fixes the bugs or crashes you are seeing, -that indicates a likely \fBg77\fR bugs -(though, all compiler crashes are considered bugs), -so, please report it. -(Note that the known bugs, now believed fixed, produced compiler crashes -rather than causing the generation of incorrect code.) -.Sp -Use of this option should not affect how Fortran code compiled -by \fBg77\fR works in terms of its interfaces to other code, -e.g. that compiled by \fBf2c\fR -.Sp -As of \s-1GCC\s0 version 3.0, this option is not necessary anymore. -.Sp -\&\fICaution:\fR Future versions of \fBg77\fR might ignore both forms -of this option. -.IP "\fB\-falias\-check\fR" 4 -.IX Item "-falias-check" -.PD 0 -.IP "\fB\-fargument\-alias\fR" 4 -.IX Item "-fargument-alias" -.IP "\fB\-fargument\-noalias\fR" 4 -.IX Item "-fargument-noalias" -.IP "\fB\-fno\-argument\-noalias\-global\fR" 4 -.IX Item "-fno-argument-noalias-global" -.PD -\&\fIVersion info:\fR -These options are not supported by -versions of \fBg77\fR based on \fBgcc\fR version 2.8. -.Sp -These options specify to what degree aliasing -(overlap) -is permitted between -arguments (passed as pointers) and \f(CW\*(C`COMMON\*(C'\fR (external, or -public) storage. -.Sp -The default for Fortran code, as mandated by the \s-1FORTRAN\s0 77 and -Fortran 90 standards, is \fB\-fargument\-noalias\-global\fR. -The default for code written in the C language family is -\&\fB\-fargument\-alias\fR. -.Sp -Note that, on some systems, compiling with \fB\-fforce\-addr\fR in -effect can produce more optimal code when the default aliasing -options are in effect (and when optimization is enabled). -.IP "\fB\-fno\-globals\fR" 4 -.IX Item "-fno-globals" -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 \fB\-Wno\-globals\fR is specified, -in which case no relevant diagnostics are produced.) -.Sp -Further, this option disables such inlining, to -avoid compiler crashes resulting from incorrect -code that would otherwise be diagnosed. -.Sp -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 which \fBg77\fR diagnoses. -.Sp -Use of this option therefore has the effect of -instructing \fBg77\fR 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). -.Sp -Without this option, \fBg77\fR 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 as (fatal) errors, -and warns about similar disagreements -that are currently believed to not -likely to result in the compiler later crashing -or producing incorrect code. -.IP "\fB\-fflatten\-arrays\fR" 4 -.IX Item "-fflatten-arrays" -Use back end's C\-like constructs -(pointer plus offset) -instead of its \f(CW\*(C`ARRAY_REF\*(C'\fR construct -to handle all array references. -.Sp -\&\fINote:\fR This option is not supported. -It is intended for use only by \fBg77\fR developers, -to evaluate code-generation issues. -It might be removed at any time. -.IP "\fB\-fbounds\-check\fR" 4 -.IX Item "-fbounds-check" -.PD 0 -.IP "\fB\-ffortran\-bounds\-check\fR" 4 -.IX Item "-ffortran-bounds-check" -.PD -Enable generation of run-time checks for array subscripts -and substring start and end points -against the (locally) declared minimum and maximum values. -.Sp -The current implementation uses the \f(CW\*(C`libf2c\*(C'\fR -library routine \f(CW\*(C`s_rnge\*(C'\fR to print the diagnostic. -.Sp -However, whereas \fBf2c\fR generates a single check per -reference for a multi-dimensional array, of the computed -offset against the valid offset range (0 through the size of the array), -\&\fBg77\fR generates a single check per \fIsubscript\fR expression. -This catches some cases of potential bugs that \fBf2c\fR does not, -such as references to below the beginning of an assumed-size array. -.Sp -\&\fBg77\fR also generates checks for \f(CW\*(C`CHARACTER\*(C'\fR substring references, -something \fBf2c\fR currently does not do. -.Sp -Use the new \fB\-ffortran\-bounds\-check\fR option -to specify bounds-checking for only the Fortran code you are compiling, -not necessarily for code written in other languages. -.Sp -\&\fINote:\fR To provide more detailed information on the offending subscript, -\&\fBg77\fR provides the \f(CW\*(C`libg2c\*(C'\fR run-time library routine \f(CW\*(C`s_rnge\*(C'\fR -with somewhat differently-formatted information. -Here's a sample diagnostic: -.Sp -.Vb 3 -\& Subscript out of range on file line 4, procedure rnge.f/bf. -\& Attempt to access the -6-th element of variable b[subscript-2-of-2]. -\& Aborted -.Ve -.Sp -The above message indicates that the offending source line is -line 4 of the file \fIrnge.f\fR, -within the program unit (or statement function) named \fBbf\fR. -The offended array is named \fBb\fR. -The offended array dimension is the second for a two-dimensional array, -and the offending, computed subscript expression was \fB\-6\fR. -.Sp -For a \f(CW\*(C`CHARACTER\*(C'\fR substring reference, the second line has -this appearance: -.Sp -.Vb 1 -\& Attempt to access the 11-th element of variable a[start-substring]. -.Ve -.Sp -This indicates that the offended \f(CW\*(C`CHARACTER\*(C'\fR variable or array -is named \fBa\fR, -the offended substring position is the starting (leftmost) position, -and the offending substring expression is \fB11\fR. -.Sp -(Though the verbage of \f(CW\*(C`s_rnge\*(C'\fR is not ideal -for the purpose of the \fBg77\fR compiler, -the above information should provide adequate diagnostic abilities -to it users.) -.PP -Some of these do \fInot\fR work when compiling programs written in Fortran: -.IP "\fB\-fpcc\-struct\-return\fR" 4 -.IX Item "-fpcc-struct-return" -.PD 0 -.IP "\fB\-freg\-struct\-return\fR" 4 -.IX Item "-freg-struct-return" -.PD -You should not use these except strictly the same way as you -used them to build the version of \f(CW\*(C`libg2c\*(C'\fR with which -you will be linking all code compiled by \fBg77\fR with the -same option. -.IP "\fB\-fshort\-double\fR" 4 -.IX Item "-fshort-double" -This probably either has no effect on Fortran programs, or -makes them act loopy. -.IP "\fB\-fno\-common\fR" 4 -.IX Item "-fno-common" -Do not use this when compiling Fortran programs, -or there will be Trouble. -.IP "\fB\-fpack\-struct\fR" 4 -.IX Item "-fpack-struct" -This probably will break any calls to the \f(CW\*(C`libg2c\*(C'\fR library, -at the very least, even if it is built with the same option. -.SH "ENVIRONMENT" -.IX Header "ENVIRONMENT" -\&\s-1GNU\s0 Fortran currently does not make use of any environment -variables to control its operation above and beyond those -that affect the operation of \fBgcc\fR. -.SH "BUGS" -.IX Header "BUGS" -For instructions on reporting bugs, see -<\fBhttp://gcc.gnu.org/bugs.html\fR>. Use of the \fBgccbug\fR -script to report bugs is recommended. -.SH "FOOTNOTES" -.IX Header "FOOTNOTES" -.IP "1." 4 -\&\fIloop discovery\fR refers to the -process by which a compiler, or indeed any reader of a program, -determines which portions of the program are more likely to be executed -repeatedly as it is being run. Such discovery typically is done early -when compiling using optimization techniques, so the ``discovered'' -loops get more attention\-\-\-and more run-time resources, such as -registers\-\-\-from the compiler. It is easy to ``discover'' loops that are -constructed out of looping constructs in the language -(such as Fortran's \f(CW\*(C`DO\*(C'\fR). For some programs, ``discovering'' loops -constructed out of lower-level constructs (such as \f(CW\*(C`IF\*(C'\fR and -\&\f(CW\*(C`GOTO\*(C'\fR) can lead to generation of more optimal code -than otherwise. -.SH "SEE ALSO" -.IX Header "SEE ALSO" -\&\fIgpl\fR\|(7), \fIgfdl\fR\|(7), \fIfsf\-funding\fR\|(7), -\&\fIcpp\fR\|(1), \fIgcov\fR\|(1), \fIgcc\fR\|(1), \fIas\fR\|(1), \fIld\fR\|(1), \fIgdb\fR\|(1), \fIadb\fR\|(1), \fIdbx\fR\|(1), \fIsdb\fR\|(1) -and the Info entries for \fIgcc\fR, \fIcpp\fR, \fIg77\fR, \fIas\fR, -\&\fIld\fR, \fIbinutils\fR and \fIgdb\fR. -.SH "AUTHOR" -.IX Header "AUTHOR" -See the Info entry for \fBg77\fR for contributors to \s-1GCC\s0 and G77. -.SH "COPYRIGHT" -.IX Header "COPYRIGHT" -Copyright (c) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2004 -Free Software Foundation, Inc. -.PP -Permission is granted to copy, distribute and/or modify this document -under the terms of the \s-1GNU\s0 Free Documentation License, Version 1.2 or -any later version published by the Free Software Foundation; with the -Invariant Sections being ``\s-1GNU\s0 General Public License'' and ``Funding -Free Software'', the Front-Cover texts being (a) (see below), and with -the Back-Cover Texts being (b) (see below). A copy of the license is -included in the \fIgfdl\fR\|(7) man page. -.PP -(a) The \s-1FSF\s0's Front-Cover Text is: -.PP -.Vb 1 -\& A GNU Manual -.Ve -.PP -(b) The \s-1FSF\s0's Back-Cover Text is: -.PP -.Vb 3 -\& You have freedom to copy and modify this GNU Manual, like GNU -\& software. Copies published by the Free Software Foundation raise -\& funds for GNU development. -.Ve diff --git a/contrib/gcc-3.4/gcc/f/ansify.c b/contrib/gcc-3.4/gcc/f/ansify.c deleted file mode 100644 index b03206d79e..0000000000 --- a/contrib/gcc-3.4/gcc/f/ansify.c +++ /dev/null @@ -1,190 +0,0 @@ -/* ansify.c - Copyright (C) 1997, 2003 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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 "bconfig.h" -#include "system.h" -#include "coretypes.h" -#include "tm.h" - -#define die_unless(c) \ - do if (!(c)) \ - { \ - fprintf (stderr, "%s:%lu: %s\n", argv[1], lineno, #c); \ - die (); \ - } \ - while(0) - -static void ATTRIBUTE_NORETURN -die (void) -{ - exit (1); -} - -int -main(int argc, char **argv) -{ - int c; - static unsigned long lineno = 1; - - die_unless (argc == 2); - - printf ("\ -/* This file is automatically generated from `%s',\n\ - which you should modify instead. */\n\ -#line 1 \"%s\"\n\ -", - argv[1], argv[1]); - - while ((c = getchar ()) != EOF) - { - switch (c) - { - default: - putchar (c); - break; - - case '\n': - ++lineno; - putchar (c); - break; - - case '"': - putchar (c); - for (;;) - { - c = getchar (); - die_unless (c != EOF); - switch (c) - { - case '"': - putchar (c); - goto next_char; - - case '\n': - putchar ('\\'); - putchar ('n'); - putchar ('\\'); - putchar ('\n'); - ++lineno; - break; - - case '\\': - putchar (c); - c = getchar (); - die_unless (c != EOF); - putchar (c); - if (c == '\n') - ++lineno; - break; - - default: - putchar (c); - break; - } - } - break; - - case '\'': - putchar (c); - for (;;) - { - c = getchar (); - die_unless (c != EOF); - switch (c) - { - case '\'': - putchar (c); - goto next_char; - - case '\n': - putchar ('\\'); - putchar ('n'); - putchar ('\\'); - putchar ('\n'); - ++lineno; - break; - - case '\\': - putchar (c); - c = getchar (); - die_unless (c != EOF); - putchar (c); - if (c == '\n') - ++lineno; - break; - - default: - putchar (c); - break; - } - } - break; - - case '/': - putchar (c); - c = getchar (); - putchar (c); - if (c != '*') - break; - for (;;) - { - c = getchar (); - die_unless (c != EOF); - - switch (c) - { - case '\n': - ++lineno; - putchar (c); - break; - - case '*': - c = getchar (); - die_unless (c != EOF); - if (c == '/') - { - putchar ('*'); - putchar ('/'); - goto next_char; - } - if (c == '\n') - { - ++lineno; - putchar (c); - } - break; - - default: - /* Don't bother outputting content of comments. */ - break; - } - } - break; - } - - next_char: - ; - } - - die_unless (c == EOF); - - return 0; -} diff --git a/contrib/gcc-3.4/gcc/f/bad.c b/contrib/gcc-3.4/gcc/f/bad.c deleted file mode 100644 index bed9734ecc..0000000000 --- a/contrib/gcc-3.4/gcc/f/bad.c +++ /dev/null @@ -1,537 +0,0 @@ -/* bad.c -- Implementation File (module.c template V1.0) - Copyright (C) 1995, 2002, 2003 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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 "bad.h" -#include "flags.h" -#include "com.h" -#include "toplev.h" -#include "where.h" -#include "intl.h" -#include "diagnostic.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_ - { - const ffebadSeverity severity; - const char *const message; - }; - -/* Static objects accessed by functions in this module. */ - -static const struct _ffebad_message_ ffebad_messages_[] -= -{ -#define FFEBAD_MSG(kwd,sev,msgid) { sev, msgid }, -#if FFEBAD_LONG_MSGS_ == 0 -#define LONG(m) -#define SHORT(m) m -#else -#define LONG(m) m -#define SHORT(m) -#endif -#include "bad.def" -#undef FFEBAD_MSG -#undef LONG -#undef SHORT -}; - -static struct - { - ffewhereLine line; - ffewhereColumn col; - ffebadIndex tag; - } - -ffebad_here_[FFEBAD_MAX_]; -static const char *ffebad_string_[FFEBAD_MAX_]; -static ffebadIndex ffebad_order_[FFEBAD_MAX_]; -static ffebad ffebad_errnum_; -static ffebadSeverity ffebad_severity_; -static const 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, const 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, const 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 (void) -{ - 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, - const char *msgid) -{ - 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_ = gettext (ffebad_messages_[errnum].message); - } - else - { - ffebad_severity_ = sev; - ffebad_message_ = gettext (msgid); - } - - 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 (!diagnostic_report_warnings_p ()) - { /* User wants no warnings. */ - ffebad_is_temp_inhibited_ = TRUE; - return FALSE; - } - diagnostic_kind_count (global_dc, DK_WARNING)++; - break; - } - /* Fall through (PEDANTIC && flag_pedantic_errors). */ - case FFEBAD_severityFATAL: - case FFEBAD_severityWEIRD: - case FFEBAD_severitySEVERE: - case FFEBAD_severityDISASTER: - diagnostic_kind_count (global_dc, DK_ERROR)++; - break; - - default: - break; - } - - 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(const 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 (const 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 (void) -{ -#define MAX_SPACES 132 - static const char *const 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; - unsigned char c; - unsigned const char *s; - const 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); - diagnostic_report_current_function (global_dc); - fprintf (stderr, - /* 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, - 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') - { - 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 (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/contrib/gcc-3.4/gcc/f/bad.def b/contrib/gcc-3.4/gcc/f/bad.def deleted file mode 100644 index 92d7e23303..0000000000 --- a/contrib/gcc-3.4/gcc/f/bad.def +++ /dev/null @@ -1,1103 +0,0 @@ -/* bad.def -- Public #include File (module.h template V1.0) - Copyright (C) 1995, 1996, 1997, 2002 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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_MSG (FFEBAD_MISSING_FIRST_BINARY_OPERAND, FATAL, -/* xgettext:no-c-format */ -"Missing first operand for binary operator at %0") -FFEBAD_MSG (FFEBAD_NULL_CHAR_CONST, WARN, -/* xgettext:no-c-format */ -"Zero-length character constant at %0") -FFEBAD_MSG (FFEBAD_INVALID_TOKEN_IN_EXPRESSION, FATAL, -/* xgettext:no-c-format */ -"Invalid token at %0 in expression or subexpression at %1") -FFEBAD_MSG (FFEBAD_MISSING_OPERAND_FOR_OPERATOR, FATAL, -/* xgettext:no-c-format */ -"Missing operand for operator at %1 at end of expression at %0") -FFEBAD_MSG (FFEBAD_LABEL_ALREADY_DEFINED, FATAL, -/* xgettext:no-c-format */ -"Label %A already defined at %1 when redefined at %0") -FFEBAD_MSG (FFEBAD_UNRECOGNIZED_CHARACTER, FATAL, -/* xgettext:no-c-format */ -"Unrecognized character at %0 [info -f g77 M LEX]") -FFEBAD_MSG (FFEBAD_LABEL_WITHOUT_STMT, WARN, -/* xgettext:no-c-format */ -"Label definition %A at %0 on empty statement (as of %1)") -FFEBAD_MSG (FFEBAD_EXTRA_LABEL_DEF, FATAL, -/* xgettext:no-c-format */ -LONG("Extra label definition %A at %0 -- perhaps previous label definition %B at %1 should have CONTINUE statement?") -/* xgettext:no-c-format */ -SHORT("Extra label definition %A at %0 following label definition %B at %1")) -FFEBAD_MSG (FFEBAD_FIRST_CHAR_INVALID, FATAL, -/* xgettext:no-c-format */ -"Invalid first character at %0 [info -f g77 M LEX]") -FFEBAD_MSG (FFEBAD_LINE_TOO_LONG, FATAL, -/* xgettext:no-c-format */ -"Line too long as of %0 [info -f g77 M LEX]") -FFEBAD_MSG (FFEBAD_LABEL_FIELD_NOT_NUMERIC, FATAL, -/* xgettext:no-c-format */ -"Non-numeric character at %0 in label field [info -f g77 M LEX]") -FFEBAD_MSG (FFEBAD_LABEL_NUMBER_INVALID, FATAL, -/* xgettext:no-c-format */ -"Label number at %0 not in range 1-99999") -FFEBAD_MSG (FFEBAD_NON_ANSI_COMMENT, WARN, -/* xgettext:no-c-format */ -"At %0, '!' and '/*' are not valid comment delimiters") -FFEBAD_MSG (FFEBAD_NON_ANSI_CONTINUATION_COLUMN, WARN, -/* xgettext:no-c-format */ -"Continuation indicator at %0 must appear in column 6 [info -f g77 M LEX]") -FFEBAD_MSG (FFEBAD_LABEL_ON_CONTINUATION, FATAL, -/* xgettext:no-c-format */ -"Label at %0 invalid with continuation line indicator at %1 [info -f g77 M LEX]") -FFEBAD_MSG (FFEBAD_INVALID_CONTINUATION, FATAL, -/* xgettext:no-c-format */ -LONG("Continuation indicator at %0 invalid on first non-comment line of file or following END or INCLUDE [info -f g77 M LEX]") -/* xgettext:no-c-format */ -SHORT("Continuation indicator at %0 invalid here [info -f g77 M LEX]")) -FFEBAD_MSG (FFEBAD_NO_CLOSING_APOSTROPHE, FATAL, -/* xgettext:no-c-format */ -"Character constant at %0 has no closing apostrophe at %1") -FFEBAD_MSG (FFEBAD_NOT_ENOUGH_HOLLERITH_CHARS, FATAL, -/* xgettext:no-c-format */ -"Hollerith constant at %0 specified %A more characters than are present as of %1") -FFEBAD_MSG (FFEBAD_MISSING_CLOSE_PAREN, FATAL, -/* xgettext:no-c-format */ -"Missing close parenthese at %0 needed to match open parenthese at %1") -FFEBAD_MSG (FFEBAD_INTEGER_TOO_LARGE, FATAL, -/* xgettext:no-c-format */ -"Integer at %0 too large") -FFEBAD_MSG (FFEBAD_BAD_MAGICAL, WARN, -/* xgettext:no-c-format */ -LONG("Integer at %0 too large except as negative number (preceded by unary minus sign)") -/* xgettext:no-c-format */ -SHORT("Non-negative integer at %0 too large")) -FFEBAD_MSG (FFEBAD_BAD_MAGICAL_PRECEDENCE, WARN, -/* xgettext:no-c-format */ -LONG("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") -/* xgettext:no-c-format */ -SHORT("Integer at %0 too large (%2 has precedence over %1)")) -FFEBAD_MSG (FFEBAD_BAD_MAGICAL_BINARY, WARN, -/* xgettext:no-c-format */ -LONG("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") -/* xgettext:no-c-format */ -SHORT("Integer at %0 too large (needs unary, not binary, minus at %1)")) -FFEBAD_MSG (FFEBAD_BAD_MAGICAL_PRECEDENCE_BINARY, WARN, -/* xgettext:no-c-format */ -LONG("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") -/* xgettext:no-c-format */ -SHORT("Integer at %0 too large (%2 has precedence over %1, which needs to be unary, not binary, minus)")) -FFEBAD_MSG (FFEBAD_IGNORING_PERIOD, FATAL, -/* xgettext:no-c-format */ -"Period at %0 not followed by digits for floating-point number or by `NOT.', `TRUE.', or `FALSE.'") -FFEBAD_MSG (FFEBAD_INSERTING_PERIOD, FATAL, -/* xgettext:no-c-format */ -"Missing close-period between `.%A' at %0 and %1") -FFEBAD_MSG (FFEBAD_INVALID_EXPONENT, FATAL, -/* xgettext:no-c-format */ -"Invalid exponent at %0 for real constant at %1; nondigit `%A' in exponent field") -FFEBAD_MSG (FFEBAD_MISSING_EXPONENT_VALUE, FATAL, -/* xgettext:no-c-format */ -"Missing value at %1 for real-number exponent at %0") -FFEBAD_MSG (FFEBAD_MISSING_BINARY_OPERATOR, FATAL, -/* xgettext:no-c-format */ -"Expected binary operator between expressions at %0 and at %1") -FFEBAD_MSG (FFEBAD_INVALID_DOTDOT, FATAL, -/* xgettext:no-c-format */ -LONG("Period at %0 not followed by valid keyword forming a valid binary operator; `.%A.' is not a valid binary operator") -/* xgettext:no-c-format */ -SHORT("`.%A.' at %0 not a binary operator")) -FFEBAD_MSG (FFEBAD_QUOTE_MISSES_DIGITS, FATAL, -/* xgettext:no-c-format */ -LONG("Double-quote at %0 not followed by a string of valid octal digits at %1") -/* xgettext:no-c-format */ -SHORT("Invalid octal constant at %0")) -FFEBAD_MSG (FFEBAD_INVALID_BINARY_DIGIT, FATAL, -/* xgettext:no-c-format */ -LONG("Invalid binary digit(s) found in string of digits at %0") -/* xgettext:no-c-format */ -SHORT("Invalid binary constant at %0")) -FFEBAD_MSG (FFEBAD_INVALID_HEX_DIGIT, FATAL, -/* xgettext:no-c-format */ -LONG("Invalid hexadecimal digit(s) found in string of digits at %0") -/* xgettext:no-c-format */ -SHORT("Invalid hexadecimal constant at %0")) -FFEBAD_MSG (FFEBAD_INVALID_OCTAL_DIGIT, FATAL, -/* xgettext:no-c-format */ -LONG("Invalid octal digit(s) found in string of digits at %0") -/* xgettext:no-c-format */ -SHORT("Invalid octal constant at %0")) -FFEBAD_MSG (FFEBAD_INVALID_RADIX_SPECIFIER, FATAL, -/* xgettext:no-c-format */ -LONG("Invalid radix specifier `%A' at %0 for typeless constant at %1") -/* xgettext:no-c-format */ -SHORT("Invalid typeless constant at %1")) -FFEBAD_MSG (FFEBAD_INVALID_TYPELESS_BINARY_DIGIT, FATAL, -/* xgettext:no-c-format */ -LONG("Invalid binary digit(s) found in string of digits at %0") -/* xgettext:no-c-format */ -SHORT("Invalid binary constant at %0")) -FFEBAD_MSG (FFEBAD_INVALID_TYPELESS_OCTAL_DIGIT, FATAL, -/* xgettext:no-c-format */ -LONG("Invalid octal digit(s) found in string of digits at %0") -/* xgettext:no-c-format */ -SHORT("Invalid octal constant at %0")) -FFEBAD_MSG (FFEBAD_INVALID_TYPELESS_HEX_DIGIT, FATAL, -/* xgettext:no-c-format */ -LONG("Invalid hexadecimal digit(s) found in string of digits at %0") -/* xgettext:no-c-format */ -SHORT("Invalid hexadecimal constant at %0")) -FFEBAD_MSG (FFEBAD_INVALID_COMPLEX_PART, FATAL, -/* xgettext:no-c-format */ -LONG("%A part of complex constant at %0 must be a real or integer constant -- otherwise use CMPLX() or COMPLEX() in place of ()") -/* xgettext:no-c-format */ -SHORT("%A part of complex constant at %0 not a real or integer constant")) -FFEBAD_MSG (FFEBAD_INVALID_PERCENT, FATAL, -/* xgettext:no-c-format */ -LONG("Invalid keyword `%%%A' at %0 in this context") -/* xgettext:no-c-format */ -SHORT("Invalid keyword `%%%A' at %0")) -FFEBAD_MSG (FFEBAD_NULL_EXPRESSION, FATAL, -/* xgettext:no-c-format */ -LONG("Null expression between %0 and %1 invalid in this context") -/* xgettext:no-c-format */ -SHORT("Invalid null expression between %0 and %1")) -FFEBAD_MSG (FFEBAD_CONCAT_ARGS_TYPE, FATAL, -/* xgettext:no-c-format */ -LONG("Concatenation operator at %0 must operate on two subexpressions of character type, but neither subexpression at %1 or %2 is of character type") -/* xgettext:no-c-format */ -SHORT("Invalid operands at %1 and %2 for concatenation operator at %0")) -FFEBAD_MSG (FFEBAD_CONCAT_ARG_TYPE, FATAL, -/* xgettext:no-c-format */ -LONG("Concatenation operator at %0 must operate on two subexpressions of character type, but the subexpression at %1 is not of character type") -/* xgettext:no-c-format */ -SHORT("Invalid operand at %1 for concatenation operator at %0")) -FFEBAD_MSG (FFEBAD_CONCAT_ARG_KIND, FATAL, -/* xgettext:no-c-format */ -LONG("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") -/* xgettext:no-c-format */ -SHORT("Invalid operand (is %A) at %1 for concatenation operator at %0")) -FFEBAD_MSG (FFEBAD_MATH_ARGS_TYPE, FATAL, -/* xgettext:no-c-format */ -LONG("Arithmetic operator at %0 must operate on two subexpressions of arithmetic type, but neither subexpression at %1 or %2 is of arithmetic type") -/* xgettext:no-c-format */ -SHORT("Invalid operands at %1 and %2 for arithmetic operator at %0")) -FFEBAD_MSG (FFEBAD_MATH_ARG_TYPE, FATAL, -/* xgettext:no-c-format */ -LONG("Arithmetic operator at %0 must operate on two subexpressions of arithmetic type, but the subexpression at %1 is not of arithmetic type") -/* xgettext:no-c-format */ -SHORT("Invalid operand at %1 for arithmetic operator at %0")) -FFEBAD_MSG (FFEBAD_MATH_ARG_KIND, FATAL, -/* xgettext:no-c-format */ -LONG("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") -/* xgettext:no-c-format */ -SHORT("Invalid operand (is %A) at %1 for arithmetic operator at %0")) -FFEBAD_MSG (FFEBAD_NO_CLOSING_QUOTE, FATAL, -/* xgettext:no-c-format */ -LONG("Character constant at %0 has no closing quote at %1 [info -f g77 M LEX]") -/* xgettext:no-c-format */ -SHORT("Unterminated character constant at %0 [info -f g77 M LEX]")) -FFEBAD_MSG (FFEBAD_BAD_CHAR_CONTINUE, FATAL, -/* xgettext:no-c-format */ -LONG("Continuation line at %0 must have initial `&' since it continues a character context [info -f g77 M LEX]") -/* xgettext:no-c-format */ -SHORT("Missing initial `&' on continuation line at %0 [info -f g77 M LEX]")) -FFEBAD_MSG (FFEBAD_BAD_LEXTOK_CONTINUE, FATAL, -/* xgettext:no-c-format */ -LONG("Continuation line at %0 must have initial `&' since it continues a split lexical token [info -f g77 M LEX]") -/* xgettext:no-c-format */ -SHORT("Missing initial `&' on continuation line at %0 [info -f g77 M LEX]")) -FFEBAD_MSG (FFEBAD_BAD_FREE_CONTINUE, FATAL, -/* xgettext:no-c-format */ -LONG("Continuation line at %0 invalid because it consists only of a single `&' as the only nonblank character") -/* xgettext:no-c-format */ -SHORT("Invalid continuation line at %0")) -FFEBAD_MSG (FFEBAD_STMT_BEGINS_BAD, FATAL, -/* xgettext:no-c-format */ -LONG("Statement at %0 begins with invalid token [info -f g77 M LEX]") -/* xgettext:no-c-format */ -SHORT("Invalid statement at %0 [info -f g77 M LEX]")) -FFEBAD_MSG (FFEBAD_SEMICOLON, FATAL, -/* xgettext:no-c-format */ -"Semicolon at %0 is an invalid token") -FFEBAD_MSG (FFEBAD_UNREC_STMT, FATAL, -/* xgettext:no-c-format */ -LONG("Unrecognized statement name at %0 and invalid form for assignment or statement-function definition at %1") -/* xgettext:no-c-format */ -SHORT("Invalid statement at %0")) -FFEBAD_MSG (FFEBAD_INVALID_STMT_FORM, FATAL, -/* xgettext:no-c-format */ -LONG("Invalid form for %A statement at %0") -/* xgettext:no-c-format */ -SHORT("Invalid %A statement at %0")) -FFEBAD_MSG (FFEBAD_INVALID_HOLL_IN_STMT, FATAL, -/* xgettext:no-c-format */ -LONG("Invalid use of hollerith constant in statement at %0 -- enclose the constant in parentheses (for example, change BACKSPACE 2HAB to BACKSPACE (2HAB))") -/* xgettext:no-c-format */ -SHORT("Enclose hollerith constant in statement at %0 in parentheses")) -FFEBAD_MSG (FFEBAD_FORMAT_EXTRA_COMMA, FATAL, -/* xgettext:no-c-format */ -"Extraneous comma in FORMAT statement at %0") -FFEBAD_MSG (FFEBAD_FORMAT_MISSING_COMMA, WARN, -/* xgettext:no-c-format */ -"Missing comma in FORMAT statement at %0") -FFEBAD_MSG (FFEBAD_FORMAT_SPURIOUS_SIGN, FATAL, -/* xgettext:no-c-format */ -"Spurious sign in FORMAT statement at %0") -FFEBAD_MSG (FFEBAD_FORMAT_SPURIOUS_NUMBER, FATAL, -/* xgettext:no-c-format */ -"Spurious number in FORMAT statement at %0") -FFEBAD_MSG (FFEBAD_FORMAT_TEXT_IN_NUMBER, FATAL, -/* xgettext:no-c-format */ -"Spurious text trailing number in FORMAT statement at %0") -FFEBAD_MSG (FFEBAD_FORMAT_P_NOCOMMA, FATAL, -/* xgettext:no-c-format */ -LONG("nP control edit descriptor not followed by comma but followed by edit descriptor at %0 other than D, E, EN, F, or G") -/* xgettext:no-c-format */ -SHORT("Invalid edit descriptor at %0 following nP control edit descriptor")) -FFEBAD_MSG (FFEBAD_FORMAT_BAD_SPEC, FATAL, -/* xgettext:no-c-format */ -"Unrecognized FORMAT specifier at %0") -FFEBAD_MSG (FFEBAD_FORMAT_BAD_I_SPEC, FATAL, -/* xgettext:no-c-format */ -LONG("Invalid I specifier in FORMAT statement at %0 -- correct form: [r]Iw.[m]") -/* xgettext:no-c-format */ -SHORT("Invalid I specifier in FORMAT statement at %0")) -FFEBAD_MSG (FFEBAD_FORMAT_BAD_B_SPEC, FATAL, -/* xgettext:no-c-format */ -LONG("Invalid B specifier in FORMAT statement at %0 -- correct form: [r]Bw.[m]") -/* xgettext:no-c-format */ -SHORT("Invalid B specifier in FORMAT statement at %0")) -FFEBAD_MSG (FFEBAD_FORMAT_BAD_O_SPEC, FATAL, -/* xgettext:no-c-format */ -LONG("Invalid O specifier in FORMAT statement at %0 -- correct form: [r]Ow.[m]") -/* xgettext:no-c-format */ -SHORT("Invalid O specifier in FORMAT statement at %0")) -FFEBAD_MSG (FFEBAD_FORMAT_BAD_Z_SPEC, FATAL, -/* xgettext:no-c-format */ -LONG("Invalid Z specifier in FORMAT statement at %0 -- correct form: [r]Zw.[m]") -/* xgettext:no-c-format */ -SHORT("Invalid Z specifier in FORMAT statement at %0")) -FFEBAD_MSG (FFEBAD_FORMAT_BAD_F_SPEC, FATAL, -/* xgettext:no-c-format */ -LONG("Invalid F specifier in FORMAT statement at %0 -- correct form: [r]Fw.d") -/* xgettext:no-c-format */ -SHORT("Invalid F specifier in FORMAT statement at %0")) -FFEBAD_MSG (FFEBAD_FORMAT_BAD_E_SPEC, FATAL, -/* xgettext:no-c-format */ -LONG("Invalid E specifier in FORMAT statement at %0 -- correct form: [r]Ew.d[Ee]") -/* xgettext:no-c-format */ -SHORT("Invalid E specifier in FORMAT statement at %0")) -FFEBAD_MSG (FFEBAD_FORMAT_BAD_EN_SPEC, FATAL, -/* xgettext:no-c-format */ -LONG("Invalid EN specifier in FORMAT statement at %0 -- correct form: [r]ENw.d[Ee]") -/* xgettext:no-c-format */ -SHORT("Invalid EN specifier in FORMAT statement at %0")) -FFEBAD_MSG (FFEBAD_FORMAT_BAD_G_SPEC, FATAL, -/* xgettext:no-c-format */ -LONG("Invalid G specifier in FORMAT statement at %0 -- correct form: [r]Gw.d[Ee]") -/* xgettext:no-c-format */ -SHORT("Invalid G specifier in FORMAT statement at %0")) -FFEBAD_MSG (FFEBAD_FORMAT_BAD_L_SPEC, FATAL, -/* xgettext:no-c-format */ -LONG("Invalid L specifier in FORMAT statement at %0 -- correct form: [r]Lw") -/* xgettext:no-c-format */ -SHORT("Invalid L specifier in FORMAT statement at %0")) -FFEBAD_MSG (FFEBAD_FORMAT_BAD_A_SPEC, FATAL, -/* xgettext:no-c-format */ -LONG("Invalid A specifier in FORMAT statement at %0 -- correct form: [r]A[w]") -/* xgettext:no-c-format */ -SHORT("Invalid A specifier in FORMAT statement at %0")) -FFEBAD_MSG (FFEBAD_FORMAT_BAD_D_SPEC, FATAL, -/* xgettext:no-c-format */ -LONG("Invalid D specifier in FORMAT statement at %0 -- correct form: [r]Dw.d") -/* xgettext:no-c-format */ -SHORT("Invalid D specifier in FORMAT statement at %0")) -FFEBAD_MSG (FFEBAD_FORMAT_BAD_Q_SPEC, FATAL, -/* xgettext:no-c-format */ -LONG("Invalid Q specifier in FORMAT statement at %0 -- correct form: Q") -/* xgettext:no-c-format */ -SHORT("Invalid Q specifier in FORMAT statement at %0")) -FFEBAD_MSG (FFEBAD_FORMAT_BAD_DOLLAR_SPEC, FATAL, -/* xgettext:no-c-format */ -LONG("Invalid $ specifier in FORMAT statement at %0 -- correct form: $") -/* xgettext:no-c-format */ -SHORT("Invalid $ specifier in FORMAT statement at %0")) -FFEBAD_MSG (FFEBAD_FORMAT_BAD_P_SPEC, FATAL, -/* xgettext:no-c-format */ -LONG("Invalid P specifier in FORMAT statement at %0 -- correct form: kP") -/* xgettext:no-c-format */ -SHORT("Invalid P specifier in FORMAT statement at %0")) -FFEBAD_MSG (FFEBAD_FORMAT_BAD_T_SPEC, FATAL, -/* xgettext:no-c-format */ -LONG("Invalid T specifier in FORMAT statement at %0 -- correct form: Tn") -/* xgettext:no-c-format */ -SHORT("Invalid T specifier in FORMAT statement at %0")) -FFEBAD_MSG (FFEBAD_FORMAT_BAD_TL_SPEC, FATAL, -/* xgettext:no-c-format */ -LONG("Invalid TL specifier in FORMAT statement at %0 -- correct form: TLn") -/* xgettext:no-c-format */ -SHORT("Invalid TL specifier in FORMAT statement at %0")) -FFEBAD_MSG (FFEBAD_FORMAT_BAD_TR_SPEC, FATAL, -/* xgettext:no-c-format */ -LONG("Invalid TR specifier in FORMAT statement at %0 -- correct form: TRn") -/* xgettext:no-c-format */ -SHORT("Invalid TR specifier in FORMAT statement at %0")) -FFEBAD_MSG (FFEBAD_FORMAT_BAD_X_SPEC, FATAL, -/* xgettext:no-c-format */ -LONG("Invalid X specifier in FORMAT statement at %0 -- correct form: nX") -/* xgettext:no-c-format */ -SHORT("Invalid X specifier in FORMAT statement at %0")) -FFEBAD_MSG (FFEBAD_FORMAT_BAD_S_SPEC, FATAL, -/* xgettext:no-c-format */ -LONG("Invalid S specifier in FORMAT statement at %0 -- correct form: S") -/* xgettext:no-c-format */ -SHORT("Invalid S specifier in FORMAT statement at %0")) -FFEBAD_MSG (FFEBAD_FORMAT_BAD_SP_SPEC, FATAL, -/* xgettext:no-c-format */ -LONG("Invalid SP specifier in FORMAT statement at %0 -- correct form: SP") -/* xgettext:no-c-format */ -SHORT("Invalid SP specifier in FORMAT statement at %0")) -FFEBAD_MSG (FFEBAD_FORMAT_BAD_SS_SPEC, FATAL, -/* xgettext:no-c-format */ -LONG("Invalid SS specifier in FORMAT statement at %0 -- correct form: SS") -/* xgettext:no-c-format */ -SHORT("Invalid SS specifier in FORMAT statement at %0")) -FFEBAD_MSG (FFEBAD_FORMAT_BAD_BN_SPEC, FATAL, -/* xgettext:no-c-format */ -LONG("Invalid BN specifier in FORMAT statement at %0 -- correct form: BN") -/* xgettext:no-c-format */ -SHORT("Invalid BN specifier in FORMAT statement at %0")) -FFEBAD_MSG (FFEBAD_FORMAT_BAD_BZ_SPEC, FATAL, -/* xgettext:no-c-format */ -LONG("Invalid BZ specifier in FORMAT statement at %0 -- correct form: BZ") -/* xgettext:no-c-format */ -SHORT("Invalid BZ specifier in FORMAT statement at %0")) -FFEBAD_MSG (FFEBAD_FORMAT_BAD_COLON_SPEC, FATAL, -/* xgettext:no-c-format */ -LONG("Invalid : specifier in FORMAT statement at %0 -- correct form: :") -/* xgettext:no-c-format */ -SHORT("Invalid : specifier in FORMAT statement at %0")) -FFEBAD_MSG (FFEBAD_FORMAT_BAD_H_SPEC, FATAL, -/* xgettext:no-c-format */ -LONG("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)") -/* xgettext:no-c-format */ -SHORT("Invalid H specifier in FORMAT statement at %0")) -FFEBAD_MSG (FFEBAD_FORMAT_MISSING_PAREN, FATAL, -/* xgettext:no-c-format */ -"Missing close-parenthese(s) in FORMAT statement at %0") -FFEBAD_MSG (FFEBAD_FORMAT_MISSING_DOT, FATAL, -/* xgettext:no-c-format */ -"Missing number following period in FORMAT statement at %0") -FFEBAD_MSG (FFEBAD_FORMAT_MISSING_EXP, FATAL, -/* xgettext:no-c-format */ -"Missing number following `E' in FORMAT statement at %0") -FFEBAD_MSG (FFEBAD_FORMAT_EXPR_TOKEN, FATAL, -/* xgettext:no-c-format */ -LONG("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") -/* xgettext:no-c-format */ -SHORT("Invalid token with FORMAT run-time expression at %0")) -FFEBAD_MSG (FFEBAD_TRAILING_COMMA, WARN, -/* xgettext:no-c-format */ -"Spurious trailing comma preceding terminator at %0") -FFEBAD_MSG (FFEBAD_INTERFACE_ASSIGNMENT, WARN, -/* xgettext:no-c-format */ -"At %0, specify OPERATOR instead of ASSIGNMENT for INTERFACE statement not specifying the assignment operator (=)") -FFEBAD_MSG (FFEBAD_INTERFACE_OPERATOR, WARN, -/* xgettext:no-c-format */ -"At %0, specify ASSIGNMENT instead of OPERATOR for INTERFACE statement specifying the assignment operator (=)") -FFEBAD_MSG (FFEBAD_INTERFACE_NONLETTER, FATAL, -/* xgettext:no-c-format */ -LONG("Defined operator at %0 contains a nonletter -- must contain only letters A-Z (or a-z)") -/* xgettext:no-c-format */ -SHORT("Nonletter in defined operator at %0")) -FFEBAD_MSG (FFEBAD_INVALID_TYPEDECL_ATTR, FATAL, -/* xgettext:no-c-format */ -LONG("Invalid type-declaration attribute at %0 -- must be one of: DIMENSION(array-spec), EXTERNAL, INTRINSIC, PARAMETER, or SAVE") -/* xgettext:no-c-format */ -SHORT("Invalid type-declaration attribute at %0")) -FFEBAD_MSG (FFEBAD_INVALID_TYPEDECL_INIT, FATAL, -/* xgettext:no-c-format */ -"Cannot specify =initialization-expr at %0 unless `::' appears before list of objects") -FFEBAD_MSG (FFEBAD_LABEL_USE_DEF, FATAL, -/* xgettext:no-c-format */ -"Reference to label at %1 inconsistent with its definition at %0") -FFEBAD_MSG (FFEBAD_LABEL_USE_USE, FATAL, -/* xgettext:no-c-format */ -"Reference to label at %1 inconsistent with earlier reference at %0") -FFEBAD_MSG (FFEBAD_LABEL_DEF_DO, FATAL, -/* xgettext:no-c-format */ -"DO-statement reference to label at %1 follows its definition at %0") -FFEBAD_MSG (FFEBAD_LABEL_BLOCK, WARN, -/* xgettext:no-c-format */ -"Reference to label at %1 is outside block containing definition at %0") -FFEBAD_MSG (FFEBAD_LABEL_DO_BLOCK_DO, FATAL, -/* xgettext:no-c-format */ -"DO-statement references to label at %0 and %2 separated by unterminated block starting at %1") -FFEBAD_MSG (FFEBAD_LABEL_DO_BLOCK_END, FATAL, -/* xgettext:no-c-format */ -"DO-statement reference to label at %0 and label definition at %2 separated by unterminated block starting at %1") -FFEBAD_MSG (FFEBAD_INVALID_LABEL_DEF, FATAL, -/* xgettext:no-c-format */ -"Label definition at %0 invalid on this kind of statement") -FFEBAD_MSG (FFEBAD_ORDER_1, FATAL, -/* xgettext:no-c-format */ -"Statement at %0 invalid in this context") -FFEBAD_MSG (FFEBAD_ORDER_2, FATAL, -/* xgettext:no-c-format */ -"Statement at %0 invalid in context established by statement at %1") -FFEBAD_MSG (FFEBAD_CONSTRUCT_NAMED, FATAL, -/* xgettext:no-c-format */ -"Statement at %0 must specify construct name specified at %1") -FFEBAD_MSG (FFEBAD_CONSTRUCT_NOT_NAMED, FATAL, -/* xgettext:no-c-format */ -"Construct name at %0 superfluous, no construct name specified at %1") -FFEBAD_MSG (FFEBAD_CONSTRUCT_WRONG_NAME, FATAL, -/* xgettext:no-c-format */ -"Construct name at %0 not the same as construct name at %1") -FFEBAD_MSG (FFEBAD_CONSTRUCT_NO_DO_NAME, FATAL, -/* xgettext:no-c-format */ -"Construct name at %0 does not match construct name for any containing DO constructs") -FFEBAD_MSG (FFEBAD_DO_HAD_LABEL, FATAL, -/* xgettext:no-c-format */ -"Label definition missing at %0 for DO construct specifying label at %1") -FFEBAD_MSG (FFEBAD_AFTER_ELSE, FATAL, -/* xgettext:no-c-format */ -"Statement at %0 follows ELSE block for IF construct at %1") -FFEBAD_MSG (FFEBAD_FORMAT_NO_LABEL_DEF, FATAL, -/* xgettext:no-c-format */ -"No label definition for FORMAT statement at %0") -FFEBAD_MSG (FFEBAD_SECOND_ELSE_WHERE, FATAL, -/* xgettext:no-c-format */ -"Second occurrence of ELSE WHERE at %0 within WHERE at %1") -FFEBAD_MSG (FFEBAD_END_WO, WARN, -/* xgettext:no-c-format */ -"END statement at %0 missing `%A' keyword required for internal or module procedure(s) bounded by %1") -FFEBAD_MSG (FFEBAD_INVALID_MODULE_PROCEDURE, FATAL, -/* xgettext:no-c-format */ -"MODULE PROCEDURE statement at %0 disallowed because INTERFACE at %1 specifies no generic name, operator, or assignment") -FFEBAD_MSG (FFEBAD_BLOCKDATA_NOT_NAMED, FATAL, -/* xgettext:no-c-format */ -"BLOCK DATA name at %0 superfluous, no name specified at %1") -FFEBAD_MSG (FFEBAD_PROGRAM_NOT_NAMED, FATAL, -/* xgettext:no-c-format */ -"Program name at %0 superfluous, no PROGRAM statement specified at %1") -FFEBAD_MSG (FFEBAD_UNIT_WRONG_NAME, FATAL, -/* xgettext:no-c-format */ -"Program unit name at %0 not the same as name at %1") -FFEBAD_MSG (FFEBAD_TYPE_WRONG_NAME, FATAL, -/* xgettext:no-c-format */ -"Type name at %0 not the same as name at %1") -FFEBAD_MSG (FFEBAD_EOF_BEFORE_BLOCK_END, FATAL, -/* xgettext:no-c-format */ -"End of source file before end of block started at %0") -FFEBAD_MSG (FFEBAD_UNDEF_LABEL, FATAL, -/* xgettext:no-c-format */ -"Undefined label, first referenced at %0") -FFEBAD_MSG (FFEBAD_CONFLICTING_SAVES, WARN, -/* xgettext:no-c-format */ -"SAVE statement or attribute at %1 cannot be specified along with SAVE statement or attribute at %0") -FFEBAD_MSG (FFEBAD_CONFLICTING_ACCESSES, FATAL, -/* xgettext:no-c-format */ -"PUBLIC or PRIVATE statement at %1 cannot be specified along with PUBLIC or PRIVATE statement at %0") -FFEBAD_MSG (FFEBAD_RETURN_IN_MAIN, WARN, -/* xgettext:no-c-format */ -"RETURN statement at %0 invalid within a main program unit") -FFEBAD_MSG (FFEBAD_ALTRETURN_IN_PROGRAM, FATAL, -/* xgettext:no-c-format */ -"Alternate return specifier at %0 invalid within a main program unit") -FFEBAD_MSG (FFEBAD_ALTRETURN_IN_FUNCTION, FATAL, -/* xgettext:no-c-format */ -"Alternate return specifier at %0 invalid within a function") -FFEBAD_MSG (FFEBAD_DERIVTYP_ACCESS, FATAL, -/* xgettext:no-c-format */ -"Access specifier or PRIVATE statement at %0 invalid for derived-type definition within other than the specification part of a module") -FFEBAD_MSG (FFEBAD_DERIVTYP_ACCESS_FIRST, FATAL, -/* xgettext:no-c-format */ -"Access specifier at %0 must immediately follow derived-type statement at %1 with no intervening statements") -FFEBAD_MSG (FFEBAD_DERIVTYP_NO_COMPONENTS, FATAL, -/* xgettext:no-c-format */ -"No components specified as of %0 for derived-type definition beginning at %1") -FFEBAD_MSG (FFEBAD_STRUCT_NO_COMPONENTS, FATAL, -/* xgettext:no-c-format */ -"No components specified as of %0 for structure definition beginning at %1") -FFEBAD_MSG (FFEBAD_STRUCT_MISSING_NAME, FATAL, -/* xgettext:no-c-format */ -"Missing structure name for outer structure definition at %0") -FFEBAD_MSG (FFEBAD_STRUCT_IGNORING_FIELD, FATAL, -/* xgettext:no-c-format */ -"Field names at %0 for outer structure definition -- specify them in a subsequent RECORD statement instead") -FFEBAD_MSG (FFEBAD_STRUCT_MISSING_FIELD, FATAL, -/* xgettext:no-c-format */ -"Missing field name(s) for structure definition at %0 within structure definition at %1") -FFEBAD_MSG (FFEBAD_MAP_NO_COMPONENTS, FATAL, -/* xgettext:no-c-format */ -"No components specified as of %0 for map beginning at %1") -FFEBAD_MSG (FFEBAD_UNION_NO_TWO_MAPS, FATAL, -/* xgettext:no-c-format */ -"Zero or one maps specified as of %0 for union beginning at %1 -- at least two are required") -FFEBAD_MSG (FFEBAD_MISSING_SPECIFIER, FATAL, -/* xgettext:no-c-format */ -"Missing %A specifier in statement at %0") -FFEBAD_MSG (FFEBAD_NAMELIST_ITEMS, FATAL, -/* xgettext:no-c-format */ -"Items in I/O list starting at %0 invalid for namelist-directed I/O") -FFEBAD_MSG (FFEBAD_CONFLICTING_SPECS, FATAL, -/* xgettext:no-c-format */ -"Conflicting I/O control specifications at %0 and %1") -FFEBAD_MSG (FFEBAD_NO_UNIT_SPEC, FATAL, -/* xgettext:no-c-format */ -"No UNIT= specifier in I/O control list at %0") -FFEBAD_MSG (FFEBAD_MISSING_ADVANCE_SPEC, FATAL, -/* xgettext:no-c-format */ -"Specification at %0 requires ADVANCE=`NO' specification in same I/O control list") -FFEBAD_MSG (FFEBAD_MISSING_FORMAT_SPEC, FATAL, -/* xgettext:no-c-format */ -"Specification at %0 requires explicit FMT= specification in same I/O control list") -FFEBAD_MSG (FFEBAD_SPEC_VALUE, FATAL, -/* xgettext:no-c-format */ -LONG("Unrecognized value for character constant at %0 -- expecting %A") -/* xgettext:no-c-format */ -SHORT("Unrecognized value for character constant at %0")) -FFEBAD_MSG (FFEBAD_CASE_SECOND_DEFAULT, FATAL, -/* xgettext:no-c-format */ -"Second occurrence of CASE DEFAULT at %0 within SELECT CASE at %1") -FFEBAD_MSG (FFEBAD_CASE_DUPLICATE, FATAL, -/* xgettext:no-c-format */ -"Duplicate or overlapping case values/ranges at %0 and %1") -FFEBAD_MSG (FFEBAD_CASE_TYPE_DISAGREE, FATAL, -/* xgettext:no-c-format */ -"Type and/or kind-type parameter disagreement between CASE value or value within range at %0 and SELECT CASE at %1") -FFEBAD_MSG (FFEBAD_CASE_LOGICAL_RANGE, FATAL, -/* xgettext:no-c-format */ -"Range specification at %0 invalid for CASE statement within logical-type SELECT CASE statement") -FFEBAD_MSG (FFEBAD_CASE_BAD_RANGE, FATAL, -/* xgettext:no-c-format */ -LONG("Range specification at %0 invalid -- at least one expression must be specified, or use CASE DEFAULT") -/* xgettext:no-c-format */ -SHORT("Range specification at %0 invalid")) -FFEBAD_MSG (FFEBAD_CASE_RANGE_USELESS, INFORM, -/* xgettext:no-c-format */ -LONG("Range specification at %0 useless; first expression greater than second expression in range, so range can never be matched by any selection expression") -/* xgettext:no-c-format */ -SHORT("Useless range at %0")) -FFEBAD_MSG (FFEBAD_F90, FATAL, -/* xgettext:no-c-format */ -"Fortran 90 feature at %0 unsupported") -FFEBAD_MSG (FFEBAD_KINDTYPE, FATAL, -/* xgettext:no-c-format */ -LONG("Invalid kind at %0 for type at %1 -- unsupported or not permitted") -/* xgettext:no-c-format */ -SHORT("Invalid kind at %0 for type at %1")) -FFEBAD_MSG (FFEBAD_BAD_IMPLICIT, FATAL, -/* xgettext:no-c-format */ -LONG("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") -/* xgettext:no-c-format */ -SHORT("Cannot establish implicit type for initial letter `%A' at %0")) -FFEBAD_MSG (FFEBAD_SYMERR, FATAL, -/* xgettext:no-c-format */ -"Invalid declaration of or reference to symbol `%A' at %0 [initially seen at %1]") -FFEBAD_MSG (FFEBAD_LABEL_WRONG_PLACE, FATAL, -/* xgettext:no-c-format */ -LONG("Label definition %A (at %0) invalid -- must be in columns 1-5") -/* xgettext:no-c-format */ -SHORT("Invalid label definition %A (at %0)")) -FFEBAD_MSG (FFEBAD_NULL_ELEMENT, FATAL, -/* xgettext:no-c-format */ -"Null element at %0 for array reference at %1") -FFEBAD_MSG (FFEBAD_TOO_FEW_ELEMENTS, FATAL, -/* xgettext:no-c-format */ -"Too few elements (%A missing) as of %0 for array reference at %1") -FFEBAD_MSG (FFEBAD_TOO_MANY_ELEMENTS, FATAL, -/* xgettext:no-c-format */ -"Too many elements as of %0 for array reference at %1") -FFEBAD_MSG (FFEBAD_MISSING_COLON_IN_SUBSTR, FATAL, -/* xgettext:no-c-format */ -"Missing colon as of %0 in substring reference for %1") -FFEBAD_MSG (FFEBAD_BAD_SUBSTR, FATAL, -/* xgettext:no-c-format */ -"Invalid use at %0 of substring operator on %1") -FFEBAD_MSG (FFEBAD_RANGE_SUBSTR, WARN, -/* xgettext:no-c-format */ -"Substring begin/end point at %0 out of defined range") -FFEBAD_MSG (FFEBAD_RANGE_ARRAY, WARN, -/* xgettext:no-c-format */ -"Array element value at %0 out of defined range") -FFEBAD_MSG (FFEBAD_EXPR_WRONG, FATAL, -/* xgettext:no-c-format */ -"Expression at %0 has incorrect data type or rank for its context") -FFEBAD_MSG (FFEBAD_DIV_BY_ZERO, WARN, -/* xgettext:no-c-format */ -"Division by 0 (zero) at %0 (IEEE not yet supported)") -FFEBAD_MSG (FFEBAD_DO_STEP_ZERO, FATAL, -/* xgettext:no-c-format */ -"%A step count known to be 0 (zero) at %0") -FFEBAD_MSG (FFEBAD_DO_END_OVERFLOW, WARN, -/* xgettext:no-c-format */ -"%A end value plus step count known to overflow at %0") -FFEBAD_MSG (FFEBAD_DO_IMP_OVERFLOW, WARN, -/* xgettext:no-c-format */ -"%A begin, end, and step-count values known to result in implementation-dependent behavior due to overflow(s) in intermediate calculations at %0") -FFEBAD_MSG (FFEBAD_DO_NULL, WARN, -/* xgettext:no-c-format */ -"%A begin, end, and step-count values known to result in no iterations at %0") -FFEBAD_MSG (FFEBAD_BAD_TYPES, FATAL, -/* xgettext:no-c-format */ -"Type disagreement between expressions at %0 and %1") -FFEBAD_MSG (FFEBAD_FORMAT_EXPR_SPEC, FATAL, -/* xgettext:no-c-format */ -LONG("Run-time expression at %0 in FORMAT statement that does not follow the first executable statement in the program unit -- move the statement") -/* xgettext:no-c-format */ -SHORT("FORMAT at %0 with run-time expression must follow first executable statement")) -FFEBAD_MSG (FFEBAD_BAD_IMPDO, FATAL, -/* xgettext:no-c-format */ -LONG("Unexpected token at %0 in implied-DO construct at %1 -- form of implied-DO is `(item-list,do-var=start,end[,incr])'") -/* xgettext:no-c-format */ -SHORT("Unexpected token at %0 in implied-DO construct at %1")) -FFEBAD_MSG (FFEBAD_BAD_IMPDCL, FATAL, -/* xgettext:no-c-format */ -"No specification for implied-DO iterator `%A' at %0") -FFEBAD_MSG (FFEBAD_IMPDO_PAREN, WARN, -/* xgettext:no-c-format */ -"Gratuitous parentheses surround implied-DO construct at %0") -FFEBAD_MSG (FFEBAD_ZERO_SIZE, FATAL, -/* xgettext:no-c-format */ -"Zero-size specification invalid at %0") -FFEBAD_MSG (FFEBAD_ZERO_ARRAY, FATAL, -/* xgettext:no-c-format */ -"Zero-size array at %0") -FFEBAD_MSG (FFEBAD_BAD_COMPLEX, FATAL, -/* xgettext:no-c-format */ -"Target machine does not support complex entity of kind specified at %0") -FFEBAD_MSG (FFEBAD_BAD_DBLCMPLX, FATAL, -/* xgettext:no-c-format */ -"Target machine does not support DOUBLE COMPLEX, specified at %0") -FFEBAD_MSG (FFEBAD_BAD_POWER, WARN, -/* xgettext:no-c-format */ -"Attempt to raise constant zero to a power at %0") -FFEBAD_MSG (FFEBAD_BOOL_ARGS_TYPE, FATAL, -/* xgettext:no-c-format */ -LONG("Boolean/logical operator at %0 must operate on two subexpressions of logical type, but neither subexpression at %1 or %2 is of logical type") -/* xgettext:no-c-format */ -SHORT("Invalid operands at %1 and %2 for boolean operator at %0")) -FFEBAD_MSG (FFEBAD_BOOL_ARG_TYPE, FATAL, -/* xgettext:no-c-format */ -LONG("Boolean/logical operator at %0 must operate on two subexpressions of logical type, but the subexpression at %1 is not of logical type") -/* xgettext:no-c-format */ -SHORT("Invalid operand at %1 for boolean operator at %0")) -FFEBAD_MSG (FFEBAD_BOOL_ARG_KIND, FATAL, -/* xgettext:no-c-format */ -LONG("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") -/* xgettext:no-c-format */ -SHORT("Invalid operand (is %A) at %1 for boolean operator at %0")) -FFEBAD_MSG (FFEBAD_NOT_ARG_TYPE, FATAL, -/* xgettext:no-c-format */ -LONG(".NOT. operator at %0 must operate on subexpression of logical type, but the subexpression at %1 is not of logical type") -/* xgettext:no-c-format */ -SHORT("Invalid operand at %1 for .NOT. operator at %0")) -FFEBAD_MSG (FFEBAD_NOT_ARG_KIND, FATAL, -/* xgettext:no-c-format */ -LONG(".NOT. operator at %0 must operate on scalar subexpressions -- but the subexpression at %1 is %A") -/* xgettext:no-c-format */ -SHORT("Invalid operand (is %A) at %1 for .NOT. operator at %0")) -FFEBAD_MSG (FFEBAD_EQOP_ARGS_TYPE, FATAL, -/* xgettext:no-c-format */ -LONG("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") -/* xgettext:no-c-format */ -SHORT("Invalid operands at %1 and %2 for equality operator at %0")) -FFEBAD_MSG (FFEBAD_EQOP_ARG_TYPE, FATAL, -/* xgettext:no-c-format */ -LONG("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") -/* xgettext:no-c-format */ -SHORT("Invalid operand at %1 for equality operator at %0")) -FFEBAD_MSG (FFEBAD_EQOP_ARG_KIND, FATAL, -/* xgettext:no-c-format */ -LONG("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") -/* xgettext:no-c-format */ -SHORT("Invalid operand (is %A) at %1 for equality operator at %0")) -FFEBAD_MSG (FFEBAD_RELOP_ARGS_TYPE, FATAL, -/* xgettext:no-c-format */ -LONG("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") -/* xgettext:no-c-format */ -SHORT("Invalid operands at %1 and %2 for relational operator at %0")) -FFEBAD_MSG (FFEBAD_RELOP_ARG_TYPE, FATAL, -/* xgettext:no-c-format */ -LONG("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") -/* xgettext:no-c-format */ -SHORT("Invalid operand at %1 for relational operator at %0")) -FFEBAD_MSG (FFEBAD_RELOP_ARG_KIND, FATAL, -/* xgettext:no-c-format */ -LONG("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") -/* xgettext:no-c-format */ -SHORT("Invalid operand (is %A) at %1 for relational operator at %0")) -FFEBAD_MSG (FFEBAD_INTRINSIC_REF, FATAL, -/* xgettext:no-c-format */ -LONG("Reference to intrinsic `%A' at %0 invalid -- one or more arguments have incorrect type") -/* xgettext:no-c-format */ -SHORT("Invalid reference to intrinsic `%A' at %0")) -FFEBAD_MSG (FFEBAD_INTRINSIC_TOOFEW, FATAL, -/* xgettext:no-c-format */ -LONG("Too few arguments passed to intrinsic `%A' at %0") -/* xgettext:no-c-format */ -SHORT("Too few arguments for intrinsic `%A' at %0")) -FFEBAD_MSG (FFEBAD_INTRINSIC_TOOMANY, FATAL, -/* xgettext:no-c-format */ -LONG("Too many arguments passed to intrinsic `%A' at %0") -/* xgettext:no-c-format */ -SHORT("Too many arguments for intrinsic `%A' at %0")) -FFEBAD_MSG (FFEBAD_INTRINSIC_DISABLED, FATAL, -/* xgettext:no-c-format */ -LONG("Reference to disabled intrinsic `%A' at %0") -/* xgettext:no-c-format */ -SHORT("Disabled intrinsic `%A' at %0")) -FFEBAD_MSG (FFEBAD_INTRINSIC_IS_SUBR, FATAL, -/* xgettext:no-c-format */ -LONG("Reference to intrinsic subroutine `%A' as if it were a function at %0") -/* xgettext:no-c-format */ -SHORT("Function reference to intrinsic subroutine `%A' at %0")) -FFEBAD_MSG (FFEBAD_INTRINSIC_IS_FUNC, FATAL, -/* xgettext:no-c-format */ -LONG("Reference to intrinsic function `%A' as if it were a subroutine at %0") -/* xgettext:no-c-format */ -SHORT("Subroutine reference to intrinsic function `%A' at %0")) -FFEBAD_MSG (FFEBAD_INTRINSIC_UNIMPL, FATAL, -/* xgettext:no-c-format */ -LONG("Reference to unimplemented intrinsic `%A' at %0 -- use EXTERNAL to reference user-written procedure with this name") -/* xgettext:no-c-format */ -SHORT("Unimplemented intrinsic `%A' at %0")) -FFEBAD_MSG (FFEBAD_INTRINSIC_UNIMPLW, WARN, -/* xgettext:no-c-format */ -LONG("Reference to unimplemented intrinsic `%A' at %0 (assumed EXTERNAL)") -/* xgettext:no-c-format */ -SHORT("Unimplemented intrinsic `%A' at %0 (assumed EXTERNAL)")) -FFEBAD_MSG (FFEBAD_INTRINSIC_AMBIG, FATAL, -/* xgettext:no-c-format */ -"Reference to generic intrinsic `%A' at %0 could be to form %B or %C") -FFEBAD_MSG (FFEBAD_INTRINSIC_CMPAMBIG, FATAL, -/* xgettext:no-c-format */ -"Ambiguous use of intrinsic `%A' at %0 [info -f g77 M CMPAMBIG]") -FFEBAD_MSG (FFEBAD_INTRINSIC_EXPIMP, WARN, -/* xgettext:no-c-format */ -"Intrinsic `%A' referenced %Bly at %0, %Cly at %1 [info -f g77 M EXPIMP]") -FFEBAD_MSG (FFEBAD_INTRINSIC_GLOBAL, WARN, -/* xgettext:no-c-format */ -"Same name `%A' used for %B at %0 and %C at %1 [info -f g77 M INTGLOB]") -FFEBAD_MSG (FFEBAD_INTRINSIC_TYPE, WARN, -/* xgettext:no-c-format */ -"Explicit type declaration for intrinsic `%A' disagrees with invocation at %0") -FFEBAD_MSG (FFEBAD_OPEN_INCLUDE, FATAL, -/* xgettext:no-c-format */ -"Unable to open INCLUDE file `%A' at %0") -FFEBAD_MSG (FFEBAD_DOITER, FATAL, -/* xgettext:no-c-format */ -LONG("Attempt to modify variable `%A' at %0 while it serves as DO-loop iterator at %1") -/* xgettext:no-c-format */ -SHORT("Modification of DO-loop iterator `%A' at %0")) -FFEBAD_MSG (FFEBAD_DOITER_IMPDO, FATAL, -/* xgettext:no-c-format */ -LONG("Attempt to modify variable `%A' via item #%B in list at %0 while it serves as implied-DO iterator at %1") -/* xgettext:no-c-format */ -SHORT("Modification of DO-loop iterator `%A' at %0")) -FFEBAD_MSG (FFEBAD_TOO_MANY_DIMS, FATAL, -/* xgettext:no-c-format */ -LONG("Array has too many dimensions, as of dimension specifier at %0") -/* xgettext:no-c-format */ -SHORT("Too many dimensions at %0")) -FFEBAD_MSG (FFEBAD_NULL_ARGUMENT, FATAL, -/* xgettext:no-c-format */ -"Null argument at %0 for statement function reference at %1") -FFEBAD_MSG (FFEBAD_NULL_ARGUMENT_W, WARN, -/* xgettext:no-c-format */ -"Null argument at %0 for procedure invocation at %1") -FFEBAD_MSG (FFEBAD_TOO_FEW_ARGUMENTS, FATAL, -/* xgettext:no-c-format */ -"%A too few arguments (starting with dummy argument `%B') as of %0 for statement function reference at %1") -FFEBAD_MSG (FFEBAD_TOO_MANY_ARGUMENTS, FATAL, -/* xgettext:no-c-format */ -"%A too many arguments as of %0 for statement function reference at %1") -FFEBAD_MSG (FFEBAD_ARRAY_AS_SFARG, FATAL, -/* xgettext:no-c-format */ -"Array supplied at %1 for dummy argument `%A' in statement function reference at %0") -FFEBAD_MSG (FFEBAD_FORMAT_UNSUPPORTED, FATAL, -/* xgettext:no-c-format */ -"Unsupported FORMAT specifier at %0") -FFEBAD_MSG (FFEBAD_FORMAT_VARIABLE, FATAL, -/* xgettext:no-c-format */ -"Variable-expression FORMAT specifier at %0 -- unsupported") -FFEBAD_MSG (FFEBAD_OPEN_UNSUPPORTED, FATAL, -/* xgettext:no-c-format */ -LONG("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") -/* xgettext:no-c-format */ -SHORT("Unsupported OPEN control item at %0")) -FFEBAD_MSG (FFEBAD_INQUIRE_UNSUPPORTED, FATAL, -/* xgettext:no-c-format */ -LONG("Unsupported INQUIRE control item at %0 -- ACTION=, CARRIAGECONTROL=, DEFAULTFILE=, DELIM=, KEYED=, ORGANIZATION=, PAD=, POSITION=, READ=, READWRITE=, RECORDTYPE=, and WRITE= are not supported") -/* xgettext:no-c-format */ -SHORT("Unsupported INQUIRE control item at %0")) -FFEBAD_MSG (FFEBAD_READ_UNSUPPORTED, FATAL, -/* xgettext:no-c-format */ -LONG("Unsupported READ control item at %0 -- ADVANCE=, EOR=, KEYEQ=, KEYGE=, KEYGT=, KEYID=, NULLS=, and SIZE= are not supported") -/* xgettext:no-c-format */ -SHORT("Unsupported READ control item at %0")) -FFEBAD_MSG (FFEBAD_WRITE_UNSUPPORTED, FATAL, -/* xgettext:no-c-format */ -LONG("Unsupported WRITE control item at %0 -- ADVANCE= and EOR= are not supported") -/* xgettext:no-c-format */ -SHORT("Unsupported WRITE control item at %0")) -FFEBAD_MSG (FFEBAD_VXT_UNSUPPORTED, FATAL, -/* xgettext:no-c-format */ -"Unsupported VXT statement at %0") -FFEBAD_MSG (FFEBAD_DATA_REINIT, FATAL, -/* xgettext:no-c-format */ -"Attempt to specify second initial value for `%A' at %0") -FFEBAD_MSG (FFEBAD_DATA_TOOFEW, FATAL, -/* xgettext:no-c-format */ -"Too few initial values in list of initializers for `%A' at %0") -FFEBAD_MSG (FFEBAD_DATA_TOOMANY, FATAL, -/* xgettext:no-c-format */ -"Too many initial values in list of initializers starting at %0") -FFEBAD_MSG (FFEBAD_DATA_RANGE, FATAL, -/* xgettext:no-c-format */ -"Array or substring specification for `%A' out of range in statement at %0") -FFEBAD_MSG (FFEBAD_DATA_SUBSCRIPT, FATAL, -/* xgettext:no-c-format */ -"Array subscript #%B out of range for initialization of `%A' in statement at %0") -FFEBAD_MSG (FFEBAD_DATA_ZERO, FATAL, -/* xgettext:no-c-format */ -"Implied do-loop step count of 0 (zero) for iteration variable `%A' in statement at %0") -FFEBAD_MSG (FFEBAD_DATA_EMPTY, FATAL, -/* xgettext:no-c-format */ -"Implied do-loop iteration count of 0 (zero) for iteration variable `%A' in statement at %0") -FFEBAD_MSG (FFEBAD_DATA_EVAL, FATAL, -/* xgettext:no-c-format */ -"Not an integer constant expression in implied do-loop in statement at %0") -FFEBAD_MSG (FFEBAD_DATA_MULTIPLE, FATAL, -/* xgettext:no-c-format */ -"Attempt to specify second initial value for element of `%A' at %0") -FFEBAD_MSG (FFEBAD_EQUIV_COMMON, FATAL, -/* xgettext:no-c-format */ -"Attempt to EQUIVALENCE common areas `%A' and `%B' at %0") -FFEBAD_MSG (FFEBAD_EQUIV_ALIGN, FATAL, -/* xgettext:no-c-format */ -"Can't place `%A' as directed by EQUIVALENCE due to alignment restrictions") -FFEBAD_MSG (FFEBAD_EQUIV_MISMATCH, FATAL, -/* xgettext:no-c-format */ -"Mismatched EQUIVALENCE requirements for placement of `%A' at both %C and %D bytes offset from `%B'") -FFEBAD_MSG (FFEBAD_EQUIV_RANGE, FATAL, -/* xgettext:no-c-format */ -"Array or substring specification for `%A' out of range in EQUIVALENCE statement") -FFEBAD_MSG (FFEBAD_EQUIV_SUBSTR, FATAL, -/* xgettext:no-c-format */ -"Substring of non-CHARACTER entity `%A' in EQUIVALENCE statement") -FFEBAD_MSG (FFEBAD_EQUIV_ARRAY, FATAL, -/* xgettext:no-c-format */ -"Array reference to scalar variable `%A' in EQUIVALENCE statement") -FFEBAD_MSG (FFEBAD_EQUIV_SUBSCRIPT, WARN, -/* xgettext:no-c-format */ -"Array subscript #%B out of range for EQUIVALENCE of `%A'") -FFEBAD_MSG (FFEBAD_COMMON_PAD, WARN, -/* xgettext:no-c-format */ -LONG("Padding of %A %D required before `%B' in common block `%C' at %0 -- consider reordering members, largest-type-size first") -/* xgettext:no-c-format */ -SHORT("Padding of %A %D required before `%B' in common block `%C' at %0")) -FFEBAD_MSG (FFEBAD_COMMON_NEG, FATAL, -/* xgettext:no-c-format */ -"Attempt to extend COMMON area beyond its starting point via EQUIVALENCE of `%A'") -FFEBAD_MSG (FFEBAD_EQUIV_FEW, FATAL, -/* xgettext:no-c-format */ -"Too few elements in reference to array `%A' in EQUIVALENCE statement") -FFEBAD_MSG (FFEBAD_EQUIV_MANY, FATAL, -/* xgettext:no-c-format */ -"Too many elements in reference to array `%A' in EQUIVALENCE statement") -FFEBAD_MSG (FFEBAD_MIXED_TYPES, WARN, -/* xgettext:no-c-format */ -"Mixed CHARACTER and non-CHARACTER types via COMMON/EQUIVALENCE -- for example, `%A' and `%B'") -FFEBAD_MSG (FFEBAD_IMPLICIT_ADJLEN, FATAL, -/* xgettext:no-c-format */ -LONG("Invalid length specification at %0 for IMPLICIT statement -- must be integer constant expression") -/* xgettext:no-c-format */ -SHORT("Invalid length specification at %0")) -FFEBAD_MSG (FFEBAD_ENTRY_CONFLICTS, FATAL, -/* xgettext:no-c-format */ -LONG("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") -/* xgettext:no-c-format */ -SHORT("Type of ENTRY point at %0 to function conflicts with type(s) of previous entrypoint(s)")) -FFEBAD_MSG (FFEBAD_RETURN_VALUE_UNSET, WARN, -/* xgettext:no-c-format */ -"Return value `%A' for FUNCTION at %0 not referenced in subprogram") -FFEBAD_MSG (FFEBAD_COMMON_ALREADY_INIT, FATAL, -/* xgettext:no-c-format */ -LONG("Common block `%A' initialized at %0 already initialized at %1 -- only one program unit may specify initial values for a particular common block") -/* xgettext:no-c-format */ -SHORT("Common block `%A' initialized at %0 already initialized at %1")) -FFEBAD_MSG (FFEBAD_COMMON_INIT_PAD, WARN, -/* xgettext:no-c-format */ -LONG("Initial padding for common block `%A' is %B %C at %0 -- consider reordering members, largest-type-size first") -/* xgettext:no-c-format */ -SHORT("Initial padding for common block `%A' is %B %C at %0")) -FFEBAD_MSG (FFEBAD_COMMON_DIFF_PAD, FATAL, -/* xgettext:no-c-format */ -LONG("Initial padding for common block `%A' is %B %D at %0 but %C %E at %1 -- consider reordering members, largest-type-size first") -/* xgettext:no-c-format */ -SHORT("Initial padding for common block `%A' is %B %D at %0 but %C %E at %1")) -FFEBAD_MSG (FFEBAD_COMMON_DIFF_SAVE, WARN, -/* xgettext:no-c-format */ -"Common block `%A' is SAVEd, explicitly or implicitly, at %0 but not SAVEd at %1") -FFEBAD_MSG (FFEBAD_COMMON_DIFF_SIZE, WARN, -/* xgettext:no-c-format */ -"Common block `%A' is %B %D in length at %0 but %C %E at %1") -FFEBAD_MSG (FFEBAD_COMMON_ENLARGED, FATAL, -/* xgettext:no-c-format */ -LONG("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") -/* xgettext:no-c-format */ -SHORT("Common block `%A' is initialized to %B %D long at %0 but enlarged to %C %E at %1")) -FFEBAD_MSG (FFEBAD_COMMON_BLANK_INIT, WARN, -/* xgettext:no-c-format */ -"Blank common initialized at %0") -FFEBAD_MSG (FFEBAD_NEED_INTRINSIC, WARN, -/* xgettext:no-c-format */ -"Intrinsic `%A' is passed as actual argument at %0 but not explicitly declared INTRINSIC") -FFEBAD_MSG (FFEBAD_NEED_EXTERNAL, WARN, -/* xgettext:no-c-format */ -"External procedure `%A' is passed as actual argument at %0 but not explicitly declared EXTERNAL") -FFEBAD_MSG (FFEBAD_SYMBOL_UPPER_CASE, WARN, -/* xgettext:no-c-format */ -"Character `%A' (for example) is upper-case in symbol name at %0") -FFEBAD_MSG (FFEBAD_SYMBOL_LOWER_CASE, WARN, -/* xgettext:no-c-format */ -"Character `%A' (for example) is lower-case in symbol name at %0") -FFEBAD_MSG (FFEBAD_SYMBOL_NOLOWER_INITCAP, WARN, -/* xgettext:no-c-format */ -"Character `%A' not followed at some point by lower-case character in symbol name at %0") -FFEBAD_MSG (FFEBAD_SYMBOL_LOWER_INITCAP, WARN, -/* xgettext:no-c-format */ -"Initial character `%A' is lower-case in symbol name at %0") -FFEBAD_MSG (FFEBAD_DO_REAL, WARN, -/* xgettext:no-c-format */ -LONG("DO-variable `%A' is type REAL or DOUBLE PRECISION at %0 -- unexpected behavior likely") -/* xgettext:no-c-format */ -SHORT("DO-variable `%A' is type REAL or DOUBLE PRECISION at %0")) -FFEBAD_MSG (FFEBAD_NAMELIST_CASE, WARN, -/* xgettext:no-c-format */ -"NAMELIST not adequately supported by run-time library for source files with case preserved") -FFEBAD_MSG (FFEBAD_NESTED_PERCENT, WARN, -/* xgettext:no-c-format */ -"Nested %% construct (%%VAL, %%REF, or %%DESCR) at %0") -FFEBAD_MSG (FFEBAD_ACTUALARG, WARN, -/* xgettext:no-c-format */ -LONG("Invalid actual argument at %0 -- replace hollerith constants with %%REF('string') and typeless constants with INTEGER constant equivalents, or use -fugly-args or -fugly") -/* xgettext:no-c-format */ -SHORT("Invalid actual argument at %0")) -FFEBAD_MSG (FFEBAD_QUAD_UNSUPPORTED, FATAL, -/* xgettext:no-c-format */ -LONG("Quadruple-precision floating-point unsupported -- treating constant at %0 as double-precision") -/* xgettext:no-c-format */ -SHORT("Quadruple-precision floating-point unsupported")) -FFEBAD_MSG (FFEBAD_TOO_BIG_INIT, WARN, -/* xgettext:no-c-format */ -LONG("Initialization of large (%B-unit) aggregate area `%A' at %0 slow and takes lots of memory during g77 compile") -/* xgettext:no-c-format */ -SHORT("This could take a while (initializing `%A' at %0)...")) -FFEBAD_MSG (FFEBAD_BLOCKDATA_STMT, FATAL, -/* xgettext:no-c-format */ -"Statement at %0 invalid in BLOCK DATA program unit at %1") -FFEBAD_MSG (FFEBAD_TRUNCATING_CHARACTER, FATAL, -/* xgettext:no-c-format */ -"Truncating characters on right side of character constant at %0") -FFEBAD_MSG (FFEBAD_TRUNCATING_HOLLERITH, FATAL, -/* xgettext:no-c-format */ -"Truncating characters on right side of hollerith constant at %0") -FFEBAD_MSG (FFEBAD_TRUNCATING_NUMERIC, FATAL, -/* xgettext:no-c-format */ -"Truncating non-zero data on left side of numeric constant at %0") -FFEBAD_MSG (FFEBAD_TRUNCATING_TYPELESS, FATAL, -/* xgettext:no-c-format */ -"Truncating non-zero data on left side of typeless constant at %0") -FFEBAD_MSG (FFEBAD_TYPELESS_OVERFLOW, FATAL, -/* xgettext:no-c-format */ -"Typeless constant at %0 too large") -FFEBAD_MSG (FFEBAD_AMPERSAND, WARN, -/* xgettext:no-c-format */ -"First-column ampersand continuation at %0") -FFEBAD_MSG (FFEBAD_FILEWIDE_ALREADY_SEEN, FATAL, -/* xgettext:no-c-format */ -"Global name `%A' defined at %0 already defined at %1 [info -f g77 M GLOBALS]") -FFEBAD_MSG (FFEBAD_FILEWIDE_ALREADY_SEEN_W, WARN, -/* xgettext:no-c-format */ -"Global name `%A' defined at %0 already defined at %1 [info -f g77 M GLOBALS]") -FFEBAD_MSG (FFEBAD_FILEWIDE_DISAGREEMENT, FATAL, -/* xgettext:no-c-format */ -"Global name `%A' is %B at %0 but is %C at %1 [info -f g77 M GLOBALS]") -FFEBAD_MSG (FFEBAD_FILEWIDE_DISAGREEMENT_W, WARN, -/* xgettext:no-c-format */ -"Global name `%A' is %B at %0 but is %C at %1 [info -f g77 M GLOBALS]") -FFEBAD_MSG (FFEBAD_FILEWIDE_TYPE_MISMATCH, FATAL, -/* xgettext:no-c-format */ -"Global name `%A' at %0 has different type at %1 [info -f g77 M GLOBALS]") -FFEBAD_MSG (FFEBAD_FILEWIDE_TYPE_MISMATCH_W, WARN, -/* xgettext:no-c-format */ -"Global name `%A' at %0 has different type at %1 [info -f g77 M GLOBALS]") -FFEBAD_MSG (FFEBAD_FILEWIDE_NARGS, FATAL, -/* xgettext:no-c-format */ -"Too %B arguments passed to `%A' at %0 versus definition at %1 [info -f g77 M GLOBALS]") -FFEBAD_MSG (FFEBAD_FILEWIDE_NARGS_W, WARN, -/* xgettext:no-c-format */ -"Too %B arguments for `%A' at %0 versus invocation at %1 [info -f g77 M GLOBALS]") -FFEBAD_MSG (FFEBAD_FILEWIDE_ARG, FATAL, -/* xgettext:no-c-format */ -"Argument #%B of `%A' is %C at %0 but is %D at %1 [info -f g77 M GLOBALS]") -FFEBAD_MSG (FFEBAD_FILEWIDE_ARG_W, WARN, -/* xgettext:no-c-format */ -"Argument #%B of `%A' is %C at %0 but is %D at %1 [info -f g77 M GLOBALS]") -FFEBAD_MSG (FFEBAD_ARRAY_LARGE, FATAL, -/* xgettext:no-c-format */ -"Array `%A' at %0 is too large to handle") -FFEBAD_MSG (FFEBAD_SFUNC_UNUSED, WARN, -/* xgettext:no-c-format */ -"Statement function `%A' defined at %0 is not used") -FFEBAD_MSG (FFEBAD_INTRINSIC_Y2KBAD, WARN, -/* xgettext:no-c-format */ -"Intrinsic `%A', invoked at %0, known to be non-Y2K-compliant [info -f g77 M Y2KBAD]") -FFEBAD_MSG (FFEBAD_NOCANDO, DISASTER, -/* xgettext:no-c-format */ -"Internal compiler error -- cannot perform operation") - -#undef INFORM -#undef TRIVIAL -#undef WARN -#undef PECULIAR -#undef FATAL -#undef WEIRD -#undef SEVERE -#undef DISASTER diff --git a/contrib/gcc-3.4/gcc/f/bad.h b/contrib/gcc-3.4/gcc/f/bad.h deleted file mode 100644 index bd7581e50d..0000000000 --- a/contrib/gcc-3.4/gcc/f/bad.h +++ /dev/null @@ -1,106 +0,0 @@ -/* bad.h -- Public #include File (module.h template V1.0) - Copyright (C) 1995, 2002 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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 GCC_F_BAD_H -#define GCC_F_BAD_H - -/* Simple definitions and enumerations. */ - -typedef enum - { -#define FFEBAD_MSG(KWD,SEV,MSG) KWD, -#include "bad.def" -#undef FFEBAD_MSG - 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, - const char *msgid); -void ffebad_string (const 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(msgid,s) ffebad_start_ (FALSE, FFEBAD, (s), (msgid)) -#define ffebad_start_msg_lex(msgid,s) ffebad_start_ (TRUE, FFEBAD, (s), (msgid)) -#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 /* ! GCC_F_BAD_H */ diff --git a/contrib/gcc-3.4/gcc/f/bit.c b/contrib/gcc-3.4/gcc/f/bit.c deleted file mode 100644 index 00f064b1da..0000000000 --- a/contrib/gcc-3.4/gcc/f/bit.c +++ /dev/null @@ -1,200 +0,0 @@ -/* bit.c -- Implementation File (module.c template V1.0) - Copyright (C) 1995 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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 "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/contrib/gcc-3.4/gcc/f/bit.h b/contrib/gcc-3.4/gcc/f/bit.h deleted file mode 100644 index 6b559efe66..0000000000 --- a/contrib/gcc-3.4/gcc/f/bit.h +++ /dev/null @@ -1,84 +0,0 @@ -/* bit.h -- Public #include File (module.h template V1.0) - Copyright (C) 1995 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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 GCC_F_BIT_H -#define GCC_F_BIT_H - -/* 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 /* ! GCC_F_BIT_H */ diff --git a/contrib/gcc-3.4/gcc/f/bld-op.def b/contrib/gcc-3.4/gcc/f/bld-op.def deleted file mode 100644 index 737dcc7e2f..0000000000 --- a/contrib/gcc-3.4/gcc/f/bld-op.def +++ /dev/null @@ -1,69 +0,0 @@ -/* bld-op.def -- Public #include File (module.h template V1.0) - Copyright (C) 1995 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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/contrib/gcc-3.4/gcc/f/bld.c b/contrib/gcc-3.4/gcc/f/bld.c deleted file mode 100644 index d3000695ce..0000000000 --- a/contrib/gcc-3.4/gcc/f/bld.c +++ /dev/null @@ -1,3135 +0,0 @@ -/* bld.c -- Implementation File (module.c template V1.0) - Copyright (C) 1995, 1996, 2003, 2004 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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 "bld.h" -#include "bit.h" -#include "info.h" -#include "lex.h" -#include "malloc.h" -#include "target.h" -#include "where.h" -#include "real.h" - -/* Externals defined here. */ - -const ffebldArity ffebld_arity_op_[(int) FFEBLD_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 FFETARGET_okCHARACTER1 -static ffebldConstant ffebld_constant_character1_; -#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_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_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_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 -static ffebldConstant ffebld_constant_hollerith_; -static ffebldConstant ffebld_constant_typeless_[FFEBLD_constTYPELESS_LAST - - FFEBLD_constTYPELESS_FIRST + 1]; - -static const char *const 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_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_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_okCHARACTER1 - case FFEBLD_constCHARACTER1: - return ffetarget_cmp_character1 (ffebld_constant_character1 (c1), - ffebld_constant_character1 (c2)); -#endif - - default: - assert ("bad constant type" == NULL); - return 0; - } -} - -/* 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_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_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_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_okCHARACTER1 - case FFEBLD_constCHARACTER1: - return ffetarget_iszero_character1 (ffebld_constant_character1 (c)); -#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 nc; - ffebldConstant P; - ffebldConstant Q; - int cmp = 0; - P = ffebld_constant_character1_; - Q = P; - if (!P) - { - /* make this node the root */ - nc = malloc_new_kp (ffebld_constant_pool(), - "FFEBLD_constCHARACTER1", - sizeof (*nc)); - nc->consttype = FFEBLD_constCHARACTER1; - nc->u.character1 = val; - nc->hook = FFECOM_constantNULL; - nc->llink = NULL; - nc->rlink = NULL; - ffebld_constant_character1_ = nc; - return nc; - } - else - while (P) - { - Q = P; - cmp = ffetarget_cmp_character1 (val, ffebld_constant_character1 (P)); - if (cmp > 0) - P = P->llink; - else if (cmp < 0) - P = P->rlink; - else - return P; - } - - nc = malloc_new_kp (ffebld_constant_pool(), - "FFEBLD_constCHARACTER1", - sizeof (*nc)); - nc->consttype = FFEBLD_constCHARACTER1; - nc->u.character1 = val; - nc->hook = FFECOM_constantNULL; - nc->llink = NULL; - nc->rlink = NULL; - - if (cmp < 0) - Q->llink = nc; - else - Q->rlink = 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 nc; - ffebldConstant P; - ffebldConstant Q; - int cmp = 0; - P = ffebld_constant_complex1_; - Q = P; - if (!P) - { - /* make this node the root */ - nc = malloc_new_kp (ffebld_constant_pool(), - "FFEBLD_constCOMPLEX1", - sizeof (*nc)); - nc->consttype = FFEBLD_constCOMPLEX1; - nc->u.complex1 = val; - nc->hook = FFECOM_constantNULL; - nc->llink = NULL; - nc->rlink = NULL; - ffebld_constant_complex1_ = nc; - return nc; - } - else - while (P) - { - Q = P; - cmp = ffetarget_cmp_real1 (val.real, - ffebld_constant_complex1 (P).real); - if (cmp == 0) - cmp = ffetarget_cmp_real1 (val.imaginary, - ffebld_constant_complex1 (P).imaginary); - if (cmp > 0) - P = P->llink; - else if (cmp < 0) - P = P->rlink; - else - return P; - } - - nc = malloc_new_kp (ffebld_constant_pool(), - "FFEBLD_constCOMPLEX1", - sizeof (*nc)); - nc->consttype = FFEBLD_constCOMPLEX1; - nc->u.complex1 = val; - nc->hook = FFECOM_constantNULL; - nc->llink = NULL; - nc->rlink = NULL; - - if (cmp < 0) - Q->llink = nc; - else - Q->rlink = 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 nc; - ffebldConstant P; - ffebldConstant Q; - int cmp = 0; - P = ffebld_constant_complex2_; - Q = P; - if (!P) - { - /* make this node the root */ - nc = malloc_new_kp (ffebld_constant_pool(), - "FFEBLD_constCOMPLEX2", - sizeof (*nc)); - nc->consttype = FFEBLD_constCOMPLEX2; - nc->u.complex2 = val; - nc->hook = FFECOM_constantNULL; - nc->llink = NULL; - nc->rlink = NULL; - ffebld_constant_complex2_ = nc; - return nc; - } - else - while (P) - { - Q = P; - cmp = ffetarget_cmp_real2 (val.real, - ffebld_constant_complex2 (P).real); - if (cmp == 0) - cmp = ffetarget_cmp_real2 (val.imaginary, - ffebld_constant_complex2 (P).imaginary); - if (cmp > 0) - P = P->llink; - else if (cmp < 0) - P = P->rlink; - else - return P; - } - - nc = malloc_new_kp (ffebld_constant_pool(), - "FFEBLD_constCOMPLEX2", - sizeof (*nc)); - nc->consttype = FFEBLD_constCOMPLEX2; - nc->u.complex2 = val; - nc->hook = FFECOM_constantNULL; - nc->llink = NULL; - nc->rlink = NULL; - - if (cmp < 0) - Q->llink = nc; - else - Q->rlink = 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 nc; - ffebldConstant P; - ffebldConstant Q; - int cmp = 0; - P = ffebld_constant_hollerith_; - Q = P; - if (!P) - { - /* make this node the root */ - nc = malloc_new_kp (ffebld_constant_pool(), - "FFEBLD_constHOLLERITH", - sizeof (*nc)); - nc->consttype = FFEBLD_constHOLLERITH; - nc->u.hollerith = val; - nc->hook = FFECOM_constantNULL; - nc->llink = NULL; - nc->rlink = NULL; - ffebld_constant_hollerith_ = nc; - return nc; - } - else - while (P) - { - Q = P; - cmp = ffetarget_cmp_hollerith (val, ffebld_constant_hollerith (P)); - if (cmp > 0) - P = P->llink; - else if (cmp < 0) - P = P->rlink; - else - return P; - } - - nc = malloc_new_kp (ffebld_constant_pool(), - "FFEBLD_constHOLLERITH", - sizeof (*nc)); - nc->consttype = FFEBLD_constHOLLERITH; - nc->u.hollerith = val; - nc->hook = FFECOM_constantNULL; - nc->llink = NULL; - nc->rlink = NULL; - - if (cmp < 0) - Q->llink = nc; - else - Q->rlink = 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 nc; - ffebldConstant P; - ffebldConstant Q; - int cmp = 0; - P = ffebld_constant_integer1_; - Q = P; - if (!P) - { - /* make this node the root */ - nc = malloc_new_kp (ffebld_constant_pool(), - "FFEBLD_constINTEGER1", - sizeof (*nc)); - nc->consttype = FFEBLD_constINTEGER1; - nc->u.integer1 = val; - nc->hook = FFECOM_constantNULL; - nc->llink = NULL; - nc->rlink = NULL; - ffebld_constant_integer1_ = nc; - return nc; - } - else - while (P) - { - Q = P; - cmp = ffetarget_cmp_integer1 (val, ffebld_constant_integer1 (P)); - if (cmp > 0) - P = P->llink; - else if (cmp < 0) - P = P->rlink; - else - return P; - } - - nc = malloc_new_kp (ffebld_constant_pool(), - "FFEBLD_constINTEGER1", - sizeof (*nc)); - nc->consttype = FFEBLD_constINTEGER1; - nc->u.integer1 = val; - nc->hook = FFECOM_constantNULL; - nc->llink = NULL; - nc->rlink = NULL; - - if (cmp < 0) - Q->llink = nc; - else - Q->rlink = 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 nc; - ffebldConstant P; - ffebldConstant Q; - int cmp = 0; - P = ffebld_constant_integer2_; - Q = P; - if (!P) - { - /* make this node the root */ - nc = malloc_new_kp (ffebld_constant_pool(), - "FFEBLD_constINTEGER2", - sizeof (*nc)); - nc->consttype = FFEBLD_constINTEGER2; - nc->u.integer2 = val; - nc->hook = FFECOM_constantNULL; - nc->llink = NULL; - nc->rlink = NULL; - ffebld_constant_integer2_ = nc; - return nc; - } - else - while (P) - { - Q = P; - cmp = ffetarget_cmp_integer2 (val, ffebld_constant_integer2 (P)); - if (cmp > 0) - P = P->llink; - else if (cmp < 0) - P = P->rlink; - else - return P; - } - - nc = malloc_new_kp (ffebld_constant_pool(), - "FFEBLD_constINTEGER2", - sizeof (*nc)); - nc->consttype = FFEBLD_constINTEGER2; - nc->u.integer2 = val; - nc->hook = FFECOM_constantNULL; - nc->llink = NULL; - nc->rlink = NULL; - - if (cmp < 0) - Q->llink = nc; - else - Q->rlink = 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 nc; - ffebldConstant P; - ffebldConstant Q; - int cmp = 0; - P = ffebld_constant_integer3_; - Q = P; - if (!P) - { - /* make this node the root */ - nc = malloc_new_kp (ffebld_constant_pool(), - "FFEBLD_constINTEGER3", - sizeof (*nc)); - nc->consttype = FFEBLD_constINTEGER3; - nc->u.integer3 = val; - nc->hook = FFECOM_constantNULL; - nc->llink = NULL; - nc->rlink = NULL; - ffebld_constant_integer3_ = nc; - return nc; - } - else - while (P) - { - Q = P; - cmp = ffetarget_cmp_integer3 (val, ffebld_constant_integer3 (P)); - if (cmp > 0) - P = P->llink; - else if (cmp < 0) - P = P->rlink; - else - return P; - } - - nc = malloc_new_kp (ffebld_constant_pool(), - "FFEBLD_constINTEGER3", - sizeof (*nc)); - nc->consttype = FFEBLD_constINTEGER3; - nc->u.integer3 = val; - nc->hook = FFECOM_constantNULL; - nc->llink = NULL; - nc->rlink = NULL; - - if (cmp < 0) - Q->llink = nc; - else - Q->rlink = 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 nc; - ffebldConstant P; - ffebldConstant Q; - int cmp = 0; - P = ffebld_constant_integer4_; - Q = P; - if (!P) - { - /* make this node the root */ - nc = malloc_new_kp (ffebld_constant_pool(), - "FFEBLD_constINTEGER4", - sizeof (*nc)); - nc->consttype = FFEBLD_constINTEGER4; - nc->u.integer4 = val; - nc->hook = FFECOM_constantNULL; - nc->llink = NULL; - nc->rlink = NULL; - ffebld_constant_integer4_ = nc; - return nc; - } - else - while (P) - { - Q = P; - cmp = ffetarget_cmp_integer4 (val, ffebld_constant_integer4 (P)); - if (cmp > 0) - P = P->llink; - else if (cmp < 0) - P = P->rlink; - else - return P; - } - - nc = malloc_new_kp (ffebld_constant_pool(), - "FFEBLD_constINTEGER4", - sizeof (*nc)); - nc->consttype = FFEBLD_constINTEGER4; - nc->u.integer4 = val; - nc->hook = FFECOM_constantNULL; - nc->llink = NULL; - nc->rlink = NULL; - - if (cmp < 0) - Q->llink = nc; - else - Q->rlink = 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 nc; - ffebldConstant P; - ffebldConstant Q; - int cmp = 0; - P = ffebld_constant_logical1_; - Q = P; - if (!P) - { - /* make this node the root */ - nc = malloc_new_kp (ffebld_constant_pool(), - "FFEBLD_constLOGICAL1", - sizeof (*nc)); - nc->consttype = FFEBLD_constLOGICAL1; - nc->u.logical1 = val; - nc->hook = FFECOM_constantNULL; - nc->llink = NULL; - nc->rlink = NULL; - ffebld_constant_logical1_ = nc; - return nc; - } - else - while (P) - { - Q = P; - cmp = ffetarget_cmp_logical1 (val, ffebld_constant_logical1 (P)); - if (cmp > 0) - P = P->llink; - else if (cmp < 0) - P = P->rlink; - else - return P; - } - - nc = malloc_new_kp (ffebld_constant_pool(), - "FFEBLD_constLOGICAL1", - sizeof (*nc)); - nc->consttype = FFEBLD_constLOGICAL1; - nc->u.logical1 = val; - nc->hook = FFECOM_constantNULL; - nc->llink = NULL; - nc->rlink = NULL; - - if (cmp < 0) - Q->llink = nc; - else - Q->rlink = 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 nc; - ffebldConstant P; - ffebldConstant Q; - int cmp = 0; - P = ffebld_constant_logical2_; - Q = P; - if (!P) - { - /* make this node the root */ - nc = malloc_new_kp (ffebld_constant_pool(), - "FFEBLD_constLOGICAL2", - sizeof (*nc)); - nc->consttype = FFEBLD_constLOGICAL2; - nc->u.logical2 = val; - nc->hook = FFECOM_constantNULL; - nc->llink = NULL; - nc->rlink = NULL; - ffebld_constant_logical2_ = nc; - return nc; - } - else - while (P) - { - Q = P; - cmp = ffetarget_cmp_logical2 (val, ffebld_constant_logical2 (P)); - if (cmp > 0) - P = P->llink; - else if (cmp < 0) - P = P->rlink; - else - return P; - } - - nc = malloc_new_kp (ffebld_constant_pool(), - "FFEBLD_constLOGICAL2", - sizeof (*nc)); - nc->consttype = FFEBLD_constLOGICAL2; - nc->u.logical2 = val; - nc->hook = FFECOM_constantNULL; - nc->llink = NULL; - nc->rlink = NULL; - - if (cmp < 0) - Q->llink = nc; - else - Q->rlink = 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 nc; - ffebldConstant P; - ffebldConstant Q; - int cmp = 0; - P = ffebld_constant_logical3_; - Q = P; - if (!P) - { - /* make this node the root */ - nc = malloc_new_kp (ffebld_constant_pool(), - "FFEBLD_constLOGICAL3", - sizeof (*nc)); - nc->consttype = FFEBLD_constLOGICAL3; - nc->u.logical3 = val; - nc->hook = FFECOM_constantNULL; - nc->llink = NULL; - nc->rlink = NULL; - ffebld_constant_logical3_ = nc; - return nc; - } - else - while (P) - { - Q = P; - cmp = ffetarget_cmp_logical3 (val, ffebld_constant_logical3 (P)); - if (cmp > 0) - P = P->llink; - else if (cmp < 0) - P = P->rlink; - else - return P; - } - - nc = malloc_new_kp (ffebld_constant_pool(), - "FFEBLD_constLOGICAL3", - sizeof (*nc)); - nc->consttype = FFEBLD_constLOGICAL3; - nc->u.logical3 = val; - nc->hook = FFECOM_constantNULL; - nc->llink = NULL; - nc->rlink = NULL; - - if (cmp < 0) - Q->llink = nc; - else - Q->rlink = 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 nc; - ffebldConstant P; - ffebldConstant Q; - int cmp = 0; - P = ffebld_constant_logical4_; - Q = P; - if (!P) - { - /* make this node the root */ - nc = malloc_new_kp (ffebld_constant_pool(), - "FFEBLD_constLOGICAL4", - sizeof (*nc)); - nc->consttype = FFEBLD_constLOGICAL4; - nc->u.logical4 = val; - nc->hook = FFECOM_constantNULL; - nc->llink = NULL; - nc->rlink = NULL; - ffebld_constant_logical4_ = nc; - return nc; - } - else - while (P) - { - Q = P; - cmp = ffetarget_cmp_logical4 (val, ffebld_constant_logical4 (P)); - if (cmp > 0) - P = P->llink; - else if (cmp < 0) - P = P->rlink; - else - return P; - } - - nc = malloc_new_kp (ffebld_constant_pool(), - "FFEBLD_constLOGICAL4", - sizeof (*nc)); - nc->consttype = FFEBLD_constLOGICAL4; - nc->u.logical4 = val; - nc->hook = FFECOM_constantNULL; - nc->llink = NULL; - nc->rlink = NULL; - - if (cmp < 0) - Q->llink = nc; - else - Q->rlink = 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 nc; - ffebldConstant P; - ffebldConstant Q; - int cmp = 0; - P = ffebld_constant_real1_; - Q = P; - if (!P) - { - /* make this node the root */ - nc = malloc_new_kp (ffebld_constant_pool(), - "FFEBLD_constREAL1", - sizeof (*nc)); - nc->consttype = FFEBLD_constREAL1; - nc->u.real1 = val; - nc->hook = FFECOM_constantNULL; - nc->llink = NULL; - nc->rlink = NULL; - ffebld_constant_real1_ = nc; - return nc; - } - else - while (P) - { - Q = P; - cmp = ffetarget_cmp_real1 (val, ffebld_constant_real1 (P)); - if (cmp > 0) - P = P->llink; - else if (cmp < 0) - P = P->rlink; - else - return P; - } - - nc = malloc_new_kp (ffebld_constant_pool(), - "FFEBLD_constREAL1", - sizeof (*nc)); - nc->consttype = FFEBLD_constREAL1; - nc->u.real1 = val; - nc->hook = FFECOM_constantNULL; - nc->llink = NULL; - nc->rlink = NULL; - - if (cmp < 0) - Q->llink = nc; - else - Q->rlink = 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 nc; - ffebldConstant P; - ffebldConstant Q; - int cmp = 0; - P = ffebld_constant_real2_; - Q = P; - if (!P) - { - /* make this node the root */ - nc = malloc_new_kp (ffebld_constant_pool(), - "FFEBLD_constREAL2", - sizeof (*nc)); - nc->consttype = FFEBLD_constREAL2; - nc->u.real2 = val; - nc->hook = FFECOM_constantNULL; - nc->llink = NULL; - nc->rlink = NULL; - ffebld_constant_real2_ = nc; - return nc; - } - else - while (P) - { - Q = P; - cmp = ffetarget_cmp_real2 (val, ffebld_constant_real2 (P)); - if (cmp > 0) - P = P->llink; - else if (cmp < 0) - P = P->rlink; - else - return P; - } - - nc = malloc_new_kp (ffebld_constant_pool(), - "FFEBLD_constREAL2", - sizeof (*nc)); - nc->consttype = FFEBLD_constREAL2; - nc->u.real2 = val; - nc->hook = FFECOM_constantNULL; - nc->llink = NULL; - nc->rlink = NULL; - - if (cmp < 0) - Q->llink = nc; - else - Q->rlink = 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 nc; - ffebldConstant P; - ffebldConstant Q; - int cmp = 0; - P = ffebld_constant_typeless_[type - - FFEBLD_constTYPELESS_FIRST]; - Q = P; - if (!P) - { - /* make this node the root */ - nc = malloc_new_kp (ffebld_constant_pool(), - "FFEBLD_constTYPELESS", - sizeof (*nc)); - nc->consttype = type; - nc->u.typeless = val; - nc->hook = FFECOM_constantNULL; - nc->llink = NULL; - nc->rlink = NULL; - ffebld_constant_typeless_[type- FFEBLD_constTYPELESS_FIRST] = nc; - return nc; - } - else - while (P) - { - Q = P; - cmp = ffetarget_cmp_typeless (val, ffebld_constant_typeless (P)); - if (cmp > 0) - P = P->llink; - else if (cmp < 0) - P = P->rlink; - else - return P; - } - - nc = malloc_new_kp (ffebld_constant_pool(), - "FFEBLD_constTYPELESS", - sizeof (*nc)); - nc->consttype = type; - nc->u.typeless = val; - nc->hook = FFECOM_constantNULL; - nc->llink = NULL; - nc->rlink = NULL; - - if (cmp < 0) - Q->llink = nc; - else - Q->rlink = nc; - return nc; -} - -/* 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - default: - assert ("bad CHARACTER kindtype" == NULL); - break; - } - break; - - default: - assert ("bad basictype" == NULL); - break; - } -} - -/* ffebld_init_0 -- Initialize the module - - ffebld_init_0(); */ - -void -ffebld_init_0 (void) -{ - 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 (void) -{ -#if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstFILE_ - int i; - -#if FFETARGET_okCHARACTER1 - ffebld_constant_character1_ = 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_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_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_okREAL1 - ffebld_constant_real1_ = NULL; -#endif -#if FFETARGET_okREAL2 - ffebld_constant_real2_ = NULL; -#endif -#if FFETARGET_okREAL3 - ffebld_constant_real3_ = 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 (void) -{ -#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_okCOMPLEX1 - ffebld_constant_complex1_ = NULL; -#endif -#if FFETARGET_okCOMPLEX2 - ffebld_constant_complex2_ = NULL; -#endif -#if FFETARGET_okCOMPLEX3 - ffebld_constant_complex3_ = 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_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_okREAL1 - ffebld_constant_real1_ = NULL; -#endif -#if FFETARGET_okREAL2 - ffebld_constant_real2_ = NULL; -#endif -#if FFETARGET_okREAL3 - ffebld_constant_real3_ = 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 (); - x->op = FFEBLD_opACCTER; - x->u.accter.array = a; - x->u.accter.bits = b; - x->u.accter.pad = 0; - 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 (); - x->op = FFEBLD_opARRTER; - x->u.arrter.array = a; - x->u.arrter.size = size; - x->u.arrter.pad = 0; - 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 (); - x->op = FFEBLD_opCONTER; - x->u.conter.expr = c; - x->u.conter.orig = o; - x->u.conter.pad = 0; - 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 (); - 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 (); - 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 (); - 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 (); - 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 (); - x->op = o; - x->u.nonter.left = left; - x->u.nonter.hook = FFECOM_nonterNULL; - 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 (); - 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 (); - x->op = o; - x->u.nonter.left = left; - x->u.nonter.right = right; - x->u.nonter.hook = FFECOM_nonterNULL; - return x; -} - -/* ffebld_pool_pop -- Pop ffebld's pool stack - - ffebld_pool_pop(); */ - -void -ffebld_pool_pop (void) -{ - 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. */ - -const 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/contrib/gcc-3.4/gcc/f/bld.h b/contrib/gcc-3.4/gcc/f/bld.h deleted file mode 100644 index 900b5dea01..0000000000 --- a/contrib/gcc-3.4/gcc/f/bld.h +++ /dev/null @@ -1,748 +0,0 @@ -/* bld.h -- Public #include File (module.h template V1.0) - Copyright (C) 1995, 1996, 2003 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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 GCC_F_BLD_H -#define GCC_F_BLD_H - -/* 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 - -#define FFEBLD_whereconstCURRENT_ FFEBLD_whereconstFILE_ - -/* 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_okLOGICAL1 - ffetargetLogical1 logical1; -#endif -#if FFETARGET_okLOGICAL2 - ffetargetLogical2 logical2; -#endif -#if FFETARGET_okLOGICAL3 - ffetargetLogical3 logical3; -#endif -#if FFETARGET_okLOGICAL4 - ffetargetLogical4 logical4; -#endif -#if FFETARGET_okREAL1 - ffetargetReal1 real1; -#endif -#if FFETARGET_okREAL2 - ffetargetReal2 real2; -#endif -#if FFETARGET_okREAL3 - ffetargetReal3 real3; -#endif -#if FFETARGET_okCOMPLEX1 - ffetargetComplex1 complex1; -#endif -#if FFETARGET_okCOMPLEX2 - ffetargetComplex2 complex2; -#endif -#if FFETARGET_okCOMPLEX3 - ffetargetComplex3 complex3; -#endif -#if FFETARGET_okCHARACTER1 - ffetargetCharacter1 character1; -#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_okLOGICAL1 - ffetargetLogical1 *logical1; -#endif -#if FFETARGET_okLOGICAL2 - ffetargetLogical2 *logical2; -#endif -#if FFETARGET_okLOGICAL3 - ffetargetLogical3 *logical3; -#endif -#if FFETARGET_okLOGICAL4 - ffetargetLogical4 *logical4; -#endif -#if FFETARGET_okREAL1 - ffetargetReal1 *real1; -#endif -#if FFETARGET_okREAL2 - ffetargetReal2 *real2; -#endif -#if FFETARGET_okREAL3 - ffetargetReal3 *real3; -#endif -#if FFETARGET_okCOMPLEX1 - ffetargetComplex1 *complex1; -#endif -#if FFETARGET_okCOMPLEX2 - ffetargetComplex2 *complex2; -#endif -#if FFETARGET_okCOMPLEX3 - ffetargetComplex3 *complex3; -#endif -#if FFETARGET_okCHARACTER1 - ffetargetCharacterUnit1 *character1; -#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; - ffecomNonter hook; /* Whatever the compiler/backend wants! */ - } - nonter; - struct - { - ffebld head; - ffebld trail; - } - item; - struct - { - ffebldConstant expr; - ffebld orig; /* Original expression, or NULL if none. */ - ffetargetAlign pad; /* Initial padding (for DATA, etc.). */ - } - conter; - struct - { - ffebldConstantArray array; - ffetargetOffset size; - ffetargetAlign pad; /* Initial padding (for DATA, etc.). */ - } - arrter; - struct - { - ffebldConstantArray array; - ffebit bits; - ffetargetAlign pad; /* Initial padding (for DATA, etc.). */ - } - 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 rlink; - ffebldConstant llink; - ffebldConstant first_complex; /* First complex const with me as - real. */ - ffebldConst consttype; - ffecomConstant hook; /* Whatever the compiler/backend wants! */ - 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 const ffebldArity ffebld_arity_op_[(int) FFEBLD_op]; -extern struct _ffebld_pool_stack_ ffebld_pool_stack_; - -/* Declare functions with prototypes. */ - -int ffebld_constant_cmp (ffebldConstant c1, ffebldConstant c2); -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_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 -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 -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_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 -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); -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_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); -const 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_pad(b) ((b)->u.accter.pad) -#define ffebld_accter_set_bits(b,bt) ((b)->u.accter.bits = (bt)) -#define ffebld_accter_set_pad(b,p) ((b)->u.accter.pad = (p)) -#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_pad(b) ((b)->u.arrter.pad) -#define ffebld_arrter_set_pad(b,p) ((b)->u.arrter.pad = (p)) -#define ffebld_arrter_set_size(b,s) ((b)->u.arrter.size = (s)) -#define ffebld_arrter_size(b) ((b)->u.arrter.size) -#define ffebld_basictype(b) (ffeinfo_basictype (ffebld_info ((b)))) -#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_pad(b) ((b)->u.conter.pad) -#define ffebld_conter_set_orig(b,o) ((b)->u.conter.orig = (o)) -#define ffebld_conter_set_pad(b,p) ((b)->u.conter.pad = (p)) -#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_item_hook(b) ((b)->u.item.hook) -#define ffebld_item_set_hook(b,h) ((b)->u.item.hook = (h)) -#define ffebld_kind(b) (ffeinfo_kind (ffebld_info ((b)))) -#define ffebld_kindtype(b) (ffeinfo_kindtype (ffebld_info ((b)))) -#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_nonter_hook(b) ((b)->u.nonter.hook) -#define ffebld_nonter_set_hook(b,h) ((b)->u.nonter.hook = (h)) -#define ffebld_op(b) ((b)->op) -#define ffebld_pool() (ffebld_pool_stack_.pool) -#define ffebld_rank(b) (ffeinfo_rank (ffebld_info ((b)))) -#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 (ffebld_info ((b)))) -#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) -#define ffebld_where(b) (ffeinfo_where (ffebld_info ((b)))) - -/* End of #include file. */ - -#endif /* ! GCC_F_BLD_H */ diff --git a/contrib/gcc-3.4/gcc/f/bugs.texi b/contrib/gcc-3.4/gcc/f/bugs.texi deleted file mode 100644 index fdc4f159de..0000000000 --- a/contrib/gcc-3.4/gcc/f/bugs.texi +++ /dev/null @@ -1,260 +0,0 @@ -@c Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2004 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 Keep this the same as the dates above, since it's used -@c in the standalone derivations of this file (e.g. BUGS). -@set copyrights-bugs 1995,1996,1997,1998,1999,2000,2001,2002,2004 - -@set last-update-bugs 2004-05-18 - -@ifset DOC-BUGS -@include root.texi -@c The immediately following lines apply to the BUGS file -@c which is derived from this file. -@emph{Note:} This file is automatically generated from the files -@file{bugs0.texi} and @file{bugs.texi}. -@file{BUGS} is @emph{not} a source file, -although it is normally included within source distributions. - -This file lists known bugs in the @value{which-g77} version -of the GNU Fortran compiler. -Copyright (C) @value{copyrights-bugs} 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 Known Bugs In GNU Fortran -@end ifset - -@ifset DOC-G77 -@node Known Bugs -@section Known Bugs In GNU Fortran -@end ifset - -This section identifies bugs that @code{g77} @emph{users} -might run into in the @value{which-g77} version -of @code{g77}. -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. - -@ifset DOC-G77 -For information on bugs in @emph{other} versions of @code{g77}, -see @ref{News,,News About GNU Fortran}. -There, lists of bugs fixed in various versions of @code{g77} -can help determine what bugs existed in prior versions. -@end ifset - -@ifset DOC-BUGS -For information on bugs in @emph{other} versions of @code{g77}, -see @file{@value{path-g77}/NEWS}. -There, lists of bugs fixed in various versions of @code{g77} -can help determine what bugs existed in prior versions. -@end ifset - -@ifset DEVELOPMENT -@emph{Warning:} The information below is still under development, -and might not accurately reflect the @code{g77} code base -of which it is a part. -Efforts are made to keep it somewhat up-to-date, -but they are particularly concentrated -on any version of this information -that is distributed as part of a @emph{released} @code{g77}. - -In particular, while this information is intended to apply to -the @value{which-g77} version of @code{g77}, -only an official @emph{release} of that version -is expected to contain documentation that is -most consistent with the @code{g77} product in that version. -@end ifset - -The following information was last updated on @value{last-update-bugs}: - -@itemize @bullet -@item -@code{g77} fails to warn about -use of a ``live'' iterative-DO variable -as an implied-DO variable -in a @code{WRITE} or @code{PRINT} statement -(although it does warn about this in a @code{READ} statement). - -@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. - -@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. - -@cindex compiler speed -@cindex speed, of compiler -@cindex compiler memory usage -@cindex memory usage, of compiler -@cindex large aggregate areas -@cindex initialization, bug -@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. - -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. -@ifset DOC-G77 -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{@value{path-g77}/data.c}, the macro -@code{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. -@end ifset - -@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 @code{MAIN__} (or @code{MAIN___} or @code{MAIN_} if -@code{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 Alpha, support -@cindex support, Alpha -@item -@code{g77} doesn't work perfectly on 64-bit configurations -such as the Digital Semiconductor (``DEC'') Alpha. - -This problem is largely resolved as of version 0.5.23. - -@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 is usually good for performance). - -The @code{gcc} back end needs to provide a wider array -of specifications of alignment requirements and preferences for targets, -and front ends like @code{g77} should take advantage of this -when it becomes available. - -@cindex complex performance -@cindex aliasing -@item -The @code{libf2c} routines that perform some run-time -arithmetic on @code{COMPLEX} operands -were modified circa version 0.5.20 of @code{g77} -to work properly even in the presence of aliased operands. - -While the @code{g77} and @code{netlib} versions of @code{libf2c} -differ on how this is accomplished, -the main differences are that we believe -the @code{g77} version works properly -even in the presence of @emph{partially} aliased operands. - -However, these modifications have reduced performance -on targets such as x86, -due to the extra copies of operands involved. -@end itemize diff --git a/contrib/gcc-3.4/gcc/f/bugs0.texi b/contrib/gcc-3.4/gcc/f/bugs0.texi deleted file mode 100644 index 9636f4da3d..0000000000 --- a/contrib/gcc-3.4/gcc/f/bugs0.texi +++ /dev/null @@ -1,9 +0,0 @@ -\input texinfo @c -*-texinfo-*- -@c %**start of header -@setfilename BUGS -@c %**end of header - -@c This tells bugs.texi that it's generating just the BUGS file. -@set DOC-BUGS -@include bugs.texi -@bye diff --git a/contrib/gcc-3.4/gcc/f/com-rt.def b/contrib/gcc-3.4/gcc/f/com-rt.def deleted file mode 100644 index 185aef52d0..0000000000 --- a/contrib/gcc-3.4/gcc/f/com-rt.def +++ /dev/null @@ -1,289 +0,0 @@ -/* com-rt.def -- Public #include File (module.h template V1.0) - Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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,CONST): - - 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 - - CONST -- TRUE if the function is const - (does not have side effects and only depends on its arguments). - -*/ - -DEFGFRT (FFECOM_gfrtCAT, "s_cat", FFECOM_rttypeVOID_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtCMP, "s_cmp", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtCOPY, "s_copy", FFECOM_rttypeVOID_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtPAUSE, "s_paus", FFECOM_rttypeVOID_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtSTOP, "s_stop", FFECOM_rttypeVOID_, 0, TRUE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtRANGE, "s_rnge", FFECOM_rttypeINTEGER_, 0, TRUE, FALSE, FALSE) - -DEFGFRT (FFECOM_gfrtSRDUE, "s_rdue", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtERDUE, "e_rdue", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtSRSUE, "s_rsue", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtERSUE, "e_rsue", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtSRDFE, "s_rdfe", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtERDFE, "e_rdfe", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtSRSFI, "s_rsfi", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtERSFI, "e_rsfi", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtSRSFE, "s_rsfe", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtERSFE, "e_rsfe", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtSRSLI, "s_rsli", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtERSLI, "e_rsli", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtSRSLE, "s_rsle", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtERSLE, "e_rsle", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtSRSNE, "s_rsne", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) - -DEFGFRT (FFECOM_gfrtSWDUE, "s_wdue", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtEWDUE, "e_wdue", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtSWSUE, "s_wsue", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtEWSUE, "e_wsue", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtSWDFE, "s_wdfe", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtEWDFE, "e_wdfe", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtSWSFI, "s_wsfi", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtEWSFI, "e_wsfi", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtSWSFE, "s_wsfe", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtEWSFE, "e_wsfe", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtSWSLI, "s_wsli", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtEWSLI, "e_wsli", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtSWSLE, "s_wsle", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtEWSLE, "e_wsle", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtSWSNE, "s_wsne", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) - -DEFGFRT (FFECOM_gfrtDOFIO, "do_fio", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtDOLIO, "do_lio", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtDOUIO, "do_uio", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) - -DEFGFRT (FFECOM_gfrtFOPEN, "f_open", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtFCLOS, "f_clos", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtFINQU, "f_inqu", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) - -DEFGFRT (FFECOM_gfrtFBACK, "f_back", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtFEND, "f_end", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtFREW, "f_rew", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) - -DEFGFRT (FFECOM_gfrtABORT, "G77_abort_0", FFECOM_rttypeVOID_, 0, TRUE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtABS, "r_abs", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtACCESS, "G77_access_0", FFECOM_rttypeINTEGER_, "&a&a", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtACOS, "r_acos", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtAIMAG, "r_imag", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtAINT, "r_int", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtALARM, "G77_alarm_0", FFECOM_rttypeINTEGER_, "&i0", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtALOG, "r_log", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtALOG10, "r_lg10", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtAMOD, "r_mod", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtANINT, "r_nint", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtASIN, "r_asin", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtATAN, "r_atan", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtATAN2, "r_atn2", FFECOM_rttypeREAL_F2C_, "&f&f", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtCABS, "c_abs", FFECOM_rttypeREAL_F2C_, "&c", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtCCOS, "c_cos", FFECOM_rttypeCOMPLEX_F2C_, "&c", FALSE, TRUE, FALSE) -DEFGFRT (FFECOM_gfrtCEXP, "c_exp", FFECOM_rttypeCOMPLEX_F2C_, "&c", FALSE, TRUE, FALSE) -DEFGFRT (FFECOM_gfrtCHDIR, "G77_chdir_0", FFECOM_rttypeINTEGER_, "&a", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtCLOG, "c_log", FFECOM_rttypeCOMPLEX_F2C_, "&c", FALSE, TRUE, FALSE) -DEFGFRT (FFECOM_gfrtCHMOD, "G77_chmod_0", FFECOM_rttypeINTEGER_, "&a&a", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtCONJG, "r_cnjg", FFECOM_rttypeCOMPLEX_F2C_, "&c", FALSE, TRUE, FALSE) -DEFGFRT (FFECOM_gfrtCOS, "r_cos", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtCOSH, "r_cosh", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtCSIN, "c_sin", FFECOM_rttypeCOMPLEX_F2C_, "&c", FALSE, TRUE, FALSE) -DEFGFRT (FFECOM_gfrtCSQRT, "c_sqrt", FFECOM_rttypeCOMPLEX_F2C_, "&c", FALSE, TRUE, FALSE) -DEFGFRT (FFECOM_gfrtCTIME, "G77_ctime_0", FFECOM_rttypeCHARACTER_, "&j", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtDABS, "d_abs", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtDACOS, "d_acos", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtDASIN, "d_asin", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtDATAN, "d_atan", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtDATAN2, "d_atn2", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtDATE, "G77_date_y2kbug_0", FFECOM_rttypeVOID_, "&a", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtDATE_AND_TIME, "G77_date_and_time_0", FFECOM_rttypeVOID_, "&a&a&a&i", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtL_BESJ0, "j0", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE) -DEFGFRT (FFECOM_gfrtL_BESJ1, "j1", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE) -DEFGFRT (FFECOM_gfrtL_BESJN, "jn", FFECOM_rttypeDOUBLE_, "id", FALSE, FALSE, TRUE) -DEFGFRT (FFECOM_gfrtL_BESY0, "y0", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE) -DEFGFRT (FFECOM_gfrtL_BESY1, "y1", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE) -DEFGFRT (FFECOM_gfrtL_BESYN, "yn", FFECOM_rttypeDOUBLE_, "id", FALSE, FALSE, TRUE) -DEFGFRT (FFECOM_gfrtDCOS, "d_cos", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtDCOSH, "d_cosh", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtDDIM, "d_dim", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtDERF, "G77_derf_0", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtDERFC, "G77_derfc_0", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtDEXP, "d_exp", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtDIM, "r_dim", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtDINT, "d_int", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtDLOG, "d_log", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtDLOG10, "d_lg10", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtDMOD, "d_mod", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtDNINT, "d_nint", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtDPROD, "d_prod", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtDSIGN, "d_sign", FFECOM_rttypeDOUBLE_, "&d&d", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtDSIN, "d_sin", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtDSINH, "d_sinh", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtDSQRT, "d_sqrt", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtDTAN, "d_tan", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtDTANH, "d_tanh", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtDTIME, "G77_dtime_0", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtERF, "G77_erf_0", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtERFC, "G77_erfc_0", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtETIME, "G77_etime_0", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtEXIT, "G77_exit_0", FFECOM_rttypeVOID_, "&i", TRUE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtEXP, "r_exp", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtFDATE, "G77_fdate_0", FFECOM_rttypeCHARACTER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtFGET, "G77_fget_0", FFECOM_rttypeINTEGER_, "&a", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtFGETC, "G77_fgetc_0", FFECOM_rttypeINTEGER_, "&i&a", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtFLUSH, "G77_flush_0", FFECOM_rttypeVOID_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtFLUSH1, "G77_flush1_0", FFECOM_rttypeVOID_, "&i", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtFNUM, "G77_fnum_0", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtFPUT, "G77_fput_0", FFECOM_rttypeINTEGER_, "&a", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtFPUTC, "G77_fputc_0", FFECOM_rttypeINTEGER_, "&i&a", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtFSTAT, "G77_fstat_0", FFECOM_rttypeINTEGER_, "&i&i", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtFTELL, "G77_ftell_0", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtFSEEK, "G77_fseek_0", FFECOM_rttypeINTEGER_, "&i&i&i", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtGERROR, "G77_gerror_0", FFECOM_rttypeVOID_, "&a", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtGETARG, "G77_getarg_0", FFECOM_rttypeVOID_, "&i&a", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtGETCWD, "G77_getcwd_0", FFECOM_rttypeINTEGER_, "&a", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtGETGID, "G77_getgid_0", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtGETLOG, "G77_getlog_0", FFECOM_rttypeVOID_, "&a", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtGETPID, "G77_getpid_0", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtGETUID, "G77_getuid_0", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtGETENV, "G77_getenv_0", FFECOM_rttypeVOID_, "&a&a", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtGMTIME, "G77_gmtime_0", FFECOM_rttypeVOID_, "&i&i", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtHOSTNM, "G77_hostnm_0", FFECOM_rttypeINTEGER_, "&a", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtIABS, "i_abs", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtIARGC, "G77_iargc_0", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtIDATE, "G77_idate_0", FFECOM_rttypeVOID_, "&i", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtIDIM, "i_dim", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtIDNINT, "i_dnnt", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtIERRNO, "G77_ierrno_0", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtINDEX, "i_indx", FFECOM_rttypeINTEGER_, "&a&a", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtIRAND, "G77_irand_0", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtISIGN, "i_sign", FFECOM_rttypeINTEGER_, "&i&i", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtISATTY, "G77_isatty_0", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtITIME, "G77_itime_0", FFECOM_rttypeVOID_, "&i", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtKILL, "G77_kill_0", FFECOM_rttypeINTEGER_, "&i&i", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtLEN, "i_len", FFECOM_rttypeINTEGER_, "&a", FALSE, FALSE, TRUE) -DEFGFRT (FFECOM_gfrtLGE, "l_ge", FFECOM_rttypeLOGICAL_, "&a", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtLGT, "l_gt", FFECOM_rttypeLOGICAL_, "&a", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtLINK, "G77_link_0", FFECOM_rttypeINTEGER_, "&a&a", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtLLE, "l_le", FFECOM_rttypeLOGICAL_, "&a", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtLLT, "l_lt", FFECOM_rttypeLOGICAL_, "&a", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtLNBLNK, "G77_lnblnk_0", FFECOM_rttypeINTEGER_, "&a", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtLSTAT, "G77_lstat_0", FFECOM_rttypeINTEGER_, "&a&i", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtLTIME, "G77_ltime_0", FFECOM_rttypeVOID_, "&i&i", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtMCLOCK, "G77_mclock_0", FFECOM_rttypeLONGINT_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtMOD, "i_mod", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtNINT, "i_nint", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtPERROR, "G77_perror_0", FFECOM_rttypeVOID_, "&a", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtRAND, "G77_rand_0", FFECOM_rttypeREAL_F2C_, "&i", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtRENAME, "G77_rename_0", FFECOM_rttypeINTEGER_, "&a&a", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtSECNDS, "G77_secnds_0", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtSECOND, "G77_second_0", FFECOM_rttypeREAL_F2C_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtSIGN, "r_sign", FFECOM_rttypeREAL_F2C_, "&f&f", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtL_SIGNAL, "G77_signal_0", FFECOM_rttypeVOIDSTAR_, "&i0", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtSIN, "r_sin", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtSINH, "r_sinh", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtSLEEP, "G77_sleep_0", FFECOM_rttypeVOID_, "&i", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtSQRT, "r_sqrt", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtSRAND, "G77_srand_0", FFECOM_rttypeVOID_, "&i", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtSTAT, "G77_stat_0", FFECOM_rttypeINTEGER_, "&a&i", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtSYMLNK, "G77_symlnk_0", FFECOM_rttypeINTEGER_, "&a&a", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtSYSTEM, "G77_system_0", FFECOM_rttypeINTEGER_, "&a", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtSYSTEM_CLOCK, "G77_system_clock_0", FFECOM_rttypeVOID_, "&i&i&i", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtTAN, "r_tan", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtTANH, "r_tanh", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtTIME, "G77_time_0", FFECOM_rttypeLONGINT_, 0, FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtTTYNAM, "G77_ttynam_0", FFECOM_rttypeCHARACTER_, "&i", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtUNLINK, "G77_unlink_0", FFECOM_rttypeINTEGER_, "&a", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtUMASK, "G77_umask_0", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtVXTIDATE, "G77_vxtidate_y2kbug_0", FFECOM_rttypeVOID_, "&i&i&i", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtVXTTIME, "G77_vxttime_0", FFECOM_rttypeVOID_, "&a", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtCDABS, "z_abs", FFECOM_rttypeDOUBLE_, "&e", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtCDCOS, "z_cos", FFECOM_rttypeDBLCMPLX_F2C_, "&e", FALSE, TRUE, FALSE) -DEFGFRT (FFECOM_gfrtCDEXP, "z_exp", FFECOM_rttypeDBLCMPLX_F2C_, "&e", FALSE, TRUE, FALSE) -DEFGFRT (FFECOM_gfrtCDLOG, "z_log", FFECOM_rttypeDBLCMPLX_F2C_, "&e", FALSE, TRUE, FALSE) -DEFGFRT (FFECOM_gfrtDCONJG, "d_cnjg", FFECOM_rttypeDBLCMPLX_F2C_, "&e", FALSE, TRUE, FALSE) -DEFGFRT (FFECOM_gfrtCDSIN, "z_sin", FFECOM_rttypeDBLCMPLX_F2C_, "&e", FALSE, TRUE, FALSE) -DEFGFRT (FFECOM_gfrtCDSQRT, "z_sqrt", FFECOM_rttypeDBLCMPLX_F2C_, "&e", FALSE, TRUE, FALSE) -DEFGFRT (FFECOM_gfrtDIMAG, "d_imag", FFECOM_rttypeDOUBLE_, "&e", FALSE, FALSE, FALSE) - -DEFGFRT (FFECOM_gfrtL_ACOS, "acos", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE) -DEFGFRT (FFECOM_gfrtL_ASIN, "asin", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE) -DEFGFRT (FFECOM_gfrtL_ATAN, "__builtin_atan", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE) -DEFGFRT (FFECOM_gfrtL_ATAN2, "__builtin_atan2", FFECOM_rttypeDOUBLE_, "dd", FALSE, FALSE, TRUE) -DEFGFRT (FFECOM_gfrtL_COS, "__builtin_cos", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE) -DEFGFRT (FFECOM_gfrtL_COSH, "cosh", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE) -DEFGFRT (FFECOM_gfrtL_ERF, "erf", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE) -DEFGFRT (FFECOM_gfrtL_ERFC, "erfc", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE) -DEFGFRT (FFECOM_gfrtL_EXP, "__builtin_exp", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE) -DEFGFRT (FFECOM_gfrtL_FLOOR, "__builtin_floor", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE) -DEFGFRT (FFECOM_gfrtL_FMOD, "__builtin_fmod", FFECOM_rttypeDOUBLE_, "dd", FALSE, FALSE, TRUE) -DEFGFRT (FFECOM_gfrtL_LOG, "__builtin_log", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE) -DEFGFRT (FFECOM_gfrtL_LOG10, "log10", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE) -DEFGFRT (FFECOM_gfrtL_POW, "__builtin_pow", FFECOM_rttypeDOUBLE_, "dd", FALSE, FALSE, TRUE) -DEFGFRT (FFECOM_gfrtL_SIN, "__builtin_sin", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE) -DEFGFRT (FFECOM_gfrtL_SINH, "sinh", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE) -DEFGFRT (FFECOM_gfrtL_SQRT, "__builtin_sqrt", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE) -DEFGFRT (FFECOM_gfrtL_TAN, "__builtin_tan", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE) -DEFGFRT (FFECOM_gfrtL_TANH, "tanh", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE) - -DEFGFRT (FFECOM_gfrtPOW_CI, "pow_ci", FFECOM_rttypeCOMPLEX_F2C_, "&c&i", FALSE, TRUE, FALSE) -DEFGFRT (FFECOM_gfrtPOW_DD, "pow_dd", FFECOM_rttypeDOUBLE_, "&d&d", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtPOW_DI, "pow_di", FFECOM_rttypeDOUBLE_, "&d&i", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtPOW_II, "pow_ii", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtPOW_QQ, "pow_qq", FFECOM_rttypeLONGINT_, "&j&j", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtPOW_RI, "pow_ri", FFECOM_rttypeREAL_F2C_, "&f&i", FALSE, FALSE, FALSE) -DEFGFRT (FFECOM_gfrtPOW_ZI, "pow_zi", FFECOM_rttypeDBLCMPLX_F2C_, "&e&i", FALSE, TRUE, FALSE) -DEFGFRT (FFECOM_gfrtPOW_ZZ, "pow_zz", FFECOM_rttypeDBLCMPLX_F2C_, "&e&e", FALSE, TRUE, FALSE) -DEFGFRT (FFECOM_gfrtDIV_CC, "c_div", FFECOM_rttypeCOMPLEX_F2C_, "&c", FALSE, TRUE, FALSE) -DEFGFRT (FFECOM_gfrtDIV_ZZ, "z_div", FFECOM_rttypeDBLCMPLX_F2C_, "&e", FALSE, TRUE, FALSE) diff --git a/contrib/gcc-3.4/gcc/f/com.c b/contrib/gcc-3.4/gcc/f/com.c deleted file mode 100644 index a64ef86b17..0000000000 --- a/contrib/gcc-3.4/gcc/f/com.c +++ /dev/null @@ -1,16525 +0,0 @@ -/* com.c -- Implementation File (module.c template V1.0) - Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 - Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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): - 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 (); - - Everything Else: - tree d; - tree init; - // 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); - -*/ - -/* Include files. */ - -#include "proj.h" -#include "flags.h" -#include "real.h" -#include "rtl.h" -#include "toplev.h" -#include "tree.h" -#include "output.h" /* Must follow tree.h so TREE_CODE is defined! */ -#include "convert.h" -#include "ggc.h" -#include "diagnostic.h" -#include "intl.h" -#include "langhooks.h" -#include "langhooks-def.h" -#include "debug.h" - -/* 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 */ -#endif /* VMS */ - -#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. */ - -/* Stream for reading from the input file. */ -FILE *finput; - -/* 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). */ - -tree string_type_node; - -/* 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 GTY(()) tree ffecom_tree_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 GTY(()) tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype]; -static GTY(()) tree - ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype]; -static GTY(()) tree ffecom_tree_subr_type; -static GTY(()) tree ffecom_tree_ptr_to_subr_type; -static GTY(()) tree ffecom_tree_blockdata_type; - -static GTY(()) tree ffecom_tree_xargc_; - -ffecomSymbol ffecom_symbol_null_ -= -{ - NULL_TREE, - NULL_TREE, - NULL_TREE, - NULL_TREE, - false -}; -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; -static GTY(()) tree ffecom_f2c_ptr_to_integer_type_node; -tree ffecom_f2c_address_type_node; -tree ffecom_f2c_real_type_node; -static GTY(()) 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; - -/* 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_rttypeVOIDSTAR_, /* C's `void *' type. */ - FFECOM_rttypeFTNINT_, /* f2c's `ftnint' type. */ - FFECOM_rttypeINTEGER_, /* f2c's `integer' type. */ - FFECOM_rttypeLONGINT_, /* f2c's `longint' type. */ - FFECOM_rttypeLOGICAL_, /* f2c's `logical' type. */ - FFECOM_rttypeREAL_F2C_, /* f2c's `real' returned as `double'. */ - FFECOM_rttypeREAL_GNU_, /* `real' returned as such. */ - FFECOM_rttypeCOMPLEX_F2C_, /* f2c's `complex' returned via 1st arg. */ - FFECOM_rttypeCOMPLEX_GNU_, /* f2c's `complex' returned directly. */ - FFECOM_rttypeDOUBLE_, /* C's `double' type. */ - FFECOM_rttypeDOUBLEREAL_, /* f2c's `doublereal' type. */ - FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */ - FFECOM_rttypeDBLCMPLX_GNU_, /* f2c's `doublecomplex' returned directly. */ - FFECOM_rttypeCHARACTER_, /* f2c `char *'/`ftnlen' pair. */ - FFECOM_rttype_ - } ffecomRttype_; - -/* Internal typedefs. */ - -typedef struct _ffecom_concat_list_ ffecomConcatList_; - -/* Private include files. */ - - -/* Internal structure definitions. */ - -struct _ffecom_concat_list_ - { - ffebld *exprs; - int count; - int max; - ffetargetCharacterSize minlen; - ffetargetCharacterSize maxlen; - }; - -/* Static functions (internal). */ - -static tree ffe_type_for_mode (enum machine_mode, int); -static tree ffe_type_for_size (unsigned int, int); -static tree ffe_unsigned_type (tree); -static tree ffe_signed_type (tree); -static tree ffe_signed_or_unsigned_type (int, tree); -static bool ffe_mark_addressable (tree); -static tree ffe_truthvalue_conversion (tree); -static void ffecom_init_decl_processing (void); -static tree ffecom_arglist_expr_ (const char *argstring, ffebld args); -static tree ffecom_widest_expr_type_ (ffebld list); -static bool ffecom_overlap_ (tree dest_decl, tree dest_offset, - 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, const 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, tree hook); -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, bool ref, tree hook); -static void ffecom_char_args_x_ (tree *xitem, tree *length, - ffebld expr, bool with_null); -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, const 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, bool widenp); -static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree, - ffebld dest, bool *dest_used); -static tree ffecom_expr_power_integer_ (ffebld expr); -static void ffecom_expr_transform_ (ffebld expr); -static void ffecom_f2c_make_type_ (tree *type, int tcode, const 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, const char *text); -static tree ffecom_get_external_identifier_ (ffesymbol s); -static tree ffecom_get_identifier_ (const char *text); -static tree ffecom_gen_sfuncdef_ (ffesymbol s, - ffeinfoBasictype bt, - ffeinfoKindtype kt); -static const 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); -static void ffecom_member_phase2_ (ffestorag mst, ffestorag st); -static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, - ffebld source); -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, tree hook); -static tree ffecom_type_localvar_ (ffesymbol s, - ffeinfoBasictype bt, - ffeinfoKindtype kt); -static tree ffecom_type_namelist_ (void); -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); -static tree ffecom_convert_narrow_ (tree type, tree expr); -static tree ffecom_convert_widen_ (tree type, tree expr); - -/* These are static functions that parallel those found in the C front - end and thus have the same names. */ - -static tree bison_rule_compstmt_ (void); -static void bison_rule_pushlevel_ (void); -static void delete_block (tree block); -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 const char *ffe_printable_name (tree decl, int v); -static void ffe_print_error_function (diagnostic_context *, const char *); -static tree lookup_name_current_level (tree name); -static struct f_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 int kept_level_p (void); -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); -static void ffecom_file_ (const char *name); -static void ffecom_close_include_ (FILE *f); -static FILE *ffecom_open_include_ (char *name, ffewhereLine l, - ffewhereColumn c); - -/* 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_; -static GTY(()) tree ffecom_outer_function_decl_; -static GTY(()) tree ffecom_previous_function_decl_; -static GTY(()) tree ffecom_which_entrypoint_decl_; -static GTY(()) tree ffecom_float_zero_; -static GTY(()) tree ffecom_float_half_; -static GTY(()) tree ffecom_double_zero_; -static GTY(()) tree ffecom_double_half_; -static GTY(()) tree ffecom_func_result_;/* For functions. */ -static GTY(()) 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 GTY(()) tree ffecom_multi_type_node_; -static GTY(()) tree ffecom_multi_retval_; -static GTY(()) 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; -static int ffecom_typesize_pointer_; -static int ffecom_typesize_integer1_; - -/* Holds pointer-to-function expressions. */ - -static GTY(()) tree ffecom_gfrt_[FFECOM_gfrt]; - -/* Holds the external names of the functions. */ - -static const char *const ffecom_gfrt_name_[FFECOM_gfrt] -= -{ -#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME, -#include "com-rt.def" -#undef DEFGFRT -}; - -/* Whether the function returns. */ - -static const bool ffecom_gfrt_volatile_[FFECOM_gfrt] -= -{ -#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE, -#include "com-rt.def" -#undef DEFGFRT -}; - -/* Whether the function returns type complex. */ - -static const bool ffecom_gfrt_complex_[FFECOM_gfrt] -= -{ -#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX, -#include "com-rt.def" -#undef DEFGFRT -}; - -/* Whether the function is const - (i.e., has no side effects and only depends on its arguments). */ - -static const bool ffecom_gfrt_const_[FFECOM_gfrt] -= -{ -#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST, -#include "com-rt.def" -#undef DEFGFRT -}; - -/* Type code for the function return value. */ - -static const ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt] -= -{ -#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE, -#include "com-rt.def" -#undef DEFGFRT -}; - -/* String of codes for the function's arguments. */ - -static const char *const ffecom_gfrt_argstring_[FFECOM_gfrt] -= -{ -#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS, -#include "com-rt.def" -#undef DEFGFRT -}; - -/* Internal macros. */ - -/* 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. */ - -#ifndef SIZE_TYPE -#define SIZE_TYPE "long unsigned 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_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE) -#define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE) - -/* 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 f_binding_level GTY(()) - { - /* 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 f_binding_level *level_chain; - - /* 0: no ffecom_prepare_* functions called at this level yet; - 1: ffecom_prepare* functions called, except not ffecom_prepare_end; - 2: ffecom_prepare_end called. */ - int prep_state; - }; - -#define NULL_BINDING_LEVEL (struct f_binding_level *) NULL - -/* The binding level currently in effect. */ - -static GTY(()) struct f_binding_level *current_binding_level; - -/* A chain of binding_level structures awaiting reuse. */ - -static GTY((deletable (""))) struct f_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 f_binding_level *global_binding_level; - -/* Binding level structures are initialized by copying this one. */ - -static const struct f_binding_level clear_binding_level -= -{NULL, NULL, NULL, NULL_BINDING_LEVEL, 0}; - -/* Language-dependent contents of an identifier. */ - -struct lang_identifier GTY(()) -{ - struct tree_identifier common; - tree global_value; - tree local_value; - tree 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) - -/* The resulting tree type. */ -union lang_tree_node - GTY((desc ("TREE_CODE (&%h.generic) == IDENTIFIER_NODE"), - chain_next ("(union lang_tree_node *)TREE_CHAIN (&%h.generic)"))) -{ - union tree_node GTY ((tag ("0"), - desc ("tree_node_structure (&%h)"))) - generic; - struct lang_identifier GTY ((tag ("1"))) identifier; -}; - -/* Fortran doesn't use either of these. */ -struct lang_decl GTY(()) -{ -}; -struct lang_type GTY(()) -{ -}; - -/* 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 GTY(()) tree named_labels; - -/* A list of LABEL_DECLs from outer contexts that are currently shadowed. */ - -static GTY(()) tree shadowed_labels; - -/* Return the subscript expression, modified to do range-checking. - - `array' is the array type to be checked against. - `element' is the subscript expression to check. - `dim' is the dimension number (starting at 0). - `total_dims' is the total number of dimensions (0 for CHARACTER substring). - `item' is the array decl or NULL_TREE. -*/ - -static tree -ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims, - const char *array_name, tree item) -{ - tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array)); - tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array)); - tree cond; - tree die; - tree args; - - if (element == error_mark_node) - return element; - - if (TREE_TYPE (low) != TREE_TYPE (element)) - { - if (TYPE_PRECISION (TREE_TYPE (low)) - > TYPE_PRECISION (TREE_TYPE (element))) - element = convert (TREE_TYPE (low), element); - else - { - low = convert (TREE_TYPE (element), low); - if (high) - high = convert (TREE_TYPE (element), high); - } - } - - element = ffecom_save_tree (element); - if (total_dims == 0) - { - /* Special handling for substring range checks. Fortran allows the - end subscript < begin subscript, which means that expressions like - string(1:0) are valid (and yield a null string). In view of this, - enforce two simpler conditions: - 1) element<=high for end-substring; - 2) element>=low for start-substring. - Run-time character movement will enforce remaining conditions. - - More complicated checks would be better, but present structure only - provides one index element at a time, so it is not possible to - enforce a check of both i and j in string(i:j). If it were, the - complete set of rules would read, - if ( ((j ffecom_typesize_integer1_ - && ffetype_size (type) > ffecom_typesize_integer1_) - /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit - pointers and 32-bit integers. Do the full 64-bit pointer - arithmetic, for codes using arrays for nonstandard heap-like - work. */ - flatten = 1; - } - - total_dims = i; - - need_ptr = want_ptr || flatten; - - if (! item) - { - if (need_ptr) - item = ffecom_ptr_to_expr (ffebld_left (expr)); - else - item = ffecom_expr (ffebld_left (expr)); - - if (item == error_mark_node) - return item; - - if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING - && ! ffe_mark_addressable (item)) - return error_mark_node; - } - - if (item == error_mark_node) - return item; - - if (need_ptr) - { - tree min; - - for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))); - i >= 0; - --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array))) - { - min = TYPE_MIN_VALUE (TYPE_DOMAIN (array)); - element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE); - if (flag_bounds_check) - element = ffecom_subscript_check_ (array, element, i, total_dims, - array_name, item); - if (element == error_mark_node) - return element; - - /* Widen integral arithmetic as desired while preserving - signedness. */ - tree_type = TREE_TYPE (element); - tree_type_x = tree_type; - if (tree_type - && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT - && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype)) - tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype); - - if (TREE_TYPE (min) != tree_type_x) - min = convert (tree_type_x, min); - if (TREE_TYPE (element) != tree_type_x) - element = convert (tree_type_x, element); - - item = ffecom_2 (PLUS_EXPR, - build_pointer_type (TREE_TYPE (array)), - item, - size_binop (MULT_EXPR, - size_in_bytes (TREE_TYPE (array)), - convert (sizetype, - fold (build (MINUS_EXPR, - tree_type_x, - element, min))))); - } - if (! want_ptr) - { - item = ffecom_1 (INDIRECT_REF, - TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))), - item); - } - } - else - { - for (--i; - i >= 0; - --i) - { - array = TYPE_MAIN_VARIANT (TREE_TYPE (item)); - - element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE); - if (flag_bounds_check) - element = ffecom_subscript_check_ (array, element, i, total_dims, - array_name, item); - if (element == error_mark_node) - return element; - - /* Widen integral arithmetic as desired while preserving - signedness. */ - tree_type = TREE_TYPE (element); - tree_type_x = tree_type; - if (tree_type - && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT - && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype)) - tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype); - - element = convert (tree_type_x, element); - - item = ffecom_2 (ARRAY_REF, - TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))), - item, - element); - } - } - - return item; -} - -/* 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. */ - -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: - abort (); - - - 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); - - return result; -} - -/* 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'). */ - -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)); -} - -/* Like gcc's convert(), but crashes if widening might happen. */ - -static tree -ffecom_convert_narrow_ (tree type, tree 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 - && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e))) - || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE - && (TYPE_PRECISION (type) - == TREE_INT_CST_LOW (TYPE_SIZE (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); - /* Check that at least the first field name agrees. */ - assert (DECL_NAME (TYPE_FIELDS (type)) - == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e)))); - assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type))) - <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))))); - if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type))) - == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))))) - return e; - return fold (ffecom_convert_to_complex_ (type, e)); - } - - assert ("conversion to non-scalar type requested" == NULL); - return error_mark_node; -} - -/* Like gcc's convert(), but crashes if narrowing might happen. */ - -static tree -ffecom_convert_widen_ (tree type, tree 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 - && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e))) - || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE - && (TYPE_PRECISION (type) - == TREE_INT_CST_LOW (TYPE_SIZE (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); - /* Check that at least the first field name agrees. */ - assert (DECL_NAME (TYPE_FIELDS (type)) - == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e)))); - assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type))) - >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))))); - if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type))) - == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))))) - return e; - return fold (ffecom_convert_to_complex_ (type, e)); - } - - assert ("conversion to non-scalar type requested" == NULL); - return error_mark_node; -} - -/* Handles making a COMPLEX type, either the standard - (but buggy?) gbe way, or the safer (but less elegant?) - f2c way. */ - -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; -} - -/* Chooses either the gbe or the f2c way to build a - complex constant. */ - -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, bothparts); - } - else - { - bothparts = build_complex (type, realpart, imagpart); - } - - return bothparts; -} - -static tree -ffecom_arglist_expr_ (const 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; - static const char zed[] = "0"; - - if (c == NULL) - c = &zed[0]; - - 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); - } - } - - /* We've run out of args in the call; if the implementation expects - more, supply null pointers for them, which the implementation can - check to see if an arg was omitted. */ - - while (*c != '\0' && *c != '0') - { - if (*c == '&') - ++c; - else - assert ("missing arg to run-time routine!" == NULL); - - switch (*(c++)) - { - case '\0': - case 'a': - case 'c': - case 'd': - case 'e': - case 'f': - case 'i': - case 'j': - break; - - default: - assert ("bad arg string code" == NULL); - break; - } - *plist - = build_tree_list (NULL_TREE, - null_pointer_node); - plist = &TREE_CHAIN (*plist); - } - - *plist = trail; - - return list; -} - -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; -} - -/* Check whether a partial overlap between two expressions is possible. - - Can *starting* to write a portion of expr1 change the value - computed (perhaps already, *partially*) by expr2? - - Currently, this is a concern only for a COMPLEX expr1. But if it - isn't in COMMON or local EQUIVALENCE, since we don't support - aliasing of arguments, it isn't a concern. */ - -static bool -ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED) -{ - ffesymbol sym; - ffestorag st; - - switch (ffebld_op (expr1)) - { - case FFEBLD_opSYMTER: - sym = ffebld_symter (expr1); - break; - - case FFEBLD_opARRAYREF: - if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER) - return FALSE; - sym = ffebld_symter (ffebld_left (expr1)); - break; - - default: - return FALSE; - } - - if (ffesymbol_where (sym) != FFEINFO_whereCOMMON - && (ffesymbol_where (sym) != FFEINFO_whereLOCAL - || ! (st = ffesymbol_storage (sym)) - || ! ffestorag_parent (st))) - return FALSE; - - /* It's in COMMON or local EQUIVALENCE. */ - - return TRUE; -} - -/* 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. */ - -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 NEGATE_EXPR: - case MIN_EXPR: - case MAX_EXPR: - case ABS_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_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 = bitsize_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. */ -} - -/* 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). */ - -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; -} - -/* 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. */ - -static tree -ffecom_build_f2c_string_ (int i, const char *s) -{ - if (!ffe_is_f2c_library ()) - return build_string (i, s); - - { - char *tmp; - const 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 = 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; - } -} - -/* 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. */ - -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 hook) -{ - 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 = hook; - assert (tempvar); - } - 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; -} - -/* Given two arguments, transform them and make a call to the given - function via ffecom_call_. */ - -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, bool ref, tree hook) -{ - tree left_tree; - tree right_tree; - tree left_length; - tree right_length; - - if (ref) - { - /* Pass arguments by reference. */ - left_tree = ffecom_arg_ptr_to_expr (left, &left_length); - right_tree = ffecom_arg_ptr_to_expr (right, &right_length); - } - else - { - /* Pass arguments by value. */ - left_tree = ffecom_arg_expr (left, &left_length); - right_tree = ffecom_arg_expr (right, &right_length); - } - - - 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, hook); -} - -/* Return ptr/length args for char subexpression - - 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. - - Note that if with_null is TRUE, and the expression is an opCONTER, - a null byte is appended to the string. */ - -static void -ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null) -{ - tree item; - tree high; - ffetargetCharacter1 val; - ffetargetCharacterSize newlen; - - switch (ffebld_op (expr)) - { - case FFEBLD_opCONTER: - val = ffebld_constant_character1 (ffebld_conter (expr)); - newlen = ffetarget_length_character1 (val); - if (with_null) - { - /* Begin FFETARGET-NULL-KLUDGE. */ - if (newlen != 0) - ++newlen; - } - *length = build_int_2 (newlen, 0); - TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node; - high = build_int_2 (newlen, 0); - TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node; - item = build_string (newlen, - ffetarget_text_character1 (val)); - /* End FFETARGET-NULL-KLUDGE. */ - 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: - { - ffecom_char_args_ (&item, length, ffebld_left (expr)); - - if (item == error_mark_node || *length == error_mark_node) - { - item = *length = error_mark_node; - break; - } - - item = ffecom_arrayref_ (item, expr, 1); - } - break; - - case FFEBLD_opSUBSTR: - { - ffebld start; - ffebld end; - ffebld thing = ffebld_right (expr); - tree start_tree; - tree end_tree; - const char *char_name; - ffebld left_symter; - tree array; - - assert (ffebld_op (thing) == FFEBLD_opITEM); - start = ffebld_head (thing); - thing = ffebld_trail (thing); - assert (ffebld_trail (thing) == NULL); - end = ffebld_head (thing); - - /* Determine name for pretty-printing range-check errors. */ - for (left_symter = ffebld_left (expr); - left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF; - left_symter = ffebld_left (left_symter)) - ; - if (ffebld_op (left_symter) == FFEBLD_opSYMTER) - char_name = ffesymbol_text (ffebld_symter (left_symter)); - else - char_name = "[expr?]"; - - ffecom_char_args_ (&item, length, ffebld_left (expr)); - - if (item == error_mark_node || *length == error_mark_node) - { - item = *length = error_mark_node; - break; - } - - array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))); - - /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF. */ - - if (start == NULL) - { - if (end == NULL) - ; - else - { - end_tree = ffecom_expr (end); - if (flag_bounds_check) - end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0, - char_name, NULL_TREE); - end_tree = convert (ffecom_f2c_ftnlen_type_node, - end_tree); - - if (end_tree == error_mark_node) - { - item = *length = error_mark_node; - break; - } - - *length = end_tree; - } - } - else - { - start_tree = ffecom_expr (start); - if (flag_bounds_check) - start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0, - char_name, NULL_TREE); - start_tree = convert (ffecom_f2c_ftnlen_type_node, - start_tree); - - 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 = ffecom_expr (end); - if (flag_bounds_check) - end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0, - char_name, NULL_TREE); - end_tree = convert (ffecom_f2c_ftnlen_type_node, - end_tree); - - 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) - /* ~~Kludge alert! This should someday be fixed. */ - size = 24; - - *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); - } - tempvar = ffebld_nonter_hook (expr); - assert (tempvar); - tempvar = ffecom_1 (ADDR_EXPR, - build_pointer_type (TREE_TYPE (tempvar)), - tempvar); - - 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); - } - break; - - case FFEBLD_opCONVERT: - - ffecom_char_args_ (&item, length, ffebld_left (expr)); - - 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; - - tempvar = ffebld_nonter_hook (expr); - assert (tempvar); - 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, NULL_TREE); - 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; -} - -/* 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. */ - -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; - - /* An array is too large if size is negative or the type_size overflows - or its "upper half" is larger than 3 (which would make the signed - byte size and offset computations overflow). */ - - if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0) - || (!dummy && (TREE_INT_CST_HIGH (TYPE_SIZE (type)) > 3 - || 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; -} - -/* 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). */ - -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)); - else - tlen = ffecom_get_invented_identifier ("__g77_%s", "length"); - tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node); - DECL_ARTIFICIAL (tlen) = 1; - } - - if (sz == FFETARGET_charactersizeNONE) - { - assert (tlen != NULL_TREE); - highval = variable_size (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; -} - -/* 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. */ - -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: - /* ~~Do useful truncations here. */ - break; - - 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; - } -} - -/* 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. */ - -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])); -} - -/* Make list of concatenated string exprs. - - Returns a flattened list of concatenated subexpressions given a - tree of such expressions. */ - -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); -} - -/* Provide some kind of useful info on member of aggregate area, - since current g77/gcc technology does not provide debug info - on these members. */ - -static void -ffecom_debug_kludge_ (tree aggr, const 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); -} - -/* 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). */ - -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. */ - location_t old_loc = input_location; - - input_filename = ffesymbol_where_filename (fn); - input_line = ffesymbol_where_filelinenum (fn); - - 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. */ - - 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"); - - /* 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); - - store_parm_decls (0); - - ffecom_start_compstmt (); - /* Disallow temp vars at this level. */ - current_binding_level->prep_state = 2; - - /* Make local var to hold return type for multi-type master fn. */ - - if (multi) - { - multi_retval = ffecom_get_invented_identifier ("__g77_%s", - "multi_retval"); - 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); - } - 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 - || ffesymbol_hook (s).decl_tree == error_mark_node) - 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 - || ffesymbol_hook (s).length_tree == error_mark_node) - 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); - } - } - - ffecom_end_compstmt (); - - finish_function (0); - - input_location = old_loc; - - ffecom_doing_entry_ = FALSE; -} - -/* 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. */ - -static tree -ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest, bool *dest_used, - bool assignp, bool widenp) -{ - tree item; - tree list; - tree args; - ffeinfoBasictype bt; - ffeinfoKindtype kt; - tree t; - tree dt; /* decl_tree for an ffesymbol. */ - tree tree_type, tree_type_x; - tree left, right; - 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)); - tree_type = ffecom_tree_type[bt][kt]; - - /* Widen integral arithmetic as desired while preserving signedness. */ - tree_type_x = NULL_TREE; - if (widenp && tree_type - && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT - && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype)) - tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype); - - switch (ffebld_op (expr)) - { - case FFEBLD_opACCTER: - { - ffebitCount i; - ffebit bits = ffebld_accter_bits (expr); - ffetargetOffset source_offset = 0; - ffetargetOffset dest_offset = ffebld_accter_pad (expr); - tree purpose; - - assert (dest_offset == 0 - || (bt == FFEINFO_basictypeCHARACTER - && kt == FFEINFO_kindtypeCHARACTER1)); - - 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 - && dest_offset != 0) - purpose = build_int_2 (dest_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; - dest_offset += length; - } - } - - item = build_int_2 ((ffebld_accter_size (expr) - + ffebld_accter_pad (expr)) - 1, 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, list); - TREE_CONSTANT (list) = 1; - TREE_STATIC (list) = 1; - return list; - - case FFEBLD_opARRTER: - { - ffetargetOffset i; - - list = NULL_TREE; - if (ffebld_arrter_pad (expr) == 0) - item = NULL_TREE; - else - { - assert (bt == FFEINFO_basictypeCHARACTER - && kt == FFEINFO_kindtypeCHARACTER1); - - /* Becomes PURPOSE first time through loop. */ - item = build_int_2 (ffebld_arrter_pad (expr), 0); - } - - 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) - /* Assume item is PURPOSE first time through loop. */ - list = item = build_tree_list (item, t); - else - { - TREE_CHAIN (item) = build_tree_list (NULL_TREE, t); - item = TREE_CHAIN (item); - } - } - } - - item = build_int_2 ((ffebld_arrter_size (expr) - + ffebld_arrter_pad (expr)) - 1, 0); - 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, list); - TREE_CONSTANT (list) = 1; - TREE_STATIC (list) = 1; - return list; - - case FFEBLD_opCONTER: - assert (ffebld_conter_pad (expr) == 0); - 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) - { - /* xgettext:no-c-format */ - 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: - return ffecom_arrayref_ (NULL_TREE, expr, 0); - - case FFEBLD_opUPLUS: - left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp); - return ffecom_1 (NOP_EXPR, tree_type, left); - - case FFEBLD_opPAREN: - /* ~~~Make sure Fortran rules respected here */ - left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp); - return ffecom_1 (NOP_EXPR, tree_type, left); - - case FFEBLD_opUMINUS: - left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp); - if (tree_type_x) - { - tree_type = tree_type_x; - left = convert (tree_type, left); - } - return ffecom_1 (NEGATE_EXPR, tree_type, left); - - case FFEBLD_opADD: - left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp); - right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp); - if (tree_type_x) - { - tree_type = tree_type_x; - left = convert (tree_type, left); - right = convert (tree_type, right); - } - return ffecom_2 (PLUS_EXPR, tree_type, left, right); - - case FFEBLD_opSUBTRACT: - left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp); - right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp); - if (tree_type_x) - { - tree_type = tree_type_x; - left = convert (tree_type, left); - right = convert (tree_type, right); - } - return ffecom_2 (MINUS_EXPR, tree_type, left, right); - - case FFEBLD_opMULTIPLY: - left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp); - right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp); - if (tree_type_x) - { - tree_type = tree_type_x; - left = convert (tree_type, left); - right = convert (tree_type, right); - } - return ffecom_2 (MULT_EXPR, tree_type, left, right); - - case FFEBLD_opDIVIDE: - left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp); - right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp); - if (tree_type_x) - { - tree_type = tree_type_x; - left = convert (tree_type, left); - right = convert (tree_type, right); - } - return ffecom_tree_divide_ (tree_type, left, right, - dest_tree, dest, dest_used, - ffebld_nonter_hook (expr)); - - case FFEBLD_opPOWER: - { - ffebld left = ffebld_left (expr); - ffebld right = ffebld_right (expr); - ffecomGfrt code; - ffeinfoKindtype rtkt; - ffeinfoKindtype ltkt; - bool ref = TRUE; - - switch (ffeinfo_basictype (ffebld_info (right))) - { - - case FFEINFO_basictypeINTEGER: - if (1 || optimize) - { - item = ffecom_expr_power_integer_ (expr); - 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; - ltkt = FFEINFO_kindtypeINTEGER4; - rtkt = FFEINFO_kindtypeINTEGER4; - } - else - { - code = FFECOM_gfrtPOW_II; - ltkt = FFEINFO_kindtypeINTEGER1; - } - break; - - case FFEINFO_basictypeREAL: - if (ffeinfo_kindtype (ffebld_info (left)) - == FFEINFO_kindtypeREAL1) - { - code = FFECOM_gfrtPOW_RI; - ltkt = FFEINFO_kindtypeREAL1; - } - else - { - code = FFECOM_gfrtPOW_DI; - ltkt = FFEINFO_kindtypeREAL2; - } - break; - - case FFEINFO_basictypeCOMPLEX: - if (ffeinfo_kindtype (ffebld_info (left)) - == FFEINFO_kindtypeREAL1) - { - code = FFECOM_gfrtPOW_CI; /* Overlapping result okay. */ - ltkt = FFEINFO_kindtypeREAL1; - } - else - { - code = FFECOM_gfrtPOW_ZI; /* Overlapping result okay. */ - ltkt = FFEINFO_kindtypeREAL2; - } - break; - - default: - assert ("bad pow_*i" == NULL); - code = FFECOM_gfrtPOW_CI; /* Overlapping result okay. */ - ltkt = FFEINFO_kindtypeREAL1; - break; - } - if (ffeinfo_kindtype (ffebld_info (left)) != ltkt) - left = ffeexpr_convert (left, NULL, NULL, - ffeinfo_basictype (ffebld_info (left)), - ltkt, 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); - /* We used to call FFECOM_gfrtPOW_DD here, - which passes arguments by reference. */ - code = FFECOM_gfrtL_POW; - /* Pass arguments by value. */ - ref = FALSE; - 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. */ - ref = TRUE; /* Pass arguments by reference. */ - 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, ref, - ffebld_nonter_hook (expr)); - } - - case FFEBLD_opNOT: - 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: - 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); - - if (ffesymbol_where (s) == FFEINFO_whereCONSTANT) - args = ffecom_list_expr (ffebld_right (expr)); - else - args = ffecom_list_ptr_to_expr (ffebld_right (expr)); - - if (args == error_mark_node) - return error_mark_node; - - 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, - ffebld_nonter_hook (expr)); - TREE_SIDE_EFFECTS (item) = 1; - return item; - - case FFEBLD_opAND: - 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: - 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: - 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: - 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; - - 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: /* :::::::::::::::::::: */ - 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: - { - 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) - 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, NULL_TREE); - item = ffecom_2 (code, integer_type_node, - item, - convert (TREE_TYPE (item), - integer_zero_node)); - } - item = convert (tree_type, item); - } - - return item; - - default: - assert ("relational bad basictype" == NULL); - /* Fall through. */ - case FFEINFO_basictypeANY: - return error_mark_node; - } - break; - - case FFEBLD_opPERCENT_LOC: - item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list); - return convert (tree_type, item); - - case FFEBLD_opPERCENT_VAL: - item = ffecom_arg_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 -} - -/* 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. */ - -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)), - NULL_TREE), - 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))), - NULL_TREE) - )) - ); -#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_)))), - NULL_TREE), - 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))), - NULL_TREE)) - ) - ); -#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: - tempvar = ffebld_nonter_hook (expr); - assert (tempvar); - { - 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) - /* We used to call FFECOM_gfrtALOG10 here. */ - gfrt = FFECOM_gfrtL_LOG10; - else if (kt == FFEINFO_kindtypeREAL2) - /* We used to call FFECOM_gfrtDLOG10 here. */ - gfrt = FFECOM_gfrtL_LOG10; - 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) - /* We used to call FFECOM_gfrtAMOD here. */ - gfrt = FFECOM_gfrtL_FMOD; - else if (kt == FFEINFO_kindtypeREAL2) - /* We used to call FFECOM_gfrtDMOD here. */ - gfrt = FFECOM_gfrtL_FMOD; - 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 target_true; - ffetargetLogical1 target_false; - tree true_tree; - tree false_tree; - - ffetarget_logical1 (&target_true, TRUE); - ffetarget_logical1 (&target_false, FALSE); - if (target_true == 1) - true_tree = convert (tree_type, integer_one_node); - else - true_tree = convert (tree_type, build_int_2 (target_true, 0)); - if (target_false == 0) - false_tree = convert (tree_type, integer_zero_node); - else - false_tree = convert (tree_type, build_int_2 (target_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)))); - /* Fix up, because the RSHIFT_EXPR above can't shift over TYPE_SIZE. */ - 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)); - } - 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)))); - /* Fix up, because {L|R}SHIFT_EXPR don't go over TYPE_SIZE bounds. */ - expr_tree - = ffecom_3 (COND_EXPR, tree_type, - ffecom_truth_value - (ffecom_2 (NE_EXPR, integer_type_node, - ffecom_1 (ABS_EXPR, - integer_type_node, - arg2_tree), - TYPE_SIZE (uns_type))), - expr_tree, - convert (tree_type, integer_zero_node)); - /* 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); - /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE. */ - 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)); - 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; - - 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 (NULL_TREE, 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))); - - 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); - /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE. */ - 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)); - 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); - /* Fix up (twice), because LSHIFT_EXPR above - can't shift over TYPE_SIZE. */ - 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); - 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; - - 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_w (NULL_TREE, arg3); - else - arg3_tree = NULL_TREE; - - 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, - ffebld_nonter_hook (expr)); - - 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; - - 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_w (NULL_TREE, arg3); - else - arg3_tree = NULL_TREE; - - 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, - ffebld_nonter_hook (expr)); - - 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; - - arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len); - - if (arg2 != NULL) - arg2_tree = ffecom_expr_w (NULL_TREE, arg2); - else - arg2_tree = NULL_TREE; - - 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, - ffebld_nonter_hook (expr)); - - 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, - ffebld_nonter_hook (expr)); - - 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; - - 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_w (NULL_TREE, arg3); - else - arg3_tree = NULL_TREE; - - 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, - ffebld_nonter_hook (expr)); - 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; - - arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len); - - arg2_tree = ffecom_ptr_to_expr (arg2); - - if (arg3 != NULL) - arg3_tree = ffecom_expr_w (NULL_TREE, arg3); - else - arg3_tree = NULL_TREE; - - 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, - ffebld_nonter_hook (expr)); - 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; - - 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); - if (arg3 != NULL) - arg3_tree = ffecom_expr_w (NULL_TREE, arg3); - else - arg3_tree = NULL_TREE; - - 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, - ffebld_nonter_hook (expr)); - 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_impFSTAT_subr: - { - tree arg1_tree; - tree arg2_tree; - tree arg3_tree; - - 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_w (NULL_TREE, arg3); - - 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, - ffebld_nonter_hook (expr)); - 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; - - 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_w (NULL_TREE, arg3); - - 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, - ffebld_nonter_hook (expr)); - 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; - - arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len); - - arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ? - ffecom_f2c_longint_type_node : - ffecom_f2c_integer_type_node), - ffecom_expr (arg1)); - arg2_tree = ffecom_1 (ADDR_EXPR, - build_pointer_type (TREE_TYPE (arg2_tree)), - arg2_tree); - - 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, - ffebld_nonter_hook (expr)); - TREE_SIDE_EFFECTS (expr_tree) = 1; - } - 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_real_type_node), - arg1_tree, - dest_tree, dest, dest_used, - NULL_TREE, TRUE, - ffebld_nonter_hook (expr)); - } - return expr_tree; - - case FFEINTRIN_impFTELL_subr: - case FFEINTRIN_impUMASK_subr: - { - tree arg1_tree; - tree arg2_tree; - - 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_w (NULL_TREE, arg2); - - 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, - ffebld_nonter_hook (expr)); - 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; - - arg1_tree = ffecom_expr_w (NULL_TREE, arg1); - - expr_tree - = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), - ffecom_gfrt_kindtype (gfrt), - FALSE, - NULL_TREE, - NULL_TREE, - NULL_TREE, NULL, NULL, NULL_TREE, TRUE, - ffebld_nonter_hook (expr)); - - 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 result_tree; - - result_tree = ffecom_expr_w (NULL_TREE, arg2); - - arg1_tree = ffecom_ptr_to_expr (arg1); - - 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, - ffebld_nonter_hook (expr)); - expr_tree = ffecom_modify (NULL_TREE, result_tree, - convert (TREE_TYPE (result_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_impDATE_AND_TIME: - 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! */ - - expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt), - ffebld_right (expr)); - - 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, - ffebld_nonter_hook (expr)); - - /* See bottom of this file for f2c transforms used to determine - many of the above implementations. The info seems to confuse - Emacs's C mode indentation, which is why it's been moved to - the bottom of this source file. */ -} - -/* 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). */ - -static tree -ffecom_expr_power_integer_ (ffebld expr) -{ - tree l = ffecom_expr (ffebld_left (expr)); - tree r = ffecom_expr (ffebld_right (expr)); - 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, NULL_TREE); - 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, - ffebld_nonter_hook (expr)); - 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 divide; - tree basetypeof_l_is_int; - tree se; - tree t; - - basetypeof_l_is_int - = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0); - - se = expand_start_stmt_expr (/*has_scope=*/1); - - ffecom_start_compstmt (); - - rtmp = ffecom_make_tempvar ("power_r", rtype, - FFETARGET_charactersizeNONE, -1); - ltmp = ffecom_make_tempvar ("power_l", ltype, - FFETARGET_charactersizeNONE, -1); - result = ffecom_make_tempvar ("power_res", ltype, - FFETARGET_charactersizeNONE, -1); - if (TREE_CODE (ltype) == COMPLEX_TYPE - || TREE_CODE (ltype) == RECORD_TYPE) - divide = ffecom_make_tempvar ("power_div", ltype, - FFETARGET_charactersizeNONE, -1); - else - divide = NULL_TREE; - - 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, - divide))); - 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, - divide))); - 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); - - t = ffecom_end_compstmt (); - - result = expand_end_stmt_expr (se); - - /* This code comes from c-parse.in, after its expand_end_stmt_expr. */ - - if (TREE_CODE (t) == BLOCK) - { - /* Make a BIND_EXPR for the BLOCK already made. */ - result = build (BIND_EXPR, TREE_TYPE (result), - NULL_TREE, result, t); - /* Remove the block from the tree at this point. - It gets put back at the proper place - when the BIND_EXPR is expanded. */ - delete_block (t); - } - else - result = t; - } - - return result; -} - -/* ffecom_expr_transform_ -- Transform symbols in expr - - ffebld expr; // FFE expression. - ffecom_expr_transform_ (expr); - - Recursive descent on expr while transforming any untransformed SYMTERs. */ - -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; -} - -/* Make a type based on info in live f2c.h file. */ - -static void -ffecom_f2c_make_type_ (tree *type, int tcode, const 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), - *type)); -} - -/* 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 - && compare_tree_int (TYPE_SIZE (t), size) == 0) - { - assert (code != -1); - ffecom_f2c_typecode_[bt][j] = code; - code = -1; - } -} - -/* Finish up globals after doing all program units in file - - Need to handle only uninitialized COMMON areas. */ - -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. */ - - DECL_EXTERNAL (cbt) = 0; - - /* Give the array a size now. */ - - size = build_int_2 ((ffeglobal_common_size (global) - + ffeglobal_common_pad (global)) - 1, - 0); - - cbtype = TREE_TYPE (cbt); - TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node, - integer_zero_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; -} - -/* Finish up any untransformed symbols. */ - -static ffesymbol -ffecom_finish_symbol_transform_ (ffesymbol s) -{ - if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK)) - 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) - { - if (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)) - { - /* 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)); - } - - return s; -} - -/* 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. */ - -static tree -ffecom_get_appended_identifier_ (char us, const 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; -} - -/* Decide whether to append underscore to name before calling - get_identifier. */ - -static tree -ffecom_get_external_identifier_ (ffesymbol s) -{ - char us; - const 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) - || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0) - || (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); -} - -/* 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. */ - -static tree -ffecom_get_identifier_ (const 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); -} - -/* 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. */ - -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; - location_t old_loc = input_location; - - 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); - input_line = 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; - - push_f_function_context (); - - 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. */ - - 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"); - - 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); - - 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_prepare_let_char_ (sz, expr); - - ffecom_prepare_end (); - - ffecom_let_char_ (result, result_length, sz, expr); - expand_null_return (); - } - else - { - ffecom_prepare_expr (expr); - - ffecom_prepare_end (); - - expand_return (ffecom_modify (NULL_TREE, - DECL_RESULT (current_function_decl), - ffecom_expr (expr))); - } - } - - ffecom_end_compstmt (); - - func = current_function_decl; - finish_function (1); - - pop_f_function_context (); - - recurse = FALSE; - - input_location = old_loc; - - ffecom_nested_entry_ = NULL; - - return func; -} - -static const char * -ffecom_gfrt_args_ (ffecomGfrt ix) -{ - return ffecom_gfrt_argstring_[ix]; -} - -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]); -} - -/* Return initialize-to-zero expression for this VAR_DECL. */ - -/* A somewhat evil way to prevent the garbage collector - from collecting 'tree' structures. */ -#define NUM_TRACKED_CHUNK 63 -struct tree_ggc_tracker GTY(()) -{ - struct tree_ggc_tracker *next; - tree trees[NUM_TRACKED_CHUNK]; -}; -static GTY(()) struct tree_ggc_tracker *tracker_head; - -void -ffecom_save_tree_forever (tree t) -{ - int i; - if (tracker_head != NULL) - for (i = 0; i < NUM_TRACKED_CHUNK; i++) - if (tracker_head->trees[i] == NULL) - { - tracker_head->trees[i] = t; - return; - } - - { - /* Need to allocate a new block. */ - struct tree_ggc_tracker *old_head = tracker_head; - - tracker_head = ggc_alloc (sizeof (*tracker_head)); - tracker_head->next = old_head; - tracker_head->trees[0] = t; - for (i = 1; i < NUM_TRACKED_CHUNK; i++) - tracker_head->trees[i] = NULL; - } -} - -static tree -ffecom_init_zero_ (tree decl) -{ - tree init; - int incremental = TREE_STATIC (decl); - tree type = TREE_TYPE (decl); - - if (incremental) - { - make_decl_rtl (decl, NULL); - assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1); - } - - 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) - { - init = build_constructor (type, NULL_TREE); - TREE_CONSTANT (init) = 1; - TREE_STATIC (init) = 1; - } - else - { - assemble_zeros (int_size_in_bytes (type)); - init = error_mark_node; - } - - return init; -} - -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_char_args_ (&expr_tree, &length_tree, arg); - - 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; - } -} - -/* 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. */ - -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; -} - -/* Handle CHARACTER assignments. - - Generates code to do the assignment. Used by ordinary assignment - statement handler ffecom_let_stmt and by statement-function - handler to generate code for a statement function. */ - -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, NULL_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, NULL_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; - - { - tree hook; - - hook = ffebld_nonter_hook (source); - assert (hook); - assert (TREE_CODE (hook) == TREE_VEC); - assert (TREE_VEC_LENGTH (hook) == 2); - length_array = lengths = TREE_VEC_ELT (hook, 0); - item_array = items = TREE_VEC_ELT (hook, 1); - } - - 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, NULL_TREE); - TREE_SIDE_EFFECTS (expr_tree) = 1; - - expand_expr_stmt (expr_tree); - } - - ffecom_concat_list_kill_ (catlist); -} - -/* 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). */ - -static void -ffecom_make_gfrt_ (ffecomGfrt ix) -{ - tree t; - tree ttype; - - switch (ffecom_gfrt_type_[ix]) - { - case FFECOM_rttypeVOID_: - ttype = void_type_node; - break; - - case FFECOM_rttypeVOIDSTAR_: - ttype = TREE_TYPE (null_pointer_node); /* `void *'. */ - break; - - case FFECOM_rttypeFTNINT_: - ttype = ffecom_f2c_ftnint_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 = double_type_node; - break; - - case FFECOM_rttypeREAL_GNU_: - ttype = float_type_node; - 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_rttypeDOUBLEREAL_: - ttype = ffecom_f2c_doublereal_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_READONLY (t) = ffecom_gfrt_const_[ix] ? 1 : 0; - TREE_PUBLIC (t) = 1; - TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0; - - /* Sanity check: A function that's const cannot be volatile. */ - - assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_volatile_[ix] : 1); - - /* Sanity check: A function that's const cannot return complex. */ - - assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_complex_[ix] : 1); - - t = start_decl (t, TRUE); - - finish_decl (t, NULL_TREE, TRUE); - - ffecom_gfrt_[ix] = t; -} - -/* Phase 1 pass over each member of a COMMON/EQUIVALENCE group. */ - -static void -ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st) -{ - ffesymbol s = ffestorag_symbol (st); - - if (ffesymbol_namelisted (s)) - ffecom_member_namelisted_ = TRUE; -} - -/* 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. */ - -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; - TREE_USED (t) = 1; - - SET_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); -} - -/* Prepare source expression for assignment into a destination perhaps known - to be of a specific size. */ - -static void -ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source) -{ - ffecomConcatList_ catlist; - int count; - int i; - tree ltmp; - tree itmp; - tree tempvar = NULL_TREE; - - while (ffebld_op (source) == FFEBLD_opCONVERT) - source = ffebld_left (source); - - catlist = ffecom_concat_list_new_ (source, dest_size); - count = ffecom_concat_list_count_ (catlist); - - if (count >= 2) - { - ltmp - = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node, - FFETARGET_charactersizeNONE, count); - itmp - = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node, - FFETARGET_charactersizeNONE, count); - - tempvar = make_tree_vec (2); - TREE_VEC_ELT (tempvar, 0) = ltmp; - TREE_VEC_ELT (tempvar, 1) = itmp; - } - - for (i = 0; i < count; ++i) - ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i)); - - ffecom_concat_list_kill_ (catlist); - - if (tempvar) - { - ffebld_nonter_set_hook (source, tempvar); - current_binding_level->prep_state = 1; - } -} - -/* 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). */ - -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; -} - -/* 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. */ - -static void -ffecom_start_progunit_ (void) -{ - 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; - location_t old_loc = input_location; - - assert (fn != NULL); - assert (ffesymbol_hook (fn).decl_tree == NULL_TREE); - - input_filename = ffesymbol_where_filename (fn); - input_line = ffesymbol_where_filelinenum (fn); - - 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)); - } -#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 */ - - TREE_USED (current_function_decl) = 1; /* Avoid spurious warning if altentries. */ - - if (!altentries - && ((g = ffesymbol_global (fn)) != NULL) - && ((ffeglobal_type (g) == gt) - || (ffeglobal_type (g) == egt))) - { - ffeglobal_set_hook (g, current_function_decl); - } - - /* 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"), - 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"); - - /* 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); - } - - if (TREE_CODE (current_function_decl) != ERROR_MARK) - store_parm_decls (main_program ? 1 : 0); - - ffecom_start_compstmt (); - /* Disallow temp vars at this level. */ - current_binding_level->prep_state = 2; - - input_location = old_loc; - - /* 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_); -} - -/* 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. */ - -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; - location_t old_loc = input_location; - - /* Must ensure special ASSIGN variables are declared at top of outermost - block, else they'll end up in the innermost block when their first - ASSIGN is seen, which leaves them out of scope when they're the - subject of a GOTO or I/O statement. - - We make this variable even if -fugly-assign. Just let it go unused, - in case it turns out there are cases where we really want to use this - variable anyway (e.g. ASSIGN to INTEGER*2 variable). */ - - if (! ffecom_transform_only_dummies_ - && ffesymbol_assigned (s) - && ! ffesymbol_hook (s).assign_tree) - s = ffecom_sym_transform_assign_ (s); - - if (ffesymbol_sfdummyparent (s) == NULL) - { - input_filename = ffesymbol_where_filename (s); - input_line = ffesymbol_where_filelinenum (s); - } - else - { - ffesymbol sf = ffesymbol_sfdummyparent (s); - - input_filename = ffesymbol_where_filename (sf); - input_line = 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); - DECL_ARTIFICIAL (t) = 1; - 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; - } - - 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); - - ffecom_save_tree_forever (t); - - 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; - - type = ffecom_type_localvar_ (s, bt, kt); - - if (type == error_mark_node) - { - t = error_mark_node; - break; - } - - if ((st != NULL) - && (ffestorag_size (st) == 0)) - { - t = error_mark_node; - break; - } - - if ((st != NULL) - && (ffestorag_parent (st) != NULL)) - { /* Child of EQUIVALENCE parent. */ - ffestorag est; - tree et; - 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, /*rescan=*/true); - - 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); - TREE_CONSTANT (t) = staticp (et); - - addr = TRUE; - } - else - { - tree initexpr; - bool init = ffesymbol_is_init (s); - - 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) - { - assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST); - assert (0 == compare_tree_int (DECL_SIZE_UNIT (t), - ffestorag_size (st))); - } - } - } - 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)) - { - 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]); - - break; - } - - 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; - - 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)). */ - /* Even more recently used to set to INT_MAX, but that - broke when some overflow checking went into the back - end. Now we just leave the upper bound unspecified. */ - high = NULL; - } - 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) - || (high && 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 (high && 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 (high && 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); - DECL_ARTIFICIAL (t) = 1; - - /* 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; - - cs = ffesymbol_common (s); /* The COMMON area itself. */ - if (st != NULL) /* Else not laid out. */ - { - ffecom_transform_common_ (cs); - st = ffesymbol_storage (s); - } - - 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; - tree toffset; - - 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)); - toffset = build_int_2 (offset, 0); - TREE_TYPE (toffset) = ssizetype; - t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t), - t, toffset); - t = convert (build_pointer_type (type), - t); - TREE_CONSTANT (t) = 1; - - addr = TRUE; - } - } - 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; - } - - 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); - - ffecom_save_tree_forever (t); - - 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); - DECL_ARTIFICIAL (t) = 1; - 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; - } - - 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, ffe_is_globals ()); - finish_decl (t, NULL_TREE, ffe_is_globals ()); - - if ((g != NULL) - && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR) - || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))) - ffeglobal_set_hook (g, t); - - ffecom_save_tree_forever (t); - - 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); - DECL_ARTIFICIAL (t) = 1; - 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_); - - 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); - - ffecom_save_tree_forever (t); - - 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; - - input_location = old_loc; - - return s; -} - -/* 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. */ - -static ffesymbol -ffecom_sym_transform_assign_ (ffesymbol s) -{ - tree t; /* Transformed thingy. */ - location_t old_loc = input_location; - - if (ffesymbol_sfdummyparent (s) == NULL) - { - input_filename = ffesymbol_where_filename (s); - input_line = ffesymbol_where_filelinenum (s); - } - else - { - ffesymbol sf = ffesymbol_sfdummyparent (s); - - input_filename = ffesymbol_where_filename (sf); - input_line = ffesymbol_where_filelinenum (sf); - } - - assert (!ffecom_transform_only_dummies_); - - t = build_decl (VAR_DECL, - ffecom_get_invented_identifier ("__g77_ASSIGN_%s", - ffesymbol_text (s)), - 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); - - ffesymbol_hook (s).assign_tree = t; - - input_location = old_loc; - - return s; -} - -/* 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). */ - -static void -ffecom_transform_common_ (ffesymbol s) -{ - ffestorag st = ffesymbol_storage (s); - ffeglobal g = ffesymbol_global (s); - tree cbt; - tree cbtype; - tree init; - tree high; - 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))) - { - if (st->hook == NULL) ffestorag_set_hook (st, cbt); - return; - } - - /* Process inits. */ - - if (is_init) - { - if (ffestorag_init (st) != NULL) - { - ffebld sexp; - - /* Set the padding for the expression, so ffecom_expr - knows to insert that many zeros. */ - switch (ffebld_op (sexp = ffestorag_init (st))) - { - case FFEBLD_opCONTER: - ffebld_conter_set_pad (sexp, ffestorag_modulo (st)); - break; - - case FFEBLD_opARRTER: - ffebld_arrter_set_pad (sexp, ffestorag_modulo (st)); - break; - - case FFEBLD_opACCTER: - ffebld_accter_set_pad (sexp, ffestorag_modulo (st)); - break; - - default: - assert ("bad op for cmn init (pad)" == NULL); - break; - } - - init = ffecom_expr (sexp); - 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; - - /* cbtype must be permanently allocated! */ - - /* Allocate the MAX of the areas so far, seen filewide. */ - high = build_int_2 ((ffeglobal_common_size (g) - + ffeglobal_common_pad (g)) - 1, 0); - TREE_TYPE (high) = ffecom_integer_type_node; - - if (init) - cbtype = build_array_type (char_type_node, - build_range_type (integer_type_node, - integer_zero_node, - high)); - 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; - DECL_USER_ALIGN (cbt) = 0; - - 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) - { - assert (DECL_SIZE_UNIT (cbt) != NULL_TREE); - assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST); - assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt), - (ffeglobal_common_size (g) - + ffeglobal_common_pad (g)))); - } - - ffeglobal_set_hook (g, cbt); - - ffestorag_set_hook (st, cbt); - - ffecom_save_tree_forever (cbt); -} - -/* Make master area for local EQUIVALENCE. */ - -static void -ffecom_transform_equiv_ (ffestorag eqst) -{ - tree eqt; - tree eqtype; - tree init; - tree high; - bool is_init = ffestorag_is_init (eqst); - - assert (eqst != NULL); - - eqt = ffestorag_hook (eqst); - - if (eqt != NULL_TREE) - return; - - /* Process inits. */ - - if (is_init) - { - if (ffestorag_init (eqst) != NULL) - { - ffebld sexp; - - /* Set the padding for the expression, so ffecom_expr - knows to insert that many zeros. */ - switch (ffebld_op (sexp = ffestorag_init (eqst))) - { - case FFEBLD_opCONTER: - ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst)); - break; - - case FFEBLD_opARRTER: - ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst)); - break; - - case FFEBLD_opACCTER: - ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst)); - break; - - default: - assert ("bad op for eqv init (pad)" == NULL); - break; - } - - init = ffecom_expr (sexp); - 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); - - high = build_int_2 ((ffestorag_size (eqst) - + ffestorag_modulo (eqst)) - 1, 0); - TREE_TYPE (high) = ffecom_integer_type_node; - - eqtype = build_array_type (char_type_node, - build_range_type (ffecom_integer_type_node, - ffecom_integer_zero_node, - high)); - - eqt = build_decl (VAR_DECL, - ffecom_get_invented_identifier ("__g77_equiv_%s", - ffesymbol_text - (ffestorag_symbol (eqst))), - 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; - TREE_ADDRESSABLE (eqt) = 1; /* Ensure non-register allocation */ - 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 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; - DECL_USER_ALIGN (eqt) = 0; - - 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 ()); - - { - assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST); - assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt), - (ffestorag_size (eqst) - + ffestorag_modulo (eqst)))); - } - - ffestorag_set_hook (eqst, eqt); - - ffestorag_drive (ffestorag_list_equivs (eqst), - &ffecom_member_phase2_, - eqst); -} - -/* Implement NAMELIST in back end. See f2c/format.c for more info. */ - -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 i; - static int mynumber = 0; - - nmlt = build_decl (VAR_DECL, - ffecom_get_invented_identifier ("__g77_namelist_%d", - 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, nmlinits); - TREE_CONSTANT (nmlinits) = 1; - TREE_STATIC (nmlinits) = 1; - - finish_decl (nmlt, nmlinits, FALSE); - - nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt); - - return nmlt; -} - -/* 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. */ - -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 = fold (build (PLUS_EXPR, TREE_TYPE (*offset), - *offset, TREE_OPERAND (t, 1))); - /* Convert offset (presumably in bytes) into canonical units - (presumably bits). */ - *offset = size_binop (MULT_EXPR, - convert (bitsizetype, *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 = bitsize_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 = bitsize_zero_node; - break; - } - /* Fall through. */ - default: - /* Not a COMMON reference, so an unrecognized pattern. */ - *decl = error_mark_node; - break; - } -} - -/* 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. */ - -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 NEGATE_EXPR: - case MIN_EXPR: - case MAX_EXPR: - case ABS_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_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 = bitsize_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; - - /* Calculate ((element - base) * NBBY) + init_offset. */ - *offset = fold (build (MINUS_EXPR, TREE_TYPE (element), - element, - TYPE_MIN_VALUE (TYPE_DOMAIN - (TREE_TYPE (array))))); - - *offset = size_binop (MULT_EXPR, - convert (bitsizetype, *offset), - TYPE_SIZE (TREE_TYPE (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; - } -} - -/* Do divide operation appropriate to type of operands. */ - -static tree -ffecom_tree_divide_ (tree tree_type, tree left, tree right, tree dest_tree, - ffebld dest, bool *dest_used, tree hook) -{ - 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: - if (! optimize_size) - return ffecom_2 (RDIV_EXPR, tree_type, - left, - right); - { - 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, hook); - } - 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, hook); - } - break; - - default: - return ffecom_2 (RDIV_EXPR, tree_type, - left, - right); - } -} - -/* Build type info for non-dummy variable. */ - -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; -} - -/* Build Namelist type. */ - -static GTY(()) tree ffecom_type_namelist_var; -static tree -ffecom_type_namelist_ (void) -{ - if (ffecom_type_namelist_var == NULL_TREE) - { - tree namefield, varsfield, nvarsfield, vardesctype, type; - - vardesctype = ffecom_type_vardesc_ (); - - 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); - - ffecom_type_namelist_var = type; - } - - return ffecom_type_namelist_var; -} - -/* Build Vardesc type. */ - -static GTY(()) tree ffecom_type_vardesc_var; -static tree -ffecom_type_vardesc_ (void) -{ - if (ffecom_type_vardesc_var == NULL_TREE) - { - tree namefield, addrfield, dimsfield, typefield, type; - 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_ptr_to_ftnlen_type_node); - typefield = ffecom_decl_field (type, dimsfield, "type", - integer_type_node); - - TYPE_FIELDS (type) = namefield; - layout_type (type); - - ffecom_type_vardesc_var = type; - } - - return ffecom_type_vardesc_var; -} - -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; - static int mynumber = 0; - - var = build_decl (VAR_DECL, - ffecom_get_invented_identifier ("__g77_vardesc_%d", - 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, varinits); - TREE_CONSTANT (varinits) = 1; - TREE_STATIC (varinits) = 1; - - finish_decl (var, varinits, FALSE); - - var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var); - - ffesymbol_hook (s).vardesc_tree = var; - } - - return ffesymbol_hook (s).vardesc_tree; -} - -static tree -ffecom_vardesc_array_ (ffesymbol s) -{ - ffebld b; - tree list; - tree item = NULL_TREE; - tree var; - int i; - 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); - } - } - - 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, list); - TREE_CONSTANT (list) = 1; - TREE_STATIC (list) = 1; - - var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", 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); - - return var; -} - -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; - 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; - - 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, numdim); - TREE_CONSTANT (list) = 1; - TREE_STATIC (list) = 1; - - var = ffecom_get_invented_identifier ("__g77_dims_%d", 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); - - return var; - } -} - -/* 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. */ - -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 (!ffe_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; - else if (code == INDIRECT_REF) - TREE_READONLY (item) = TYPE_READONLY (type); - return fold (item); -} - -/* 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). */ - -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); -} - -/* Essentially does a "fold (build (code, type, node1, node2))" while - checking for certain housekeeping things. */ - -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, 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); -} - -/* 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. */ - -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; -} - -/* 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. */ - -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); -} - -/* Essentially does a "fold (build (code, type, node1, node2))" while - checking for certain housekeeping things. Always sets - TREE_SIDE_EFFECTS. */ - -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); -} - -/* Essentially does a "fold (build (code, type, node1, node2, node3))" while - checking for certain housekeeping things. */ - -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); -} - -/* Essentially does a "fold (build (code, type, node1, node2, node3))" while - checking for certain housekeeping things. Always sets - TREE_SIDE_EFFECTS. */ - -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); -} - -/* 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). */ - -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); -} - -/* Transform expression into constant argument-pointer-to-expression tree. - - If the expression can be transformed into a argument-pointer-to-expression - tree that is constant, that is done, and the tree returned. Else - NULL_TREE is returned. - - That way, a caller can attempt to provide compile-time initialization - of a variable and, if that fails, *then* choose to start a new block - and resort to using temporaries, as appropriate. */ - -tree -ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length) -{ - if (! expr) - return integer_zero_node; - - if (ffebld_op (expr) == FFEBLD_opANY) - { - if (length) - *length = error_mark_node; - return error_mark_node; - } - - if (ffebld_arity (expr) == 0 - && (ffebld_op (expr) != FFEBLD_opSYMTER - || ffebld_where (expr) == FFEINFO_whereCOMMON - || ffebld_where (expr) == FFEINFO_whereGLOBAL - || ffebld_where (expr) == FFEINFO_whereINTRINSIC)) - { - tree t; - - t = ffecom_arg_ptr_to_expr (expr, length); - assert (TREE_CONSTANT (t)); - assert (! length || TREE_CONSTANT (*length)); - return t; - } - - if (length - && ffebld_size (expr) != FFETARGET_charactersizeNONE) - *length = build_int_2 (ffebld_size (expr), 0); - else if (length) - *length = NULL_TREE; - return NULL_TREE; -} - -/* 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 the length argument is NULL, this is a slightly special - case of building a FORMAT expression, that is, an expression that - will be used at run time without regard to length. For the current - implementation, which uses the libf2c library, this means it is nice - to append a null byte to the end of the expression, where feasible, - to make sure any diagnostic about the FORMAT string terminates at - some useful point. - - For now, treat %REF(char-expr) as the same as char-expr with a NULL - length argument. This might even be seen as a feature, if a null - byte can always be appended. */ - -tree -ffecom_arg_ptr_to_expr (ffebld expr, tree *length) -{ - tree item; - tree ign_length; - ffecomConcatList_ catlist; - - if (length != NULL) - *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); - if (temp_exp == error_mark_node) - return error_mark_node; - - 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)); - if (length != NULL) - { - ign_length = NULL_TREE; - length = &ign_length; - } - expr = ffebld_left (expr); - break; - - case FFEBLD_opPERCENT_DESCR: - switch (ffeinfo_basictype (ffebld_info (expr))) - { - 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; - } - - if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER) - return ffecom_ptr_to_expr (expr); - - assert (ffeinfo_kindtype (ffebld_info (expr)) - == FFEINFO_kindtypeCHARACTER1); - - while (ffebld_op (expr) == FFEBLD_opPAREN) - expr = ffebld_left (expr); - - catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE); - switch (ffecom_concat_list_count_ (catlist)) - { - case 0: /* Shouldn't happen, but in case it does... */ - if (length != NULL) - { - *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. */ - if (length == NULL) - ffecom_char_args_with_null_ (&item, &ign_length, - ffecom_concat_list_expr_ (catlist, 0)); - else - 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; - - sz = ffecom_concat_list_maxlen_ (catlist); - /* ~~Kludge! */ - assert (sz != FFETARGET_charactersizeNONE); - - { - tree hook; - - hook = ffebld_nonter_hook (expr); - assert (hook); - assert (TREE_CODE (hook) == TREE_VEC); - assert (TREE_VEC_LENGTH (hook) == 3); - length_array = lengths = TREE_VEC_ELT (hook, 0); - item_array = items = TREE_VEC_ELT (hook, 1); - temporary = TREE_VEC_ELT (hook, 2); - } - - known_length = ffecom_f2c_ftnlen_zero_node; - - for (i = 0; i < count; ++i) - { - if ((i == count) - && (length == NULL)) - ffecom_char_args_with_null_ (&citem, &clength, - ffecom_concat_list_expr_ (catlist, i)); - else - 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); - if (length != NULL) - 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); - } - - 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, NULL_TREE); - TREE_SIDE_EFFECTS (item) = 1; - item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary), - item, - temporary); - - if (length != NULL) - *length = known_length; - } - - ffecom_concat_list_kill_ (catlist); - assert (item != NULL_TREE); - return item; -} - -/* Generate call to run-time function. - - 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). */ - -tree -ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook) -{ - 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, hook); -} - -/* Transform constant-union to tree. */ - -tree -ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt, - ffeinfoKindtype kt, tree tree_type) -{ - tree item; - - switch (bt) - { - case FFEINFO_basictypeINTEGER: - { - HOST_WIDE_INT hi, lo; - - switch (kt) - { -#if FFETARGET_okINTEGER1 - case FFEINFO_kindtypeINTEGER1: - lo = ffebld_cu_val_integer1 (*cu); - hi = (lo < 0) ? -1 : 0; - break; -#endif - -#if FFETARGET_okINTEGER2 - case FFEINFO_kindtypeINTEGER2: - lo = ffebld_cu_val_integer2 (*cu); - hi = (lo < 0) ? -1 : 0; - break; -#endif - -#if FFETARGET_okINTEGER3 - case FFEINFO_kindtypeINTEGER3: - lo = ffebld_cu_val_integer3 (*cu); - hi = (lo < 0) ? -1 : 0; - break; -#endif - -#if FFETARGET_okINTEGER4 - case FFEINFO_kindtypeINTEGER4: -#if HOST_BITS_PER_LONGLONG > HOST_BITS_PER_WIDE_INT - { - long long int big = ffebld_cu_val_integer4 (*cu); - hi = (HOST_WIDE_INT) (big >> HOST_BITS_PER_WIDE_INT); - lo = (HOST_WIDE_INT) big; - } -#else - lo = ffebld_cu_val_integer4 (*cu); - hi = (lo < 0) ? -1 : 0; -#endif - break; -#endif - - default: - assert ("bad INTEGER constant kind type" == NULL); - /* Fall through. */ - case FFEINFO_kindtypeANY: - return error_mark_node; - } - item = build_int_2 (lo, hi); - 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 - - 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 - - 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; -} - -/* Transform constant-union to tree, with the type known. */ - -tree -ffecom_constantunion_with_type (ffebldConstantUnion *cu, tree tree_type, - ffebldConst ct) -{ - tree item; - - int val; - - switch (ct) - { -#if FFETARGET_okINTEGER1 - case FFEBLD_constINTEGER1: - val = ffebld_cu_val_integer1 (*cu); - item = build_int_2 (val, (val < 0) ? -1 : 0); - break; -#endif -#if FFETARGET_okINTEGER2 - case FFEBLD_constINTEGER2: - val = ffebld_cu_val_integer2 (*cu); - item = build_int_2 (val, (val < 0) ? -1 : 0); - break; -#endif -#if FFETARGET_okINTEGER3 - case FFEBLD_constINTEGER3: - val = ffebld_cu_val_integer3 (*cu); - item = build_int_2 (val, (val < 0) ? -1 : 0); - break; -#endif -#if FFETARGET_okINTEGER4 - case FFEBLD_constINTEGER4: -#if HOST_BITS_PER_LONGLONG > HOST_BITS_PER_WIDE_INT - { - long long int big = ffebld_cu_val_integer4 (*cu); - item = build_int_2 ((HOST_WIDE_INT) big, - (HOST_WIDE_INT) - (big >> HOST_BITS_PER_WIDE_INT)); - } -#else - val = ffebld_cu_val_integer4 (*cu); - item = build_int_2 (val, (val < 0) ? -1 : 0); -#endif - break; -#endif -#if FFETARGET_okLOGICAL1 - case FFEBLD_constLOGICAL1: - val = ffebld_cu_val_logical1 (*cu); - item = build_int_2 (val, (val < 0) ? -1 : 0); - break; -#endif -#if FFETARGET_okLOGICAL2 - case FFEBLD_constLOGICAL2: - val = ffebld_cu_val_logical2 (*cu); - item = build_int_2 (val, (val < 0) ? -1 : 0); - break; -#endif -#if FFETARGET_okLOGICAL3 - case FFEBLD_constLOGICAL3: - val = ffebld_cu_val_logical3 (*cu); - item = build_int_2 (val, (val < 0) ? -1 : 0); - break; -#endif -#if FFETARGET_okLOGICAL4 - case FFEBLD_constLOGICAL4: - val = ffebld_cu_val_logical4 (*cu); - item = build_int_2 (val, (val < 0) ? -1 : 0); - break; -#endif - default: - assert ("constant type not supported"==NULL); - return error_mark_node; - break; - } - - TREE_TYPE (item) = tree_type; - - TREE_CONSTANT (item) = 1; - - return item; -} -/* Transform expression into constant tree. - - If the expression can be transformed into a tree that is constant, - that is done, and the tree returned. Else NULL_TREE is returned. - - That way, a caller can attempt to provide compile-time initialization - of a variable and, if that fails, *then* choose to start a new block - and resort to using temporaries, as appropriate. */ - -tree -ffecom_const_expr (ffebld expr) -{ - if (! expr) - return integer_zero_node; - - if (ffebld_op (expr) == FFEBLD_opANY) - return error_mark_node; - - if (ffebld_arity (expr) == 0 - && (ffebld_op (expr) != FFEBLD_opSYMTER - || ffebld_where (expr) == FFEINFO_whereGLOBAL - || ffebld_where (expr) == FFEINFO_whereINTRINSIC)) - { - tree t; - - t = ffecom_expr (expr); - assert (TREE_CONSTANT (t)); - return t; - } - - return NULL_TREE; -} - -/* Handy way to make a field in a struct/union. */ - -tree -ffecom_decl_field (tree context, tree prevfield, const char *name, tree type) -{ - tree field; - - field = build_decl (FIELD_DECL, get_identifier (name), type); - DECL_CONTEXT (field) = context; - DECL_ALIGN (field) = 0; - DECL_USER_ALIGN (field) = 0; - if (prevfield != NULL_TREE) - TREE_CHAIN (prevfield) = field; - - return field; -} - -void -ffecom_close_include (FILE *f) -{ - ffecom_close_include_ (f); -} - -/* End a compound statement (block). */ - -tree -ffecom_end_compstmt (void) -{ - return bison_rule_compstmt_ (); -} - -/* 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 (void) -{ - ffebld item; - - if (ffe_is_ffedebug ()) - fprintf (dmpout, "; end_stmt_transition\n"); - - ffecom_list_blockdata_ = NULL; - ffecom_list_common_ = NULL; - - ffesymbol_drive (ffecom_sym_end_transition); - if (ffe_is_ffedebug ()) - { - ffestorag_report (); - } - - ffecom_start_progunit_ (); - - for (item = ffecom_list_blockdata_; - item != NULL; - item = ffebld_trail (item)) - { - ffebld callee; - ffesymbol s; - tree dt; - tree t; - tree var; - 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; - } - - dt = build_pointer_type (TREE_TYPE (t)); - - var = build_decl (VAR_DECL, - ffecom_get_invented_identifier ("__g77_forceload_%d", - 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); - } - - /* 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; -} - -/* 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 (void) -{ - 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 (); - } - - if (inhibited) - ffebad_set_inhibit (TRUE); -} - -/* Handle assignment statement. - - Convert dest and source using ffecom_expr, then join them - with an ASSIGN op and pass the whole thing to expand_expr_stmt. */ - -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; - tree assign_temp; - - /* This attempts to replicate the test below, but must not be - true when the test below is false. (Always err on the side - of creating unused temporaries, to avoid ICEs.) */ - if (ffebld_op (dest) != FFEBLD_opSYMTER - || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree) - && (TREE_CODE (dest_tree) != VAR_DECL - || TREE_ADDRESSABLE (dest_tree)))) - { - ffecom_prepare_expr_ (source, dest); - dest_used = TRUE; - } - else - { - ffecom_prepare_expr_ (source, NULL); - dest_used = FALSE; - } - - ffecom_prepare_expr_w (NULL_TREE, dest); - - /* For COMPLEX assignment like C1=C2, if partial overlap is possible, - create a temporary through which the assignment is to take place, - since MODIFY_EXPR doesn't handle partial overlap properly. */ - if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX - && ffecom_possible_partial_overlap_ (dest, source)) - { - assign_temp = ffecom_make_tempvar ("complex_let", - ffecom_tree_type - [ffebld_basictype (dest)] - [ffebld_kindtype (dest)], - FFETARGET_charactersizeNONE, - -1); - } - else - assign_temp = NULL_TREE; - - ffecom_prepare_end (); - - dest_tree = ffecom_expr_w (NULL_TREE, 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, FALSE); - else - { - assert (! dest_used); - dest_used = FALSE; - source_tree = ffecom_expr (source); - } - if (source_tree == error_mark_node) - return; - - if (dest_used) - expr_tree = source_tree; - else if (assign_temp) - { - expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node, - assign_temp, - source_tree); - expand_expr_stmt (expr_tree); - expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node, - dest_tree, - assign_temp); - } - else - expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node, - dest_tree, - source_tree); - - expand_expr_stmt (expr_tree); - return; - } - - ffecom_prepare_let_char_ (ffebld_size_known (dest), source); - ffecom_prepare_expr_w (NULL_TREE, dest); - - ffecom_prepare_end (); - - ffecom_char_args_ (&dest_tree, &dest_length, dest); - ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest), - source); -} - -/* 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. */ - -tree -ffecom_expr (ffebld expr) -{ - return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE); -} - -/* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT. */ - -tree -ffecom_expr_assign (ffebld expr) -{ - return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE); -} - -/* Like ffecom_expr_rw, but return tree usable for ASSIGN. */ - -tree -ffecom_expr_assign_w (ffebld expr) -{ - return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE); -} - -/* 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. */ - -tree -ffecom_expr_rw (tree type, ffebld expr) -{ - assert (expr != NULL); - /* Different target types not yet supported. */ - assert (type == NULL_TREE || type == ffecom_type_expr (expr)); - - return stabilize_reference (ffecom_expr (expr)); -} - -/* Transform expr for use as into write tree and stabilize the - reference. Not for use on CHARACTER expressions. - - Recursive descent on expr while making corresponding tree nodes and - attaching type info and such. */ - -tree -ffecom_expr_w (tree type, ffebld expr) -{ - assert (expr != NULL); - /* Different target types not yet supported. */ - assert (type == NULL_TREE || type == ffecom_type_expr (expr)); - - return stabilize_reference (ffecom_expr (expr)); -} - -/* Do global stuff. */ - -void -ffecom_finish_compile (void) -{ - assert (ffecom_outer_function_decl_ == NULL_TREE); - assert (current_function_decl == NULL_TREE); - - ffeglobal_drive (ffecom_finish_global_); -} - -/* Public entry point for front end to access finish_decl. */ - -void -ffecom_finish_decl (tree decl, tree init, bool is_top_level) -{ - assert (!is_top_level); - finish_decl (decl, init, FALSE); -} - -/* Finish a program unit. */ - -void -ffecom_finish_progunit (void) -{ - ffecom_end_compstmt (); - - ffecom_previous_function_decl_ = current_function_decl; - ffecom_which_entrypoint_decl_ = NULL_TREE; - - finish_function (0); -} - -/* Wrapper for get_identifier. pattern is sprintf-like. */ - -tree -ffecom_get_invented_identifier (const char *pattern, ...) -{ - tree decl; - char *nam; - va_list ap; - - va_start (ap, pattern); - if (vasprintf (&nam, pattern, ap) == 0) - abort (); - va_end (ap); - decl = get_identifier (nam); - free (nam); - IDENTIFIER_INVENTED (decl) = 1; - return decl; -} - -ffeinfoBasictype -ffecom_gfrt_basictype (ffecomGfrt gfrt) -{ - assert (gfrt < FFECOM_gfrt); - - switch (ffecom_gfrt_type_[gfrt]) - { - case FFECOM_rttypeVOID_: - case FFECOM_rttypeVOIDSTAR_: - return FFEINFO_basictypeNONE; - - case FFECOM_rttypeFTNINT_: - 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_: - case FFECOM_rttypeDOUBLEREAL_: - 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_: - case FFECOM_rttypeVOIDSTAR_: - return FFEINFO_kindtypeNONE; - - case FFECOM_rttypeFTNINT_: - 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_: - case FFECOM_rttypeDOUBLEREAL_: - 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 (void) -{ - tree endlink; - int i; - int j; - tree t; - tree field; - ffetype type; - ffetype base_type; - tree double_ftype_double, double_ftype_double_double; - tree float_ftype_float, float_ftype_float_float; - tree ldouble_ftype_ldouble, ldouble_ftype_ldouble_ldouble; - tree ffecom_tree_ptr_to_fun_type_void; - - /* 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 const char names[][12] - = - {"bar", "bletch", "foo", "foobar"}; - const char *name; - unsigned long ul; - double fl; - - name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]), - (int (*)(const void *, const void *)) strcmp); - if (name != &names[2][0]) - { - 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 (); - } - } - - 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; - /* Make the binding_level structure for global names. */ - pushlevel (0); - global_binding_level = current_binding_level; - current_binding_level->prep_state = 2; - - build_common_tree_nodes (1); - - /* Define `int' and `char' first so that dbx will output them first. */ - pushdecl (build_decl (TYPE_DECL, get_identifier ("int"), - integer_type_node)); - /* CHARACTER*1 is unsigned in ICHAR contexts. */ - char_type_node = make_unsigned_type (CHAR_TYPE_SIZE); - pushdecl (build_decl (TYPE_DECL, get_identifier ("char"), - char_type_node)); - pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"), - long_integer_type_node)); - pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"), - unsigned_type_node)); - pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"), - long_unsigned_type_node)); - pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"), - long_long_integer_type_node)); - pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"), - long_long_unsigned_type_node)); - pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"), - short_integer_type_node)); - pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"), - short_unsigned_type_node)); - - /* Set the sizetype before we make other types. This *should* be the - first type we create. */ - - set_sizetype - (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE)))); - ffecom_typesize_pointer_ - = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT; - - build_common_tree_nodes_2 (0); - - /* Define both `signed char' and `unsigned char'. */ - pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"), - signed_char_type_node)); - - pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"), - unsigned_char_type_node)); - - pushdecl (build_decl (TYPE_DECL, get_identifier ("float"), - float_type_node)); - pushdecl (build_decl (TYPE_DECL, get_identifier ("double"), - double_type_node)); - pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"), - long_double_type_node)); - - /* For now, override what build_common_tree_nodes has done. */ - complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node); - complex_float_type_node = ffecom_make_complex_type_ (float_type_node); - complex_double_type_node = ffecom_make_complex_type_ (double_type_node); - complex_long_double_type_node - = ffecom_make_complex_type_ (long_double_type_node); - - pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"), - complex_integer_type_node)); - pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"), - complex_float_type_node)); - pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"), - complex_double_type_node)); - pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"), - complex_long_double_type_node)); - - pushdecl (build_decl (TYPE_DECL, get_identifier ("void"), - void_type_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; - TYPE_USER_ALIGN (void_type_node) = 0; - - 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); - - t = tree_cons (NULL_TREE, float_type_node, endlink); - float_ftype_float = build_function_type (float_type_node, t); - t = tree_cons (NULL_TREE, float_type_node, t); - float_ftype_float_float = build_function_type (float_type_node, t); - - t = tree_cons (NULL_TREE, double_type_node, endlink); - double_ftype_double = build_function_type (double_type_node, t); - t = tree_cons (NULL_TREE, double_type_node, t); - double_ftype_double_double = build_function_type (double_type_node, t); - - t = tree_cons (NULL_TREE, long_double_type_node, endlink); - ldouble_ftype_ldouble = build_function_type (long_double_type_node, t); - t = tree_cons (NULL_TREE, long_double_type_node, t); - ldouble_ftype_ldouble_ldouble = build_function_type (long_double_type_node, - t); - - 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); - ffecom_typesize_integer1_ = ffetype_size (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_error ("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_); - ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGERDEFAULT), - 7, - ffeinfo_type (FFEINFO_basictypeINTEGER, - ffecom_pointer_kind_)); - - 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); - /* ~~~Not really such a type in libf2c, e.g. I/O support? */ - 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_ALIGN (ffecom_multi_fields_[i][j]) = 0; - DECL_USER_ALIGN (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_atanf", float_ftype_float, - BUILT_IN_ATANF, BUILT_IN_NORMAL, "atanf", NULL_TREE); - builtin_function ("__builtin_atan", double_ftype_double, - BUILT_IN_ATAN, BUILT_IN_NORMAL, "atan", NULL_TREE); - builtin_function ("__builtin_atanl", ldouble_ftype_ldouble, - BUILT_IN_ATANL, BUILT_IN_NORMAL, "atanl", NULL_TREE); - - builtin_function ("__builtin_atan2f", float_ftype_float_float, - BUILT_IN_ATAN2F, BUILT_IN_NORMAL, "atan2f", NULL_TREE); - builtin_function ("__builtin_atan2", double_ftype_double_double, - BUILT_IN_ATAN2, BUILT_IN_NORMAL, "atan2", NULL_TREE); - builtin_function ("__builtin_atan2l", ldouble_ftype_ldouble_ldouble, - BUILT_IN_ATAN2L, BUILT_IN_NORMAL, "atan2l", NULL_TREE); - - builtin_function ("__builtin_cosf", float_ftype_float, - BUILT_IN_COSF, BUILT_IN_NORMAL, "cosf", NULL_TREE); - builtin_function ("__builtin_cos", double_ftype_double, - BUILT_IN_COS, BUILT_IN_NORMAL, "cos", NULL_TREE); - builtin_function ("__builtin_cosl", ldouble_ftype_ldouble, - BUILT_IN_COSL, BUILT_IN_NORMAL, "cosl", NULL_TREE); - - builtin_function ("__builtin_expf", float_ftype_float, - BUILT_IN_EXPF, BUILT_IN_NORMAL, "expf", NULL_TREE); - builtin_function ("__builtin_exp", double_ftype_double, - BUILT_IN_EXP, BUILT_IN_NORMAL, "exp", NULL_TREE); - builtin_function ("__builtin_expl", ldouble_ftype_ldouble, - BUILT_IN_EXPL, BUILT_IN_NORMAL, "expl", NULL_TREE); - - builtin_function ("__builtin_floorf", float_ftype_float, - BUILT_IN_FLOORF, BUILT_IN_NORMAL, "floorf", NULL_TREE); - builtin_function ("__builtin_floor", double_ftype_double, - BUILT_IN_FLOOR, BUILT_IN_NORMAL, "floor", NULL_TREE); - builtin_function ("__builtin_floorl", ldouble_ftype_ldouble, - BUILT_IN_FLOORL, BUILT_IN_NORMAL, "floorl", NULL_TREE); - - builtin_function ("__builtin_fmodf", float_ftype_float_float, - BUILT_IN_FMODF, BUILT_IN_NORMAL, "fmodf", NULL_TREE); - builtin_function ("__builtin_fmod", double_ftype_double_double, - BUILT_IN_FMOD, BUILT_IN_NORMAL, "fmod", NULL_TREE); - builtin_function ("__builtin_fmodl", ldouble_ftype_ldouble_ldouble, - BUILT_IN_FMODL, BUILT_IN_NORMAL, "fmodl", NULL_TREE); - - builtin_function ("__builtin_logf", float_ftype_float, - BUILT_IN_LOGF, BUILT_IN_NORMAL, "logf", NULL_TREE); - builtin_function ("__builtin_log", double_ftype_double, - BUILT_IN_LOG, BUILT_IN_NORMAL, "log", NULL_TREE); - builtin_function ("__builtin_logl", ldouble_ftype_ldouble, - BUILT_IN_LOGL, BUILT_IN_NORMAL, "logl", NULL_TREE); - - builtin_function ("__builtin_powf", float_ftype_float_float, - BUILT_IN_POWF, BUILT_IN_NORMAL, "powf", NULL_TREE); - builtin_function ("__builtin_pow", double_ftype_double_double, - BUILT_IN_POW, BUILT_IN_NORMAL, "pow", NULL_TREE); - builtin_function ("__builtin_powl", ldouble_ftype_ldouble_ldouble, - BUILT_IN_POWL, BUILT_IN_NORMAL, "powl", NULL_TREE); - - builtin_function ("__builtin_sinf", float_ftype_float, - BUILT_IN_SINF, BUILT_IN_NORMAL, "sinf", NULL_TREE); - builtin_function ("__builtin_sin", double_ftype_double, - BUILT_IN_SIN, BUILT_IN_NORMAL, "sin", NULL_TREE); - builtin_function ("__builtin_sinl", ldouble_ftype_ldouble, - BUILT_IN_SINL, BUILT_IN_NORMAL, "sinl", NULL_TREE); - - builtin_function ("__builtin_sqrtf", float_ftype_float, - BUILT_IN_SQRTF, BUILT_IN_NORMAL, "sqrtf", NULL_TREE); - builtin_function ("__builtin_sqrt", double_ftype_double, - BUILT_IN_SQRT, BUILT_IN_NORMAL, "sqrt", NULL_TREE); - builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble, - BUILT_IN_SQRTL, BUILT_IN_NORMAL, "sqrtl", NULL_TREE); - - builtin_function ("__builtin_tanf", float_ftype_float, - BUILT_IN_TANF, BUILT_IN_NORMAL, "tanf", NULL_TREE); - builtin_function ("__builtin_tan", double_ftype_double, - BUILT_IN_TAN, BUILT_IN_NORMAL, "tan", NULL_TREE); - builtin_function ("__builtin_tanl", ldouble_ftype_ldouble, - BUILT_IN_TANL, BUILT_IN_NORMAL, "tanl", NULL_TREE); - - pedantic_lvalues = FALSE; - - 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); - ffecom_float_half_ = build_real (float_type_node, dconsthalf); - ffecom_double_half_ = build_real (double_type_node, dconsthalf); - - /* Do "extern int xargc;". */ - - ffecom_tree_xargc_ = build_decl (VAR_DECL, - get_identifier ("f__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."); - } -#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 -} - -/* ffecom_init_2 -- Initialize - - ffecom_init_2(); */ - -void -ffecom_init_2 (void) -{ - 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_primary_entry_ = NULL; - ffecom_is_altreturning_ = FALSE; - ffecom_func_result_ = NULL_TREE; - ffecom_multi_retval_ = NULL_TREE; -} - -/* 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. */ - -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) - { - tree texpr = ffecom_arg_expr (ffebld_head (expr), &length); - - if (texpr == error_mark_node) - return error_mark_node; - - *plist = build_tree_list (NULL_TREE, texpr); - 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; -} - -/* 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). */ - -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) - { - tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length); - - if (texpr == error_mark_node) - return error_mark_node; - - *plist = build_tree_list (NULL_TREE, texpr); - 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; -} - -/* Obtain gcc's LABEL_DECL tree for label. */ - -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: - glabel = build_decl (VAR_DECL, - ffecom_get_invented_identifier - ("__g77_format_%d", (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) = current_function_decl; - DECL_INITIAL (glabel) = NULL; - make_decl_rtl (glabel, NULL); - expand_decl (glabel); - - ffecom_save_tree_forever (glabel); - - 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; -} - -/* 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. */ - -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); -} - -/* Register source file name. */ - -void -ffecom_file (const char *name) -{ - ffecom_file_ (name); -} - -/* 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 (ffestorag_init (st) == NULL) - { - init = ffestorag_accretion (st); - assert (init != NULL); - ffestorag_set_accretion (st, NULL); - ffestorag_set_accretes (st, 0); - ffestorag_set_init (st, init); - } -} - -/* 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 (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); - ffesymbol_set_init (s, init); - } -} - -/* 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_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; - } - } - } -} - -FILE * -ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c) -{ - return ffecom_open_include_ (name, l, c); -} - -/* 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. */ - -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: - return ffecom_arrayref_ (NULL_TREE, expr, 1); - - 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: - 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; -} - -/* Obtain a temp var with given data type. - - 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. */ - -tree -ffecom_make_tempvar (const char *commentary, tree type, - ffetargetCharacterSize size, int elements) -{ - tree t; - static int mynumber; - - assert (current_binding_level->prep_state < 2); - - if (type == error_mark_node) - return error_mark_node; - - 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_%s_%d", - commentary, - mynumber++), - type); - - t = start_decl (t, FALSE); - finish_decl (t, NULL_TREE, FALSE); - - return t; -} - -/* Prepare argument pointer to expression. - - Like ffecom_prepare_expr, except for expressions to be evaluated - via ffecom_arg_ptr_to_expr. */ - -void -ffecom_prepare_arg_ptr_to_expr (ffebld expr) -{ - /* ~~For now, it seems to be the same thing. */ - ffecom_prepare_expr (expr); - return; -} - -/* End of preparations. */ - -bool -ffecom_prepare_end (void) -{ - int prep_state = current_binding_level->prep_state; - - assert (prep_state < 2); - current_binding_level->prep_state = 2; - - return (prep_state == 1) ? TRUE : FALSE; -} - -/* Prepare expression. - - This is called before any code is generated for the current block. - It scans the expression, declares any temporaries that might be needed - during evaluation of the expression, and stores those temporaries in - the appropriate "hook" fields of the expression. `dest', if not NULL, - specifies the destination that ffecom_expr_ will see, in case that - helps avoid generating unused temporaries. - - ~~Improve to avoid allocating unused temporaries by taking `dest' - into account vis-a-vis aliasing requirements of complex/character - functions. */ - -void -ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED) -{ - ffeinfoBasictype bt; - ffeinfoKindtype kt; - ffetargetCharacterSize sz; - tree tempvar = NULL_TREE; - - assert (current_binding_level->prep_state < 2); - - if (! expr) - return; - - bt = ffeinfo_basictype (ffebld_info (expr)); - kt = ffeinfo_kindtype (ffebld_info (expr)); - sz = ffeinfo_size (ffebld_info (expr)); - - /* Generate whatever temporaries are needed to represent the result - of the expression. */ - - if (bt == FFEINFO_basictypeCHARACTER) - { - while (ffebld_op (expr) == FFEBLD_opPAREN) - expr = ffebld_left (expr); - } - - switch (ffebld_op (expr)) - { - default: - /* Don't make temps for SYMTER, CONTER, etc. */ - if (ffebld_arity (expr) == 0) - break; - - switch (bt) - { - case FFEINFO_basictypeCOMPLEX: - if (ffebld_op (expr) == FFEBLD_opFUNCREF) - { - ffesymbol s; - - if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER) - break; - - s = ffebld_symter (ffebld_left (expr)); - if (ffesymbol_where (s) == FFEINFO_whereCONSTANT - || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC - && ! ffesymbol_is_f2c (s)) - || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC - && ! ffe_is_f2c_library ())) - break; - } - else if (ffebld_op (expr) == FFEBLD_opPOWER) - { - /* Requires special treatment. There's no POW_CC function - in libg2c, so POW_ZZ is used, which means we always - need a double-complex temp, not a single-complex. */ - kt = FFEINFO_kindtypeREAL2; - } - else if (ffebld_op (expr) != FFEBLD_opDIVIDE) - /* The other ops don't need temps for complex operands. */ - break; - - /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C), - REAL(C). See 19990325-0.f, routine `check', for cases. */ - tempvar = ffecom_make_tempvar ("complex", - ffecom_tree_type - [FFEINFO_basictypeCOMPLEX][kt], - FFETARGET_charactersizeNONE, - -1); - break; - - case FFEINFO_basictypeCHARACTER: - if (ffebld_op (expr) != FFEBLD_opFUNCREF) - break; - - if (sz == FFETARGET_charactersizeNONE) - /* ~~Kludge alert! This should someday be fixed. */ - sz = 24; - - tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1); - break; - - default: - break; - } - break; - - case FFEBLD_opCONCATENATE: - { - /* This gets special handling, because only one set of temps - is needed for a tree of these -- the tree is treated as - a flattened list of concatenations when generating code. */ - - ffecomConcatList_ catlist; - tree ltmp, itmp, result; - int count; - int i; - - catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE); - count = ffecom_concat_list_count_ (catlist); - - if (count >= 2) - { - ltmp - = ffecom_make_tempvar ("concat_len", - ffecom_f2c_ftnlen_type_node, - FFETARGET_charactersizeNONE, count); - itmp - = ffecom_make_tempvar ("concat_item", - ffecom_f2c_address_type_node, - FFETARGET_charactersizeNONE, count); - result - = ffecom_make_tempvar ("concat_res", - char_type_node, - ffecom_concat_list_maxlen_ (catlist), - -1); - - tempvar = make_tree_vec (3); - TREE_VEC_ELT (tempvar, 0) = ltmp; - TREE_VEC_ELT (tempvar, 1) = itmp; - TREE_VEC_ELT (tempvar, 2) = result; - } - - for (i = 0; i < count; ++i) - ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, - i)); - - ffecom_concat_list_kill_ (catlist); - - if (tempvar) - { - ffebld_nonter_set_hook (expr, tempvar); - current_binding_level->prep_state = 1; - } - } - return; - - case FFEBLD_opCONVERT: - if (bt == FFEINFO_basictypeCHARACTER - && ((ffebld_size_known (ffebld_left (expr)) - == FFETARGET_charactersizeNONE) - || (ffebld_size_known (ffebld_left (expr)) >= sz))) - tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1); - break; - } - - if (tempvar) - { - ffebld_nonter_set_hook (expr, tempvar); - current_binding_level->prep_state = 1; - } - - /* Prepare subexpressions for this expr. */ - - switch (ffebld_op (expr)) - { - case FFEBLD_opPERCENT_LOC: - ffecom_prepare_ptr_to_expr (ffebld_left (expr)); - break; - - case FFEBLD_opPERCENT_VAL: - case FFEBLD_opPERCENT_REF: - ffecom_prepare_expr (ffebld_left (expr)); - break; - - case FFEBLD_opPERCENT_DESCR: - ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr)); - break; - - case FFEBLD_opITEM: - { - ffebld item; - - for (item = expr; - item != NULL; - item = ffebld_trail (item)) - if (ffebld_head (item) != NULL) - ffecom_prepare_expr (ffebld_head (item)); - } - break; - - default: - /* Need to handle character conversion specially. */ - switch (ffebld_arity (expr)) - { - case 2: - ffecom_prepare_expr (ffebld_left (expr)); - ffecom_prepare_expr (ffebld_right (expr)); - break; - - case 1: - ffecom_prepare_expr (ffebld_left (expr)); - break; - - default: - break; - } - } - - return; -} - -/* Prepare expression for reading and writing. - - Like ffecom_prepare_expr, except for expressions to be evaluated - via ffecom_expr_rw. */ - -void -ffecom_prepare_expr_rw (tree type, ffebld expr) -{ - /* This is all we support for now. */ - assert (type == NULL_TREE || type == ffecom_type_expr (expr)); - - /* ~~For now, it seems to be the same thing. */ - ffecom_prepare_expr (expr); - return; -} - -/* Prepare expression for writing. - - Like ffecom_prepare_expr, except for expressions to be evaluated - via ffecom_expr_w. */ - -void -ffecom_prepare_expr_w (tree type, ffebld expr) -{ - /* This is all we support for now. */ - assert (type == NULL_TREE || type == ffecom_type_expr (expr)); - - /* ~~For now, it seems to be the same thing. */ - ffecom_prepare_expr (expr); - return; -} - -/* Prepare expression for returning. - - Like ffecom_prepare_expr, except for expressions to be evaluated - via ffecom_return_expr. */ - -void -ffecom_prepare_return_expr (ffebld expr) -{ - assert (current_binding_level->prep_state < 2); - - if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE - && ffecom_is_altreturning_ - && expr != NULL) - ffecom_prepare_expr (expr); -} - -/* Prepare pointer to expression. - - Like ffecom_prepare_expr, except for expressions to be evaluated - via ffecom_ptr_to_expr. */ - -void -ffecom_prepare_ptr_to_expr (ffebld expr) -{ - /* ~~For now, it seems to be the same thing. */ - ffecom_prepare_expr (expr); - return; -} - -/* Transform expression into constant pointer-to-expression tree. - - If the expression can be transformed into a pointer-to-expression tree - that is constant, that is done, and the tree returned. Else NULL_TREE - is returned. - - That way, a caller can attempt to provide compile-time initialization - of a variable and, if that fails, *then* choose to start a new block - and resort to using temporaries, as appropriate. */ - -tree -ffecom_ptr_to_const_expr (ffebld expr) -{ - if (! expr) - return integer_zero_node; - - if (ffebld_op (expr) == FFEBLD_opANY) - return error_mark_node; - - if (ffebld_arity (expr) == 0 - && (ffebld_op (expr) != FFEBLD_opSYMTER - || ffebld_where (expr) == FFEINFO_whereCOMMON - || ffebld_where (expr) == FFEINFO_whereGLOBAL - || ffebld_where (expr) == FFEINFO_whereINTRINSIC)) - { - tree t; - - t = ffecom_ptr_to_expr (expr); - assert (TREE_CONSTANT (t)); - return t; - } - - return NULL_TREE; -} - -/* 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). */ - -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; -} - -/* Do save_expr only if tree is not error_mark_node. */ - -tree -ffecom_save_tree (tree t) -{ - return save_expr (t); -} - -/* Start a compound statement (block). */ - -void -ffecom_start_compstmt (void) -{ - bison_rule_pushlevel_ (); -} - -/* Public entry point for front end to access start_decl. */ - -tree -ffecom_start_decl (tree decl, bool is_initialized) -{ - DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE; - return start_decl (decl, FALSE); -} - -/* 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. */ - -void -ffecom_sym_commit (ffesymbol s UNUSED) -{ - assert (!ffesymbol_retractable ()); -} - -/* 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 ((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_); - } - - /* 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 ((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_); - } - - 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. */ - -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 -} - -/* Create temporary gcc label. */ - -tree -ffecom_temp_label (void) -{ - tree glabel; - static int mynumber = 0; - - glabel = build_decl (LABEL_DECL, - ffecom_get_invented_identifier ("__g77_label_%d", - mynumber++), - void_type_node); - DECL_CONTEXT (glabel) = current_function_decl; - DECL_MODE (glabel) = VOIDmode; - - return glabel; -} - -/* 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. */ - -tree -ffecom_truth_value (tree expr) -{ - return ffe_truthvalue_conversion (expr); -} - -/* 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. */ - -tree -ffecom_truth_value_invert (tree expr) -{ - return invert_truthvalue (ffecom_truth_value (expr)); -} - -/* Return the tree that is the type of the expression, as would be - returned in TREE_TYPE(ffecom_expr(expr)), without otherwise - transforming the expression, generating temporaries, etc. */ - -tree -ffecom_type_expr (ffebld expr) -{ - ffeinfoBasictype bt; - ffeinfoKindtype kt; - tree tree_type; - - assert (expr != NULL); - - bt = ffeinfo_basictype (ffebld_info (expr)); - kt = ffeinfo_kindtype (ffebld_info (expr)); - tree_type = ffecom_tree_type[bt][kt]; - - switch (ffebld_op (expr)) - { - case FFEBLD_opCONTER: - case FFEBLD_opSYMTER: - case FFEBLD_opARRAYREF: - case FFEBLD_opUPLUS: - case FFEBLD_opPAREN: - case FFEBLD_opUMINUS: - case FFEBLD_opADD: - case FFEBLD_opSUBTRACT: - case FFEBLD_opMULTIPLY: - case FFEBLD_opDIVIDE: - case FFEBLD_opPOWER: - case FFEBLD_opNOT: - case FFEBLD_opFUNCREF: - case FFEBLD_opSUBRREF: - case FFEBLD_opAND: - case FFEBLD_opOR: - case FFEBLD_opXOR: - case FFEBLD_opNEQV: - case FFEBLD_opEQV: - case FFEBLD_opCONVERT: - case FFEBLD_opLT: - case FFEBLD_opLE: - case FFEBLD_opEQ: - case FFEBLD_opNE: - case FFEBLD_opGT: - case FFEBLD_opGE: - case FFEBLD_opPERCENT_LOC: - return tree_type; - - case FFEBLD_opACCTER: - case FFEBLD_opARRTER: - 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 for ffecom_type_expr" == NULL); - /* Fall through. */ - case FFEBLD_opANY: - return error_mark_node; - } -} - -/* 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). */ - -tree -ffecom_which_entrypoint_decl (void) -{ - assert (ffecom_which_entrypoint_decl_ != NULL_TREE); - - return ffecom_which_entrypoint_decl_; -} - -/* 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. */ - -static void -bison_rule_pushlevel_ (void) -{ - emit_line_note (input_location); - pushlevel (0); - clear_last_expr (); - expand_start_bindings (0); -} - -static tree -bison_rule_compstmt_ (void) -{ - tree t; - int keep = kept_level_p (); - - /* Make the temps go away. */ - if (! keep) - current_binding_level->names = NULL_TREE; - - emit_line_note (input_location); - expand_end_bindings (getdecls (), keep, 0); - t = poplevel (keep, 1, 0); - - return t; -} - -/* 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. If - ATTRS is nonzero, use that for the function's attribute list. */ - -tree -builtin_function (const char *name, tree type, int function_code, - enum built_in_class class, const char *library_name, - tree attrs ATTRIBUTE_UNUSED) -{ - tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type); - DECL_EXTERNAL (decl) = 1; - TREE_PUBLIC (decl) = 1; - if (library_name) - SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name)); - make_decl_rtl (decl, NULL); - pushdecl (decl); - DECL_BUILT_IN_CLASS (decl) = class; - 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)); - - 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; - } - } - 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) - { - /* 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); - DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl); - if (TREE_CODE (olddecl) != FUNCTION_DECL) - if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl)) - { - DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl); - DECL_USER_ALIGN (newdecl) |= DECL_USER_ALIGN (olddecl); - } - } - - /* Keep the old rtl since we can safely use it. */ - COPY_DECL_RTL (olddecl, newdecl); - - /* Merge the type qualifiers. */ - 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_LOCATION (newdecl) = DECL_SOURCE_LOCATION (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); - - /* Copy the assembler name. */ - COPY_DECL_ASSEMBLER_NAME (olddecl, newdecl); - - if (TREE_CODE (newdecl) == FUNCTION_DECL) - { - DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl); - DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl); - TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl); - TREE_READONLY (newdecl) |= TREE_READONLY (olddecl); - DECL_IS_MALLOC (newdecl) |= DECL_IS_MALLOC (olddecl); - DECL_IS_PURE (newdecl) |= DECL_IS_PURE (olddecl); - } - } - /* 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_CLASS (olddecl) = NOT_BUILT_IN; - } - - /* 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_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl); - DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (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); - - memcpy ((char *) olddecl + sizeof (struct tree_common), - (char *) newdecl + 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); - 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; - } - } - - /* 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, - DECL_CONTEXT (decl) == 0, - 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 (TREE_CODE (fndecl) != ERROR_MARK) - { - 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); - - if (TREE_CODE (fndecl) != ERROR_MARK) - { - 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 (); - - /* If this is a nested function, protect the local variables in the stack - above us from being collected while we're compiling this function. */ - if (nested) - ggc_push_context (); - - /* Run the optimizers and output the assembler code for this function. */ - rest_of_compilation (fndecl); - - /* Undo the GC context switch. */ - if (nested) - ggc_pop_context (); - } - - if (TREE_CODE (fndecl) != ERROR_MARK - && !nested - && DECL_SAVED_INSNS (fndecl) == 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. */ - /* 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 const char * -ffe_printable_name (tree decl, int v) -{ - /* Just to keep GCC quiet about the unused variable. - In theory, differing values of V should produce different - output. */ - switch (v) - { - default: - if (TREE_CODE (decl) == ERROR_MARK) - return "erroneous code"; - return IDENTIFIER_POINTER (DECL_NAME (decl)); - } -} - -/* g77's function to print out name of current function that caused - an error. */ - -static void -ffe_print_error_function (diagnostic_context *context __attribute__((unused)), - const char *file) -{ - static ffeglobal last_g = NULL; - static ffesymbol last_s = NULL; - ffeglobal g; - ffesymbol s; - const char *kind; - - if ((ffecom_primary_entry_ == NULL) - || (ffesymbol_global (ffecom_primary_entry_) == NULL)) - { - g = NULL; - s = NULL; - kind = NULL; - } - else - { - g = ffesymbol_global (ffecom_primary_entry_); - if (ffecom_nested_entry_ == NULL) - { - s = ffecom_primary_entry_; - kind = _(ffeinfo_kind_message (ffesymbol_kind (s))); - } - else - { - s = ffecom_nested_entry_; - kind = _("In statement function"); - } - } - - if ((last_g != g) || (last_s != s)) - { - if (file) - fprintf (stderr, "%s: ", file); - - if (s == NULL) - fprintf (stderr, _("Outside of any program unit:\n")); - else - { - const char *name = ffesymbol_text (s); - - fprintf (stderr, "%s `%s':\n", kind, name); - } - - last_g = g; - last_s = s; - } -} - -/* 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 f_binding_level'. */ - -static struct f_binding_level * -make_binding_level (void) -{ - /* NOSTRICT */ - return ggc_alloc (sizeof (struct f_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 f_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 (void) -{ - 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 (current_function_decl != error_mark_node - && 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 (void) -{ - struct f_function *p = 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; - - /* 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 (tree x) -{ - register tree t; - register struct f_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 (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; - - if (fndecl == error_mark_node) - return; - - /* 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); - - /* 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); - - 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_SET_P (tem)) - { - 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); - } - - 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 - ffe_parse_file 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); - } - - if (TREE_CODE (type) == ERROR_MARK) - decl1 = current_function_decl = error_mark_node; - else - { - 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); - current_binding_level->prep_state = 2; - - if (TREE_CODE (current_function_decl) != ERROR_MARK) - { - make_decl_rtl (current_function_decl, NULL); - - restype = TREE_TYPE (TREE_TYPE (current_function_decl)); - DECL_RESULT (current_function_decl) - = build_decl (RESULT_DECL, NULL_TREE, restype); - } - - if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK)) - TREE_ADDRESSABLE (current_function_decl) = 1; - - immediate_size_expand = old_immediate_size_expand; -} - -/* Here are the public functions the GNU back end needs. */ - -tree -convert (tree type, tree 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; -} - -/* 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 (void) -{ - return current_binding_level->names; -} - -/* Nonzero if we are currently in the global binding level. */ - -int -global_bindings_p (void) -{ - return current_binding_level == global_binding_level; -} - -static void -ffecom_init_decl_processing (void) -{ - malloc_init (); - - ffe_init_0 (); -} - -/* Delete the node BLOCK from the current binding level. - This is used for the block inside a stmt expr ({...}) - so that the block can be reinserted where appropriate. */ - -static void -delete_block (tree block) -{ - tree t; - if (current_binding_level->blocks == block) - current_binding_level->blocks = TREE_CHAIN (block); - for (t = current_binding_level->blocks; t;) - { - if (TREE_CHAIN (t) == block) - TREE_CHAIN (t) = TREE_CHAIN (block); - else - t = TREE_CHAIN (t); - } - TREE_CHAIN (block) = NULL; - /* Clear TREE_USED which is always set by poplevel. - The flag is set again if insert_block is called. */ - TREE_USED (block) = 0; -} - -void -insert_block (tree block) -{ - TREE_USED (block) = 1; - current_binding_level->blocks - = chainon (current_binding_level->blocks, block); -} - -/* Each front end provides its own. */ -static bool ffe_init (void); -static void ffe_finish (void); -static bool ffe_post_options (const char **); -static void ffe_print_identifier (FILE *, tree, int); - -struct language_function GTY(()) -{ - int unused; -}; - -#undef LANG_HOOKS_NAME -#define LANG_HOOKS_NAME "GNU F77" -#undef LANG_HOOKS_INIT -#define LANG_HOOKS_INIT ffe_init -#undef LANG_HOOKS_FINISH -#define LANG_HOOKS_FINISH ffe_finish -#undef LANG_HOOKS_INIT_OPTIONS -#define LANG_HOOKS_INIT_OPTIONS ffe_init_options -#undef LANG_HOOKS_HANDLE_OPTION -#define LANG_HOOKS_HANDLE_OPTION ffe_handle_option -#undef LANG_HOOKS_POST_OPTIONS -#define LANG_HOOKS_POST_OPTIONS ffe_post_options -#undef LANG_HOOKS_PARSE_FILE -#define LANG_HOOKS_PARSE_FILE ffe_parse_file -#undef LANG_HOOKS_MARK_ADDRESSABLE -#define LANG_HOOKS_MARK_ADDRESSABLE ffe_mark_addressable -#undef LANG_HOOKS_PRINT_IDENTIFIER -#define LANG_HOOKS_PRINT_IDENTIFIER ffe_print_identifier -#undef LANG_HOOKS_DECL_PRINTABLE_NAME -#define LANG_HOOKS_DECL_PRINTABLE_NAME ffe_printable_name -#undef LANG_HOOKS_PRINT_ERROR_FUNCTION -#define LANG_HOOKS_PRINT_ERROR_FUNCTION ffe_print_error_function -#undef LANG_HOOKS_TRUTHVALUE_CONVERSION -#define LANG_HOOKS_TRUTHVALUE_CONVERSION ffe_truthvalue_conversion - -#undef LANG_HOOKS_TYPE_FOR_MODE -#define LANG_HOOKS_TYPE_FOR_MODE ffe_type_for_mode -#undef LANG_HOOKS_TYPE_FOR_SIZE -#define LANG_HOOKS_TYPE_FOR_SIZE ffe_type_for_size -#undef LANG_HOOKS_SIGNED_TYPE -#define LANG_HOOKS_SIGNED_TYPE ffe_signed_type -#undef LANG_HOOKS_UNSIGNED_TYPE -#define LANG_HOOKS_UNSIGNED_TYPE ffe_unsigned_type -#undef LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE -#define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE ffe_signed_or_unsigned_type - -/* We do not wish to use alias-set based aliasing at all. Used in the - extreme (every object with its own set, with equivalences recorded) it - might be helpful, but there are problems when it comes to inlining. We - get on ok with flag_argument_noalias, and alias-set aliasing does - currently limit how stack slots can be reused, which is a lose. */ -#undef LANG_HOOKS_GET_ALIAS_SET -#define LANG_HOOKS_GET_ALIAS_SET hook_get_alias_set_0 - -const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER; - -/* Table indexed by tree code giving a string containing a character - classifying the tree code. Possibilities are - t, d, s, c, r, <, 1, 2 and e. See tree.def for details. */ - -#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE, - -const char tree_code_type[] = { -#include "tree.def" -}; -#undef DEFTREECODE - -/* Table indexed by tree code giving number of expression - operands beyond the fixed part of the node structure. - Not used for types or decls. */ - -#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH, - -const unsigned char tree_code_length[] = { -#include "tree.def" -}; -#undef DEFTREECODE - -/* Names of tree components. - Used for printing out the tree and error messages. */ -#define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME, - -const char *const tree_code_name[] = { -#include "tree.def" -}; -#undef DEFTREECODE - -static bool -ffe_post_options (const char **pfilename) -{ - const char *filename = *pfilename; - - /* Open input file. */ - if (filename == 0 || !strcmp (filename, "-")) - { - finput = stdin; - filename = "stdin"; - } - else - finput = fopen (filename, "r"); - - if (finput == 0) - fatal_error ("can't open %s: %m", filename); - - return false; -} - - -static bool -ffe_init (void) -{ -#ifdef IO_BUFFER_SIZE - setvbuf (finput, xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE); -#endif - - ffecom_init_decl_processing (); - - /* 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); - - push_srcloc (input_filename, 0); - - /* FIXME: The ffelex_hash_kludge code needs to be cleaned up to - set the new file name. Maybe in ffe_post_options. */ - return true; -} - -static void -ffe_finish (void) -{ - ffe_terminate_0 (); - - if (ffe_is_ffedebug ()) - malloc_pool_display (malloc_pool_image ()); - - fclose (finput); -} - -static bool -ffe_mark_addressable (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 true; - - 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 false; - } - 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 false; - } - assert ("address of register var requested" == NULL); - } - put_var_into_stack (x, /*rescan=*/true); - - /* 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 true; - } -} - -/* 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 (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. - - DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is - true, since then the decl goes through save_for_inline_copying. */ - if (DECL_ABSTRACT_ORIGIN (decl) != 0 - && DECL_ABSTRACT_ORIGIN (decl) != decl) - TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1; - else if (DECL_SAVED_INSNS (decl) != 0) - { - 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; - } - - /* 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 f_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 - && current_function_decl != error_mark_node) - 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); - - if (block) - TREE_USED (block) = 1; - return block; -} - -static void -ffe_print_identifier (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); -} - -/* 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 (tree x) -{ - register tree t; - register tree name = DECL_NAME (x); - register struct f_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)) - { - DECL_ARTIFICIAL (x) = 1; - DECL_IN_SYSTEM_HEADER (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 it 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; -} - -/* Nonzero if the current level needs to have a BLOCK made. */ - -static int -kept_level_p (void) -{ - tree decl; - - for (decl = current_binding_level->names; - decl; - decl = TREE_CHAIN (decl)) - { - if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL - || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl))) - /* Currently, there aren't supposed to be non-artificial names - at other than the top block for a function -- they're - believed to always be temps. But it's wise to check anyway. */ - return 1; - } - return 0; -} - -/* 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 (int tag_transparent) -{ - register struct f_binding_level *newlevel = NULL_BINDING_LEVEL; - - assert (! tag_transparent); - - if (current_binding_level == global_binding_level) - { - named_labels = 0; - } - - /* 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 (tree block) -{ - current_binding_level->this_block = block; - current_binding_level->names = chainon (current_binding_level->names, - BLOCK_VARS (block)); - current_binding_level->blocks = chainon (current_binding_level->blocks, - BLOCK_SUBBLOCKS (block)); -} - -static tree -ffe_signed_or_unsigned_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 = ffe_type_for_size (TYPE_PRECISION (type), unsignedp); - if (type2 == NULL_TREE) - return type; - - return type2; -} - -static tree -ffe_signed_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 = ffe_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'. */ - -static tree -ffe_truthvalue_conversion (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, - ffe_truthvalue_conversion (TREE_OPERAND (expr, 0)), - ffe_truthvalue_conversion (TREE_OPERAND (expr, 1))); - - case NEGATE_EXPR: - case ABS_EXPR: - case FLOAT_EXPR: - /* These don't change whether an object is nonzero or zero. */ - return ffe_truthvalue_conversion (TREE_OPERAND (expr, 0)); - - case LROTATE_EXPR: - case RROTATE_EXPR: - /* These don't change whether an object is zero or nonzero, 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), - ffe_truthvalue_conversion (TREE_OPERAND (expr, 0))); - else - return ffe_truthvalue_conversion (TREE_OPERAND (expr, 0)); - - case COND_EXPR: - { - /* Distribute the conversion into the arms of a COND_EXPR. */ - tree arg1 = TREE_OPERAND (expr, 1); - tree arg2 = TREE_OPERAND (expr, 2); - if (! VOID_TYPE_P (TREE_TYPE (arg1))) - arg1 = ffe_truthvalue_conversion (arg1); - if (! VOID_TYPE_P (TREE_TYPE (arg2))) - arg2 = ffe_truthvalue_conversion (arg2); - return fold (build (COND_EXPR, integer_type_node, - TREE_OPERAND (expr, 0), arg1, arg2)); - } - - 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 ffe_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, - ffe_truthvalue_conversion (ffecom_1 (REALPART_EXPR, - TREE_TYPE (TREE_TYPE (expr)), - expr)), - ffe_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)); -} - -static tree -ffe_type_for_mode (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 HOST_BITS_PER_WIDE_INT >= 64 - if (mode == TYPE_MODE (intTI_type_node)) - return unsignedp ? unsigned_intTI_type_node : intTI_type_node; -#endif - - 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 (long_double_type_node)) - return long_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; -} - -static tree -ffe_type_for_size (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; -} - -static tree -ffe_unsigned_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 = ffe_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; -} - -/* 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 const char * -skip_redundant_dir_prefix (const 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; - const char *fname; - /* Mapping of file names for this directory. */ - struct file_name_map *name_map; - /* Nonzero 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 { - const char *fname; - /* Filename specified with #line command. */ - const 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. */ - -/* Current nesting level of input sources. - `instack[indepth]' is the level currently being read. */ -static int indepth = -1; - -typedef struct file_buf FILE_BUF; - -/* 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 *read_filename_string (int ch, FILE *f); -static struct file_name_map *read_name_map (const char *dirname); - -/* 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 (struct file_name_list *first, - struct file_name_list *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 (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 = strrchr (filename, '/'); -#ifdef DIR_SEPARATOR - if (! p) p = strrchr (filename, DIR_SEPARATOR); - else { - char *tmp = strrchr (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 = xmalloc (p - filename + 1); - memcpy (dir, filename, 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; - const char *str1; - const 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 = ""; - - /* xgettext:no-c-format */ - 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 (int ch, FILE *f) -{ - char *alloc, *set; - int len; - - len = 20; - set = alloc = xmalloc (len + 1); - if (! ISSPACE (ch)) - { - *set++ = ch; - while ((ch = getc (f)) != EOF && ! ISSPACE (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 (const 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 = xmalloc (sizeof (struct file_name_map_list)); - map_list_ptr->map_list_name = xstrdup (dirname); - map_list_ptr->map_list_map = NULL; - - dirlen = strlen (dirname); - separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/'; - if (separator_needed) - name = concat (dirname, "/", FILE_NAME_MAP_FILE, NULL); - else - name = concat (dirname, FILE_NAME_MAP_FILE, NULL); - 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 (ISSPACE (ch)) - continue; - from = read_filename_string (ch, f); - while ((ch = getc (f)) != EOF && ISSPACE (ch) && ch != '\n') - ; - to = read_filename_string (ch, f); - - ptr = xmalloc (sizeof (struct file_name_map)); - ptr->map_from = from; - - /* Make the real filename absolute. */ - if (*to == '/') - ptr->map_to = to; - else - { - if (separator_needed) - ptr->map_to = concat (dirname, "/", to, NULL); - else - ptr->map_to = concat (dirname, to, NULL); - 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 void -ffecom_file_ (const 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]; - memset (fp, 0, sizeof (FILE_BUF)); - if (name == NULL) - name = ""; - fp->nominal_fname = fp->fname = name; -} - -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); -} - -void -ffecom_decode_include_option (const char *dir) -{ - if (! ignore_srcdir && !strcmp (dir, "-")) - ignore_srcdir = 1; - else - { - struct file_name_list *dirtmp - = xmalloc (sizeof (struct file_name_list)); - dirtmp->next = 0; /* New one goes on the end */ - dirtmp->fname = dir; - dirtmp->got_name_map = 0; - append_include_chain (dirtmp, dirtmp); - } -} - -/* 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; - const 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 = strrchr (nam, '/'); -#ifdef DIR_SEPARATOR - if (ep == NULL) ep = strrchr (nam, DIR_SEPARATOR); - else { - char *tmp = strrchr (nam, DIR_SEPARATOR); - if (tmp != NULL && tmp > ep) ep = tmp; - } -#endif -#else /* VMS */ - ep = strrchr (nam, ']'); - if (ep == NULL) ep = strrchr (nam, '>'); - if (ep == NULL) ep = strrchr (nam, ':'); - if (ep != NULL) ep++; -#endif /* VMS */ - if (ep != NULL) - { - n = ep - nam; - fname = xmalloc (n + 1); - strncpy (fname, nam, n); - fname[n] = '\0'; - dsp[0].fname = fname; - 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); - } - 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 (strchr (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); - /* xgettext:no-c-format */ - 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 ((char *) dsp[0].fname); - - if (f == NULL) - return NULL; - - if (indepth >= (INPUT_STACK_MAX - 1)) - { - print_containing_files (FFEBAD_severityFATAL); - /* xgettext:no-c-format */ - 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]; - memset (fp, 0, sizeof (FILE_BUF)); - fp->nominal_fname = fp->fname = fname; - fp->dir = searchptr; - - indepth++; - input_file_stack_tick++; - - return f; -} - -/**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.) // - - - - - - - - - - - - - - - - - - - - - - - -// 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) - -*/ - -#include "gt-f-com.h" -#include "gtype-f.h" diff --git a/contrib/gcc-3.4/gcc/f/com.h b/contrib/gcc-3.4/gcc/f/com.h deleted file mode 100644 index d23db6687a..0000000000 --- a/contrib/gcc-3.4/gcc/f/com.h +++ /dev/null @@ -1,290 +0,0 @@ -/* com.h -- Public #include File (module.h template V1.0) - Copyright (C) 1995, 1996, 1997, 2000, 2003, 2004 - Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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 GCC_F_COM_H -#define GCC_F_COM_H - -/* Simple definitions and enumerations. */ - -#define FFECOM_dimensionsMAX 7 /* Max # dimensions (quick hack). */ - -#define FFECOM_SIZE_UNIT "byte" /* Singular form. */ -#define FFECOM_SIZE_UNITS "bytes" /* Plural form. */ - -#define FFECOM_constantNULL NULL_TREE -#define FFECOM_nonterNULL 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. */ - -/* The C front-end provides __g77_integer and __g77_uinteger types so that - the appropriately-sized signed and unsigned integer types are available - for libf2c. If you change this, also the definitions of those types - in ../c-decl.c. */ -#define FFECOM_f2cINTEGER \ - (LONG_TYPE_SIZE == FLOAT_TYPE_SIZE \ - ? FFECOM_f2ccodeLONG \ - : (INT_TYPE_SIZE == FLOAT_TYPE_SIZE \ - ? FFECOM_f2ccodeINT \ - : (abort (), -1))) - -#define FFECOM_f2cLOGICAL FFECOM_f2cINTEGER - -/* The C front-end provides __g77_longint and __g77_ulongint types so that - the appropriately-sized signed and unsigned integer types are available - for libf2c. If you change this, also the definitions of those types - in ../c-decl.c. */ -#define FFECOM_f2cLONGINT \ - (LONG_TYPE_SIZE == (FLOAT_TYPE_SIZE * 2) \ - ? FFECOM_f2ccodeLONG \ - : (LONG_LONG_TYPE_SIZE == (FLOAT_TYPE_SIZE * 2) \ - ? FFECOM_f2ccodeLONGLONG \ - : (abort (), -1))) - -#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,CONST) CODE, -#include "com-rt.def" -#undef DEFGFRT - FFECOM_gfrt - } ffecomGfrt; - -/* Typedefs. */ - -#ifndef TREE_CODE -#include "tree.h" -#endif - -typedef tree ffecomConstant; -typedef tree ffecomNonter; -typedef tree ffecomLabel; -typedef tree ffecomGlobal; -typedef tree ffecomStorage; -typedef struct _ffecom_symbol_ ffecomSymbol; - -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. */ - }; - -/* Include files needed by this one. */ - -#include "bld.h" -#include "info.h" -#include "lab.h" -#include "storag.h" -#include "symbol.h" - -extern int global_bindings_p (void); -extern tree getdecls (void); -extern void pushlevel (int); -extern tree poplevel (int,int, int); -extern void insert_block (tree); -extern void set_block (tree); -extern tree pushdecl (tree); - -/* Global objects accessed by users of this module. */ - -extern GTY(()) tree string_type_node; -extern GTY(()) tree ffecom_integer_type_node; -extern GTY(()) tree ffecom_integer_zero_node; -extern GTY(()) tree ffecom_integer_one_node; -extern GTY(()) 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 GTY(()) tree ffecom_f2c_integer_type_node; -extern GTY(()) tree ffecom_f2c_address_type_node; -extern GTY(()) tree ffecom_f2c_real_type_node; -extern GTY(()) tree ffecom_f2c_doublereal_type_node; -extern GTY(()) tree ffecom_f2c_complex_type_node; -extern GTY(()) tree ffecom_f2c_doublecomplex_type_node; -extern GTY(()) tree ffecom_f2c_longint_type_node; -extern GTY(()) tree ffecom_f2c_logical_type_node; -extern GTY(()) tree ffecom_f2c_flag_type_node; -extern GTY(()) tree ffecom_f2c_ftnlen_type_node; -extern GTY(()) tree ffecom_f2c_ftnlen_zero_node; -extern GTY(()) tree ffecom_f2c_ftnlen_one_node; -extern GTY(()) tree ffecom_f2c_ftnlen_two_node; -extern GTY(()) tree ffecom_f2c_ptr_to_ftnlen_type_node; -extern GTY(()) tree ffecom_f2c_ftnint_type_node; -extern GTY(()) tree ffecom_f2c_ptr_to_ftnint_type_node; - -/* Declare functions with prototypes. */ - -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_const_expr (ffebld expr, tree *length); -tree ffecom_arg_ptr_to_expr (ffebld expr, tree *length); -tree ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook); -tree ffecom_constantunion_with_type (ffebldConstantUnion *cu, - tree tree_type,ffebldConst ct); -tree ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt, - ffeinfoKindtype kt, tree tree_type); -tree ffecom_const_expr (ffebld expr); -tree ffecom_decl_field (tree context, tree prevfield, const char *name, - tree type); -void ffecom_close_include (FILE *f); -void ffecom_decode_include_option (const char *dir); -tree ffecom_end_compstmt (void); -void ffecom_end_transition (void); -void ffecom_exec_transition (void); -void ffecom_expand_let_stmt (ffebld dest, ffebld source); -tree ffecom_expr (ffebld expr); -tree ffecom_expr_assign (ffebld expr); -tree ffecom_expr_assign_w (ffebld expr); -tree ffecom_expr_rw (tree type, ffebld expr); -tree ffecom_expr_w (tree type, 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 (const char *pattern, ...) - ATTRIBUTE_PRINTF_1; -ffeinfoBasictype 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_make_tempvar (const char *commentary, tree type, - ffetargetCharacterSize size, int elements); -tree ffecom_modify (tree newtype, tree lhs, tree rhs); -void ffecom_save_tree_forever (tree t); -void ffecom_file (const char *name); -void ffecom_notify_init_storage (ffestorag st); -void ffecom_notify_init_symbol (ffesymbol s); -void ffecom_notify_primary_entry (ffesymbol fn); -FILE *ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c); -void ffecom_prepare_arg_ptr_to_expr (ffebld expr); -bool ffecom_prepare_end (void); -void ffecom_prepare_expr_ (ffebld expr, ffebld dest); -void ffecom_prepare_expr_rw (tree type, ffebld expr); -void ffecom_prepare_expr_w (tree type, ffebld expr); -void ffecom_prepare_ptr_to_expr (ffebld expr); -void ffecom_prepare_return_expr (ffebld expr); -tree ffecom_ptr_to_const_expr (ffebld expr); -tree ffecom_ptr_to_expr (ffebld expr); -tree ffecom_return_expr (ffebld expr); -tree ffecom_save_tree (tree t); -void ffecom_start_compstmt (void); -tree ffecom_start_decl (tree decl, bool is_init); -void ffecom_sym_commit (ffesymbol s); -ffesymbol ffecom_sym_end_transition (ffesymbol s); -ffesymbol ffecom_sym_exec_transition (ffesymbol s); -ffesymbol ffecom_sym_learned (ffesymbol s); -void ffecom_sym_retract (ffesymbol s); -tree ffecom_temp_label (void); -tree ffecom_truth_value (tree expr); -tree ffecom_truth_value_invert (tree expr); -tree ffecom_type_expr (ffebld expr); -tree ffecom_which_entrypoint_decl (void); -void ffe_parse_file (int); - -/* Define macros. */ - -#define ffecom_f2c_typecode(bt,kt) ffecom_f2c_typecode_[(bt)][(kt)] -#define ffecom_label_kind() ffecom_label_kind_ -#define ffecom_pointer_kind() ffecom_pointer_kind_ -#define ffecom_prepare_expr(e) ffecom_prepare_expr_ ((e), NULL) - -#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 /* ! GCC_F_COM_H */ diff --git a/contrib/gcc-3.4/gcc/f/data.c b/contrib/gcc-3.4/gcc/f/data.c deleted file mode 100644 index 2040f0ab6d..0000000000 --- a/contrib/gcc-3.4/gcc/f/data.c +++ /dev/null @@ -1,1877 +0,0 @@ -/* data.c -- Implementation File (module.c template V1.0) - Copyright (C) 1995, 1996, 2002, 2003 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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_ (void) -{ - 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); - if (ffeinfo_basictype (ffebld_info (start)) != FFEINFO_basictypeINTEGER) - { - ffebad_start (FFEBAD_DATA_EVAL); - ffest_ffebad_here_current_stmt (0); - ffebad_finish (); - ffedata_pop_ (); - ffedata_reported_error_ = TRUE; - return FALSE; - } - 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)); - if (ffeinfo_basictype (ffebld_info (end)) != FFEINFO_basictypeINTEGER) - { - ffebad_start (FFEBAD_DATA_EVAL); - ffest_ffebad_here_current_stmt (0); - ffebad_finish (); - ffedata_pop_ (); - ffedata_reported_error_ = TRUE; - return FALSE; - } - 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 - { - if (ffeinfo_basictype (ffebld_info (incr)) != FFEINFO_basictypeINTEGER) - { - ffebad_start (FFEBAD_DATA_EVAL); - ffest_ffebad_here_current_stmt (0); - ffebad_finish (); - ffedata_pop_ (); - ffedata_reported_error_ = TRUE; - return FALSE; - } - 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. */ - -static 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 = 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) - { - ffeinfoKindtype sub_kind, low_kind, hi_kind; - ffebld sub1, low1, hi1; - - ++rank; - assert (dims != NULL); - - subscript = ffebld_head (subscripts); - dim = ffebld_head (dims); - - assert (ffeinfo_basictype (ffebld_info (subscript)) == FFEINFO_basictypeINTEGER); - if (ffebld_op (subscript) == FFEBLD_opCONTER) - { - /* Force to default - it's a constant expression ! */ - sub_kind = ffeinfo_kindtype (ffebld_info (subscript)); - sub1 = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val ( - sub_kind == FFEINFO_kindtypeINTEGER2 ? subscript->u.conter.expr->u.integer2 : - sub_kind == FFEINFO_kindtypeINTEGER3 ? subscript->u.conter.expr->u.integer3 : - sub_kind == FFEINFO_kindtypeINTEGER4 ? subscript->u.conter.expr->u.integer4 : - subscript->u.conter.expr->u.integer1), NULL); - value = ffedata_eval_integer1_ (sub1); - } - else - 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); - if (ffebld_op (low) == FFEBLD_opCONTER) - { - /* Force to default - it's a constant expression ! */ - low_kind = ffeinfo_kindtype (ffebld_info (low)); - low1 = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val ( - low_kind == FFEINFO_kindtypeINTEGER2 ? low->u.conter.expr->u.integer2 : - low_kind == FFEINFO_kindtypeINTEGER3 ? low->u.conter.expr->u.integer3 : - low_kind == FFEINFO_kindtypeINTEGER4 ? low->u.conter.expr->u.integer4 : - low->u.conter.expr->u.integer1), NULL); - lowbound = ffedata_eval_integer1_ (low1); - } - else - lowbound = ffedata_eval_integer1_ (low); - } - - assert (ffeinfo_basictype (ffebld_info (high)) == FFEINFO_basictypeINTEGER); - if (ffebld_op (high) == FFEBLD_opCONTER) - { - /* Force to default - it's a constant expression ! */ - hi_kind = ffeinfo_kindtype (ffebld_info (high)); - hi1 = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val ( - hi_kind == FFEINFO_kindtypeINTEGER2 ? high->u.conter.expr->u.integer2 : - hi_kind == FFEINFO_kindtypeINTEGER3 ? high->u.conter.expr->u.integer3 : - hi_kind == FFEINFO_kindtypeINTEGER4 ? high->u.conter.expr->u.integer4 : - high->u.conter.expr->u.integer1), NULL); - highbound = ffedata_eval_integer1_ (hi1); - } - else - 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. */ - -static 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_); - ffebld_arrter_set_pad (ffestorag_init (mst), 0); - 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_); - ffebld_arrter_set_pad (ffestorag_init (mst), 0); - 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_); - ffebld_arrter_set_pad (ffestorag_init (mst), 0); - 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_ (void) -{ - 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_ (void) -{ - 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_); - ffebld_arrter_set_pad (ffestorag_init (ffedata_storage_), - 0); - 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_); - ffebld_arrter_set_pad (ffestorag_init (ffedata_symbol_), 0); - 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/contrib/gcc-3.4/gcc/f/data.h b/contrib/gcc-3.4/gcc/f/data.h deleted file mode 100644 index a99369d0b0..0000000000 --- a/contrib/gcc-3.4/gcc/f/data.h +++ /dev/null @@ -1,74 +0,0 @@ -/* data.h -- Public #include File (module.h template V1.0) - Copyright (C) 1995 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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 GCC_F_DATA_H -#define GCC_F_DATA_H - -/* 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 /* ! GCC_F_DATA_H */ diff --git a/contrib/gcc-3.4/gcc/f/equiv.c b/contrib/gcc-3.4/gcc/f/equiv.c deleted file mode 100644 index bd7ac6d4d2..0000000000 --- a/contrib/gcc-3.4/gcc/f/equiv.c +++ /dev/null @@ -1,1484 +0,0 @@ -/* equiv.c -- Implementation File (module.c template V1.0) - Copyright (C) 1995, 1996, 1997, 1998, 2003 - Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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. */ - ffetargetOffset new_size; - - 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)) - { - /* 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 the offset for this storage area is zero (it cannot be positive), - that means the alignment/modulo info is already correct. Otherwise, - the alignment info is correct, but the modulo info reflects a - zero offset, so fix it. */ - - if (ffestorag_offset (st) < 0) - { - /* Calculate the initial padding necessary to preserve - the alignment/modulo requirements for the storage area. - These requirements are themselves kept track of in the - record for the storage area as a whole, but really pertain - to offset 0 of that area, which is where the root symbol - was originally placed. - - The goal here is to have the offset and size for the area - faithfully reflect the area itself, not extra requirements - like alignment. So to meet the alignment requirements, - the modulo for the area should be set as if the area had an - alignment requirement of alignment/0 and was aligned/padded - downward to meet the alignment requirements of the area at - offset zero, the amount of padding needed being the desired - value for the modulo of the area. */ - - alignment = ffestorag_alignment (st); - modulo = ffestorag_modulo (st); - - /* Since we want to move the whole area *down* (lower memory - addresses) as required by the alignment/modulo paid, negate - the offset to ffetarget_align, which assumes aligning *up* - is desired. */ - pad = ffetarget_align (&alignment, &modulo, - - ffestorag_offset (st), - alignment, 0); - ffestorag_set_modulo (st, pad); - } - - 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); - - if (ffebld_op (subscript) == FFEBLD_opANY) - return FALSE; - - 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)); - - if (ffebld_op (dim) == FFEBLD_opANY) - return FALSE; - - assert (ffebld_op (dim) == FFEBLD_opBOUNDS); - low = ffebld_left (dim); - high = ffebld_right (dim); - - if (low == NULL) - lowbound = 1; - else - { - if (ffebld_op (low) == FFEBLD_opANY) - return FALSE; - - assert (ffebld_op (low) == FFEBLD_opCONTER); - assert (ffeinfo_basictype (ffebld_info (low)) - == FFEINFO_basictypeINTEGER); - assert (ffeinfo_kindtype (ffebld_info (low)) - == FFEINFO_kindtypeINTEGERDEFAULT); - lowbound - = ffebld_constant_integerdefault (ffebld_conter (low)); - } - - if (ffebld_op (high) == FFEBLD_opANY) - return FALSE; - - 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_opANY) - return FALSE; - 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 - { - if (ffebld_op (begin) == FFEBLD_opANY) - return FALSE; - 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_exec_transition -- Do the hard work on all the equivalence objects - - ffeequiv_exec_transition(); */ - -void -ffeequiv_exec_transition (void) -{ - 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 (void) -{ - 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 (void) -{ - 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/contrib/gcc-3.4/gcc/f/equiv.h b/contrib/gcc-3.4/gcc/f/equiv.h deleted file mode 100644 index 59abfc875c..0000000000 --- a/contrib/gcc-3.4/gcc/f/equiv.h +++ /dev/null @@ -1,100 +0,0 @@ -/* equiv.h -- Public #include File (module.h template V1.0) - Copyright (C) 1995, 1996 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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 GCC_F_EQUIV_H -#define GCC_F_EQUIV_H - -/* 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_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 /* ! GCC_F_EQUIV_H */ diff --git a/contrib/gcc-3.4/gcc/f/expr.c b/contrib/gcc-3.4/gcc/f/expr.c deleted file mode 100644 index ef7661dc3e..0000000000 --- a/contrib/gcc-3.4/gcc/f/expr.c +++ /dev/null @@ -1,18571 +0,0 @@ -/* expr.c -- Implementation File (module.c template V1.0) - Copyright (C) 1995, 1996, 1997, 1998, 2001, 2002, 2003 - Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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 "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 "str.h" -#include "target.h" -#include "where.h" -#include "real.h" - -/* Externals defined here. */ - - -/* Simple definitions and enumerations. */ - -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 ffestrOther 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 ffeexprExpr_ ffeexpr_expr_new_ (void); -static void ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t); -static bool ffeexpr_isdigits_ (const 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, - bool *); -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 - - 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 - - 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; - } - - /* If conversion operation is not implemented, return original expr. */ - if (error == FFEBAD_NOCANDO) - return expr; - - 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 - - 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 - - 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; - } - - /* If conversion operation is not implemented, return original expr. */ - if (error == FFEBAD_NOCANDO) - return expr; - - 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 - - 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 - - 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; - } - - /* If conversion operation is not implemented, return original expr. */ - if (error == FFEBAD_NOCANDO) - return expr; - - 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 - - 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 - - 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; - } - - /* If conversion operation is not implemented, return original expr. */ - if (error == FFEBAD_NOCANDO) - return expr; - - 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; - } - - /* If conversion operation is not implemented, return original expr. */ - if (error == FFEBAD_NOCANDO) - return expr; - - 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; - } - - /* If conversion operation is not implemented, return original expr. */ - if (error == FFEBAD_NOCANDO) - return expr; - - 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; - } - - /* If conversion operation is not implemented, return original expr. */ - if (error == FFEBAD_NOCANDO) - return expr; - - 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; - } - - /* If conversion operation is not implemented, return original expr. */ - if (error == FFEBAD_NOCANDO) - return expr; - - 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 - - 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 - - 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; - } - - /* If conversion operation is not implemented, return original expr. */ - if (error == FFEBAD_NOCANDO) - return expr; - - 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 - - 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 - - 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; - } - - /* If conversion operation is not implemented, return original expr. */ - if (error == FFEBAD_NOCANDO) - return expr; - - 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 - - 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 - - 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; - } - - /* If conversion operation is not implemented, return original expr. */ - if (error == FFEBAD_NOCANDO) - return expr; - - expr = ffebld_new_conter_with_orig - (ffebld_constant_new_real3_val - (ffebld_cu_val_real3 (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 - - 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 - - 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; - } - - /* If conversion operation is not implemented, return original expr. */ - if (error == FFEBAD_NOCANDO) - return expr; - - 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 - - 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 - - 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; - } - - /* If conversion operation is not implemented, return original expr. */ - if (error == FFEBAD_NOCANDO) - return expr; - - 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 - - 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 - - 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; - } - - /* If conversion operation is not implemented, return original expr. */ - if (error == FFEBAD_NOCANDO) - return expr; - - expr = ffebld_new_conter_with_orig - (ffebld_constant_new_complex3_val - (ffebld_cu_val_complex3 (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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 (void) -{ - 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 = (ffeexpr_stack_->expr == NULL) - ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (ffeexpr_stack_->expr)); - ffeinfoBasictype rty = (expr == NULL) - ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (expr)); - ffeinfoKindtype lkt; - ffeinfoKindtype rkt; - ffeinfoKindtype nkt; - bool ok = TRUE; - ffebld orig; - - if ((ffeexpr_stack_->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 - - 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_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) -{ - const 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 - 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_ (void) -{ - ffeexprExpr_ e; - - e = 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; - -#if 0 - /* No, %LOC(foo) is just like any INTEGER(KIND=7) - expression, so don't treat it specially. */ - case FFEBLD_opPERCENT_LOC: - as = FFEGLOBAL_argsummaryPTR; - break; -#endif - - 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 0 - /* No, LOC(foo) is just like any INTEGER(KIND=7) - expression, so don't treat it specially. */ - if ((ffebld_op (ffebld_left (item)) == FFEBLD_opSYMTER) - && (ffesymbol_specific (ffebld_symter (ffebld_left (item))) - == FFEINTRIN_specLOC)) - { - as = FFEGLOBAL_argsummaryPTR; - break; - } -#endif - /* 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_ (const 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); -} - -/* 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_)) - { - /* xgettext:no-c-format */ - 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)) - { - /* xgettext:no-c-format */ - 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_ (void) -{ - 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; - bool bothlogical; - - 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, &bothlogical); - reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator, - operand); - reduced = ffeexpr_collapse_and (reduced, operator->token); - if (ffe_is_ugly_logint() && bothlogical) - reduced = ffeexpr_convert (reduced, left_operand->token, - operator->token, - FFEINFO_basictypeLOGICAL, - FFEINFO_kindtypeLOGICALDEFAULT, 0, - FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - 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, &bothlogical); - reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator, - operand); - reduced = ffeexpr_collapse_or (reduced, operator->token); - if (ffe_is_ugly_logint() && bothlogical) - reduced = ffeexpr_convert (reduced, left_operand->token, - operator->token, - FFEINFO_basictypeLOGICAL, - FFEINFO_kindtypeLOGICALDEFAULT, 0, - FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - 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, &bothlogical); - reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator, - operand); - reduced = ffeexpr_collapse_xor (reduced, operator->token); - if (ffe_is_ugly_logint() && bothlogical) - reduced = ffeexpr_convert (reduced, left_operand->token, - operator->token, - FFEINFO_basictypeLOGICAL, - FFEINFO_kindtypeLOGICALDEFAULT, 0, - FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - 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, NULL); - 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, NULL); - 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)) - { - const 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)) - { - const 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)) - { - /* xgettext:no-c-format */ - 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) && (rbt != 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) - { - /* xgettext:no-c-format */ - 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) - && (rbt != 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, bool *bothlogical) -{ - 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. */ - } - - 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)); - } - - if (bothlogical != NULL) - *bothlogical = (lbt == FFEINFO_basictypeLOGICAL - && rbt == FFEINFO_basictypeLOGICAL); - - 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_ = ffestr_other (t); - switch (ffeexpr_current_dotdot_) - { - case FFESTR_otherNone: - return (ffelexHandler) ffeexpr_nil_rhs_ (t); - - case FFESTR_otherTRUE: - case FFESTR_otherFALSE: - case FFESTR_otherNOT: - 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 FFESTR_otherNOT: - if (ffelex_token_type (t) != FFELEX_typePERIOD) - return (ffelexHandler) ffeexpr_nil_rhs_ (t); - return (ffelexHandler) ffeexpr_nil_rhs_; - - case FFESTR_otherTRUE: - case FFESTR_otherFALSE: - 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; - const 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; - const 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; - const 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; - const 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_ = ffestr_other (t); - switch (ffeexpr_current_dotdot_) - { - case FFESTR_otherTRUE: - case FFESTR_otherFALSE: - case FFESTR_otherNOT: - 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) && (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_: - 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_basictypeHOLLERITH: - case FFEINFO_basictypeTYPELESS: - error = FALSE; - expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - break; - - case FFEINFO_basictypeINTEGER: - /* Specifically, allow INTEGER(KIND=2), aka INTEGER*8, through - unmolested. Leave it to downstream to handle kinds. */ - break; - - default: - error = TRUE; - break; - } - break; /* expr==NULL ok for substring; element case - caught by callback. */ - - 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; - - 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: - if (! ffe_is_ugly_logint ()) - error = TRUE; - if (! ffeexpr_stack_->is_rhs) - break; - expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, - ffeinfo_kindtype (info), 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: - if (! ffeexpr_stack_->is_rhs) - break; - expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, - ffeinfo_kindtype (info), 0, - FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - /* Fall through. */ - case FFEINFO_basictypeINTEGER: - if (ffeexpr_stack_->is_rhs - && (ffeinfo_kindtype (ffebld_info (expr)) - != FFEINFO_kindtypeINTEGERDEFAULT)) - expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGERDEFAULT, 0, - FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - 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: - /* Maybe this should be supported someday, but, right now, - g77 can't generate a call to libf2c to write to an - integer other than the default size. */ - error = ((! ffeexpr_stack_->is_rhs) - && ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT); - 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. */ - : (bool) (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_ = ffestr_other (t); - switch (ffeexpr_current_dotdot_) - { - case FFESTR_otherNone: - 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 FFESTR_otherTRUE: - case FFESTR_otherFALSE: - case FFESTR_otherNOT: - 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 FFESTR_otherNOT: - 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 FFESTR_otherTRUE: - 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 FFESTR_otherFALSE: - 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; - const 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; - const 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. */ - - ffeexpr_make_float_const_ ('I', ffeexpr_tokens_[0], NULL, NULL, - NULL, NULL, NULL); - 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; - const 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; - const 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_ = ffestr_other (t); - switch (ffeexpr_current_dotdot_) - { - case FFESTR_otherTRUE: - case FFESTR_otherFALSE: - case FFESTR_otherNOT: - 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_; - - 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; - - e = ffeexpr_expr_new_ (); - e->type = FFEEXPR_exprtypeBINARY_; - e->token = ffeexpr_tokens_[0]; - - switch (ffeexpr_current_dotdot_) - { - case FFESTR_otherAND: - e->u.operator.op = FFEEXPR_operatorAND_; - e->u.operator.prec = FFEEXPR_operatorprecedenceAND_; - e->u.operator.as = FFEEXPR_operatorassociativityAND_; - break; - - case FFESTR_otherOR: - e->u.operator.op = FFEEXPR_operatorOR_; - e->u.operator.prec = FFEEXPR_operatorprecedenceOR_; - e->u.operator.as = FFEEXPR_operatorassociativityOR_; - break; - - case FFESTR_otherXOR: - e->u.operator.op = FFEEXPR_operatorXOR_; - e->u.operator.prec = FFEEXPR_operatorprecedenceXOR_; - e->u.operator.as = FFEEXPR_operatorassociativityXOR_; - break; - - case FFESTR_otherEQV: - e->u.operator.op = FFEEXPR_operatorEQV_; - e->u.operator.prec = FFEEXPR_operatorprecedenceEQV_; - e->u.operator.as = FFEEXPR_operatorassociativityEQV_; - break; - - case FFESTR_otherNEQV: - e->u.operator.op = FFEEXPR_operatorNEQV_; - e->u.operator.prec = FFEEXPR_operatorprecedenceNEQV_; - e->u.operator.as = FFEEXPR_operatorassociativityNEQV_; - break; - - case FFESTR_otherLT: - e->u.operator.op = FFEEXPR_operatorLT_; - e->u.operator.prec = FFEEXPR_operatorprecedenceLT_; - e->u.operator.as = FFEEXPR_operatorassociativityLT_; - break; - - case FFESTR_otherLE: - e->u.operator.op = FFEEXPR_operatorLE_; - e->u.operator.prec = FFEEXPR_operatorprecedenceLE_; - e->u.operator.as = FFEEXPR_operatorassociativityLE_; - break; - - case FFESTR_otherEQ: - e->u.operator.op = FFEEXPR_operatorEQ_; - e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_; - e->u.operator.as = FFEEXPR_operatorassociativityEQ_; - break; - - case FFESTR_otherNE: - e->u.operator.op = FFEEXPR_operatorNE_; - e->u.operator.prec = FFEEXPR_operatorprecedenceNE_; - e->u.operator.as = FFEEXPR_operatorassociativityNE_; - break; - - case FFESTR_otherGT: - e->u.operator.op = FFEEXPR_operatorGT_; - e->u.operator.prec = FFEEXPR_operatorprecedenceGT_; - e->u.operator.as = FFEEXPR_operatorassociativityGT_; - break; - - case FFESTR_otherGE: - e->u.operator.op = FFEEXPR_operatorGE_; - e->u.operator.prec = FFEEXPR_operatorprecedenceGE_; - e->u.operator.as = FFEEXPR_operatorassociativityGE_; - break; - - default: - if (ffest_ffebad_start (FFEBAD_INVALID_DOTDOT)) - { - 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 (); - } - e->u.operator.op = FFEEXPR_operatorEQ_; - e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_; - e->u.operator.as = FFEEXPR_operatorassociativityEQ_; - break; - } - - ffeexpr_exprstack_push_binary_ (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. */ - return (ffelexHandler) ffeexpr_token_rhs_ (t); - } - - ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill dot-dot token. */ - 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 - - case 'I': /* Make an integer. */ - 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)); - break; - - 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); - else - { - 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_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_attrsARRAY - | 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); - bad = FALSE; - 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); - - /* Is there an expression to add? If the expression is nil, - it might still be an argument. It is if: - - - The current token is comma, or - - - The -fugly-comma flag was specified *and* the procedure - being invoked is external. - - Otherwise, if neither of the above is the case, just - ignore this (nil) expression. */ - - if ((expr != NULL) - || (ffelex_token_type (t) == FFELEX_typeCOMMA) - || (ffe_is_ugly_comma () - && (ffeinfo_where (info) == FFEINFO_whereGLOBAL))) - { - /* This expression, even if nil, is apparently intended as an argument. */ - - /* Internal procedure (CONTAINS, or statement function)? */ - - if (ffeinfo_where (info) == FFEINFO_whereCONSTANT) - { - if ((expr == NULL) - && 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 (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) - && 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_pedantic () - && ffebad_start (FFEBAD_NULL_ARGUMENT_W)) - { - 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 (); - } - 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 != 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 - && ffebld_kindtype (expr) == FFEINFO_kindtypeINTEGERDEFAULT) - { - 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; - bool first_known; - - string = ffeexpr_stack_->exprstack; - strop = string->u.operand; - info = ffebld_info (strop); - - if (first == NULL - || (ffebld_op (first) == FFEBLD_opCONTER - && ffebld_kindtype (first) == FFEINFO_kindtypeINTEGERDEFAULT)) - { /* The starting point is known. */ - first_val = (first == NULL) ? 1 - : ffebld_constant_integerdefault (ffebld_conter (first)); - first_known = TRUE; - } - else - { /* Assume start of the entity. */ - first_val = 1; - first_known = FALSE; - } - - if (last != NULL - && (ffebld_op (last) == FFEBLD_opCONTER - && ffebld_kindtype (last) == FFEINFO_kindtypeINTEGERDEFAULT)) - { /* The ending point is known. */ - last_val = ffebld_constant_integerdefault (ffebld_conter (last)); - - if (first_known) - { /* 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 (void) -{ - assert (ffeexpr_stack_ == NULL); - assert (ffeexpr_level_ == 0); -} diff --git a/contrib/gcc-3.4/gcc/f/expr.h b/contrib/gcc-3.4/gcc/f/expr.h deleted file mode 100644 index b82173bbf0..0000000000 --- a/contrib/gcc-3.4/gcc/f/expr.h +++ /dev/null @@ -1,194 +0,0 @@ -/* expr.h -- Public #include File (module.h template V1.0) - Copyright (C) 1995, 1996 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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 GCC_F_EXPR_H -#define GCC_F_EXPR_H - -/* 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 /* ! GCC_F_EXPR_H */ diff --git a/contrib/gcc-3.4/gcc/f/ffe.texi b/contrib/gcc-3.4/gcc/f/ffe.texi deleted file mode 100644 index fd5d3bf349..0000000000 --- a/contrib/gcc-3.4/gcc/f/ffe.texi +++ /dev/null @@ -1,2063 +0,0 @@ -@c Copyright (C) 1999, 2003 Free Software Foundation, Inc. -@c This is part of the G77 manual. -@c For copying conditions, see the file g77.texi. - -@node Front End -@chapter Front End -@cindex GNU Fortran Front End (FFE) -@cindex FFE -@cindex @code{g77}, front end -@cindex front end, @code{g77} - -This chapter describes some aspects of the design and implementation -of the @code{g77} front end. - -To find about things that are ``To Be Determined'' or ``To Be Done'', -search for the string TBD. -If you want to help by working on one or more of these items, -email @email{gcc@@gcc.gnu.org}. -If you're planning to do more than just research issues and offer comments, -see @uref{http://gcc.gnu.org/contribute.html} for steps you might -need to take first. - -@menu -* Overview of Sources:: -* Overview of Translation Process:: -* Philosophy of Code Generation:: -* Two-pass Design:: -* Challenges Posed:: -* Transforming Statements:: -* Transforming Expressions:: -* Internal Naming Conventions:: -@end menu - -@node Overview of Sources -@section Overview of Sources - -The current directory layout includes the following: - -@table @file -@item @var{srcdir}/gcc/ -Non-g77 files in gcc - -@item @var{srcdir}/gcc/f/ -GNU Fortran front end sources - -@item @var{srcdir}/libf2c/ -@code{libg2c} configuration and @code{g2c.h} file generation - -@item @var{srcdir}/libf2c/libF77/ -General support and math portion of @code{libg2c} - -@item @var{srcdir}/libf2c/libI77/ -I/O portion of @code{libg2c} - -@item @var{srcdir}/libf2c/libU77/ -Additional interfaces to Unix @code{libc} for @code{libg2c} -@end table - -Components of note in @code{g77} are described below. - -@file{f/} as a whole contains the source for @code{g77}, -while @file{libf2c/} contains a portion of the separate program -@code{f2c}. -Note that the @code{libf2c} code is not part of the program @code{g77}, -just distributed with it. - -@file{f/} contains text files that document the Fortran compiler, source -files for the GNU Fortran Front End (FFE), and some other stuff. -The @code{g77} compiler code is placed in @file{f/} because it, -along with its contents, -is designed to be a subdirectory of a @code{gcc} source directory, -@file{gcc/}, -which is structured so that language-specific front ends can be ``dropped -in'' as subdirectories. -The C++ front end (@code{g++}), is an example of this---it resides in -the @file{cp/} subdirectory. -Note that the C front end (also referred to as @code{gcc}) -is an exception to this, as its source files reside -in the @file{gcc/} directory itself. - -@file{libf2c/} contains the run-time libraries for the @code{f2c} program, -also used by @code{g77}. -These libraries normally referred to collectively as @code{libf2c}. -When built as part of @code{g77}, -@code{libf2c} is installed under the name @code{libg2c} to avoid -conflict with any existing version of @code{libf2c}, -and thus is often referred to as @code{libg2c} when the -@code{g77} version is specifically being referred to. - -The @code{netlib} version of @code{libf2c/} -contains two distinct libraries, -@code{libF77} and @code{libI77}, -each in their own subdirectories. -In @code{g77}, this distinction is not made, -beyond maintaining the subdirectory structure in the source-code tree. - -@file{libf2c/} is not part of the program @code{g77}, -just distributed with it. -It contains files not present -in the official (@code{netlib}) version of @code{libf2c}, -and also contains some minor changes made from @code{libf2c}, -to fix some bugs, -and to facilitate automatic configuration, building, and installation of -@code{libf2c} (as @code{libg2c}) for use by @code{g77} users. -See @file{libf2c/README} for more information, -including licensing conditions -governing distribution of programs containing code from @code{libg2c}. - -@code{libg2c}, @code{g77}'s version of @code{libf2c}, -adds Dave Love's implementation of @code{libU77}, -in the @file{libf2c/libU77/} directory. -This library is distributed under the -GNU Library General Public License (LGPL)---see the -file @file{libf2c/libU77/COPYING.LIB} -for more information, -as this license -governs distribution conditions for programs containing code -from this portion of the library. - -Files of note in @file{f/} and @file{libf2c/} are described below: - -@table @file -@item f/BUGS -Lists some important bugs known to be in g77. -Or use Info (or GNU Emacs Info mode) to read -the ``Actual Bugs'' node of the @code{g77} documentation: - -@smallexample -info -f f/g77.info -n "Actual Bugs" -@end smallexample - -@item f/ChangeLog -Lists recent changes to @code{g77} internals. - -@item libf2c/ChangeLog -Lists recent changes to @code{libg2c} internals. - -@item f/NEWS -Contains the per-release changes. -These include the user-visible -changes described in the node ``Changes'' -in the @code{g77} documentation, plus internal -changes of import. -Or use: - -@smallexample -info -f f/g77.info -n News -@end smallexample - -@item f/g77.info* -The @code{g77} documentation, in Info format, -produced by building @code{g77}. - -All users of @code{g77} (not just installers) should read this, -using the @code{more} command if neither the @code{info} command, -nor GNU Emacs (with its Info mode), are available, or if users -aren't yet accustomed to using these tools. -All of these files are readable as ``plain text'' files, -though they're easier to navigate using Info readers -such as @code{info} and GNU Emacs Info mode. -@end table - -If you want to explore the FFE code, which lives entirely in @file{f/}, -here are a few clues. -The file @file{g77spec.c} contains the @code{g77}-specific source code -for the @code{g77} command only---this just forms a variant of the -@code{gcc} command, so, -just as the @code{gcc} command itself does not contain the C front end, -the @code{g77} command does not contain the Fortran front end (FFE). -The FFE code ends up in an executable named @file{f771}, -which does the actual compiling, -so it contains the FFE plus the @code{gcc} back end (GBE), -the latter to do most of the optimization, and the code generation. - -The file @file{parse.c} is the source file for @code{yyparse()}, -which is invoked by the GBE to start the compilation process, -for @file{f771}. - -The file @file{top.c} contains the top-level FFE function @code{ffe_file} -and it (along with top.h) define all @samp{ffe_[a-z].*}, @samp{ffe[A-Z].*}, -and @samp{FFE_[A-Za-z].*} symbols. - -The file @file{fini.c} is a @code{main()} program that is used when building -the FFE to generate C header and source files for recognizing keywords. -The files @file{malloc.c} and @file{malloc.h} comprise a memory manager -that defines all @samp{malloc_[a-z].*}, @samp{malloc[A-Z].*}, and -@samp{MALLOC_[A-Za-z].*} symbols. - -All other modules named @var{xyz} -are comprised of all files named @samp{@var{xyz}*.@var{ext}} -and define all @samp{ffe@var{xyz}_[a-z].*}, @samp{ffe@var{xyz}[A-Z].*}, -and @samp{FFE@var{XYZ}_[A-Za-z].*} symbols. -If you understand all this, congratulations---it's easier for me to remember -how it works than to type in these regular expressions. -But it does make it easy to find where a symbol is defined. -For example, the symbol @samp{ffexyz_set_something} would be defined -in @file{xyz.h} and implemented there (if it's a macro) or in @file{xyz.c}. - -The ``porting'' files of note currently are: - -@table @file -@item proj.h -This defines the ``language'' used by all the other source files, -the language being Standard C plus some useful things -like @code{ARRAY_SIZE} and such. - -@item target.c -@itemx target.h -These describe the target machine -in terms of what data types are supported, -how they are denoted -(to what C type does an @code{INTEGER*8} map, for example), -how to convert between them, -and so on. -Over time, versions of @code{g77} rely less on this file -and more on run-time configuration based on GBE info -in @file{com.c}. - -@item com.c -@itemx com.h -These are the primary interface to the GBE. - -@item ste.c -@itemx ste.h -This contains code for implementing recognized executable statements -in the GBE. - -@item src.c -@itemx src.h -These contain information on the format(s) of source files -(such as whether they are never to be processed as case-insensitive -with regard to Fortran keywords). -@end table - -If you want to debug the @file{f771} executable, -for example if it crashes, -note that the global variables @code{lineno} and @code{input_filename} -are usually set to reflect the current line being read by the lexer -during the first-pass analysis of a program unit and to reflect -the current line being processed during the second-pass compilation -of a program unit. - -If an invocation of the function @code{ffestd_exec_end} is on the stack, -the compiler is in the second pass, otherwise it is in the first. - -(This information might help you reduce a test case and/or work around -a bug in @code{g77} until a fix is available.) - -@node Overview of Translation Process -@section Overview of Translation Process - -The order of phases translating source code to the form accepted -by the GBE is: - -@enumerate -@item -Stripping punched-card sources (@file{g77stripcard.c}) - -@item -Lexing (@file{lex.c}) - -@item -Stand-alone statement identification (@file{sta.c}) - -@item -INCLUDE handling (@file{sti.c}) - -@item -Order-dependent statement identification (@file{stq.c}) - -@item -Parsing (@file{stb.c} and @file{expr.c}) - -@item -Constructing (@file{stc.c}) - -@item -Collecting (@file{std.c}) - -@item -Expanding (@file{ste.c}) -@end enumerate - -To get a rough idea of how a particularly twisted Fortran statement -gets treated by the passes, consider: - -@smallexample - FORMAT(I2 4H)=(J/ - & I3) -@end smallexample - -The job of @file{lex.c} is to know enough about Fortran syntax rules -to break the statement up into distinct lexemes without requiring -any feedback from subsequent phases: - -@smallexample -`FORMAT' -`(' -`I24H' -`)' -`=' -`(' -`J' -`/' -`I3' -`)' -@end smallexample - -The job of @file{sta.c} is to figure out the kind of statement, -or, at least, statement form, that sequence of lexemes represent. - -The sooner it can do this (in terms of using the smallest number of -lexemes, starting with the first for each statement), the better, -because that leaves diagnostics for problems beyond the recognition -of the statement form to subsequent phases, -which can usually better describe the nature of the problem. - -In this case, the @samp{=} at ``level zero'' -(not nested within parentheses) -tells @file{sta.c} that this is an @emph{assignment-form}, -not @code{FORMAT}, statement. - -An assignment-form statement might be a statement-function -definition or an executable assignment statement. - -To make that determination, -@file{sta.c} looks at the first two lexemes. - -Since the second lexeme is @samp{(}, -the first must represent an array for this to be an assignment statement, -else it's a statement function. - -Either way, @file{sta.c} hands off the statement to @file{stq.c} -(via @file{sti.c}, which expands INCLUDE files). -@file{stq.c} figures out what a statement that is, -on its own, ambiguous, must actually be based on the context -established by previous statements. - -So, @file{stq.c} watches the statement stream for executable statements, -END statements, and so on, so it knows whether @samp{A(B)=C} is -(intended as) a statement-function definition or an assignment statement. - -After establishing the context-aware statement info, @file{stq.c} -passes the original sample statement on to @file{stb.c} -(either its statement-function parser or its assignment-statement parser). - -@file{stb.c} forms a -statement-specific record containing the pertinent information. -That information includes a source expression and, -for an assignment statement, a destination expression. -Expressions are parsed by @file{expr.c}. - -This record is passed to @file{stc.c}, -which copes with the implications of the statement -within the context established by previous statements. - -For example, if it's the first statement in the file -or after an @code{END} statement, -@file{stc.c} recognizes that, first of all, -a main program unit is now being lexed -(and tells that to @file{std.c} -before telling it about the current statement). - -@file{stc.c} attaches whatever information it can, -usually derived from the context established by the preceding statements, -and passes the information to @file{std.c}. - -@file{std.c} saves this information away, -since the GBE cannot cope with information -that might be incomplete at this stage. - -For example, @samp{I3} might later be determined -to be an argument to an alternate @code{ENTRY} point. - -When @file{std.c} is told about the end of an external (top-level) -program unit, -it passes all the information it has saved away -on statements in that program unit -to @file{ste.c}. - -@file{ste.c} ``expands'' each statement, in sequence, by -constructing the appropriate GBE information and calling -the appropriate GBE routines. - -Details on the transformational phases follow. -Keep in mind that Fortran numbering is used, -so the first character on a line is column 1, -decimal numbering is used, and so on. - -@menu -* g77stripcard:: -* lex.c:: -* sta.c:: -* sti.c:: -* stq.c:: -* stb.c:: -* expr.c:: -* stc.c:: -* std.c:: -* ste.c:: - -* Gotchas (Transforming):: -* TBD (Transforming):: -@end menu - -@node g77stripcard -@subsection g77stripcard - -The @code{g77stripcard} program handles removing content beyond -column 72 (adjustable via a command-line option), -optionally warning about that content being something other -than trailing whitespace or Fortran commentary. - -This program is needed because @code{lex.c} doesn't pay attention -to maximum line lengths at all, to make it easier to maintain, -as well as faster (for sources that don't depend on the maximum -column length vis-a-vis trailing non-blank non-commentary content). - -Just how this program will be run---whether automatically for -old source (perhaps as the default for @file{.f} files?)---is not -yet determined. - -In the meantime, it might as well be implemented as a typical UNIX pipe. - -It should accept a @samp{-fline-length-@var{n}} option, -with the default line length set to 72. - -When the text it strips off the end of a line is not blank -(not spaces and tabs), -it should insert an additional comment line -(beginning with @samp{!}, -so it works for both fixed-form and free-form files) -containing the text, -following the stripped line. -The inserted comment should have a prefix of some kind, -TBD, that distinguishes the comment as representing stripped text. -Users could use that to @code{sed} out such lines, if they wished---it -seems silly to provide a command-line option to delete information -when it can be so easily filtered out by another program. - -(This inserted comment should be designed to ``fit in'' well -with whatever the Fortran community is using these days for -preprocessor, translator, and other such products, like OpenMP. -What that's all about, and how @code{g77} can elegantly fit its -special comment conventions into it all, is TBD as well. -We don't want to reinvent the wheel here, but if there turn out -to be too many conflicting conventions, we might have to invent -one that looks nothing like the others, but which offers their -host products a better infrastructure in which to fit and coexist -peacefully.) - -@code{g77stripcard} probably shouldn't do any tab expansion or other -fancy stuff. -People can use @code{expand} or other pre-filtering if they like. -The idea here is to keep each stage quite simple, while providing -excellent performance for ``normal'' code. - -(Code with junk beyond column 73 is not really ``normal'', -as it comes from a card-punch heritage, -and will be increasingly hard for tomorrow's Fortran programmers to read.) - -@node lex.c -@subsection lex.c - -To help make the lexer simple, fast, and easy to maintain, -while also having @code{g77} generally encourage Fortran programmers -to write simple, maintainable, portable code by maximizing the -performance of compiling that kind of code: - -@itemize @bullet -@item -There'll be just one lexer, for both fixed-form and free-form source. - -@item -It'll care about the form only when handling the first 7 columns of -text, stuff like spaces between strings of alphanumerics, and -how lines are continued. - -Some other distinctions will be handled by subsequent phases, -so at least one of them will have to know which form is involved. - -For example, @samp{I = 2 . 4} is acceptable in fixed form, -and works in free form as well given the implementation @code{g77} -presently uses. -But the standard requires a diagnostic for it in free form, -so the parser has to be able to recognize that -the lexemes aren't contiguous -(information the lexer @emph{does} have to provide) -and that free-form source is being parsed, -so it can provide the diagnostic. - -The @code{g77} lexer doesn't try to gather @samp{2 . 4} into a single lexeme. -Otherwise, it'd have to know a whole lot more about how to parse Fortran, -or subsequent phases (mainly parsing) would have two paths through -lots of critical code---one to handle the lexeme @samp{2}, @samp{.}, -and @samp{4} in sequence, another to handle the lexeme @samp{2.4}. - -@item -It won't worry about line lengths -(beyond the first 7 columns for fixed-form source). - -That is, once it starts parsing the ``statement'' part of a line -(column 7 for fixed-form, column 1 for free-form), -it'll keep going until it finds a newline, -rather than ignoring everything past a particular column -(72 or 132). - -The implication here is that there shouldn't @emph{be} -anything past that last column, other than whitespace or -commentary, because users using typical editors -(or viewing output as typically printed) -won't necessarily know just where the last column is. - -Code that has ``garbage'' beyond the last column -(almost certainly only fixed-form code with a punched-card legacy, -such as code using columns 73-80 for ``sequence numbers'') -will have to be run through @code{g77stripcard} first. - -Also, keeping track of the maximum column position while also watching out -for the end of a line @emph{and} while reading from a file -just makes things slower. -Since a file must be read, and watching for the end of the line -is necessary (unless the typical input file was preprocessed to -include the necessary number of trailing spaces), -dropping the tracking of the maximum column position -is the only way to reduce the complexity of the pertinent code -while maintaining high performance. - -@item -ASCII encoding is assumed for the input file. - -Code written in other character sets will have to be converted first. - -@item -Tabs (ASCII code 9) -will be converted to spaces via the straightforward -approach. - -Specifically, a tab is converted to between one and eight spaces -as necessary to reach column @var{n}, -where dividing @samp{(@var{n} - 1)} by eight -results in a remainder of zero. - -That saves having to pass most source files through @code{expand}. - -@item -Linefeeds (ASCII code 10) -mark the ends of lines. - -@item -A carriage return (ASCII code 13) -is accept if it immediately precedes a linefeed, -in which case it is ignored. - -Otherwise, it is rejected (with a diagnostic). - -@item -Any other characters other than the above -that are not part of the GNU Fortran Character Set -(@pxref{Character Set}) -are rejected with a diagnostic. - -This includes backspaces, form feeds, and the like. - -(It might make sense to allow a form feed in column 1 -as long as that's the only character on a line. -It certainly wouldn't seem to cost much in terms of performance.) - -@item -The end of the input stream (EOF) -ends the current line. - -@item -The distinction between uppercase and lowercase letters -will be preserved. - -It will be up to subsequent phases to decide to fold case. - -Current plans are to permit any casing for Fortran (reserved) keywords -while preserving casing for user-defined names. -(This might not be made the default for @file{.f} files, though.) - -Preserving case seems necessary to provide more direct access -to facilities outside of @code{g77}, such as to C or Pascal code. - -Names of intrinsics will probably be matchable in any case, - -(How @samp{external SiN; r = sin(x)} would be handled is TBD. -I think old @code{g77} might already handle that pretty elegantly, -but whether we can cope with allowing the same fragment to reference -a @emph{different} procedure, even with the same interface, -via @samp{s = SiN(r)}, needs to be determined. -If it can't, we need to make sure that when code introduces -a user-defined name, any intrinsic matching that name -using a case-insensitive comparison -is ``turned off''.) - -@item -Backslashes in @code{CHARACTER} and Hollerith constants -are not allowed. - -This avoids the confusion introduced by some Fortran compiler vendors -providing C-like interpretation of backslashes, -while others provide straight-through interpretation. - -Some kind of lexical construct (TBD) will be provided to allow -flagging of a @code{CHARACTER} -(but probably not a Hollerith) -constant that permits backslashes. -It'll necessarily be a prefix, such as: - -@smallexample -PRINT *, C'This line has a backspace \b here.' -PRINT *, F'This line has a straight backslash \ here.' -@end smallexample - -Further, command-line options might be provided to specify that -one prefix or the other is to be assumed as the default -for @code{CHARACTER} constants. - -However, it seems more helpful for @code{g77} to provide a program -that converts prefix all constants -(or just those containing backslashes) -with the desired designation, -so printouts of code can be read -without knowing the compile-time options used when compiling it. - -If such a program is provided -(let's name it @code{g77slash} for now), -then a command-line option to @code{g77} should not be provided. -(Though, given that it'll be easy to implement, it might be hard -to resist user requests for it ``to compile faster than if we -have to invoke another filter''.) - -This program would take a command-line option to specify the -default interpretation of slashes, -affecting which prefix it uses for constants. - -@code{g77slash} probably should automatically convert Hollerith -constants that contain slashes -to the appropriate @code{CHARACTER} constants. -Then @code{g77} wouldn't have to define a prefix syntax for Hollerith -constants specifying whether they want C-style or straight-through -backslashes. - -@item -To allow for form-neutral INCLUDE files without requiring them -to be preprocessed, -the fixed-form lexer should offer an extension (if possible) -allowing a trailing @samp{&} to be ignored, especially if after -column 72, as it would be using the traditional Unix Fortran source -model (which ignores @emph{everything} after column 72). -@end itemize - -The above implements nearly exactly what is specified by -@ref{Character Set}, -and -@ref{Lines}, -except it also provides automatic conversion of tabs -and ignoring of newline-related carriage returns, -as well as accommodating form-neutral INCLUDE files. - -It also implements the ``pure visual'' model, -by which is meant that a user viewing his code -in a typical text editor -(assuming it's not preprocessed via @code{g77stripcard} or similar) -doesn't need any special knowledge -of whether spaces on the screen are really tabs, -whether lines end immediately after the last visible non-space character -or after a number of spaces and tabs that follow it, -or whether the last line in the file is ended by a newline. - -Most editors don't make these distinctions, -the ANSI FORTRAN 77 standard doesn't require them to, -and it permits a standard-conforming compiler -to define a method for transforming source code to -``standard form'' however it wants. - -So, GNU Fortran defines it such that users have the best chance -of having the code be interpreted the way it looks on the screen -of the typical editor. - -(Fancy editors should @emph{never} be required to correctly read code -written in classic two-dimensional-plaintext form. -By correct reading I mean ability to read it, book-like, without -mistaking text ignored by the compiler for program code and vice versa, -and without having to count beyond the first several columns. -The vague meaning of ASCII TAB, among other things, complicates -this somewhat, but as long as ``everyone'', including the editor, -other tools, and printer, agrees about the every-eighth-column convention, -the GNU Fortran ``pure visual'' model meets these requirements. -Any language or user-visible source form -requiring special tagging of tabs, -the ends of lines after spaces/tabs, -and so on, fails to meet this fairly straightforward specification. -Fortunately, Fortran @emph{itself} does not mandate such a failure, -though most vendor-supplied defaults for their Fortran compilers @emph{do} -fail to meet this specification for readability.) - -Further, this model provides a clean interface -to whatever preprocessors or code-generators are used -to produce input to this phase of @code{g77}. -Mainly, they need not worry about long lines. - -@node sta.c -@subsection sta.c - -@node sti.c -@subsection sti.c - -@node stq.c -@subsection stq.c - -@node stb.c -@subsection stb.c - -@node expr.c -@subsection expr.c - -@node stc.c -@subsection stc.c - -@node std.c -@subsection std.c - -@node ste.c -@subsection ste.c - -@node Gotchas (Transforming) -@subsection Gotchas (Transforming) - -This section is not about transforming ``gotchas'' into something else. -It is about the weirder aspects of transforming Fortran, -however that's defined, -into a more modern, canonical form. - -@subsubsection Multi-character Lexemes - -Each lexeme carries with it a pointer to where it appears in the source. - -To provide the ability for diagnostics to point to column numbers, -in addition to line numbers and names, -lexemes that represent more than one (significant) character -in the source code need, generally, -to provide pointers to where each @emph{character} appears in the source. - -This provides the ability to properly identify the precise location -of the problem in code like - -@smallexample -SUBROUTINE X -END -BLOCK DATA X -END -@end smallexample - -which, in fixed-form source, would result in single lexemes -consisting of the strings @samp{SUBROUTINEX} and @samp{BLOCKDATAX}. -(The problem is that @samp{X} is defined twice, -so a pointer to the @samp{X} in the second definition, -as well as a follow-up pointer to the corresponding pointer in the first, -would be preferable to pointing to the beginnings of the statements.) - -This need also arises when parsing (and diagnosing) @code{FORMAT} -statements. - -Further, it arises when diagnosing -@code{FMT=} specifiers that contain constants -(or partial constants, or even propagated constants!) -in I/O statements, as in: - -@smallexample -PRINT '(I2, 3HAB)', J -@end smallexample - -(A pointer to the beginning of the prematurely-terminated Hollerith -constant, and/or to the close parenthese, is preferable to a pointer -to the open-parenthese or the apostrophe that precedes it.) - -Multi-character lexemes, which would seem to naturally include -at least digit strings, alphanumeric strings, @code{CHARACTER} -constants, and Hollerith constants, therefore need to provide -location information on each character. -(Maybe Hollerith constants don't, but it's unnecessary to except them.) - -The question then arises, what about @emph{other} multi-character lexemes, -such as @samp{**} and @samp{//}, -and Fortran 90's @samp{(/}, @samp{/)}, @samp{::}, and so on? - -Turns out there's a need to identify the location of the second character -of these two-character lexemes. -For example, in @samp{I(/J) = K}, the slash needs to be diagnosed -as the problem, not the open parenthese. -Similarly, it is preferable to diagnose the second slash in -@samp{I = J // K} rather than the first, given the implicit typing -rules, which would result in the compiler disallowing the attempted -concatenation of two integers. -(Though, since that's more of a semantic issue, -it's not @emph{that} much preferable.) - -Even sequences that could be parsed as digit strings could use location info, -for example, to diagnose the @samp{9} in the octal constant @samp{O'129'}. -(This probably will be parsed as a character string, -to be consistent with the parsing of @samp{Z'129A'}.) - -To avoid the hassle of recording the location of the second character, -while also preserving the general rule that each significant character -is distinctly pointed to by the lexeme that contains it, -it's best to simply not have any fixed-size lexemes -larger than one character. - -This new design is expected to make checking for two -@samp{*} lexemes in a row much easier than the old design, -so this is not much of a sacrifice. -It probably makes the lexer much easier to implement -than it makes the parser harder. - -@subsubsection Space-padding Lexemes - -Certain lexemes need to be padded with virtual spaces when the -end of the line (or file) is encountered. - -This is necessary in fixed form, to handle lines that don't -extend to column 72, assuming that's the line length in effect. - -@subsubsection Bizarre Free-form Hollerith Constants - -Last I checked, the Fortran 90 standard actually required the compiler -to silently accept something like - -@smallexample -FORMAT ( 1 2 Htwelve chars ) -@end smallexample - -as a valid @code{FORMAT} statement specifying a twelve-character -Hollerith constant. - -The implication here is that, since the new lexer is a zero-feedback one, -it won't know that the special case of a @code{FORMAT} statement being parsed -requires apparently distinct lexemes @samp{1} and @samp{2} to be treated as -a single lexeme. - -(This is a horrible misfeature of the Fortran 90 language. -It's one of many such misfeatures that almost make me want -to not support them, and forge ahead with designing a new -``GNU Fortran'' language that has the features, -but not the misfeatures, of Fortran 90, -and provide utility programs to do the conversion automatically.) - -So, the lexer must gather distinct chunks of decimal strings into -a single lexeme in contexts where a single decimal lexeme might -start a Hollerith constant. - -(Which probably means it might as well do that all the time -for all multi-character lexemes, even in free-form mode, -leaving it to subsequent phases to pull them apart as they see fit.) - -Compare the treatment of this to how - -@smallexample -CHARACTER * 4 5 HEY -@end smallexample - -and - -@smallexample -CHARACTER * 12 HEY -@end smallexample - -must be treated---the former must be diagnosed, due to the separation -between lexemes, the latter must be accepted as a proper declaration. - -@subsubsection Hollerith Constants - -Recognizing a Hollerith constant---specifically, -that an @samp{H} or @samp{h} after a digit string begins -such a constant---requires some knowledge of context. - -Hollerith constants (such as @samp{2HAB}) can appear after: - -@itemize @bullet -@item -@samp{(} - -@item -@samp{,} - -@item -@samp{=} - -@item -@samp{+}, @samp{-}, @samp{/} - -@item -@samp{*}, except as noted below -@end itemize - -Hollerith constants don't appear after: - -@itemize @bullet -@item -@samp{CHARACTER*}, -which can be treated generally as -any @samp{*} that is the second lexeme of a statement -@end itemize - -@subsubsection Confusing Function Keyword - -While - -@smallexample -REAL FUNCTION FOO () -@end smallexample - -must be a @code{FUNCTION} statement and - -@smallexample -REAL FUNCTION FOO (5) -@end smallexample - -must be a type-definition statement, - -@smallexample -REAL FUNCTION FOO (@var{names}) -@end smallexample - -where @var{names} is a comma-separated list of names, -can be one or the other. - -The only way to disambiguate that statement -(short of mandating free-form source or a short maximum -length for name for external procedures) -is based on the context of the statement. - -In particular, the statement is known to be within an -already-started program unit -(but not at the outer level of the @code{CONTAINS} block), -it is a type-declaration statement. - -Otherwise, the statement is a @code{FUNCTION} statement, -in that it begins a function program unit -(external, or, within @code{CONTAINS}, nested). - -@subsubsection Weird READ - -The statement - -@smallexample -READ (N) -@end smallexample - -is equivalent to either - -@smallexample -READ (UNIT=(N)) -@end smallexample - -or - -@smallexample -READ (FMT=(N)) -@end smallexample - -depending on which would be valid in context. - -Specifically, if @samp{N} is type @code{INTEGER}, -@samp{READ (FMT=(N))} would not be valid, -because parentheses may not be used around @samp{N}, -whereas they may around it in @samp{READ (UNIT=(N))}. - -Further, if @samp{N} is type @code{CHARACTER}, -the opposite is true---@samp{READ (UNIT=(N))} is not valid, -but @samp{READ (FMT=(N))} is. - -Strictly speaking, if anything follows - -@smallexample -READ (N) -@end smallexample - -in the statement, whether the first lexeme after the close -parenthese is a comma could be used to disambiguate the two cases, -without looking at the type of @samp{N}, -because the comma is required for the @samp{READ (FMT=(N))} -interpretation and disallowed for the @samp{READ (UNIT=(N))} -interpretation. - -However, in practice, many Fortran compilers allow -the comma for the @samp{READ (UNIT=(N))} -interpretation anyway -(in that they generally allow a leading comma before -an I/O list in an I/O statement), -and much code takes advantage of this allowance. - -(This is quite a reasonable allowance, since the -juxtaposition of a comma-separated list immediately -after an I/O control-specification list, which is also comma-separated, -without an intervening comma, -looks sufficiently ``wrong'' to programmers -that they can't resist the itch to insert the comma. -@samp{READ (I, J), K, L} simply looks cleaner than -@samp{READ (I, J) K, L}.) - -So, type-based disambiguation is needed unless strict adherence -to the standard is always assumed, and we're not going to assume that. - -@node TBD (Transforming) -@subsection TBD (Transforming) - -Continue researching gotchas, designing the transformational process, -and implementing it. - -Specific issues to resolve: - -@itemize @bullet -@item -Just where should (if it was implemented) @code{USE} processing take place? - -This gets into the whole issue of how @code{g77} should handle the concept -of modules. -I think GNAT already takes on this issue, but don't know more than that. -Jim Giles has written extensively on @code{comp.lang.fortran} -about his opinions on module handling, as have others. -Jim's views should be taken into account. - -Actually, Richard M. Stallman (RMS) also has written up -some guidelines for implementing such things, -but I'm not sure where I read them. -Perhaps the old @email{gcc2@@cygnus.com} list. - -If someone could dig references to these up and get them to me, -that would be much appreciated! -Even though modules are not on the short-term list for implementation, -it'd be helpful to know @emph{now} how to avoid making them harder to -implement them @emph{later}. - -@item -Should the @code{g77} command become just a script that invokes -all the various preprocessing that might be needed, -thus making it seem slower than necessary for legacy code -that people are unwilling to convert, -or should we provide a separate script for that, -thus encouraging people to convert their code once and for all? - -At least, a separate script to behave as old @code{g77} did, -perhaps named @code{g77old}, might ease the transition, -as might a corresponding one that converts source codes -named @code{g77oldnew}. - -These scripts would take all the pertinent options @code{g77} used -to take and run the appropriate filters, -passing the results to @code{g77} or just making new sources out of them -(in a subdirectory, leaving the user to do the dirty deed of -moving or copying them over the old sources). - -@item -Do other Fortran compilers provide a prefix syntax -to govern the treatment of backslashes in @code{CHARACTER} -(or Hollerith) constants? - -Knowing what other compilers provide would help. - -@item -Is it okay to drop support for the @samp{-fintrin-case-initcap}, -@samp{-fmatch-case-initcap}, @samp{-fsymbol-case-initcap}, -and @samp{-fcase-initcap} options? - -I've asked @email{info-gnu-fortran@@gnu.org} for input on this. -Not having to support these makes it easier to write the new front end, -and might also avoid complicated its design. - -The consensus to date (1999-11-17) has been to drop this support. -Can't recall anybody saying they're using it, in fact. -@end itemize - -@node Philosophy of Code Generation -@section Philosophy of Code Generation - -Don't poke the bear. - -The @code{g77} front end generates code -via the @code{gcc} back end. - -@cindex GNU Back End (GBE) -@cindex GBE -@cindex @code{gcc}, back end -@cindex back end, gcc -@cindex code generator -The @code{gcc} back end (GBE) is a large, complex -labyrinth of intricate code -written in a combination of the C language -and specialized languages internal to @code{gcc}. - -While the @emph{code} that implements the GBE -is written in a combination of languages, -the GBE itself is, -to the front end for a language like Fortran, -best viewed as a @emph{compiler} -that compiles its own, unique, language. - -The GBE's ``source'', then, is written in this language, -which consists primarily of -a combination of calls to GBE functions -and @dfn{tree} nodes -(which are, themselves, created -by calling GBE functions). - -So, the @code{g77} generates code by, in effect, -translating the Fortran code it reads -into a form ``written'' in the ``language'' -of the @code{gcc} back end. - -@cindex GBEL -@cindex GNU Back End Language (GBEL) -This language will heretofore be referred to as @dfn{GBEL}, -for GNU Back End Language. - -GBEL is an evolving language, -not fully specified in any published form -as of this writing. -It offers many facilities, -but its ``core'' facilities -are those that corresponding most directly -to those needed to support @code{gcc} -(compiling code written in GNU C). - -The @code{g77} Fortran Front End (FFE) -is designed and implemented -to navigate the currents and eddies -of ongoing GBEL and @code{gcc} development -while also delivering on the potential -of an integrated FFE -(as compared to using a converter like @code{f2c} -and feeding the output into @code{gcc}). - -Goals of the FFE's code-generation strategy include: - -@itemize @bullet -@item -High likelihood of generation of correct code, -or, failing that, producing a fatal diagnostic or crashing. - -@item -Generation of highly optimized code, -as directed by the user -via GBE-specific (versus @code{g77}-specific) constructs, -such as command-line options. - -@item -Fast overall (FFE plus GBE) compilation. - -@item -Preservation of source-level debugging information. -@end itemize - -The strategies historically, and currently, used by the FFE -to achieve these goals include: - -@itemize @bullet -@item -Use of GBEL constructs that most faithfully encapsulate -the semantics of Fortran. - -@item -Avoidance of GBEL constructs that are so rarely used, -or limited to use in specialized situations not related to Fortran, -that their reliability and performance has not yet been established -as sufficient for use by the FFE. - -@item -Flexible design, to readily accommodate changes to specific -code-generation strategies, perhaps governed by command-line options. -@end itemize - -@cindex Bear-poking -@cindex Poking the bear -``Don't poke the bear'' somewhat summarizes the above strategies. -The GBE is the bear. -The FFE is designed and implemented to avoid poking it -in ways that are likely to just annoy it. -The FFE usually either tackles it head-on, -or avoids treating it in ways dissimilar to how -the @code{gcc} front end treats it. - -For example, the FFE uses the native array facility in the back end -instead of the lower-level pointer-arithmetic facility -used by @code{gcc} when compiling @code{f2c} output). -Theoretically, this presents more opportunities for optimization, -faster compile times, -and the production of more faithful debugging information. -These benefits were not, however, immediately realized, -mainly because @code{gcc} itself makes little or no use -of the native array facility. - -Complex arithmetic is a case study of the evolution of this strategy. -When originally implemented, -the GBEL had just evolved its own native complex-arithmetic facility, -so the FFE took advantage of that. - -When porting @code{g77} to 64-bit systems, -it was discovered that the GBE didn't really -implement its native complex-arithmetic facility properly. - -The short-term solution was to rewrite the FFE -to instead use the lower-level facilities -that'd be used by @code{gcc}-compiled code -(assuming that code, itself, didn't use the native complex type -provided, as an extension, by @code{gcc}), -since these were known to work, -and, in any case, if shown to not work, -would likely be rapidly fixed -(since they'd likely not work for vanilla C code in similar circumstances). - -However, the rewrite accommodated the original, native approach as well -by offering a command-line option to select it over the emulated approach. -This allowed users, and especially GBE maintainers, to try out -fixes to complex-arithmetic support in the GBE -while @code{g77} continued to default to compiling more code correctly, -albeit producing (typically) slower executables. - -As of April 1999, it appeared that the last few bugs -in the GBE's support of its native complex-arithmetic facility -were worked out. -The FFE was changed back to default to using that native facility, -leaving emulation as an option. - -Later during the release cycle -(which was called EGCS 1.2, but soon became GCC 2.95), -bugs in the native facility were found. -Reactions among various people included -``the last thing we should do is change the default back'', -``we must change the default back'', -and ``let's figure out whether we can narrow down the bugs to -few enough cases to allow the now-months-long-tested default -to remain the same''. -The latter viewpoint won that particular time. -The bugs exposed other concerns regarding ABI compliance -when the ABI specified treatment of complex data as different -from treatment of what Fortran and GNU C consider the equivalent -aggregation (structure) of real (or float) pairs. - -Other Fortran constructs---arrays, character strings, -complex division, @code{COMMON} and @code{EQUIVALENCE} aggregates, -and so on---involve issues similar to those pertaining to complex arithmetic. - -So, it is possible that the history -of how the FFE handled complex arithmetic -will be repeated, probably in modified form -(and hopefully over shorter timeframes), -for some of these other facilities. - -@node Two-pass Design -@section Two-pass Design - -The FFE does not tell the GBE anything about a program unit -until after the last statement in that unit has been parsed. -(A program unit is a Fortran concept that corresponds, in the C world, -mostly closely to functions definitions in ISO C. -That is, a program unit in Fortran is like a top-level function in C. -Nested functions, found among the extensions offered by GNU C, -correspond roughly to Fortran's statement functions.) - -So, while parsing the code in a program unit, -the FFE saves up all the information -on statements, expressions, names, and so on, -until it has seen the last statement. - -At that point, the FFE revisits the saved information -(in what amounts to a second @dfn{pass} over the program unit) -to perform the actual translation of the program unit into GBEL, -ultimating in the generation of assembly code for it. - -Some lookahead is performed during this second pass, -so the FFE could be viewed as a ``two-plus-pass'' design. - -@menu -* Two-pass Code:: -* Why Two Passes:: -@end menu - -@node Two-pass Code -@subsection Two-pass Code - -Most of the code that turns the first pass (parsing) -into a second pass for code generation -is in @file{@value{path-g77}/std.c}. - -It has external functions, -called mainly by siblings in @file{@value{path-g77}/stc.c}, -that record the information on statements and expressions -in the order they are seen in the source code. -These functions save that information. - -It also has an external function that revisits that information, -calling the siblings in @file{@value{path-g77}/ste.c}, -which handles the actual code generation -(by generating GBEL code, -that is, by calling GBE routines -to represent and specify expressions, statements, and so on). - -@node Why Two Passes -@subsection Why Two Passes - -The need for two passes was not immediately evident -during the design and implementation of the code in the FFE -that was to produce GBEL. -Only after a few kludges, -to handle things like incorrectly-guessed @code{ASSIGN} label nature, -had been implemented, -did enough evidence pile up to make it clear -that @file{std.c} had to be introduced to intercept, -save, then revisit as part of a second pass, -the digested contents of a program unit. - -Other such missteps have occurred during the evolution of the FFE, -because of the different goals of the FFE and the GBE. - -Because the GBE's original, and still primary, goal -was to directly support the GNU C language, -the GBEL, and the GBE itself, -requires more complexity -on the part of most front ends -than it requires of @code{gcc}'s. - -For example, -the GBEL offers an interface that permits the @code{gcc} front end -to implement most, or all, of the language features it supports, -without the front end having to -make use of non-user-defined variables. -(It's almost certainly the case that all of K&R C, -and probably ANSI C as well, -is handled by the @code{gcc} front end -without declaring such variables.) - -The FFE, on the other hand, must resort to a variety of ``tricks'' -to achieve its goals. - -Consider the following C code: - -@smallexample -int -foo (int a, int b) -@{ - int c = 0; - - if ((c = bar (c)) == 0) - goto done; - - quux (c << 1); - -done: - return c; -@} -@end smallexample - -Note what kinds of objects are declared, or defined, before their use, -and before any actual code generation involving them -would normally take place: - -@itemize @bullet -@item -Return type of function - -@item -Entry point(s) of function - -@item -Dummy arguments - -@item -Variables - -@item -Initial values for variables -@end itemize - -Whereas, the following items can, and do, -suddenly appear ``out of the blue'' in C: - -@itemize @bullet -@item -Label references - -@item -Function references -@end itemize - -Not surprisingly, the GBE faithfully permits the latter set of items -to be ``discovered'' partway through GBEL ``programs'', -just as they are permitted to in C. - -Yet, the GBE has tended, at least in the past, -to be reticent to fully support similar ``late'' discovery -of items in the former set. - -This makes Fortran a poor fit for the ``safe'' subset of GBEL. -Consider: - -@smallexample - FUNCTION X (A, ARRAY, ID1) - CHARACTER*(*) A - DOUBLE PRECISION X, Y, Z, TMP, EE, PI - REAL ARRAY(ID1*ID2) - COMMON ID2 - EXTERNAL FRED - - ASSIGN 100 TO J - CALL FOO (I) - IF (I .EQ. 0) PRINT *, A(0) - GOTO 200 - - ENTRY Y (Z) - ASSIGN 101 TO J -200 PRINT *, A(1) - READ *, TMP - GOTO J -100 X = TMP * EE - RETURN -101 Y = TMP * PI - CALL FRED - DATA EE, PI /2.71D0, 3.14D0/ - END -@end smallexample - -Here are some observations about the above code, -which, while somewhat contrived, -conforms to the FORTRAN 77 and Fortran 90 standards: - -@itemize @bullet -@item -The return type of function @samp{X} is not known -until the @samp{DOUBLE PRECISION} line has been parsed. - -@item -Whether @samp{A} is a function or a variable -is not known until the @samp{PRINT *, A(0)} statement -has been parsed. - -@item -The bounds of the array of argument @samp{ARRAY} -depend on a computation involving -the subsequent argument @samp{ID1} -and the blank-common member @samp{ID2}. - -@item -Whether @samp{Y} and @samp{Z} are local variables, -additional function entry points, -or dummy arguments to additional entry points -is not known -until the @code{ENTRY} statement is parsed. - -@item -Similarly, whether @samp{TMP} is a local variable is not known -until the @samp{READ *, TMP} statement is parsed. - -@item -The initial values for @samp{EE} and @samp{PI} -are not known until after the @code{DATA} statement is parsed. - -@item -Whether @samp{FRED} is a function returning type @code{REAL} -or a subroutine -(which can be thought of as returning type @code{void} -@emph{or}, to support alternate returns in a simple way, -type @code{int}) -is not known -until the @samp{CALL FRED} statement is parsed. - -@item -Whether @samp{100} is a @code{FORMAT} label -or the label of an executable statement -is not known -until the @samp{X =} statement is parsed. -(These two types of labels get @emph{very} different treatment, -especially when @code{ASSIGN}'ed.) - -@item -That @samp{J} is a local variable is not known -until the first @code{ASSIGN} statement is parsed. -(This happens @emph{after} executable code has been seen.) -@end itemize - -Very few of these ``discoveries'' -can be accommodated by the GBE as it has evolved over the years. -The GBEL doesn't support several of them, -and those it might appear to support -don't always work properly, -especially in combination with other GBEL and GBE features, -as implemented in the GBE. - -(Had the GBE and its GBEL originally evolved to support @code{g77}, -the shoe would be on the other foot, so to speak---most, if not all, -of the above would be directly supported by the GBEL, -and a few C constructs would probably not, as they are in reality, -be supported. -Both this mythical, and today's real, GBE caters to its GBEL -by, sometimes, scrambling around, cleaning up after itself---after -discovering that assumptions it made earlier during code generation -are incorrect. -That's not a great design, since it indicates significant code -paths that might be rarely tested but used in some key production -environments.) - -So, the FFE handles these discrepancies---between the order in which -it discovers facts about the code it is compiling, -and the order in which the GBEL and GBE support such discoveries---by -performing what amounts to two -passes over each program unit. - -(A few ambiguities can remain at that point, -such as whether, given @samp{EXTERNAL BAZ} -and no other reference to @samp{BAZ} in the program unit, -it is a subroutine, a function, or a block-data---which, in C-speak, -governs its declared return type. -Fortunately, these distinctions are easily finessed -for the procedure, library, and object-file interfaces -supported by @code{g77}.) - -@node Challenges Posed -@section Challenges Posed - -Consider the following Fortran code, which uses various extensions -(including some to Fortran 90): - -@smallexample -SUBROUTINE X(A) -CHARACTER*(*) A -COMPLEX CFUNC -INTEGER*2 CLOCKS(200) -INTEGER IFUNC - -CALL SYSTEM_CLOCK (CLOCKS (IFUNC (CFUNC ('('//A//')')))) -@end smallexample - -The above poses the following challenges to any Fortran compiler -that uses run-time interfaces, and a run-time library, roughly similar -to those used by @code{g77}: - -@itemize @bullet -@item -Assuming the library routine that supports @code{SYSTEM_CLOCK} -expects to set an @code{INTEGER*4} variable via its @code{COUNT} argument, -the compiler must make available to it a temporary variable of that type. - -@item -Further, after the @code{SYSTEM_CLOCK} library routine returns, -the compiler must ensure that the temporary variable it wrote -is copied into the appropriate element of the @samp{CLOCKS} array. -(This assumes the compiler doesn't just reject the code, -which it should if it is compiling under some kind of a ``strict'' option.) - -@item -To determine the correct index into the @samp{CLOCKS} array, -(putting aside the fact that the index, in this particular case, -need not be computed until after -the @code{SYSTEM_CLOCK} library routine returns), -the compiler must ensure that the @code{IFUNC} function is called. - -That requires evaluating its argument, -which requires, for @code{g77} -(assuming @code{-ff2c} is in force), -reserving a temporary variable of type @code{COMPLEX} -for use as a repository for the return value -being computed by @samp{CFUNC}. - -@item -Before invoking @samp{CFUNC}, -is argument must be evaluated, -which requires allocating, at run time, -a temporary large enough to hold the result of the concatenation, -as well as actually performing the concatenation. - -@item -The large temporary needed during invocation of @code{CFUNC} -should, ideally, be deallocated -(or, at least, left to the GBE to dispose of, as it sees fit) -as soon as @code{CFUNC} returns, -which means before @code{IFUNC} is called -(as it might need a lot of dynamically allocated memory). -@end itemize - -@code{g77} currently doesn't support all of the above, -but, so that it might someday, it has evolved to handle -at least some of the above requirements. - -Meeting the above requirements is made more challenging -by conforming to the requirements of the GBEL/GBE combination. - -@node Transforming Statements -@section Transforming Statements - -Most Fortran statements are given their own block, -and, for temporary variables they might need, their own scope. -(A block is what distinguishes @samp{@{ foo (); @}} -from just @samp{foo ();} in C. -A scope is included with every such block, -providing a distinct name space for local variables.) - -Label definitions for the statement precede this block, -so @samp{10 PRINT *, I} is handled more like -@samp{fl10: @{ @dots{} @}} than @samp{@{ fl10: @dots{} @}} -(where @samp{fl10} is just a notation meaning ``Fortran Label 10'' -for the purposes of this document). - -@menu -* Statements Needing Temporaries:: -* Transforming DO WHILE:: -* Transforming Iterative DO:: -* Transforming Block IF:: -* Transforming SELECT CASE:: -@end menu - -@node Statements Needing Temporaries -@subsection Statements Needing Temporaries - -Any temporaries needed during, but not beyond, -execution of a Fortran statement, -are made local to the scope of that statement's block. - -This allows the GBE to share storage for these temporaries -among the various statements without the FFE -having to manage that itself. - -(The GBE could, of course, decide to optimize -management of these temporaries. -For example, it could, theoretically, -schedule some of the computations involving these temporaries -to occur in parallel. -More practically, it might leave the storage for some temporaries -``live'' beyond their scopes, to reduce the number of -manipulations of the stack pointer at run time.) - -Temporaries needed across distinct statement boundaries usually -are associated with Fortran blocks (such as @code{DO}/@code{END DO}). -(Also, there might be temporaries not associated with blocks at all---these -would be in the scope of the entire program unit.) - -Each Fortran block @emph{should} get its own block/scope in the GBE. -This is best, because it allows temporaries to be more naturally handled. -However, it might pose problems when handling labels -(in particular, when they're the targets of @code{GOTO}s outside the Fortran -block), and generally just hassling with replicating -parts of the @code{gcc} front end -(because the FFE needs to support -an arbitrary number of nested back-end blocks -if each Fortran block gets one). - -So, there might still be a need for top-level temporaries, whose -``owning'' scope is that of the containing procedure. - -Also, there seems to be problems declaring new variables after -generating code (within a block) in the back end, leading to, e.g., -@samp{label not defined before binding contour} or similar messages, -when compiling with @samp{-fstack-check} or -when compiling for certain targets. - -Because of that, and because sometimes these temporaries are not -discovered until in the middle of of generating code for an expression -statement (as in the case of the optimization for @samp{X**I}), -it seems best to always -pre-scan all the expressions that'll be expanded for a block -before generating any of the code for that block. - -This pre-scan then handles discovering and declaring, to the back end, -the temporaries needed for that block. - -It's also important to treat distinct items in an I/O list as distinct -statements deserving their own blocks. -That's because there's a requirement -that each I/O item be fully processed before the next one, -which matters in cases like @samp{READ (*,*), I, A(I)}---the -element of @samp{A} read in the second item -@emph{must} be determined from the value -of @samp{I} read in the first item. - -@node Transforming DO WHILE -@subsection Transforming DO WHILE - -@samp{DO WHILE(expr)} @emph{must} be implemented -so that temporaries needed to evaluate @samp{expr} -are generated just for the test, each time. - -Consider how @samp{DO WHILE (A//B .NE. 'END'); @dots{}; END DO} is transformed: - -@smallexample -for (;;) - @{ - int temp0; - - @{ - char temp1[large]; - - libg77_catenate (temp1, a, b); - temp0 = libg77_ne (temp1, 'END'); - @} - - if (! temp0) - break; - - @dots{} - @} -@end smallexample - -In this case, it seems like a time/space tradeoff -between allocating and deallocating @samp{temp1} for each iteration -and allocating it just once for the entire loop. - -However, if @samp{temp1} is allocated just once for the entire loop, -it could be the wrong size for subsequent iterations of that loop -in cases like @samp{DO WHILE (A(I:J)//B .NE. 'END')}, -because the body of the loop might modify @samp{I} or @samp{J}. - -So, the above implementation is used, -though a more optimal one can be used -in specific circumstances. - -@node Transforming Iterative DO -@subsection Transforming Iterative DO - -An iterative @code{DO} loop -(one that specifies an iteration variable) -is required by the Fortran standards -to be implemented as though an iteration count -is computed before entering the loop body, -and that iteration count used to determine -the number of times the loop body is to be performed -(assuming the loop isn't cut short via @code{GOTO} or @code{EXIT}). - -The FFE handles this by allocating a temporary variable -to contain the computed number of iterations. -Since this variable must be in a scope that includes the entire loop, -a GBEL block is created for that loop, -and the variable declared as belonging to the scope of that block. - -@node Transforming Block IF -@subsection Transforming Block IF - -Consider: - -@smallexample -SUBROUTINE X(A,B,C) -CHARACTER*(*) A, B, C -LOGICAL LFUNC - -IF (LFUNC (A//B)) THEN - CALL SUBR1 -ELSE IF (LFUNC (A//C)) THEN - CALL SUBR2 -ELSE - CALL SUBR3 -END -@end smallexample - -The arguments to the two calls to @samp{LFUNC} -require dynamic allocation (at run time), -but are not required during execution of the @code{CALL} statements. - -So, the scopes of those temporaries must be within blocks inside -the block corresponding to the Fortran @code{IF} block. - -This cannot be represented ``naturally'' -in vanilla C, nor in GBEL. -The @code{if}, @code{elseif}, @code{else}, -and @code{endif} constructs -provided by both languages must, -for a given @code{if} block, -share the same C/GBE block. - -Therefore, any temporaries needed during evaluation of @samp{expr} -while executing @samp{ELSE IF(expr)} -must either have been predeclared -at the top of the corresponding @code{IF} block, -or declared within a new block for that @code{ELSE IF}---a block that, -since it cannot contain the @code{else} or @code{else if} itself -(due to the above requirement), -actually implements the rest of the @code{IF} block's -@code{ELSE IF} and @code{ELSE} statements -within an inner block. - -The FFE takes the latter approach. - -@node Transforming SELECT CASE -@subsection Transforming SELECT CASE - -@code{SELECT CASE} poses a few interesting problems for code generation, -if efficiency and frugal stack management are important. - -Consider @samp{SELECT CASE (I('PREFIX'//A))}, -where @samp{A} is @code{CHARACTER*(*)}. -In a case like this---basically, -in any case where largish temporaries are needed -to evaluate the expression---those temporaries should -not be ``live'' during execution of any of the @code{CASE} blocks. - -So, evaluation of the expression is best done within its own block, -which in turn is within the @code{SELECT CASE} block itself -(which contains the code for the CASE blocks as well, -though each within their own block). - -Otherwise, we'd have the rough equivalent of this pseudo-code: - -@smallexample -@{ - char temp[large]; - - libg77_catenate (temp, 'prefix', a); - - switch (i (temp)) - @{ - case 0: - @dots{} - @} -@} -@end smallexample - -And that would leave temp[large] in scope during the CASE blocks -(although a clever back end *could* see that it isn't referenced -in them, and thus free that temp before executing the blocks). - -So this approach is used instead: - -@smallexample -@{ - int temp0; - - @{ - char temp1[large]; - - libg77_catenate (temp1, 'prefix', a); - temp0 = i (temp1); - @} - - switch (temp0) - @{ - case 0: - @dots{} - @} -@} -@end smallexample - -Note how @samp{temp1} goes out of scope before starting the switch, -thus making it easy for a back end to free it. - -The problem @emph{that} solution has, however, -is with @samp{SELECT CASE('prefix'//A)} -(which is currently not supported). - -Unless the GBEL is extended to support arbitrarily long character strings -in its @code{case} facility, -the FFE has to implement @code{SELECT CASE} on @code{CHARACTER} -(probably excepting @code{CHARACTER*1}) -using a cascade of -@code{if}, @code{elseif}, @code{else}, and @code{endif} constructs -in GBEL. - -To prevent the (potentially large) temporary, -needed to hold the selected expression itself (@samp{'prefix'//A}), -from being in scope during execution of the @code{CASE} blocks, -two approaches are available: - -@itemize @bullet -@item -Pre-evaluate all the @code{CASE} tests, -producing an integer ordinal that is used, -a la @samp{temp0} in the earlier example, -as if @samp{SELECT CASE(temp0)} had been written. - -Each corresponding @code{CASE} is replaced with @samp{CASE(@var{i})}, -where @var{i} is the ordinal for that case, -determined while, or before, -generating the cascade of @code{if}-related constructs -to cope with @code{CHARACTER} selection. - -@item -Make @samp{temp0} above just -large enough to hold the longest @code{CASE} string -that'll actually be compared against the expression -(in this case, @samp{'prefix'//A}). - -Since that length must be constant -(because @code{CASE} expressions are all constant), -it won't be so large, -and, further, @samp{temp1} need not be dynamically allocated, -since normal @code{CHARACTER} assignment can be used -into the fixed-length @samp{temp0}. -@end itemize - -Both of these solutions require @code{SELECT CASE} implementation -to be changed so all the corresponding @code{CASE} statements -are seen during the actual code generation for @code{SELECT CASE}. - -@node Transforming Expressions -@section Transforming Expressions - -The interactions between statements, expressions, and subexpressions -at program run time can be viewed as: - -@smallexample -@var{action}(@var{expr}) -@end smallexample - -Here, @var{action} is the series of steps -performed to effect the statement, -and @var{expr} is the expression -whose value is used by @var{action}. - -Expanding the above shows a typical order of events at run time: - -@smallexample -Evaluate @var{expr} -Perform @var{action}, using result of evaluation of @var{expr} -Clean up after evaluating @var{expr} -@end smallexample - -So, if evaluating @var{expr} requires allocating memory, -that memory can be freed before performing @var{action} -only if it is not needed to hold the result of evaluating @var{expr}. -Otherwise, it must be freed no sooner than -after @var{action} has been performed. - -The above are recursive definitions, -in the sense that they apply to subexpressions of @var{expr}. - -That is, evaluating @var{expr} involves -evaluating all of its subexpressions, -performing the @var{action} that computes the -result value of @var{expr}, -then cleaning up after evaluating those subexpressions. - -The recursive nature of this evaluation is implemented -via recursive-descent transformation of the top-level statements, -their expressions, @emph{their} subexpressions, and so on. - -However, that recursive-descent transformation is, -due to the nature of the GBEL, -focused primarily on generating a @emph{single} stream of code -to be executed at run time. - -Yet, from the above, it's clear that multiple streams of code -must effectively be simultaneously generated -during the recursive-descent analysis of statements. - -The primary stream implements the primary @var{action} items, -while at least two other streams implement -the evaluation and clean-up items. - -Requirements imposed by expressions include: - -@itemize @bullet -@item -Whether the caller needs to have a temporary ready -to hold the value of the expression. - -@item -Other stuff??? -@end itemize - -@node Internal Naming Conventions -@section Internal Naming Conventions - -Names exported by FFE modules have the following (regular-expression) forms. -Note that all names beginning @code{ffe@var{mod}} or @code{FFE@var{mod}}, -where @var{mod} is lowercase or uppercase alphanumerics, respectively, -are exported by the module @code{ffe@var{mod}}, -with the source code doing the exporting in @file{@var{mod}.h}. -(Usually, the source code for the implementation is in @file{@var{mod}.c}.) - -Identifiers that don't fit the following forms -are not considered exported, -even if they are according to the C language. -(For example, they might be made available to other modules -solely for use within expansions of exported macros, -not for use within any source code in those other modules.) - -@table @code -@item ffe@var{mod} -The single typedef exported by the module. - -@item FFE@var{umod}_[A-Z][A-Z0-9_]* -(Where @var{umod} is the uppercase for of @var{mod}.) - -A @code{#define} or @code{enum} constant of the type @code{ffe@var{mod}}. - -@item ffe@var{mod}[A-Z][A-Z][a-z0-9]* -A typedef exported by the module. - -The portion of the identifier after @code{ffe@var{mod}} is -referred to as @code{ctype}, a capitalized (mixed-case) form -of @code{type}. - -@item FFE@var{umod}_@var{type}[A-Z][A-Z0-9_]*[A-Z0-9]? -(Where @var{umod} is the uppercase for of @var{mod}.) - -A @code{#define} or @code{enum} constant of the type -@code{ffe@var{mod}@var{type}}, -where @var{type} is the lowercase form of @var{ctype} -in an exported typedef. - -@item ffe@var{mod}_@var{value} -A function that does or returns something, -as described by @var{value} (see below). - -@item ffe@var{mod}_@var{value}_@var{input} -A function that does or returns something based -primarily on the thing described by @var{input} (see below). -@end table - -Below are names used for @var{value} and @var{input}, -along with their definitions. - -@table @code -@item col -A column number within a line (first column is number 1). - -@item file -An encapsulation of a file's name. - -@item find -Looks up an instance of some type that matches specified criteria, -and returns that, even if it has to create a new instance or -crash trying to find it (as appropriate). - -@item initialize -Initializes, usually a module. No type. - -@item int -A generic integer of type @code{int}. - -@item is -A generic integer that contains a true (nonzero) or false (zero) value. - -@item len -A generic integer that contains the length of something. - -@item line -A line number within a source file, -or a global line number. - -@item lookup -Looks up an instance of some type that matches specified criteria, -and returns that, or returns nil. - -@item name -A @code{text} that points to a name of something. - -@item new -Makes a new instance of the indicated type. -Might return an existing one if appropriate---if so, -similar to @code{find} without crashing. - -@item pt -Pointer to a particular character (line, column pairs) -in the input file (source code being compiled). - -@item run -Performs some herculean task. No type. - -@item terminate -Terminates, usually a module. No type. - -@item text -A @code{char *} that points to generic text. -@end table diff --git a/contrib/gcc-3.4/gcc/f/fini.c b/contrib/gcc-3.4/gcc/f/fini.c deleted file mode 100644 index 167837b461..0000000000 --- a/contrib/gcc-3.4/gcc/f/fini.c +++ /dev/null @@ -1,772 +0,0 @@ -/* fini.c - Copyright (C) 1995 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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. */ - -#define USE_BCONFIG - -#include "proj.h" -#include "malloc.h" - -#undef MAXNAMELEN -#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 const char *const xspaces[] -= -{ - "", /* 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); - -int -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; - - last_buf[0] = '\0'; - - 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"); - return (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); - return (1); - } - out = fopen (output_name, "w"); - if (out == NULL) - { - fclose (in); - fprintf (stderr, "Cannot open \"%s\"\n", output_name); - return (1); - } - incl = fopen (include_name, "w"); - if (incl == NULL) - { - fclose (in); - fprintf (stderr, "Cannot open \"%s\"\n", include_name); - return (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); - return (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 = xmalloc (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]; - newname->name_uc[i] = TOUPPER (cc); - newname->name_lc[i] = TOLOWER (cc); - 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) - return (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); - return (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 (xspaces)); - - 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\ -", - xspaces[indent - 2]); - - fprintf (out, - "\ -%sif ((c = ffesrc_strcmp_2c (ffe_case_match (), p, \"%s\", \"%s\", \"%s\")) == 0)\n\ -%sreturn %s%s%s;\n\ -", - xspaces[indent], nhalf->name_uc, nhalf->name_lc, nhalf->name_ic, - xspaces[indent + 2], prefix, nhalf->kwname, postfix); - - if (num != 1) - { - fprintf (out, - "\ -%selse if (c < 0)\n\ -", - xspaces[indent]); - - if (numhalf == 0) - fprintf (out, - "\ -%s;\n\ -", - xspaces[indent + 2]); - else - testname (TRUE, indent + 4, first, nhalf->previous); - - if (num - numhalf > 1) - { - fprintf (out, - "\ -%selse\n\ -", - xspaces[indent]); - - testname (TRUE, indent + 4, nhalf->next, last); - } - } - - if (nested) - fprintf (out, - "\ -%s}\n\ -", - xspaces[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 (xspaces)); - - 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\ -", - xspaces[indent - 2]); - - fprintf (out, - "\ -%sif ((c = ffesrc_strncmp_2c (ffe_case_match (), p, \"%s\", \"%s\", \"%s\", %d)) == 0)\n\ -%sreturn %s%s%s;\n\ -", - xspaces[indent], nhalf->name_uc, nhalf->name_lc, nhalf->name_ic, - len, xspaces[indent + 2], prefix, nhalf->kwname, postfix); - - if (num != 1) - { - fprintf (out, - "\ -%selse if (c < 0)\n\ -", - xspaces[indent]); - - if (numhalf == 0) - fprintf (out, - "\ -%s;\n\ -", - xspaces[indent + 2]); - else - testnames (TRUE, indent + 4, len, first, nhalf->previous); - - if (num - numhalf > 1) - { - fprintf (out, - "\ -%selse\n\ -", - xspaces[indent]); - - testnames (TRUE, indent + 4, len, nhalf->next, last); - } - } - - if (nested) - fprintf (out, - "\ -%s}\n\ -", - xspaces[indent - 2]); -} diff --git a/contrib/gcc-3.4/gcc/f/g77.texi b/contrib/gcc-3.4/gcc/f/g77.texi deleted file mode 100644 index 23172315fb..0000000000 --- a/contrib/gcc-3.4/gcc/f/g77.texi +++ /dev/null @@ -1,11849 +0,0 @@ -\input texinfo @c -*-texinfo-*- -@c %**start of header -@setfilename g77.info - -@set last-update 2004-03-21 -@set copyrights-g77 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004 - -@include root.texi - -@c This tells @include'd files that they're part of the overall G77 doc -@c set. (They might be part of a higher-level doc set too.) -@set DOC-G77 - -@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 - -@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 - -@c Cause even numbered pages to be printed on the left hand side of -@c the page and odd numbered pages to be printed on the right hand -@c side of the page. Using this, you can print on both sides of a -@c sheet of paper and have the text on the same part of the sheet. - -@c The text on right hand pages is pushed towards the right hand -@c margin and the text on left hand pages is pushed toward the left -@c hand margin. -@c (To provide the reverse effect, set bindingoffset to -0.75in.) - -@c @tex -@c \global\bindingoffset=0.75in -@c \global\normaloffset =0.75in -@c @end tex - -@copying -Copyright @copyright{} @value{copyrights-g77} Free Software Foundation, Inc. - -Permission is granted to copy, distribute and/or modify this document -under the terms of the GNU Free Documentation License, Version 1.2 or -any later version published by the Free Software Foundation; with the -Invariant Sections being ``GNU General Public License'' and ``Funding -Free Software'', the Front-Cover -texts being (a) (see below), and with the Back-Cover Texts being (b) -(see below). A copy of the license is included in the section entitled -``GNU Free Documentation License''. - -(a) The FSF's Front-Cover Text is: - - A GNU Manual - -(b) The FSF's Back-Cover Text is: - - You have freedom to copy and modify this GNU Manual, like GNU - software. Copies published by the Free Software Foundation raise - funds for GNU development. -@end copying - -@ifinfo -@dircategory Programming -@direntry -* g77: (g77). The GNU Fortran compiler. -@end direntry -@ifset INTERNALS -@ifset USING -This file documents the use and the internals of the GNU Fortran (@command{g77}) -compiler. -It corresponds to the @value{which-g77} version of @command{g77}. -@end ifset -@end ifset -@ifclear USING -This file documents the internals of the GNU Fortran (@command{g77}) compiler. -It corresponds to the @value{which-g77} version of @command{g77}. -@end ifclear -@ifclear INTERNALS -This file documents the use of the GNU Fortran (@command{g77}) compiler. -It corresponds to the @value{which-g77} version of @command{g77}. -@end ifclear - -Published by the Free Software Foundation -59 Temple Place - Suite 330 -Boston, MA 02111-1307 USA - -@insertcopying -@end ifinfo - -Contributed by James Craig Burley (@email{@value{email-burley}}). -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}). - -@setchapternewpage odd -@titlepage -@ifset INTERNALS -@ifset USING -@center @titlefont{Using and Porting GNU Fortran} - -@end ifset -@end ifset -@ifclear INTERNALS -@title Using GNU Fortran -@end ifclear -@ifclear USING -@title Porting GNU Fortran -@end ifclear -@sp 2 -@center James Craig Burley -@sp 3 -@center Last updated @value{last-update} -@sp 1 -@center for version @value{which-g77} -@page -@vskip 0pt plus 1filll -For the @value{which-g77} Version* -@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 -@insertcopying -@end titlepage -@summarycontents -@contents -@page - -@node Top, Copying,, (DIR) -@top Introduction -@cindex Introduction - -@ifset INTERNALS -@ifset USING -This manual documents how to run, install and port @command{g77}, -as well as its new features and incompatibilities, -and how to report bugs. -It corresponds to the @value{which-g77} version of @command{g77}. -@end ifset -@end ifset - -@ifclear INTERNALS -This manual documents how to run and install @command{g77}, -as well as its new features and incompatibilities, and how to report -bugs. -It corresponds to the @value{which-g77} version of @command{g77}. -@end ifclear -@ifclear USING -This manual documents how to port @command{g77}, -as well as its new features and incompatibilities, -and how to report bugs. -It corresponds to the @value{which-g77} version of @command{g77}. -@end ifclear - -@ifset DEVELOPMENT -@emph{Warning:} This document is still under development, -and might not accurately reflect the @command{g77} code base -of which it is a part. -Efforts are made to keep it somewhat up-to-date, -but they are particularly concentrated -on any version of this information -that is distributed as part of a @emph{released} @command{g77}. - -In particular, while this document is intended to apply to -the @value{which-g77} version of @command{g77}, -only an official @emph{release} of that version -is expected to contain documentation that is -most consistent with the @command{g77} product in that version. -@end ifset - -@menu -* Copying:: GNU General Public License says - how you can copy and share GNU Fortran. -* GNU Free Documentation License:: - How you can copy and share this manual. -* 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. -@ifset USING -* Getting Started:: Finding your way around this manual. -* What is GNU Fortran?:: How @command{g77} fits into the universe. -* G77 and GCC:: You can compile Fortran, C, or other programs. -* Invoking G77:: Command options supported by @command{g77}. -* News:: News about recent releases of @command{g77}. -* Changes:: User-visible changes to recent releases of @command{g77}. -* Language:: The GNU Fortran language. -* Compiler:: The GNU Fortran compiler. -* Other Dialects:: Dialects of Fortran supported by @command{g77}. -* Other Compilers:: Fortran compilers other than @command{g77}. -* Other Languages:: Languages other than Fortran. -* Debugging and Interfacing:: How @command{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 @command{g77} about new options. -* Projects:: Projects for @command{g77} internals hackers. -* Front End:: Design and implementation of the @command{g77} front end. -@end ifset - -* M: Diagnostics. Diagnostics produced by @command{g77}. - -* Keyword Index:: Index of concepts and symbol names. -@end menu -@c yes, the "M: " @emph{is} intentional -- bad.def references it (CMPAMBIG)! - -@include gpl.texi - -@include fdl.texi - -@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 GCC compiler. -@xref{Contributors,,Contributors to GCC,gcc,Using the GNU Compiler -Collection (GCC)}, -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 @command{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 @command{g77}'s -public release. This work consisted of testing, researching, sometimes -debugging, and occasionally providing small amounts of code and fixes -for @command{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 -Dave Love (@email{d.love@@dl.ac.uk}) -wrote the libU77 part of the run-time library. - -@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. -This support is believed to be completed at version 3.4 -of @command{gcc} by Roger Sayle (@email{roger@@eyesopen.com}). - -@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 @command{g77} code generation to at least be as good -as @command{f2c} used in conjunction with @command{gcc}. -So far, this has resulted in the three, somewhat -experimental, options added by @command{g77} to the @command{gcc} -compiler and its back end. - -(These, in turn, had made their way into the @code{egcs} -version of the compiler, and do not exist in @command{gcc} -version 2.8 or versions of @command{g77} based on that version -of @command{gcc}.) - -@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 @command{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 - -@include funding.texi - -@node Funding GNU Fortran -@chapter Funding GNU Fortran -@cindex funding improvements -@cindex improvements, funding - -James Craig Burley (@email{@value{email-burley}}), the original author -of @command{g77}, stopped working on it in September 1999 -(He has a web page at @uref{@value{www-burley}}.) - -GNU Fortran is currently maintained by Toon Moene -(@email{toon@@moene.indiv.nluug.nl}), with the help of countless other -volunteers. - -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@@gnu.org} for information on funding the FSF. - -Another important way to support work on GNU Fortran is to volunteer -to help out. - -Email @email{@value{email-general}} to volunteer for this work. - -However, we strongly expect that there will never be a version 0.6 -of @command{g77}. Work on this compiler has stopped as of the release -of GCC 3.1, except for bug fixing. @command{g77} will be succeeded by -@command{g95} - see @uref{http://g95.sourceforge.net}. - -@xref{Funding,,Funding Free Software}, 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 @command{gcc}, -you should see @ref{G77 and GCC}. - -Everyone except experienced @command{g77} users should -see @ref{Invoking G77}. - -If you're acquainted with previous versions of @command{g77}, -you should see @ref{News,,News About GNU Fortran}. -Further, if you've actually used previous versions of @command{g77}, -especially if you've written or modified Fortran code to -be compiled by previous versions of @command{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 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 @command{g77}---see @ref{Bugs}, for information on -reporting them, after reading the other material. - -If you need further help with @command{g77}, or with -freely redistributable software in general, -see @ref{Service}. - -If you would like to help the @command{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 -@command{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 @command{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 @command{g77}, is designed initially as a free replacement -for, or alternative to, the UNIX @command{f77} command. -(Similarly, @command{gcc} is designed as a replacement -for the UNIX @command{cc} command.) - -@command{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, @command{g77}, @command{gcc}, and @command{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 @command{gdb}, command -@cindex commands, @command{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 @command{gdb}). - -@cindex libraries -@cindex linking -@cindex @command{ld} command -@cindex commands, @command{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 -@command{ld} command. -However, the @command{g77} and @command{gcc} -commands, as with most compiler commands, automatically -perform the linking step by calling on @command{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 @command{g77} -@cindex @command{g77}, components of -@command{g77} consists of several components: - -@cindex @command{gcc}, command -@cindex commands, @command{gcc} -@itemize @bullet -@item -A modified version of the @command{gcc} command, which also might be -installed as the system's @command{cc} command. -(In many cases, @command{cc} refers to the -system's ``native'' C compiler, which -might be a non-GNU compiler, or an older version -of @command{gcc} considered more stable or that is -used to build the operating system kernel.) - -@cindex @command{g77}, command -@cindex commands, @command{g77} -@item -The @command{g77} command itself, which also might be installed as the -system's @command{f77} command. - -@cindex libg2c library -@cindex libf2c library -@cindex libraries, libf2c -@cindex libraries, libg2c -@cindex run-time, library -@item -The @code{libg2c} 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 @command{g77} -compilation phase. - -@code{libg2c} is just the unique name @command{g77} gives -to its version of @code{libf2c} to distinguish it from -any copy of @code{libf2c} installed from @command{f2c} -(or versions of @command{g77} that built @code{libf2c} under -that same name) -on the system. - -The maintainer of @code{libf2c} currently is -@email{dmg@@bell-labs.com}. - -@cindex @code{f771}, program -@cindex programs, @code{f771} -@cindex assembler -@cindex @command{as} command -@cindex commands, @command{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 @command{as}. -@end itemize - -@command{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, @command{gcc} determines which actions to perform, including -preprocessing, compiling (in a variety of possible languages), assembling, -and linking. - -@cindex driver, gcc command as -@cindex @command{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 @command{cpp}, then -the C compiler (internally named -@code{cc1}), then the assembler (usually @command{as}), then the linker -(@command{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}, -@command{gcc} would use the C++ compiler (named @code{cc1plus}). - -@cindex @code{f771}, program -@cindex programs, @code{f771} -In a GNU Fortran installation, @command{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 @command{gcc}, not recognizing Fortran source -@cindex unrecognized file format -@cindex file format not recognized -Non-Fortran-related operation of @command{gcc} is generally -unaffected by installing the GNU Fortran version of @command{gcc}. -However, without the installed version of @command{gcc} being the -GNU Fortran version, @command{gcc} will not be able to compile -and link Fortran programs---and since @command{g77} uses @command{gcc} -to do most of the actual work, neither will @command{g77}! - -@cindex @command{g77}, command -@cindex commands, @command{g77} -The @command{g77} command is essentially just a front-end for -the @command{gcc} command. -Fortran users will normally use @command{g77} instead of @command{gcc}, -because @command{g77} -knows how to specify the libraries needed to link with Fortran programs -(@code{libg2c} and @code{lm}). -@command{g77} can still compile and link programs and -source files written in other languages, just like @command{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 @command{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 @command{gcc} -with which that version of @command{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 @command{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 @command{g77} when compiling Fortran code) into machine -code that, when run, calls on functions in @code{libg2c}, so -@code{libg2c} must be linked with almost every useful program -having any component compiled by GNU Fortran. -(As mentioned above, the @command{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{libg2c} component comes from -the @code{libf2c} component of @command{f2c}, -a free Fortran-to-C converter distributed by Bellcore (AT&T), -plus @code{libU77}, provided by Dave Love, -and the @command{g77} command is just a small front-end to @command{gcc}, -@code{f771} is a combination of two rather -large chunks of code. - -@cindex GNU Back End (GBE) -@cindex GBE -@cindex @command{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 @command{g77}, front end -@cindex front end, @command{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 @option{-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 @command{gcc}, command -@cindex commands, @command{gcc} -A GNU Fortran installation includes a modified version of the @command{gcc} -command. - -In a non-Fortran installation, @command{gcc} recognizes C, C++, -and Objective-C source files. - -In a GNU Fortran installation, @command{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,,Programming Languages Supported by GCC,gcc,Using -the GNU Compiler Collection (GCC)}, -for information on the way different languages are handled -by the GCC compiler (@command{gcc}). - -@cindex @command{g77}, command -@cindex commands, @command{g77} -Also provided as part of GNU Fortran is the @command{g77} command. -The @command{g77} command is designed to make compiling and linking Fortran -programs somewhat easier than when using the @command{gcc} command for -these tasks. -It does this by analyzing the command line somewhat and changing it -appropriately before submitting it to the @command{gcc} command. - -@cindex -v option -@cindex @command{g77} options, -v -@cindex options, -v -Use the @option{-v} option with @command{g77} -to see what is going on---the first line of output is the invocation -of the @command{gcc} command. - -@include invoke.texi - -@include news.texi - -@set USERVISONLY -@include news.texi -@clear USERVISONLY - -@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 -@uref{http://www.fortran.com/fortran/F77_std/rjcnf0001.html} -or as monolithic text at -@uref{http://www.fortran.com/fortran/F77_std/f77_std.html}. -It offers some extensions that are popular among users -of UNIX @command{f77} and @command{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 -@uref{http://www.fortran.com/F/books.html}. There is a `cooperative -net project', @cite{User Notes on Fortran Programming} at -@uref{ftp://vms.huji.ac.il/fortran/} and mirrors elsewhere; some of this -material might not apply specifically to @command{g77}.) - -Part of what defines a particular implementation of a Fortran -system, such as @command{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 @command{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:: -* I/O:: -* Fortran 90 Features:: -@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 @command{g77} itself is in beta test. -Some current features of the language might later -be redefined as dialects of Fortran supported by @command{g77} -when better ways to express these features are added to @command{g77}, -for example. -Such features would still be supported by -@command{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} (@command{g77}). - -For example, @command{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 @command{g77} accepts -when compiling using the prevailing defaults and what this -document describes as being part of the language. - -Future versions of @command{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 @command{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 @command{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 @command{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, heterogeneous 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 @command{g77} can use to resolve -conflicts between various camps of Fortran users. -If these two camps disagree about what a particular construct should -mean, @command{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 @command{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 @command{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 @command{g77}). - -@node Standard Support -@section ANSI FORTRAN 77 Standard Support -@cindex ANSI FORTRAN 77 support -@cindex standard, support for -@cindex support, 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 @command{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 - -@command{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 - -@command{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 @command{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 @command{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, @command{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, @command{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 @command{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 @command{g77}. - -@item -Bugs in the system. -@end itemize - -Despite these ``loopholes'', the availability of a clear specification -of the language of programs submitted to @command{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 @command{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.) - -@cindex limits, lengths of names -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 trailing comment -@cindex comment -@cindex characters, comment -@cindex ! -@cindex exclamation point -@cindex continuation character -@cindex characters, continuation -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 ; -@cindex semicolon -@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, @command{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:: -* Cpp-style directives:: -@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 -@cindex ; -@cindex semicolon -Semicolon (@samp{;}) - -@item -@cindex ! -@cindex exclamation point -Exclamation point (@samp{!}) - -@item -@cindex " -@cindex double quote -Double quote (@samp{"}) - -@item -@cindex \ -@cindex backslash -Backslash (@samp{\}) - -@item -@cindex ? -@cindex question mark -Question mark (@samp{?}) - -@item -@cindex # -@cindex hash mark -@cindex pound sign -Hash mark (@samp{#}) - -@item -@cindex & -@cindex ampersand -Ampersand (@samp{&}) - -@item -@cindex % -@cindex percent sign -Percent sign (@samp{%}) - -@item -@cindex _ -@cindex underscore -Underscore (@samp{_}) - -@item -@cindex < -@cindex open angle -@cindex left angle -@cindex open bracket -@cindex left bracket -Open angle (@samp{<}) - -@item -@cindex > -@cindex close angle -@cindex right angle -@cindex close bracket -@cindex right bracket -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 blank -@cindex space -@cindex SPC -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 format -@cindex file, 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 10 (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 blank -@cindex space -@cindex SPC -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 line, number of -@cindex lines, continuation -@cindex number of continuation lines -@cindex limits, 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 directive - -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. - -(@command{g77} treats it as a filename that it searches for -in the current directory and/or directories specified -via the @option{-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 Cpp-style directives -@subsection Cpp-style directives -@cindex # -@cindex preprocessor - -@code{cpp} output-style @code{#} directives -(@pxref{C Preprocessor Output,,, cpp, The C Preprocessor}) -are recognized by the compiler even -when the preprocessor isn't run on the input (as it is when compiling -@samp{.F} files). (Note the distinction between these @command{cpp} -@code{#} @emph{output} directives and @code{#line} @emph{input} -directives.) - -@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 -@command{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 @command{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 -@command{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. -@command{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 @command{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 @command{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 -@cindex pointers -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 @command{g77}---avoid writing code depending -on them while @command{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.) - -A prefix-radix constant, such as @samp{Z'ABCD'}, can optionally be -treated as typeless. @xref{Fortran Dialect Options,, Options -Controlling Fortran Dialect}, for information on the -@option{-ftypeless-boz} option. - -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.) - -@cindex double quoted character constants -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 @command{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, @command{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(%VAL(%LOC(I)))}, and -in fact might compile to identical code. - -However, @samp{CALL FOO(%VAL(%LOC(I)))} emphatically means -``pass, by value, the address of @samp{I} in memory''. -While @samp{CALL FOO(I)} might use that same approach in a -particular version of @command{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(%VAL(%LOC(I)))} -using the same version or compiler. - -@xref{Debugging and Interfacing}, for detailed information on -how this particular version of @command{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 @command{f2c}. - -This follows Fortran 90 with the restriction that on @code{NAMELIST} -input, subscripts must have the form -@smallexample -@var{subscript} [ @code{:} @var{subscript} [ @code{:} @var{stride}]] -@end smallexample -i.e.@: -@smallexample -&xx x(1:3,8:10:2)=1,2,3,4,5,6/ -@end smallexample -is allowed, but not, say, -@smallexample -&xx x(:3,8::2)=1,2,3,4,5,6/ -@end smallexample - -As an extension of the Fortran 90 form, @code{$} and @code{$END} may be -used in place of @code{&} and @code{/} in @code{NAMELIST} input, so that -@smallexample -$&xx x(1:3,8:10:2)=1,2,3,4,5,6 $end -@end smallexample -could be used instead of the example above. - -@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 DO -@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. -The Fortran 90 ``do forever'' statement comprising just @code{DO} is -also supported. - -@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 @command{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 - -@cindex CYCLE statement -@cindex EXIT statement -@cindex statements, CYCLE -@cindex statements, EXIT -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, @command{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 @command{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, @command{g77} passes -all arguments -(other than variables and arrays of type @code{CHARACTER}) -by reference. -Future versions of, or dialects supported by, @command{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 @command{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 @command{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, @command{g77} passes -all variables and arrays of type @code{CHARACTER} -by descriptor. -Future versions of, or dialects supported by, @command{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 @command{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 1999-02-15 (Burley) to delete my email address. -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 -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 @code{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 @code{JCB002} -above will confirm that: - -@itemize @bullet -@item -Digital Semiconductor (``DEC'') Alpha OSF/1, HP-UX 10.0.1, AIX 3.2.5 -@command{f77} compilers all implement @samp{Interp 1}. - -@item -IRIX 5.3 @command{f77} compiler implements @samp{Interp 2}. - -@item -Solaris 2.5, SunOS 4.1.3, DECstation ULTRIX 4.3, -and IRIX 6.1 @command{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 @code{Real} intrinsic -@cindex intrinsics, @code{Real} -@cindex @code{AImag} intrinsic -@cindex intrinsics, @code{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 @option{-ff90} is in effect, -@command{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 @code{Cmplx} intrinsic -@cindex intrinsics, @code{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 -@command{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 @command{f77}/@command{f2c} Intrinsics - -The bit-manipulation intrinsics supported by traditional -@command{f77} and by @command{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 an 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 @command{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 symbol names, scope and classes -@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 underscore - -Underscores (@samp{_}) are accepted in symbol names after the first -character (which must be a letter). - -@node I/O -@section I/O - -@cindex dollar sign -A dollar sign at the end of an output format specification suppresses -the newline at the end of the output. - -@cindex <> edit descriptor -@cindex edit descriptor, <> -Edit descriptors in @code{FORMAT} statements may contain compile-time -@code{INTEGER} constant expressions in angle brackets, such as -@smallexample -10 FORMAT (I) -@end smallexample - -The @code{OPEN} specifier @code{NAME=} is equivalent to @code{FILE=}. - -These Fortran 90 features are supported: -@itemize @bullet -@item -@cindex FORMAT descriptors -@cindex Z edit descriptor -@cindex edit descriptor, Z -@cindex O edit descriptor -@cindex edit descriptor, O -The @code{O} and @code{Z} edit descriptors are supported for I/O of -integers in octal and hexadecimal formats, respectively. -@item -The @code{FILE=} specifier may be omitted in an @code{OPEN} statement if -@code{STATUS='SCRATCH'} is supplied. The @code{STATUS='REPLACE'} -specifier is supported. -@end itemize - -@node Fortran 90 Features -@section Fortran 90 Features -@cindex Fortran 90 -@cindex extensions, from Fortran 90 - -For convenience this section collects a list (probably incomplete) of -the Fortran 90 features supported by the GNU Fortran language, even if -they are documented elsewhere. -@xref{Characters Lines Sequence,,@asis{Characters, Lines, and Execution Sequence}}, -for information on additional fixed source form lexical issues. -@cindex @option{-ffree-form} -Further, the free source form is supported through the -@option{-ffree-form} option. -@cindex @option{-ff90} -Other Fortran 90 features can be turned on by the @option{-ff90} option; -see @ref{Fortran 90}. -For information on the Fortran 90 intrinsics available, -see @ref{Table of Intrinsic Functions}. - -@table @asis -@item Automatic arrays in procedures -@item Character assignments -@cindex character assignments -In character assignments, the variable being assigned may occur on the -right hand side of the assignment. -@item Character strings -@cindex double quoted character constants -Strings may have zero length and substrings of character constants are -permitted. Character constants may be enclosed in double quotes -(@code{"}) as well as single quotes. @xref{Character Type}. -@item Construct names -(Symbolic tags on blocks.) @xref{Construct Names}. -@item @code{CYCLE} and @code{EXIT} -@xref{CYCLE and EXIT,,The @code{CYCLE} and @code{EXIT} Statements}. -@item @code{DOUBLE COMPLEX} -@xref{DOUBLE COMPLEX,,@code{DOUBLE COMPLEX} Statement}. -@item @code{DO WHILE} -@xref{DO WHILE}. -@item @code{END} decoration -@xref{Statements}. -@item @code{END DO} -@xref{END DO}. -@item @code{KIND} -@item @code{IMPLICIT NONE} -@item @code{INCLUDE} statements -@xref{INCLUDE}. -@item List-directed and namelist I/O on internal files -@item Binary, octal and hexadecimal constants -These are supported more generally than required by Fortran 90. -@xref{Integer Type}. -@item @samp{O} and @samp{Z} edit descriptors -@item @code{NAMELIST} -@xref{NAMELIST}. -@item @code{OPEN} specifiers -@code{STATUS='REPLACE'} is supported. -The @code{FILE=} specifier may be omitted in an @code{OPEN} statement if -@code{STATUS='SCRATCH'} is supplied. -@item @code{FORMAT} edit descriptors -@cindex FORMAT descriptors -@cindex Z edit descriptor -@cindex edit descriptor, Z -The @code{Z} edit descriptor is supported. -@item Relational operators -The operators @code{<}, @code{<=}, @code{==}, @code{/=}, @code{>} and -@code{>=} may be used instead of @code{.LT.}, @code{.LE.}, @code{.EQ.}, -@code{.NE.}, @code{.GT.} and @code{.GE.} respectively. -@item @code{SELECT CASE} -Not fully implemented. -@xref{SELECT CASE on CHARACTER Type,, @code{SELECT CASE} on @code{CHARACTER} Type}. -@item Specification statements -A limited subset of the Fortran 90 syntax and semantics for variable -declarations is supported, including @code{KIND}. @xref{Kind Notation}. -(@code{KIND} is of limited usefulness in the absence of the -@code{KIND}-related intrinsics, since these intrinsics permit writing -more widely portable code.) An example of supported @code{KIND} usage -is: -@smallexample -INTEGER (KIND=1) :: FOO=1, BAR=2 -CHARACTER (LEN=3) FOO -@end smallexample -@code{PARAMETER} and @code{DIMENSION} attributes aren't supported. -@end table - -@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 -@command{g77} supports in whole or in part. - -Any of the features listed below might be disallowed by -@command{g77} unless some command-line option is specified. -Currently, some of the features are accepted using the -default invocation of @command{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 format -@cindex file, 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 -(@command{f2c}, Digital (``DEC'') Fortran, and so on). - -This section describes how @command{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 @command{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 character -@cindex horizontal tab - -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 @command{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. - -@command{g77} effectively -translates tabs to the appropriate number of spaces (a la the default -for the UNIX @command{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. - -@node Short Lines -@subsection Short Lines -@cindex short source lines -@cindex space, padding with -@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). - -@command{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 @option{-ffixed-line-length-none}, for example. - -@node Long Lines -@subsection Long Lines -@cindex long source lines -@cindex truncation, of long lines -@cindex lines, long -@cindex source lines, long - -Source lines longer than the applicable length are truncated to that -length. -Currently, @command{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 @option{-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 @command{f2c}. - -@node Trailing Comment -@section Trailing Comment - -@cindex trailing comment -@cindex comment -@cindex characters, comment -@cindex /* -@cindex ! -@cindex exclamation point -@command{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 -@cindex comment line, debug - -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, @command{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 @option{-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: @command{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{libg2c}, -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 @minus -@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 @code{BN} and @code{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 @option{-fcase-strict-upper} to specify this -combination. - -Number 43 is like Number 22 except all input must be lowercase. Use -@option{-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 @option{-fcase-upper} to specify this combination. - -Number 66 is the ``canonical'' UNIX model whereby all the source is -translated to lowercase. -Use @option{-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 -@command{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 @command{g77} -someday, and is considered a VXT Fortran feature. - -The @option{-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 - -@command{g77} treats double-quote (@samp{"}) -as beginning an octal constant of @code{INTEGER(KIND=1)} type -when the @option{-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 @option{-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 ! -@cindex exclamation point -@cindex continuation character -@cindex characters, continuation -@cindex comment character -@cindex characters, comment - -@command{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 @option{-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 @option{-ff90} option is not specified. -The features enabled by @option{-ff90} are intended to be those that, -when @option{-ff90} is not specified, would have another -meaning to @command{g77}---usually meaning something invalid in the -GNU Fortran language. - -So, the purpose of @option{-ff90} is not to specify whether @command{g77} is -to gratuitously reject Fortran 90 constructs. -The @option{-pedantic} option specified with @option{-fno-f90} is intended -to do that, although its implementation is certainly incomplete at -this point. - -When @option{-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 @option{-ff90} is specified. -@end itemize - -@node Pedantic Compilation -@section Pedantic Compilation -@cindex pedantic compilation -@cindex compilation, pedantic - -The @option{-fpedantic} command-line option specifies that @command{g77} -is to warn about code that is not standard-conforming. -This is useful for finding -some extensions @command{g77} accepts that other compilers might not accept. -(Note that the @option{-pedantic} and @option{-pedantic-errors} options -always imply @option{-fpedantic}.) - -With @option{-fno-f90} in force, ANSI FORTRAN 77 is used as the standard -for conforming code. -With @option{-ff90} in force, Fortran 90 is used. - -The constructs for which @command{g77} issues diagnostics when @option{-fpedantic} -and @option{-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 @minus -@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 @option{-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 @option{-fpedantic} is specified along with @option{-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 @option{-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. - -@menu -* Ugly Implicit Argument Conversion:: Disabled via @option{-fno-ugly-args}. -* Ugly Assumed-Size Arrays:: Enabled via @option{-fugly-assumed}. -* Ugly Null Arguments:: Enabled via @option{-fugly-comma}. -* Ugly Complex Part Extraction:: Enabled via @option{-fugly-complex}. -* Ugly Conversion of Initializers:: Disabled via @option{-fno-ugly-init}. -* Ugly Integer Conversions:: Enabled via @option{-fugly-logint}. -* Ugly Assigned Labels:: Enabled via @option{-fugly-assign}. -@end menu - -@node Ugly Implicit Argument Conversion -@subsection Implicit Argument Conversion -@cindex Hollerith constants -@cindex constants, Hollerith - -The @option{-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 @option{-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, @option{-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 @option{-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 @option{-ff90} in effect, these intrinsics return -the unconverted real and imaginary parts (respectively) -of their argument. - -With @option{-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 @option{-fno-ugly-complex} is in effect, because the -meaning is clear. - -@command{g77} enforces this restriction, unless @option{-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 comma -@cindex comma, trailing -@cindex characters, comma -@cindex null arguments -@cindex arguments, null - -The @option{-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 an external procedure, -and use of an empty list of arguments to such a procedure -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 @option{-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 @option{-fugly-comma} -in force as compared to its behavior when compiled -with the default, @option{-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 @option{-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 -@option{-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 -@option{-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 -@option{-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 @option{-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 @option{-fugly-assign} option forces @command{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, @command{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-@code{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 @command{g77} unless @option{-fugly-assign} -is specified on the command-line, ensuring that the value of @code{I} -referenced in the second line is whatever value @command{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 @option{-fugly-assign} is specified, -@command{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 @command{g77} actually writing valid pointers -to these variables, however. -While @command{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, @command{g77}, supports programs written -in the GNU Fortran language and in some other dialects of Fortran. - -Some aspects of how @command{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:: -* Run-time Environment Limits:: -* Compiler Types:: -* Compiler Constants:: -* Compiler Intrinsics:: -@end menu - -@node Compiler Limits -@section Compiler Limits -@cindex limits, compiler -@cindex compiler limits - -@command{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 -@cindex limits, continuation lines -@cindex limits, lengths of names -For example, some other Fortran compiler have an option -(such as @option{-Nl@var{x}}) to increase the limit on the -number of continuation lines. -Also, some Fortran compilation systems have an option -(such as @option{-Nx@var{x}}) to increase the limit on the -number of external symbols. - -@command{g77}, @command{gcc}, and GNU @command{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 -@cindex limits, rank -@cindex limits, array dimensions -@command{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 be lifted in a future version. - -@node Run-time Environment Limits -@section Run-time Environment Limits -@cindex limits, run-time library -@cindex wraparound - -As a portable Fortran implementation, -@command{g77} offers its users direct access to, -and otherwise depends upon, -the underlying facilities of the system -used to build @command{g77}, -the system on which @command{g77} itself is used to compile programs, -and the system on which the @command{g77}-compiled program is actually run. -(For most users, the three systems are of the same -type---combination of operating environment and hardware---often -the same physical system.) - -The run-time environment for a particular system -inevitably imposes some limits on a program's use -of various system facilities. -These limits vary from system to system. - -Even when such limits might be well beyond the -possibility of being encountered on a particular system, -the @command{g77} run-time environment -has certain built-in limits, -usually, but not always, stemming from intrinsics -with inherently limited interfaces. - -Currently, the @command{g77} run-time environment -does not generally offer a less-limiting environment -by augmenting the underlying system's own environment. - -Therefore, code written in the GNU Fortran language, -while syntactically and semantically portable, -might nevertheless make non-portable assumptions -about the run-time environment---assumptions that -prove to be false for some particular environments. - -The GNU Fortran language, -the @command{g77} compiler and run-time environment, -and the @command{g77} documentation -do not yet offer comprehensive portable work-arounds for such limits, -though programmers should be able to -find their own in specific instances. - -Not all of the limitations are described in this document. -Some of the known limitations include: - -@menu -* Timer Wraparounds:: -* Year 2000 (Y2K) Problems:: -* Array Size:: -* Character-variable Length:: -* Year 10000 (Y10K) Problems:: -@end menu - -@node Timer Wraparounds -@subsection Timer Wraparounds - -Intrinsics that return values computed from system timers, -whether elapsed (wall-clock) timers, -process CPU timers, -or other kinds of timers, -are prone to experiencing wrap-around errors -(or returning wrapped-around values from successive calls) -due to insufficient ranges -offered by the underlying system's timers. - -@cindex negative time -@cindex short time -@cindex long time -Some of the symptoms of such behaviors include -apparently negative time being computed for a duration, -an extremely short amount of time being computed for a long duration, -and an extremely long amount of time being computed for a short duration. - -See the following for intrinsics -known to have potential problems in these areas -on at least some systems: -@ref{CPU_Time Intrinsic}, -@ref{DTime Intrinsic (function)}, @ref{DTime Intrinsic (subroutine)}, -@ref{ETime Intrinsic (function)}, @ref{ETime Intrinsic (subroutine)}, -@ref{MClock Intrinsic}, @ref{MClock8 Intrinsic}, -@ref{Secnds Intrinsic}, -@ref{Second Intrinsic (function)}, @ref{Second Intrinsic (subroutine)}, -@ref{System_Clock Intrinsic}, -@ref{Time Intrinsic (UNIX)}, @ref{Time Intrinsic (VXT)}, -@ref{Time8 Intrinsic}. - -@node Year 2000 (Y2K) Problems -@subsection Year 2000 (Y2K) Problems -@cindex Y2K compliance -@cindex Year 2000 compliance - -While the @command{g77} compiler itself is believed to -be Year-2000 (Y2K) compliant, -some intrinsics are not, -and, potentially, some underlying systems are not, -perhaps rendering some Y2K-compliant intrinsics -non-compliant when used on those particular systems. - -Fortran code that uses non-Y2K-compliant intrinsics -(listed below) -is, itself, almost certainly not compliant, -and should be modified to use Y2K-compliant intrinsics instead. - -Fortran code that uses no non-Y2K-compliant intrinsics, -but which currently is running on a non-Y2K-compliant system, -can be made more Y2K compliant by compiling and -linking it for use on a new Y2K-compliant system, -such as a new version of an old, non-Y2K-compliant, system. - -Currently, information on Y2K and related issues -is being maintained at -@uref{http://www.gnu.org/software/year2000-list.html}. - -See the following for intrinsics -known to have potential problems in these areas -on at least some systems: -@ref{Date Intrinsic}, -@ref{IDate Intrinsic (VXT)}. - -@cindex y2kbuggy -@cindex date_y2kbuggy_0 -@cindex vxtidate_y2kbuggy_0 -@cindex G77_date_y2kbuggy_0 -@cindex G77_vxtidate_y2kbuggy_0 -The @code{libg2c} library -shipped with any @command{g77} that warns -about invocation of a non-Y2K-compliant intrinsic -has renamed the @code{EXTERNAL} procedure names -of those intrinsics. -This is done so that -the @code{libg2c} implementations of these intrinsics -cannot be directly linked to -as @code{EXTERNAL} names -(which normally would avoid the non-Y2K-intrinsic warning). - -The renamed forms of the @code{EXTERNAL} names -of these renamed procedures -may be linked to -by appending the string @samp{_y2kbug} -to the name of the procedure -in the source code. -For example: - -@smallexample -CHARACTER*20 STR -INTEGER YY, MM, DD -EXTERNAL DATE_Y2KBUG, VXTIDATE_Y2KBUG -CALL DATE_Y2KBUG (STR) -CALL VXTIDATE_Y2KBUG (MM, DD, YY) -@end smallexample - -(Note that the @code{EXTERNAL} statement -is not actually required, -since the modified names are not recognized as intrinsics -by the current version of @command{g77}. -But it is shown in this specific case, -for purposes of illustration.) - -The renaming of @code{EXTERNAL} procedure names of these intrinsics -causes unresolved references at link time. -For example, @samp{EXTERNAL DATE; CALL DATE(STR)} -is normally compiled by @command{g77} -as, in C, @samp{date_(&str, 20);}. -This, in turn, links to the @code{date_} procedure -in the @code{libE77} portion of @code{libg2c}, -which purposely calls a nonexistent procedure -named @code{G77_date_y2kbuggy_0}. -The resulting link-time error is designed, via this name, -to encourage the programmer to look up the -index entries to this portion of the @command{g77} documentation. - -Generally, we recommend that the @code{EXTERNAL} method -of invoking procedures in @code{libg2c} -@emph{not} be used. -When used, some of the correctness checking -normally performed by @command{g77} -is skipped. - -In particular, it is probably better to use the -@code{INTRINSIC} method of invoking -non-Y2K-compliant procedures, -so anyone compiling the code -can quickly notice the potential Y2K problems -(via the warnings printing by @command{g77}) -without having to even look at the code itself. - -If there are problems linking @code{libg2c} -to code compiled by @command{g77} -that involve the string @samp{y2kbug}, -and these are not explained above, -that probably indicates -that a version of @code{libg2c} -older than @command{g77} -is being linked to, -or that the new library is being linked -to code compiled by an older version of @command{g77}. - -That's because, as of the version that warns about -non-Y2K-compliant intrinsic invocation, -@command{g77} references the @code{libg2c} implementations -of those intrinsics -using new names, containing the string @samp{y2kbug}. - -So, linking newly-compiled code -(invoking one of the intrinsics in question) -to an old library -might yield an unresolved reference -to @code{G77_date_y2kbug_0}. -(The old library calls it @code{G77_date_0}.) - -Similarly, linking previously-compiled code -to a new library -might yield an unresolved reference -to @code{G77_vxtidate_0}. -(The new library calls it @code{G77_vxtidate_y2kbug_0}.) - -The proper fix for the above problems -is to obtain the latest release of @command{g77} -and related products -(including @code{libg2c}) -and install them on all systems, -then recompile, relink, and install -(as appropriate) -all existing Fortran programs. - -(Normally, this sort of renaming is steadfastly avoided. -In this case, however, it seems more important to highlight -potential Y2K problems -than to ease the transition -of potentially non-Y2K-compliant code -to new versions of @command{g77} and @code{libg2c}.) - -@node Array Size -@subsection Array Size -@cindex limits, array size -@cindex array size - -Currently, @command{g77} uses the default @code{INTEGER} type -for array indexes, -which limits the sizes of single-dimension arrays -on systems offering a larger address space -than can be addressed by that type. -(That @command{g77} puts all arrays in memory -could be considered another limitation---it -could use large temporary files---but that decision -is left to the programmer as an implementation choice -by most Fortran implementations.) - -@c ??? Investigate this, to offer a more clear statement -@c than the following paragraphs do. -- burley 1999-02-17 -It is not yet clear whether this limitation -never, sometimes, or always applies to the -sizes of multiple-dimension arrays as a whole. - -For example, on a system with 64-bit addresses -and 32-bit default @code{INTEGER}, -an array with a size greater than can be addressed -by a 32-bit offset -can be declared using multiple dimensions. -Such an array is therefore larger -than a single-dimension array can be, -on the same system. - -@cindex limits, multi-dimension arrays -@cindex multi-dimension arrays -@cindex arrays, dimensioning -Whether large multiple-dimension arrays are reliably supported -depends mostly on the @command{gcc} back end (code generator) -used by @command{g77}, and has not yet been fully investigated. - -@node Character-variable Length -@subsection Character-variable Length -@cindex limits, on character-variable length -@cindex character-variable length - -Currently, @command{g77} uses the default @code{INTEGER} type -for the lengths of @code{CHARACTER} variables -and array elements. - -This means that, for example, -a system with a 64-bit address space -and a 32-bit default @code{INTEGER} type -does not, under @command{g77}, -support a @code{CHARACTER*@var{n}} declaration -where @var{n} is greater than 2147483647. - -@node Year 10000 (Y10K) Problems -@subsection Year 10000 (Y10K) Problems -@cindex Y10K compliance -@cindex Year 10000 compliance - -Most intrinsics returning, or computing values based on, -date information are prone to Year-10000 (Y10K) problems, -due to supporting only 4 digits for the year. - -See the following for examples: -@ref{FDate Intrinsic (function)}, @ref{FDate Intrinsic (subroutine)}, -@ref{IDate Intrinsic (UNIX)}, -@ref{Time Intrinsic (VXT)}, -@ref{Date_and_Time Intrinsic}. - -@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.) - -@command{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 @command{gcc} and @command{g77}. -@command{g77} warns about such -situations when it encounters them.) - -@command{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 -@command{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 @command{gcc} built in the same release as @command{g77} (and -which was therefore used to build both the @command{g77} compiler -components and the @code{libg2c} 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 @command{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 @command{gcc} type as @code{INTEGER(KIND=2)}. - -@cindex INTEGER(KIND=3) type -@cindex types, INTEGER(KIND=3) -@item INTEGER(KIND=3) -Same @command{gcc} type as signed @code{char}. - -@cindex LOGICAL(KIND=3) type -@cindex types, LOGICAL(KIND=3) -@item LOGICAL(KIND=3) -Same @command{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 @command{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 @command{gcc} type occupies @var{n} times the storage -space of a @command{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 @command{g77}---avoid writing code depending -on them. - -Other types supported by @command{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 @command{gcc} already supports, @command{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 - -@command{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. - -@command{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 @command{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 - -@command{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, @command{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 @command{g77} to pretend as though the intrinsics in -that group do not exist at all, whereas disabling it tells @command{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 -@cindex @code{badu77} intrinsics group -@item badu77 -UNIX intrinsics having inappropriate forms (usually functions that -have intended side effects). - -@cindex @code{gnu} intrinsics group -@item gnu -Intrinsics the GNU Fortran language supports that are extensions to -the Fortran standards (77 and 90). - -@cindex @command{f2c} intrinsics group -@item f2c -Intrinsics supported by AT&T's @command{f2c} converter and/or @code{libf2c}. - -@cindex @code{f90} intrinsics group -@item f90 -Fortran 90 intrinsics. - -@cindex @code{mil} intrinsics group -@item mil -MIL-STD 1753 intrinsics (@code{MVBITS}, @code{IAND}, @code{BTEST}, and so on). - -@cindex @code{mil} intrinsics group -@item unix -UNIX intrinsics (@code{IARGC}, @code{EXIT}, @code{ERF}, and so on). - -@cindex @code{mil} intrinsics group -@item vxt -VAX/VMS FORTRAN (current as of v4) intrinsics. -@end table - -@node Other Intrinsics -@subsection Other Intrinsics -@cindex intrinsics, others -@cindex other intrinsics - -@command{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, @command{g77} generates code that is -object-compatible with code generated by a version of -@command{f2c} configured (with, for example, @file{f2c.h} definitions) -to be generally compatible with @command{g77} as built by @command{gcc}. -(Normally, @command{f2c} will, by default, conform to the appropriate -configuration, but it is possible that older or perhaps even newer -versions of @command{f2c}, or versions having certain configuration changes -to @command{f2c} internals, will produce object files that are -incompatible with @command{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 -@command{g77} uses the same run-time library, -@code{libf2c}, used by @command{f2c}, -though @command{g77} gives its version the name @code{libg2c} -so as to avoid conflicts when linking, -installing them in the same directories, -and so on. - -Other compilers might or might not generate code that -is object-compatible with @code{libg2c} and current @command{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 @command{f2c} Compatibility - -Specifying @option{-fno-f2c} allows @command{g77} to generate, in -some cases, faster code, by not needing to allow to the possibility -of linking with code compiled by @command{f2c}. - -For example, this affects how @code{REAL(KIND=1)}, -@code{COMPLEX(KIND=1)}, and @code{COMPLEX(KIND=2)} functions are called. -With @option{-fno-f2c}, they are -compiled as returning the appropriate @command{gcc} type -(@code{float}, @code{__complex__ float}, @code{__complex__ double}, -in many configurations). - -With @option{-ff2c} in force, they -are compiled differently (with perhaps slower run-time performance) -to accommodate the restrictions inherent in @command{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 @option{-ff2c} in force -might produce faster code than using @option{-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 @command{f2c} compatibility is a fairly static target to achieve, -though not necessarily perfectly so, since, like @command{g77}, it is -still being improved. -However, specifying @option{-fno-f2c} causes @command{g77} -to generate code that will probably be incompatible with code -generated by future versions of @command{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 @command{g77} -or @command{f2c}, especially when using options such as @option{-fno-f2c}. - -Therefore, if you are using @command{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 @command{g77}, -you might want to stick with @command{f2c} compatibility for now, and -carefully watch for any announcements about changes to the -@command{f2c}/@code{libf2c} interface that might affect existing programs -(thus requiring recompilation). - -It is probable that a future version of @command{g77} will not, -by default, generate object files compatible with @command{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 @command{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. - -(The library @command{g77} produces will no longer be named @file{libg2c} -when it is no longer generally compatible with @file{libf2c}. -It will likely be referred to, and, if installed as a distinct -library, named @code{libg77}, or some other as-yet-unused name.) - -@node Compilers Other Than f2c -@section Compilers Other Than @command{f2c} - -On systems with Fortran compilers other than @command{f2c} and @command{g77}, -code compiled by @command{g77} is not expected to work -well with code compiled by the native compiler. -(This is true for @command{f2c}-compiled objects as well.) -Libraries compiled with the native compiler probably will have -to be recompiled with @command{g77} to be used with @command{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 @command{g77} to call a procedure the linker @command{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 @command{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 @command{g77} in @command{f2c} -compatibility mode, i.e.@: not using @option{-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 @command{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 -@option{-lstdc++}, @option{-lg++} or whatever. -If you need to use another -driver program (or @command{ld} directly), -you can find out what linkage -options @command{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, @command{f2c} from -@uref{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 @command{f2c}}. - -To use @command{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 -@command{f2c} program on your path. - -Something else that might be useful is @samp{cfortran.h} from -@uref{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 @command{f2c} mode with -@command{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 -@command{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 @code{int}s, for instance; instead, declare them as -@code{integer}, a type defined by @file{g2c.h}. -@file{g2c.h} is installed where @command{gcc} will find it by -default, assuming you use a copy of @command{gcc} compatible with -@command{g77}, probably built at the same time as @command{g77}. - -@node f2c Skeletons and Prototypes -@subsection Generating Skeletons and Prototypes with @command{f2c} - -@pindex f2c -@cindex -fno-second-underscore -A simple and foolproof way to write @command{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 @code{END} statements. -Then run @command{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 @command{f2c} conventions, -such as not using @code{doublereal} -as the return type of a @code{REAL} @code{FUNCTION}.) - -@pindex ftnchek -@command{f2c} also can help with calling Fortran from C, using its -@option{-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 @command{ftnchek} tool from @uref{ftp://ftp.netlib.org/fortran} -or @uref{ftp://ftp.dsm.fordham.edu} 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 @command{g77}) and -C handle arrays. - -@node C++ Considerations -@subsection C++ Considerations - -@cindex C++ -@command{f2c} can be used to generate suitable code for compilation with a -C++ system using the @option{-C++} option. -The important thing about linking @command{g77}-compiled -code with C++ is that the prototypes for the @command{g77} -routines must specify C linkage to avoid name mangling. -So, use an @samp{extern "C"} declaration. -@command{f2c}'s @option{-C++} option will not take care -of this when generating skeletons or prototype files as above, however, -it will avoid clashes with C++ reserved words in addition to those in C@. - -@node Startup Code -@subsection Startup Code - -@cindex startup code -@cindex run-time, initialization -@cindex initialization, run-time -Unlike with some runtime systems, -it shouldn't be necessary -(unless there are bugs) -to use a Fortran main program unit to ensure the -runtime---specifically the I/O system---is initialized. - -However, to use the @command{g77} intrinsics @code{GETARG} and @code{IARGC}, -either the @code{main} routine from the @file{libg2c} library must be used, -or the @code{f_setarg} routine -(new as of @code{egcs} version 1.1 and @command{g77} version 0.5.23) -must be called with the appropriate @code{argc} and @code{argv} arguments -prior to the program calling @code{GETARG} or @code{IARGC}. - -To provide more flexibility for mixed-language programming -involving @command{g77} while allowing for shared libraries, -as of @code{egcs} version 1.1 and @command{g77} version 0.5.23, -@command{g77}'s @code{main} routine in @code{libg2c} -does the following, in order: - -@enumerate -@item -Calls @code{f_setarg} -with the incoming @code{argc} and @code{argv} arguments, -in the same order as for @code{main} itself. - -This sets up the command-line environment -for @code{GETARG} and @code{IARGC}. - -@item -Calls @code{f_setsig} (with no arguments). - -This sets up the signaling and exception environment. - -@item -Calls @code{f_init} (with no arguments). - -This initializes the I/O environment, -though that should not be necessary, -as all I/O functions in @code{libf2c} -are believed to call @code{f_init} automatically, -if necessary. - -(A future version of @command{g77} might skip this explicit step, -to speed up normal exit of a program.) - -@item -Arranges for @code{f_exit} to be called (with no arguments) -when the program exits. - -This ensures that the I/O environment is properly shut down -before the program exits normally. -Otherwise, output buffers might not be fully flushed, -scratch files might not be deleted, and so on. - -The simple way @code{main} does this is -to call @code{f_exit} itself after calling -@code{MAIN__} (in the next step). - -However, this does not catch the cases where the program -might call @code{exit} directly, -instead of using the @code{EXIT} intrinsic -(implemented as @code{exit_} in @code{libf2c}). - -So, @code{main} attempts to use -the operating environment's @code{onexit} or @code{atexit} -facility, if available, -to cause @code{f_exit} to be called automatically -upon any invocation of @code{exit}. - -@item -Calls @code{MAIN__} (with no arguments). - -This starts executing the Fortran main program unit for -the application. -(Both @command{g77} and @command{f2c} currently compile a main -program unit so that its global name is @code{MAIN__}.) - -@item -If no @code{onexit} or @code{atexit} is provided by the system, -calls @code{f_exit}. - -@item -Calls @code{exit} with a zero argument, -to signal a successful program termination. - -@item -Returns a zero value to the caller, -to signal a successful program termination, -in case @code{exit} doesn't exit on the system. -@end enumerate - -All of the above names are C @code{extern} names, -i.e.@: not mangled. - -When using the @code{main} procedure provided by @command{g77} -without a Fortran main program unit, -you need to provide @code{MAIN__} -as the entry point for your C code. -(Make sure you link the object file that defines that -entry point with the rest of your program.) - -To provide your own @code{main} procedure -in place of @command{g77}'s, -make sure you specify the object file defining that procedure -@emph{before} @option{-lg2c} on the @command{g77} command line. -Since the @option{-lg2c} option is implicitly provided, -this is usually straightforward. -(Use the @option{--verbose} option to see how and where -@command{g77} implicitly adds @option{-lg2c} in a command line -that will link the program. -Feel free to specify @option{-lg2c} explicitly, -as appropriate.) - -However, when providing your own @code{main}, -make sure you perform the appropriate tasks in the -appropriate order. -For example, if your @code{main} does not call @code{f_setarg}, -make sure the rest of your application does not call -@code{GETARG} or @code{IARGC}. - -And, if your @code{main} fails to ensure that @code{f_exit} -is called upon program exit, -some files might end up incompletely written, -some scratch files might be left lying around, -and some existing files being written might be left -with old data not properly truncated at the end. - -Note that, generally, the @command{g77} operating environment -does not depend on a procedure named @code{MAIN__} actually -being called prior to any other @command{g77}-compiled code. -That is, @code{MAIN__} does not, itself, -set up any important operating-environment characteristics -upon which other code might depend. -This might change in future versions of @command{g77}, -with appropriate notification in the release notes. - -For more information, consult the source code for the above routines. -These are in @file{@value{path-libf2c}/libF77/}, named @file{main.c}, -@file{setarg.c}, @file{setsig.c}, @file{getarg_.c}, and @file{iargc_.c}. - -Also, the file @file{@value{path-g77}/com.c} contains the code @command{g77} -uses to open-code (inline) references to @code{IARGC}. - -@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 @command{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 @command{g77}-compiled code generally -requires some understanding of the way @command{g77} compiles code for -various constructs. - -Similarly, using a debugger to debug @command{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 -@command{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 @command{g77}, sometimes even to using certain compiler options -with @command{g77} (such as @option{-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 @command{g77}. -This information -is provided primarily to make debugging of code generated by this -particular release of @command{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 @command{g77} as they -are installed, because new versions can change the behaviors -described in this section. - -@menu -* Main Program Unit:: How @command{g77} compiles a main program unit. -* Procedures:: How @command{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 @command{g77} performs complex arithmetic. -* Arrays:: Dealing with (possibly multi-dimensional) arrays. -* Adjustable Arrays:: Special consideration for adjustable arrays. -* Alternate Entry Points:: How @command{g77} implements alternate @code{ENTRY}. -* Alternate Returns:: How @command{g77} handles alternate returns. -* Assigned Statement Labels:: How @command{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 @command{g77} compiles a main program unit, it gives it the public -procedure name @code{MAIN__}. -The @code{libg2c} 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 @code{MAIN__}. - -Generally, @command{g77} and @code{libg2c} 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 @command{g77} version 0.5.16 -includes a bug fix for @code{libg2c} 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 @command{g77} (or @command{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{libg2c}, found in the source -file @file{@value{path-libf2c}/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 @code{IArgC} intrinsic -@cindex intrinsics, @code{IArgC} -@cindex @code{GetArg} intrinsic -@cindex intrinsics, @code{GetArg} -For example, @code{libg2c}'s @code{main()} sets up the information used by -the @code{IARGC} and @code{GETARG} intrinsics. -Bypassing @code{libg2c}'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{libg2c} 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 @code{MAIN__}, and then run the program. -A convenient way to do so is to add the @command{gdb} command - -@example -tbreak MAIN__ -@end example - -@noindent -to the file @file{.gdbinit} in the directory in which you're debugging -(using @command{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 @code{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, @command{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 -@command{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{@value{path-libf2c}/g2c.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 @command{g77} -does not provide the trailing null bytes on the constant -strings (@command{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 - -@command{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}, @command{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 @option{-ff2c} is in -force, @command{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 @option{-fno-f2c} is in force, -@command{g77} implements a @code{COMPLEX} function as @command{gcc}'s -@samp{__complex__ float} or @samp{__complex__ double} function -(or an emulation thereof, when @option{-femulate-complex} is in effect), -returning the result of the function in the same way as @command{gcc} would. - -For @code{REAL(KIND=1)}, when @option{-ff2c} is in force, @command{g77} implements -a function that actually returns @code{REAL(KIND=2)} (typically -C's @code{double} type). -When @option{-fno-f2c} is in force, @code{REAL(KIND=1)} -functions return @code{float}. - -@node Names -@section Names -@cindex symbol names -@cindex transforming 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 @command{g77}, -to generate code that is compatible with @command{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 @option{-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 @option{-funderscoring} is in force, any name (external or local) -that already has at least one underscore in it is -implemented by @command{g77} by appending two underscores. -(This second underscore can be disabled via the -@option{-fno-second-underscore} option.) -External names are changed this way for @command{f2c} compatibility. -Local names are changed this way to avoid collisions with external names -that are different in the source code---@command{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 @command{g77} in this regard in the future---don't -write scripts depending on this behavior! -Also, consider experimenting with the @option{-fno-underscoring} -option to try out debugging without having to massage names by -hand like this.) - -@command{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 @command{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, @command{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 @option{-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 @code{COMMON} statement -@cindex statements, @code{COMMON} - -@command{g77} names and lays out @code{COMMON} areas -the same way @command{f2c} does, -for compatibility with @command{f2c}. - -@node Local Equivalence Areas -@section Local Equivalence Areas (EQUIVALENCE) -@cindex equivalence areas -@cindex local equivalence areas -@cindex EQUIVALENCE statement -@cindex statements, EQUIVALENCE - -@command{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. - -(@emph{Note:} @command{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}, @command{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 -@cindex COMPLEX statement -@cindex statements, COMPLEX - -As of 0.5.20, @command{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, @command{g77} implements these types using an -internal construct similar to C's @code{struct}, at least -as seen by the @command{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 -@command{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 @command{gdb}, this is accomplished via @samp{set lang c} and -either @samp{set lang fortran} or @samp{set lang auto}.) - -@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 @command{f2c}, @command{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 -nonzero 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 @command{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, @command{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 @command{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 @command{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 @command{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. -@command{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 @command{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 @command{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. - -@command{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, @command{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 @command{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 @option{-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 @command{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 @command{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 @command{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 @command{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)}, @command{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 @command{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; @command{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. -@command{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 @command{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 @command{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 @command{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{libg2c} 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 @code{F_err} in @file{f/runtime/libI77/err.c} in the -@command{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 @command{g77} can be divided into two camps: - -@itemize @bullet -@item -Those writing new Fortran code to be compiled by @command{g77}. - -@item -Those using @command{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 @command{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 @command{f2c} is so great, why @command{g77}? -* Block Data and Libraries:: How @command{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 @command{f2c}, @command{g77} would have taken much longer to -do and probably not been as good for quite a while. -Sometimes people who notice how much @command{g77} depends on, and -documents encouragement to use, @command{f2c} ask why @command{g77} -was created if @command{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. -* Diagnostic Abilities:: Abilities to spot problems early. -* Compiler Options:: Features helpful to accommodate legacy code, etc. -* 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 - -@command{g77} offers several extensions to FORTRAN 77 language that @command{f2c} -doesn't: - -@itemize @bullet -@item -Automatic arrays - -@item -@code{CYCLE} and @code{EXIT} - -@item -Construct names - -@item -@code{SELECT CASE} - -@item -@code{KIND=} and @code{LEN=} notation - -@item -Semicolon as statement separator - -@item -Constant expressions in @code{FORMAT} statements -(such as @samp{FORMAT(I)}, -where @samp{J} is a @code{PARAMETER} named constant) - -@item -@code{MvBits} intrinsic - -@item -@code{libU77} (Unix-compatibility) library, -with routines known to compiler as intrinsics -(so they work even when compiler options are used -to change the interfaces used by Fortran routines) -@end itemize - -@command{g77} also implements iterative @code{DO} loops -so that they work even in the presence of certain ``extreme'' inputs, -unlike @command{f2c}. -@xref{Loops}. - -However, @command{f2c} offers a few that @command{g77} doesn't, such as: - -@itemize @bullet -@item -Intrinsics in @code{PARAMETER} statements - -@item -Array bounds expressions (such as @samp{REAL M(N(2))}) - -@item -@code{AUTOMATIC} statement -@end itemize - -It is expected that @command{g77} will offer some or all of these missing -features at some time in the future. - -@node Diagnostic Abilities -@subsection Diagnostic Abilities - -@command{g77} offers better diagnosis of problems in @code{FORMAT} statements. -@command{f2c} doesn't, for example, emit any diagnostic for -@samp{FORMAT(XZFAJG10324)}, -leaving that to be diagnosed, at run time, by -the @code{libf2c} run-time library. - -@node Compiler Options -@subsection Compiler Options - -@command{g77} offers compiler options that @command{f2c} doesn't, -most of which are designed to more easily accommodate -legacy code: - -@itemize @bullet -@item -Two that control the automatic appending of extra -underscores to external names - -@item -One that allows dollar signs (@samp{$}) in symbol names - -@item -A variety that control acceptance of various -``ugly'' constructs - -@item -Several that specify acceptable use of upper and lower case -in the source code - -@item -Many that enable, disable, delete, or hide -groups of intrinsics - -@item -One to specify the length of fixed-form source lines -(normally 72) - -@item -One to specify the the source code is written in -Fortran-90-style free-form -@end itemize - -However, @command{f2c} offers a few that @command{g77} doesn't, -like an option to have @code{REAL} default to @code{REAL*8}. -It is expected that @command{g77} will offer all of the -missing options pertinent to being a Fortran compiler -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 @command{g77} should be able to compile code much faster than using -@command{f2c} in conjunction with the equivalent invocation of @command{gcc}. - -However, due to @command{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, @command{g77} -is noticeably faster compiling many Fortran source files than using -@command{f2c} in conjunction with @command{gcc}. - -@node Program Speed -@subsection Program Speed - -@command{g77} has the potential to better optimize code than @command{f2c}, -even when @command{gcc} is used to compile the output of @command{f2c}, -because @command{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 @command{g77} can gather, preserve, and transmit that information directly -to the GBE. - -For example, @command{g77} implements @code{ASSIGN} and assigned -@code{GOTO} using direct assignment of pointers to labels and direct -jumps to labels, whereas @command{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 @command{f2c} plus @command{gcc} -can generate code that is faster than @command{g77}. - -Version 0.5.18 of @command{g77} offered default -settings and options, via patches to the @command{gcc} -back end, that allow for better program speed, though -some of these improvements also affected the performance -of programs translated by @command{f2c} and then compiled -by @command{g77}'s version of @command{gcc}. - -Version 0.5.20 of @command{g77} offers further performance -improvements, at least one of which (alias analysis) is -not generally applicable to @command{f2c} (though @command{f2c} -could presumably be changed to also take advantage of -this new capability of the @command{gcc} back end, assuming -this is made available in an upcoming release of @command{gcc}). - -@node Ease of Debugging -@subsection Ease of Debugging - -Because @command{g77} compiles directly to assembler code like @command{gcc}, -instead of translating to an intermediate language (C) as does @command{f2c}, -support for debugging can be better for @command{g77} than @command{f2c}. - -However, although @command{g77} might be somewhat more ``native'' in terms of -debugging support than @command{f2c} plus @command{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, @command{g77} doesn't have to worry about reserved names -like @command{f2c} does. -Given @samp{FOR = WHILE}, @command{f2c} must necessarily -translate this to something @emph{other} than -@samp{for = while;}, because C reserves those words. - -However, @command{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 @command{g77} user should be able to access the variables directly, by name, -without having to traverse C-like structures and unions, while @command{f2c} -is unlikely to ever offer this ability (due to limitations in the -C language). - -Yet another example is arrays. -@command{g77} represents them to the debugger -using the same ``dimensionality'' as in the source code, while @command{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 @command{g77} can vary widely. -In some cases, it can actually -be an advantage that @command{f2c} converts everything to widely supported -C semantics. - -In fairness, @command{g77} could do many of the things @command{f2c} does -to get things working at least as well as @command{f2c}---for now, -the developers prefer making @command{g77} work the -way they think it is supposed to, and finding help improving the -other products (the back end of @command{gcc}; @command{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, -@command{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. - -@command{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 @command{g77} simply asks for fewer zeros from the operating -system than @command{f2c}. -(Avoiding spurious use of zero bytes, each byte typically have -eight zero bits, also reduces the liabilities in case -Microsoft's rumored patent on the digits 0 and 1 is upheld.) - -@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 f2c compatibility -@cindex compatibility, 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}. -@command{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, @command{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, @command{g77} outputs in the data section a static pointer to the -external name @samp{FOO}.) - -The implementation @command{g77} currently uses to make this work is -one of the few things not compatible with @command{f2c} as currently -shipped. -@command{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}, -@command{f2c} doesn't generate a dummy procedure with the name @samp{FOO}. -The upshot is that you shouldn't mix @command{f2c} and @command{g77} in -this particular case. -If you use @command{f2c} to compile @samp{BLOCK DATA FOO}, -then any @command{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 @command{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 @command{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 iterative @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 @command{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 @command{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 @command{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 @command{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, @command{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 @command{g77}, use of @code{DO} loops -with @code{REAL} iteration -variables is not recommended. -Such use can be caught by specifying @option{-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. - -@command{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:: -* Floating-point precision:: -* Inconsistent Calling Sequences:: -@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 @option{-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. -(@command{g77} supports @code{IMPLICIT NONE}, as do almost all -FORTRAN 77 compilers.) - -Note that @option{-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 @command{g77} for this behavior by specifying the -@option{-finit-local-zero} option when compiling Fortran code. -(You might want to specify @option{-fno-automatic} as well, -to avoid code-size inflation for non-optimized compilations.) - -Note that a program that works better when compiled with the -@option{-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 @option{-O -Wuninitialized} -options using @command{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 @command{g77} to assume @code{SAVE} is specified for all -relevant (local) variables and arrays by using the -@option{-fno-automatic} option. - -Note that a program that works better when compiled with the -@option{-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 @command{g77}. - -@node Unwanted Variables -@subsection Unwanted Variables - -The @option{-Wunused} option can find bugs involving -implicit typing, sometimes -more easily than using @option{-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 @option{-W} also enables warnings regarding overflow -of floating-point constants under certain circumstances. - -@node Surprising Interpretations of Code -@subsection Surprising Interpretations of Code - -The @option{-Wsurprising} 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 @command{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 @command{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 @option{-falias-check}, @option{-fargument-alias}, -@option{-fargument-noalias}, -and @option{-fno-argument-noalias-global} options, -introduced in version 0.5.20 and -@command{g77}'s version 2.7.2.2.f.2 of @command{gcc}, -were withdrawn as of @command{g77} version 0.5.23 -due to their not being supported by @command{gcc} version 2.8. - -These options control the assumptions regarding aliasing -(overlapping) of writes and reads to main memory (core) made -by the @command{gcc} back end. - -The information below still is useful, but applies to -only those versions of @command{g77} that support the -alias analysis implied by support for these options. - -These options are effective only when compiling with @option{-O} -(specifying any level other than @option{-O0}) -or with @option{-falias-check}. - -The default for Fortran code is @option{-fargument-noalias-global}. -(The default for C code and code written in other C-based languages -is @option{-fargument-alias}. -These defaults apply regardless of whether you use @command{g77} or -@command{gcc} to compile your code.) - -Note that, on some systems, compiling with @option{-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 -association'', appears in Sections 15.9.3.6. -This prohibition allows implementations, such as @command{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 @option{-fargument-alias} option, which causes the -compiler to revert to assumptions essentially the same as -made by versions of @command{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 @command{g77} -in a way that results in a faster executable. - -(You might want to try compiling with @option{-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, @command{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 @command{g77}, though patches improving @command{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, @command{g77} configured its -version of the @code{libf2c} run-time library so that one of -its configuration macros, @code{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, @command{g77} no longer configures @code{libf2c} -(now named @code{libg2c} in its @command{g77} incarnation) -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{libg2c}, rebuild and reinstall @command{g77}, and -relink your programs with the modified library. - -(Ideally, @code{libg2c} would offer the choice at run-time, so -that a compile-time option to @command{g77} or @command{f2c} could -result in generating the appropriate calls to flushing or -non-flushing library routines.) - -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{libg2c} supports flagging write errors immediately when -it is built with the @code{ALWAYS_FLUSH} macro defined. -This results in a @code{libg2c} 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 @command{g77} you are building, you might wish to -modify the @command{g77} source tree so that the version of -@code{libg2c} is built with the @code{ALWAYS_FLUSH} macro -defined, enabling this behavior. - -To do this, find this line in @file{@value{path-libf2c}/f2c.h} in -your @command{g77} source tree: - -@example -/* #define ALWAYS_FLUSH */ -@end example - -Remove the leading @samp{/*@w{ }}, -so the line begins with @samp{#define}, -and the trailing @samp{@w{ }*/}. - -Then build or rebuild @command{g77} as appropriate. - -@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{libg2c}. - -The message means that your program has attempted to use a -file unit number that is out of the range accepted by -@code{libg2c}. -Normally, this range is 0 through 99, and the high end -of the range is controlled by a @code{libg2c} source-file -macro named @code{MXUNIT}. - -If you can easily change your program to use unit numbers -in the range 0 through 99, you should do so. - -As distributed, whether as part of @command{f2c} or @command{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 @code{MXUNIT} macro, which represents the maximum unit -number, to an appropriately higher value. - -To do this, edit the file @file{@value{path-libf2c}/libI77/fio.h} in your -@command{g77} source tree, changing the following line: - -@example -#define MXUNIT 100 -@end example - -Change the line so that the value of @code{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 -@code{MXUNIT} set to at least 256 to avoid crashing.) - -Then build or rebuild @command{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 Floating-point precision -@subsection Floating-point precision - -@cindex IEEE 754 conformance -@cindex conformance, IEEE 754 -@cindex floating-point, precision -@cindex ix86 floating-point -@cindex x86 floating-point -If your program depends on exact IEEE 754 floating-point handling it may -help on some systems---specifically x86 or m68k hardware---to use -the @option{-ffloat-store} option or to reset the precision flag on the -floating-point unit. -@xref{Optimize Options}. - -However, it might be better simply to put the FPU into double precision -mode and not take the performance hit of @option{-ffloat-store}. On x86 -and m68k GNU systems you can do this with a technique similar to that -for turning on floating-point exceptions -(@pxref{Floating-point Exception Handling}). -The control word could be set to double precision by some code like this -one: -@smallexample -#include -@{ - fpu_control_t cw = (_FPU_DEFAULT & ~_FPU_EXTENDED) | _FPU_DOUBLE; - _FPU_SETCW(cw); -@} -@end smallexample -(It is not clear whether this has any effect on the operation of the GNU -maths library, but we have no evidence of it causing trouble.) - -Some targets (such as the Alpha) may need special options for full IEEE -conformance. -@xref{Submodel Options,,Hardware Models and Configurations,gcc,Using -the GNU Compiler Collection (GCC)}. - -@node Inconsistent Calling Sequences -@subsection Inconsistent Calling Sequences - -@pindex ftnchek -@cindex floating-point, errors -@cindex ix86 FPU stack -@cindex x86 FPU stack -Code containing inconsistent calling sequences in the same file is -normally rejected---see @ref{GLOBALS}. -(Use, say, @command{ftnchek} to ensure -consistency across source files. -@xref{f2c Skeletons and Prototypes,, -Generating Skeletons and Prototypes with @command{f2c}}.) - -Mysterious errors, which may appear to be code generation problems, can -appear specifically on the x86 architecture with some such -inconsistencies. On x86 hardware, floating-point return values of -functions are placed on the floating-point unit's register stack, not -the normal stack. Thus calling a @code{REAL} or @code{DOUBLE PRECISION} -@code{FUNCTION} as some other sort of procedure, or vice versa, -scrambles the floating-point stack. This may break unrelated code -executed later. Similarly if, say, external C routines are written -incorrectly. - -@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 -@option{-finit-local-zero} is not needed. - -Consider using @option{-Wuninitialized} (which requires @option{-O}) to -find likely candidates, but -do not specify @option{-finit-local-zero} or @option{-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 @option{-Wuninitialized} (which requires @option{-O}) -to find likely candidates, but -do not specify @option{-finit-local-zero} or @option{-fno-automatic}, -or this technique won't work. - -The default is @option{-fautomatic}, which tells @command{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, @command{g77} supports only automatic arrays, not -@code{RECURSIVE} procedures or other means of explicitly -specifying that variables or arrays are automatic. - -@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 @option{-f@var{group}-intrinsics-disable}. -@end table - -@node Faster Programs -@section Faster Programs -@cindex speed, of programs -@cindex programs, speeding up - -Aside from the usual @command{gcc} options, such as @option{-O}, -@option{-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 alignment -@cindex data, aligned -@cindex stack, aligned -@cindex aligned data -@cindex aligned stack -@cindex Pentium optimizations -@cindex optimization, for 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. -(Such behavior isn't unique to the Intel x86 architecture.) -Other architectures might @emph{demand} 64-bit alignment -of 64-bit data. - -There are a variety of approaches to use to address this problem: - -@itemize @bullet -@item -@cindex @code{COMMON} layout -@cindex layout of @code{COMMON} blocks -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. - -If you don't ensure correct alignment of @code{COMMON} elements, the -compiler may be forced by some systems to violate the Fortran semantics by -adding padding to get @code{DOUBLE PRECISION} data properly aligned. -If the unfortunate practice is employed of overlaying different types of -data in the @code{COMMON} block, the different variants -of this block may become misaligned with respect to each other. -Even if your platform doesn't require strict alignment, -@code{COMMON} should be laid out as above for portability. -(Unfortunately the FORTRAN 77 standard didn't anticipate this -possible requirement, which is compiler-independent on a given platform.) - -@item -@cindex -malign-double option -@cindex options, -malign-double -Use the (x86-specific) @option{-malign-double} option when compiling -programs for the Pentium and Pentium Pro architectures (called 586 -and 686 in the @command{gcc} configuration subsystem). -The warning about this in the @command{gcc} manual isn't -generally relevant to Fortran, -but using it will force @code{COMMON} to be padded if necessary to align -@code{DOUBLE PRECISION} data. - -When @code{DOUBLE PRECISION} data is forcibly aligned -in @code{COMMON} by @command{g77} due to specifying @option{-malign-double}, -@command{g77} issues a warning about the need to -insert padding. - -In this case, each and every program unit that uses -the same @code{COMMON} area -must specify the same layout of variables and their types -for that area -and be compiled with @option{-malign-double} as well. -@command{g77} will issue warnings in each case, -but as long as every program unit using that area -is compiled with the same warnings, -the resulting object files should work when linked together -unless the program makes additional assumptions about -@code{COMMON} area layouts that are outside the scope -of the FORTRAN 77 standard, -or uses @code{EQUIVALENCE} or different layouts -in ways that assume no padding is ever inserted by the compiler. - -@item -Ensure that @file{crt0.o} or @file{crt1.o} -on your system guarantees a 64-bit -aligned stack for @code{main()}. -The recent one from GNU (@code{glibc2}) will do this on x86 systems, -but we don't know of any other x86 setups where it will be right. -Read your system's documentation to determine if -it is appropriate to upgrade to a more recent version -to obtain the optimal alignment. -@end itemize - -Progress is being made on making this work -``out of the box'' on future versions of @command{g77}, -@command{gcc}, and some of the relevant operating systems -(such as GNU/Linux). - -@node Prefer Automatic Uninitialized Variables -@subsection Prefer Automatic Uninitialized Variables - -If you're using @option{-fno-automatic} already, you probably -should change your code to allow compilation with @option{-fautomatic} -(the default), to allow the program to run faster. - -Similarly, you should be able to use @option{-fno-init-local-zero} -(the default) instead of @option{-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, @option{-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, @option{-fno-init-local-zero} forces such -variables to be initialized to zero---when @code{SAVE}d (such as when -@option{-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 @option{-fno-automatic} and -@option{-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 @command{f2c} compatibility -@cindex compatibility, @command{f2c} - -If you aren't linking with any code compiled using -@command{f2c}, try using the @option{-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 @command{f2c}---it is compiled by a C -compiler, typically @command{gcc}.) - -@node Use Submodel Options -@subsection Use Submodel Options -@cindex submodels - -Using an appropriate @option{-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 the -GNU Compiler Collection (GCC)}. For instance on an x86 system the -compiler might have -been built---as shown by @samp{g77 -v}---for the target -@samp{i386-pc-linux-gnu}, i.e.@: an @samp{i386} CPU@. In that case to -generate code best optimized for a Pentium you could use the option -@option{-march=pentium}. - -For recent CPUs that don't have explicit support in the released version -of @command{gcc}, it @emph{might} still be possible to get improvements -with certain @option{-m} options. - -@option{-fomit-frame-pointer} can help performance on x86 systems and -others. It will, however, inhibit debugging on the systems on which it -is not turned on anyway by @option{-O}. - -@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. - -(Note that some of this portion of the manual is lifted -directly from the @command{gcc} manual, with minor modifications -to tailor it to users of @command{g77}. -Anytime a bug seems to have more to do with the @command{gcc} -portion of @command{g77}, see -@ref{Trouble,,Known Causes of Trouble with GCC, -gcc,Using the GNU Compiler Collection (GCC)}.) - -@menu -* But-bugs:: Bugs really in other programs or elsewhere. -* Known Bugs:: Bugs known to be in this version of @command{g77}. -* 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 @command{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 @command{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 @command{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 @command{g77} maintainers have their hands full working on -just fixing and improving @command{g77}, without serving as a -clearinghouse for all bugs that happen to affect @command{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 @command{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 @uref{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 @command{ld}, error linking user code -@cindex @command{ld}, can't find strange names -On some systems, perhaps just those with out-of-date (shared?) -libraries, unresolved-reference errors happen when linking @command{g77}-compiled -programs (which should be done using @command{g77}). - -If this happens to you, try appending @option{-lc} to the command you -use to link the program, e.g. @samp{g77 foo.f -lc}. -@command{g77} already specifies @samp{-lg2c -lm} when it calls the linker, -but it cannot also specify @option{-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{-lg2c -lm} is insufficient to resolve code produced -by @command{g77}. - -@cindex undefined reference (_main) -@cindex linking error, user code -@cindex @command{ld}, error linking user code -@cindex code, user -@cindex @command{ld}, can't find @samp{_main} -If your program doesn't link due to unresolved references to names -like @samp{_main}, make sure you're using the @command{g77} command to do the -link, since this command ensures that the necessary libraries are -loaded by specifying @samp{-lg2c -lm} when it invokes the @command{gcc} -command to do the actual link. -(Use the @option{-v} option to discover -more about what actually happens when you use the @command{g77} and @command{gcc} -commands.) - -Also, try specifying @option{-lc} as the last item on the @command{g77} -command line, in case that helps. - -@node Large Common Blocks -@subsection Large Common Blocks -@cindex common blocks, large -@cindex large common blocks -@cindex linking, errors -@cindex @command{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 @command{ld}, fixed in -more recent versions of @code{binutils}, such as version 2.6. - -@node Debugger Problems -@subsection Debugger Problems -@cindex @command{gdb}, support -@cindex support, @command{gdb} -There are some known problems when using @command{gdb} on code -compiled by @command{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. -Attempts to access assumed-size arrays are -also known to crash recent versions of @command{gdb}. -(@command{gdb}'s Fortran support was done for a different compiler -and isn't properly compatible with @command{g77}.) - -@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 @command{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{@value{path-g77}/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 -@command{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 @command{csh} and derivatives) or -@kbd{ulimit -s} (in @command{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 -@option{-fno-automatic} option to reduce stack usage, probably at the -expense of speed. - -@command{g77}, on most machines, puts many variables and arrays on the stack -where possible, and can be configured (by changing -@code{FFECOM_sizeMAXSTACKITEM} in @file{@value{path-g77}/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 @code{FFECOM_sizeMAXSTACKITEM} has no -effect on automatic variables and arrays. -@xref{But-bugs}, for more information. -@emph{Note:} While @code{libg2c} 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. - -@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 @option{-fno-automatic}, -nor changing the cut-off point for @command{g77} for using the stack, -will solve the problem by changing the placement of these -large arrays, as they are @emph{necessarily} automatic. - -@command{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 -@cindex @command{test} programs -@cindex programs, @command{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 @command{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 @command{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 -@command{man}, @command{info} (on GNU systems), @command{setenv} (or -@command{set} and @command{env}), @command{which}, and @command{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 -@command{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. -(Compile your code with the @option{-fbounds-check} option -to catch many of these kinds of errors at program run time.) - -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). - -@command{g77} now offers 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 most arrays (except assumed-size arrays), -and checking for agreement between calling and called procedures. -Future improvements are likely to be made in the procedure-mismatch area, -at least. - -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 space, 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 behavior. -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 @command{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 @command{g77}, -use binary arithmetic to represent these approximations. - -Therefore, the exact value of any floating-point approximation -as manipulated by @command{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 denominator 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 @command{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{libg2c} library, -used by @command{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 @emph{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 @command{g77} and/or @code{libg2c} 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. - -A useful source of information on floating-point computation is David -Goldberg, `What Every Computer Scientist Should Know About -Floating-Point Arithmetic', Computing Surveys, 23, March 1991, pp.@: -5-48. -An online version is available at -@uref{http://docs.sun.com/}. - -Information related to the IEEE 754 floating-point standard can be found -at @uref{http://grouper.ieee.org/groups/754/} and -@uref{http://http.cs.berkeley.edu/%7Ewkahan/ieee754status/}; -see also slides from the short course referenced from -@uref{http://http.cs.berkeley.edu/%7Efateman/}. - -The supplement to the PostScript-formatted Goldberg document, -referenced above, is available in HTML format. -See `Differences Among IEEE 754 Implementations' by Doug Priest. -This document explores some of the issues surrounding computing -of extended (80-bit) results on processors such as the x86, -especially when those results are arbitrarily truncated -to 32-bit or 64-bit values by the compiler -as ``spills''. - -@cindex spills of floating-point results -@cindex 80-bit spills -@cindex truncation, of floating-point values -(@emph{Note:} @command{g77} specifically, and @command{gcc} generally, -does arbitrarily truncate 80-bit results during spills -as of this writing. -It is not yet clear whether a future version of -the GNU compiler suite will offer 80-bit spills -as an option, or perhaps even as the default behavior.) - -@c xref would be different between editions: -The GNU C library provides routines for controlling the FPU, and other -documentation about this. - -@xref{Floating-point precision}, regarding IEEE 754 conformance. - -@include bugs.texi - -@node Missing Features -@section Missing Features - -This section lists features we know are missing from @command{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:: -* Arbitrary Concatenation:: -* 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:: -* READONLY Keyword:: -* 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:: -* AUTOMATIC Statement:: -* Suppressing Space Padding:: -* Fortran Preprocessor:: -* Bit Operations on Floating-point Data:: -* Really Ugly Character Assignments:: - -New facilities: -* POSIX Standard:: -* Floating-point Exception Handling:: -* Nonportable Conversions:: -* Large Automatic Arrays:: -* Support for Threads:: -* Increasing Precision/Range:: -* Enabling Debug Lines:: - -Better diagnostics: -* Better Warnings:: -* 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:: -* Portable Unformatted Files:: -* Better List-directed I/O:: -* Default to Console I/O:: - -Debugging: -* Labels Visible to Debugger:: -@end menu - -@node Better Source Model -@subsection Better Source Model - -@command{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, @command{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, @command{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 @option{-Wno-col73to80} option. - -@node Fortran 90 Support -@subsection Fortran 90 Support -@cindex Fortran 90, support -@cindex support, Fortran 90 - -@command{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 @command{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 @command{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 - -@command{g77} doesn't allow intrinsics in @code{PARAMETER} statements. - -Related to this, @command{g77} doesn't allow non-integral -exponentiation in @code{PARAMETER} statements, such as -@samp{PARAMETER (R=2**.25)}. -It is unlikely @command{g77} will ever support this feature, -as doing it properly requires complete emulation of -a target computer's floating-point facilities when -building @command{g77} as a cross-compiler. -But, if the @command{gcc} back end is enhanced to provide -such a facility, @command{g77} will likely use that facility -in implementing this feature soon afterwards. - -@node Arbitrary Concatenation -@subsection Arbitrary Concatenation -@cindex concatenation -@cindex CHARACTER*(*) -@cindex run-time, dynamic allocation - -@command{g77} doesn't support arbitrary operands for concatenation -in contexts where run-time allocation is required. -For example: - -@smallexample -SUBROUTINE X(A) -CHARACTER*(*) A -CALL FOO(A // 'suffix') -@end smallexample - -@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 - -@command{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 -qrealsize=8 -@cindex -i8 -@cindex f2c -@cindex increasing precision -@cindex precision, increasing -@cindex increasing range -@cindex range, increasing -@cindex Toolpack -@cindex Netlib - -Some compilers, such as @command{f2c}, have an option (@option{-r8}, -@option{-qrealsize=8} 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 (@option{-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.) - -@command{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 @command{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 @code{INTEGER*2} support -@cindex types, @code{INTEGER*2} -@cindex @code{LOGICAL*1} support -@cindex types, @code{LOGICAL*1} - -@command{g77} doesn't fully support @code{INTEGER*2}, @code{LOGICAL*1}, -and similar. -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 @code{REAL*16} support -@cindex types, @code{REAL*16} -@cindex @code{INTEGER*8} support -@cindex types, @code{INTEGER*8} -@command{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. - -@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 @code{DIMENSION} statement -@cindex statements, @code{DIMENSION} - -@command{g77} doesn't support more general expressions to dimension -arrays, such as array element references, function -references, etc. - -For example, @command{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 - -@command{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 @command{g77}. - -In the meantime, consider using the @code{INTEGER(KIND=7)} -declaration to specify that a variable must be -able to hold a pointer. -This construct is not portable to other non-GNU compilers, -but it is portable to all machines GNU Fortran supports -when @command{g77} is used. - -@xref{Functions and Subroutines}, for information on -@code{%VAL()}, @code{%REF()}, and @code{%DESCR()} -constructs, which are useful for passing pointers to -procedures written in languages other than Fortran. - -@node Sensible Non-standard Constructs -@subsection Sensible Non-standard Constructs - -@command{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 @command{g77} (though @option{-fpedantic} should -trigger warnings about such non-standard constructs). - -Until @command{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, @command{g77} already has been changed to -allow this combination, because although the general -problem of gratuitously rejecting unambiguous and -``safe'' constructs still exists in @command{g77}, this -particular construct was deemed useful enough that -it was worth fixing @command{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 @command{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 @command{g77} just for cases like yours. - -@node READONLY Keyword -@subsection @code{READONLY} Keyword -@cindex READONLY - -Support for @code{READONLY}, in @code{OPEN} statements, -requires @code{libg2c} support, -to make sure that @samp{CLOSE(@dots{},STATUS='DELETE')} -does not delete a file opened on a unit -with the @code{READONLY} keyword, -and perhaps to trigger a fatal diagnostic -if a @code{WRITE} or @code{PRINT} -to such a unit is attempted. - -@emph{Note:} It is not sufficient for @command{g77} and @code{libg2c} -(its version of @code{libf2c}) -to assume that @code{READONLY} does not need some kind of explicit support -at run time, -due to UNIX systems not (generally) needing it. -@command{g77} is not just a UNIX-based compiler! - -Further, mounting of non-UNIX filesystems on UNIX systems -(such as via NFS) -might require proper @code{READONLY} support. - -@cindex SHARED -(Similar issues might be involved with supporting the @code{SHARED} -keyword.) - -@node FLUSH Statement -@subsection @code{FLUSH} Statement - -@command{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 - -@command{g77} doesn't support @samp{FORMAT(I)} and the like. -Supporting this requires a significant redesign or replacement -of @code{libg2c}. - -However, @command{g77} does support -this construct when the expression is constant -(as of version 0.5.22). -For example: - -@smallexample - PARAMETER (IWIDTH = 12) -10 FORMAT (I) -@end smallexample - -Otherwise, 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 - -@command{g77} needs to provide some way, a la @command{gcc}, for @command{g77} -code to specify explicit assembler code. - -@node Q Edit Descriptor -@subsection Q Edit Descriptor -@cindex FORMAT statement -@cindex Q edit descriptor -@cindex edit descriptor, Q - -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{libg2c}. - -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 - -@command{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 - -@command{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 - -@command{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 @command{g77}, partly -because it requires a great deal of work either upgrading or -replacing @code{libg2c}. - -@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 - -@command{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 @command{g77} itself, but -require much more work on @code{libg2c}. - -@cindex FORM='PRINT' -@cindex ANS carriage control -@cindex carriage control -@pindex asa -@pindex fpr -@command{g77} doesn't support @code{FORM='PRINT'} or an equivalent to -translate the traditional `carriage control' characters in column 1 of -output to use backspaces, carriage returns and the like. However -programs exist to translate them in output files (or standard output). -These are typically called either @command{fpr} or @command{asa}. You can get -a version of @command{asa} from -@uref{ftp://sunsite.unc.edu/pub/Linux/devel/lang/fortran} for GNU -systems which will probably build easily on other systems. -Alternatively, @command{fpr} is in BSD distributions in various archive -sites. - -@c (Can both programs can be used in a pipeline, -@c with a named input file, -@c and/or with a named output file???) - -@node ENCODE and DECODE -@subsection @code{ENCODE} and @code{DECODE} -@cindex ENCODE statement -@cindex statements, ENCODE -@cindex DECODE statement -@cindex statements, DECODE - -@command{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 @command{g77}. - -@node AUTOMATIC Statement -@subsection @code{AUTOMATIC} Statement -@cindex @code{AUTOMATIC} statement -@cindex statements, @code{AUTOMATIC} -@cindex automatic variables -@cindex variables, automatic - -@command{g77} doesn't support the @code{AUTOMATIC} statement that -@command{f2c} does. - -@code{AUTOMATIC} would identify a variable or array -as not being @code{SAVE}'d, which is normally the default, -but which would be especially useful for code that, @emph{generally}, -needed to be compiled with the @option{-fno-automatic} option. - -@code{AUTOMATIC} also would serve as a hint to the compiler that placing -the variable or array---even a very large array--on the stack is acceptable. - -@code{AUTOMATIC} would not, by itself, designate the containing procedure -as recursive. - -@code{AUTOMATIC} should work syntactically like @code{SAVE}, -in that @code{AUTOMATIC} with no variables listed should apply to -all pertinent variables and arrays -(which would not include common blocks or their members). - -Variables and arrays denoted as @code{AUTOMATIC} -would not be permitted to be initialized via @code{DATA} -or other specification of any initial values, -requiring explicit initialization, -such as via assignment statements. - -@cindex UNSAVE -@cindex STATIC -Perhaps @code{UNSAVE} and @code{STATIC}, -as strict semantic opposites to @code{SAVE} and @code{AUTOMATIC}, -should be provided as well. - -@node Suppressing Space Padding -@subsection Suppressing Space Padding of Source Lines - -@command{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 -@command{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. -@command{g77} should return the favor by offering conformance -to Digital's approach to handling the above example. - -@node Fortran Preprocessor -@subsection Fortran Preprocessor - -@command{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 @code{And} intrinsic -@cindex intrinsics, @code{And} -@cindex @code{Or} intrinsic -@cindex intrinsics, @code{Or} -@cindex @code{Shift} intrinsic -@cindex intrinsics, @code{Shift} - -@command{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 @command{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 Really Ugly Character Assignments -@subsection Really Ugly Character Assignments - -An option such as @option{-fugly-char} should be provided -to allow - -@smallexample -REAL*8 A1 -DATA A1 / '12345678' / -@end smallexample - -and: - -@smallexample -REAL*8 A1 -A1 = 'ABCDEFGH' -@end smallexample - -@node POSIX Standard -@subsection @code{POSIX} Standard - -@command{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 @command{gcc} backend and, consequently, @command{g77}, currently provides no -general 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 behavior is normally inherited from the system-dependent startup -code, though some targets, such as the Alpha, have code generation -options which change the behavior. - -Most systems provide some C-callable mechanism to change this; this can -be invoked at startup using @command{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 a GNU system using glibc 2.2 or newer: - -@smallexample -#define _GNU_SOURCE 1 -#include -static void __attribute__ ((constructor)) -trapfpe () -@{ - /* Enable some exceptions. At startup all exceptions are masked. */ - - feenableexcept (FE_INVALID|FE_DIVBYZERO|FE_OVERFLOW); -@} -@end smallexample - -Assuming the above source is in file @file{trapfpe.c}, -then compile this routine as follows: -@smallexample -gcc -c trapfpe.c -@end smallexample -and subsequently use it by adding @file{trapfpe.o} to the @command{g77} -command line when linking. - -@node Nonportable Conversions -@subsection Nonportable Conversions -@cindex nonportable conversions -@cindex conversions, nonportable - -@command{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 @command{g77} -when the @option{-fugly-logint} 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, -@command{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 @command{g77} nor the @code{libg2c} library -are thread-safe, nor does @command{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 Enabling Debug Lines -@subsection Enabling Debug Lines -@cindex debug line -@cindex comment line, debug - -An option such as @option{-fdebug-lines} should be provided -to turn fixed-form lines beginning with @samp{D} -to be treated as if they began with a space, -instead of as if they began with a @samp{C} -(as comment lines). - -@node Better Warnings -@subsection Better Warnings - -Because of how @command{g77} generates code via the back end, -it doesn't always provide warnings the user wants. -Consider: - -@smallexample -PROGRAM X -PRINT *, A -END -@end smallexample - -Currently, the above is not flagged as a case of -using an uninitialized variable, -because @command{g77} generates a run-time library call that looks, -to the GBE, like it might actually @emph{modify} @samp{A} at run time. -(And, in fact, depending on the previous run-time library call, -it would!) - -Fixing this requires one of the following: - -@itemize @bullet -@item -Switch to new library, @code{libg77}, that provides -a more ``clean'' interface, -vis-a-vis input, output, and modified arguments, -so the GBE can tell what's going on. - -This would provide a pretty big performance improvement, -at least theoretically, and, ultimately, in practice, -for some types of code. - -@item -Have @command{g77} pass a pointer to a temporary -containing a copy of @samp{A}, -instead of to @samp{A} itself. -The GBE would then complain about the copy operation -involving a potentially uninitialized variable. - -This might also provide a performance boost for some code, -because @samp{A} might then end up living in a register, -which could help with inner loops. - -@item -Have @command{g77} use a GBE construct similar to @code{ADDR_EXPR} -but with extra information on the fact that the -item pointed to won't be modified -(a la @code{const} in C). - -Probably the best solution for now, but not quite trivial -to implement in the general case. -@end itemize - -@node Gracefully Handle Sensible Bad Code -@subsection Gracefully Handle Sensible Bad Code - -@command{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 @option{-ff2c-intrinsics-disable}, -@command{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 - -@option{-Wconversion} and related should flag places where non-standard -conversions are found. -Perhaps much of this would be part of @option{-Wugly*}. - -@node Non-standard Intrinsics -@subsection Non-standard Intrinsics - -@command{g77} needs a new option, like @option{-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 - -@command{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 @command{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 - -@command{g77} needs to support @option{-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 - -@command{g77} needs a @option{-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 - -@command{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 - -@command{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, @command{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, @command{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 - -@command{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 - -@command{g77} needs a set of options such as @option{-Wugly*}, @option{-Wautomatic}, -@option{-Wvxt}, @option{-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 - -@command{g77} should warn about unused labels when @option{-Wunused} is in effect. - -@node Informational Messages -@subsection Informational Messages - -@command{g77} needs an option to suppress information messages (notes). -@option{-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 - -@command{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 Portable Unformatted Files -@subsection Portable Unformatted Files - -@cindex unformatted files -@cindex file formats -@cindex binary data -@cindex byte ordering -@command{g77} has no facility for exchanging unformatted files with systems -using different number formats---even differing only in endianness (byte -order)---or written by other compilers. Some compilers provide -facilities at least for doing byte-swapping during unformatted I/O. - -It is unrealistic to expect to cope with exchanging unformatted files -with arbitrary other compiler runtimes, but the @command{g77} runtime -should at least be able to read files written by @command{g77} on systems -with different number formats, particularly if they differ only in byte -order. - -In case you do need to write a program to translate to or from -@command{g77} (@code{libf2c}) unformatted files, they are written as -follows: -@table @asis -@item Sequential -Unformatted sequential records consist of -@enumerate -@item -A number giving the length of the record contents; -@item -the length of record contents again (for backspace). -@end enumerate - -The record length is of C type -@code{long}; this means that it is 8 bytes on 64-bit systems such as -Alpha GNU/Linux and 4 bytes on other systems, such as x86 GNU/Linux. -Consequently such files cannot be exchanged between 64-bit and 32-bit -systems, even with the same basic number format. -@item Direct access -Unformatted direct access files form a byte stream of length -@var{records}*@var{recl} bytes, where @var{records} is the maximum -record number (@code{REC=@var{records}}) written and @var{recl} is the -record length in bytes specified in the @code{OPEN} statement -(@code{RECL=@var{recl}}). Data appear in the records as determined by -the relevant @code{WRITE} statement. Dummy records with arbitrary -contents appear in the file in place of records which haven't been -written. -@end table - -Thus for exchanging a sequential or direct access unformatted file -between big- and little-endian 32-bit systems using IEEE 754 floating -point it would be sufficient to reverse the bytes in consecutive words -in the file if, and @emph{only} if, only @code{REAL*4}, @code{COMPLEX}, -@code{INTEGER*4} and/or @code{LOGICAL*4} data have been written to it by -@command{g77}. - -If necessary, it is possible to do byte-oriented i/o with @command{g77}'s -@code{FGETC} and @code{FPUTC} intrinsics. Byte-swapping can be done in -Fortran by equivalencing larger sized variables to an @code{INTEGER*1} -array or a set of scalars. - -@cindex HDF -@cindex PDB -If you need to exchange binary data between arbitrary system and -compiler variations, we recommend using a portable binary format with -Fortran bindings, such as NCSA's HDF (@uref{http://hdf.ncsa.uiuc.edu/}) -or PACT's PDB@footnote{No, not @emph{that} one.} -(@uref{http://www.llnl.gov/def_sci/pact/pact_homepage.html}). (Unlike, -say, CDF or XDR, HDF-like systems write in the native number formats and -only incur overhead when they are read on a system with a different -format.) A future @command{g77} runtime library should use such -techniques. - -@node Better List-directed I/O -@subsection Better List-directed I/O - -Values output using list-directed I/O -(@samp{PRINT *, R, D}) -should be written with a field width, precision, and so on -appropriate for the type (precision) of each value. - -(Currently, no distinction is made between single-precision -and double-precision values -by @code{libf2c}.) - -It is likely this item will require the @code{libg77} project -to be undertaken. - -In the meantime, use of formatted I/O is recommended. -While it might be of little consolation, -@command{g77} does support @samp{FORMAT(F.4)}, for example, -as long as @samp{WIDTH} is defined as a named constant -(via @code{PARAMETER}). -That at least allows some compile-time specification -of the precision of a data type, -perhaps controlled by preprocessing directives. - -@node Default to Console I/O -@subsection Default to Console I/O - -The default I/O units, -specified by @samp{READ @var{fmt}}, -@samp{READ (UNIT=*)}, -@samp{WRITE (UNIT=*)}, and -@samp{PRINT @var{fmt}}, -should not be units 5 (input) and 6 (output), -but, rather, unit numbers not normally available -for use in statements such as @code{OPEN} and @code{CLOSE}. - -Changing this would allow a program to connect units 5 and 6 -to files via @code{OPEN}, -but still use @samp{READ (UNIT=*)} and @samp{PRINT} -to do I/O to the ``console''. - -This change probably requires the @code{libg77} project. - -@node Labels Visible to Debugger -@subsection Labels Visible to Debugger - -@command{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 underscore - -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 @code{COMMON} statement -@cindex statements, @code{COMMON} -@cindex naming conflicts - -@command{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 @command{g77} does not, -to be compatible with @command{f2c}. - -@command{g77} could special-case the way it handles -@code{BLOCK DATA}, since it is not compatible with @command{f2c} in this -particular area (necessarily, since @command{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 @command{g77} would treat these references as requests to -force-load BLOCK DATA program units. - -In that case, if @command{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, -@command{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*(*) - -@command{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 @command{f77} support -@cindex support, @command{f77} - -In the opinion of many experienced Fortran users, -@option{-fno-backslash} should be the default, not @option{-fbackslash}, -as currently set by @command{g77}. - -First of all, you can always specify -@option{-fno-backslash} to turn off this processing. - -Despite not being within the spirit (though apparently within the -letter) of the ANSI FORTRAN 77 standard, @command{g77} defaults to -@option{-fbackslash} because that is what most UNIX @command{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 @option{-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 @option{-fno-backslash} the default for GNU -Fortran and thus require users of UNIX @command{f77} and @command{f2c} -to specify @option{-fbackslash} to get the UNIX behavior. - -However, the realization that @command{g77} is intended as -a replacement for @emph{UNIX} @command{f77}, caused the author -to choose to make @command{g77} as compatible with -@command{f77} as feasible, which meant making @option{-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 @command{f77} to do, by default?'' -Although at least one UNIX @command{f77} does not provide -@option{-fbackslash} as a default, it appears that -the majority of them do, which suggests that -the majority of code that is compiled by UNIX @command{f77} -compilers expects @option{-fbackslash} to be the default. - -It is probably the case that more code exists -that would @emph{not} work with @option{-fbackslash} -in force than code that requires it be in force. - -However, most of @emph{that} code is not being compiled -with @command{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 -@command{g77}'s default of @option{-fbackslash} than would -exist for the majority of UNIX @command{f77} users who -would have to modify existing, working build procedures -to explicitly specify @option{-fbackslash} if that was -not the default. - -One suggestion has been to configure the default for -@option{-fbackslash} (and perhaps other options as well) -based on the configuration of @command{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 @command{gcc}. -To change them for @command{g77}, you must first change them -for @command{gcc}. -Do not ask the maintainers of @command{g77} to do this for you, -or to disassociate @command{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 - -@command{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, @command{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} @command{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 -@command{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 - -@command{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 @command{g77} as -an invalid reference to the @code{SQRT} intrinsic function, -because the reference is a subroutine invocation. - -First, @command{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, @command{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, @command{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, @command{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, @command{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, @command{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 - -@command{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 -@command{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 @command{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 @command{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. -@command{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 -@command{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 @option{-fugly-logint}, 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. -@command{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!) - -Most dangerous of all is the fact that, -even assuming consensus on its meaning, -an expression like @samp{L.AND.M.EQ.N}, -if it is the result of a typographical error, -doesn't @emph{look} like it has such a typo. -Even experienced Fortran programmers would not likely notice that -@samp{L.AND.M.EQV.N} was, in fact, intended. - -So, this is a prime example of a circumstance in which -a quality compiler diagnoses the code, -instead of leaving it up to someone debugging it -to know to turn on special compiler options -that might diagnose it. - -@node Order of Side Effects -@subsection Order of Side Effects -@cindex side effects, order of evaluation -@cindex order of evaluation, side effects - -@command{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 @command{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 -@option{-W} options (for instance, @option{-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 @command{g77} diagnostics. - -@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 -@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. - -@menu -* Criteria: Bug Criteria. Have you really found a bug? -* Reporting: Bug Reporting. How to report a bug effectively. -@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 - -Many, perhaps most, bug reports against @command{g77} turn out to -be bugs in the user's code. -While we find such bug reports educational, they sometimes take -a considerable amount of time to track down or at least respond -to---time we could be spending making @command{g77}, not some user's -code, better. - -Some steps you can take to verify that the bug is not certainly -in the code you're compiling with @command{g77}: - -@itemize @bullet -@item -Compile your code using the @command{g77} options @samp{-W -Wall -O}. -These options enable many useful warning; the @option{-O} option -enables flow analysis that enables the uninitialized-variable -warning. - -If you investigate the warnings and find evidence of possible bugs -in your code, fix them first and retry @command{g77}. - -@item -Compile your code using the @command{g77} options @option{-finit-local-zero}, -@option{-fno-automatic}, @option{-ffloat-store}, and various -combinations thereof. - -If your code works with any of these combinations, that is not -proof that the bug isn't in @command{g77}---a @command{g77} bug exposed -by your code might simply be avoided, or have a different, more subtle -effect, when different options are used---but it can be a -strong indicator that your code is making unwarranted assumptions -about the Fortran dialect and/or underlying machine it is -being compiled and run on. - -@xref{Overly Convenient Options,,Overly Convenient Command-Line Options}, -for information on the @option{-fno-automatic} and -@option{-finit-local-zero} options and how to convert -their use into selective changes in your own code. - -@item -@pindex ftnchek -Validate your code with @command{ftnchek} or a similar code-checking -tool. -@command{ftnchek} can be found at @uref{ftp://ftp.netlib.org/fortran} -or @uref{ftp://ftp.dsm.fordham.edu}. - -@pindex make -@cindex Makefile example -Here are some sample @file{Makefile} rules using @command{ftnchek} -``project'' files to do cross-file checking and @command{sfmakedepend} -(from @uref{ftp://ahab.rutgers.edu/pub/perl/sfmakedepend}) -to maintain dependencies automatically. -These assume the use of GNU @command{make}. - -@smallexample -# Dummy suffix for ftnchek targets: -.SUFFIXES: .chek -.PHONY: chekall - -# How to compile .f files (for implicit rule): -FC = g77 -# Assume `include' directory: -FFLAGS = -Iinclude -g -O -Wall - -# Flags for ftnchek: -CHEK1 = -array=0 -include=includes -noarray -CHEK2 = -nonovice -usage=1 -notruncation -CHEKFLAGS = $(CHEK1) $(CHEK2) - -# Run ftnchek with all the .prj files except the one corresponding -# to the target's root: -%.chek : %.f ; \ - ftnchek $(filter-out $*.prj,$(PRJS)) $(CHEKFLAGS) \ - -noextern -library $< - -# Derive a project file from a source file: -%.prj : %.f ; \ - ftnchek $(CHEKFLAGS) -noextern -project -library $< - -# The list of objects is assumed to be in variable OBJS. -# Sources corresponding to the objects: -SRCS = $(OBJS:%.o=%.f) -# ftnchek project files: -PRJS = $(OBJS:%.o=%.prj) - -# Build the program -prog: $(OBJS) ; \ - $(FC) -o $@ $(OBJS) - -chekall: $(PRJS) ; \ - ftnchek $(CHEKFLAGS) $(PRJS) - -prjs: $(PRJS) - -# For Emacs M-x find-tag: -TAGS: $(SRCS) ; \ - etags $(SRCS) - -# Rebuild dependencies: -depend: ; \ - sfmakedepend -I $(PLTLIBDIR) -I includes -a prj $(SRCS1) -@end smallexample - -@item -Try your code out using other Fortran compilers, such as @command{f2c}. -If it does not work on at least one other compiler (assuming the -compiler supports the features the code needs), that is a strong -indicator of a bug in the code. - -However, even if your code works on many compilers @emph{except} -@command{g77}, that does @emph{not} mean the bug is in @command{g77}. -It might mean the bug is in your code, and that @command{g77} simply -exposes it more readily than other compilers. -@end itemize - -@node Bug Reporting -@section How to Report Bugs -@cindex compiler bugs, reporting - -Bugs should be reported to our bug database. Please refer to -@uref{http://gcc.gnu.org/bugs.html} for up-to-date instructions how to -submit bug reports. Copies of this file in HTML (@file{bugs.html}) and -plain text (@file{BUGS}) are also part of GCC releases. - - -@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 -GCC distribution. - -@item -Send a message to @email{@value{email-help}}. -@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 @command{g77}, first decide -what kind of option you wish to add. -Search the @command{g77} and @command{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 @command{g77} and @command{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{@value{path-g77}/lang-options.h}, -which is used during the build of @command{gcc} to -build a list of all options that are accepted by -at least one language's compiler. -This list goes into the @code{documented_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 @code{lang_option_decode}, which, for -@command{g77}, is in @file{@value{path-g77}/com.c} and just -calls @code{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 @option{-fno-asm} option; -even though the @code{f771} version of @code{lang_decode_option} -rejects @option{-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 @option{-fno-asm}---perhaps -a warning about this would be helpful if it were -possible. - -Code that processes Fortran options is found in -@file{@value{path-g77}/top.c}, function @code{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{@value{path-g77}/top.c}. -Many of these defaults are actually macros defined -in @file{@value{path-g77}/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 @command{g77}. - -Accessor macros for Fortran options, used by code -in the @command{g77} FFE, are defined in @file{@value{path-g77}/top.h}. - -@emph{Compiler options} are listed in @file{gcc/toplev.c} -in the array @code{f_options}. -An option not listed in @code{lang_options} is -looked up in @code{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 source code of @command{g77} and rebuilding. -How to do this depends on the version of @command{g77}: - -@table @code -@item G77 0.5.24 (EGCS 1.1) -@itemx G77 0.5.25 (EGCS 1.2 - which became GCC 2.95) -Change the @code{lang_init_options} routine in @file{gcc/gcc/f/com.c}. - -(Note that these versions of @command{g77} -perform internal consistency checking automatically -when the @option{-fversion} option is specified.) - -@item G77 0.5.23 -@itemx G77 0.5.24 (EGCS 1.0) -Change the way @code{f771} handles the @option{-fset-g77-defaults} -option, which is always provided as the first option when -called by @command{g77} or @command{gcc}. - -This code is in @code{ffe_decode_options} in @file{@value{path-g77}/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 @option{-fset-g77-defaults} option is passed to @code{f771} -automatically because of the specification information -kept in @file{@value{path-g77}/lang-specs.h}. -This file tells the @command{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{@value{path-g77}/lang-specs.h} that @option{-fset-g77-defaults}, -@option{-fversion}, and other options are passed, as appropriate, -even when the user has not explicitly specified them. -Other ``internal'' options such as @option{-quiet} also -are passed via this mechanism. -@end table - -@node Projects -@chapter Projects -@cindex projects - -If you want to contribute to @command{g77} by doing research, -design, specification, documentation, coding, or testing, -the following information should give you some ideas. - -@menu -* Efficiency:: Make @command{g77} itself compile code faster. -* Better Optimization:: Teach @command{g77} to generate faster code. -* Simplify Porting:: Make @command{g77} easier to configure, build, - and install. -* More Extensions:: Features many users won't know to ask for. -* Machine Model:: @command{g77} should better leverage @command{gcc}. -* Internals Documentation:: Make maintenance easier. -* Internals Improvements:: Make internals more robust. -* Better Diagnostics:: Make using @command{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 @code{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 @command{g77}, don't pass line/column pairs where -a simple @code{ffewhere} type, which points to the error as much as is -desired by the configuration, will do, and don't pass @code{ffelexToken} types -where a simple @code{ffewhere} type will do. -Then, allow new default -configuration of @code{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 @command{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 @command{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{libg2c} and #include'ing the resulting -file in @command{f2c}+@command{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 @code{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{libg2c} would be moved at least to the -@command{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 -@command{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 @command{g77} uses -@command{gcc} rather than @command{f2c} calling conventions.) - -@item -Do something useful with @code{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 @command{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{libg2c}) should improve portability as well as -produce more optimal code. -Further, @command{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, @command{g77} should produce the equivalent -of a @command{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, @command{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 @command{g77}, and Fortran in -general, in the long run. -Some of these items really pertain to improving @command{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 -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{libg2c} 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 @command{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{libg2c} or its replacement. - -@item -F90 and @command{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 @command{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 @code{REAL_VALUE_TYPE} to represent floating-point constants -exclusively so the target float format need not be required. -This -means changing the way @command{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 @command{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 @command{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 @command{g77} works and how to port it is needed. - -@xref{Front End}, which contains some information -on @command{g77} internals. - -@node Internals Improvements -@section Internals Improvements - -Some more items that would make @command{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 @option{-D} to establish requirements -to achieve desired implementation dialect via @file{proj.h}. - -@item -Clean up used tokens and @code{ffewhere}s in @code{ffeglobal_terminate_1}. - -@item -Replace @file{sta.c} @code{outpooldisp} mechanism with @code{malloc_pool_use}. - -@item -Check for @code{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 @command{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 @code{ffebld_new} calls (those outside of @file{ffeexpr.c} or -inside but invoked via paths not involving @code{ffeexpr_lhs} or -@code{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 @code{ffebld_list_new} (or whatever) calls might not be matched by -@code{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 -@code{ffestorag} objects, so maybe the backend (and other parts of the front -end) can notice that and handle like an @code{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), -@code{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 - -@include ffe.texi - -@end ifset - -@ifset USING -@node Diagnostics -@chapter Diagnostics -@cindex diagnostics - -Some diagnostics produced by @command{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 @command{info} -command that displays the explanation is given 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 @command{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 @command{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. -* LINKFAIL:: When linking @code{f771} fails. -* Y2KBAD:: Use of non-Y2K-compliant intrinsic. -@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 -@code{REAL}) or @samp{DIMAG(@var{expr})} (if @var{intrinsic} -is @code{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 @command{g77} option @option{-ff90}, to enable the -Fortran 90 interpretation. - -@item -Compile with the @command{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 -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 @command{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 @option{-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 @option{-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 @command{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 @command{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 @command{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 @command{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 @command{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 @option{-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 @option{-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 @command{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 @option{-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. - -@cindex continuation character -@cindex characters, continuation -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. -@cindex * -@cindex asterisk -Comment lines are indicated by the letter @samp{C} or the symbol -@samp{*} in column 1. -@cindex trailing comment -@cindex comment -@cindex characters, comment -@cindex ! -@cindex exclamation point -(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 @code{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 @code{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}, @samp{.for}, or @samp{.FOR}, -the file normally will be compiled @emph{without} preprocessing -by @command{g77}. - -Change the file's suffix from @samp{.f} to @samp{.F} -(or, on systems with case-insensitive file names, -to @samp{.fpp} or @samp{.FPP}), -from @samp{.for} to @samp{.fpp}, -or from @samp{.FOR} to @samp{.FPP}. -@command{g77} compiles files with such names @emph{with} -preprocessing. - -@pindex cpp -@cindex preprocessor -@cindex cpp program -@cindex programs, cpp -@cindex @option{-x f77-cpp-input} option -@cindex options, @option{-x f77-cpp-input} -Or, learn how to use @command{gcc}'s @option{-x} option to specify -the language @samp{f77-cpp-input} for Fortran files that -require preprocessing. -@xref{Overall Options,,Options Controlling the Kind of -Output,gcc,Using the GNU Compiler Collection (GCC)}. - -@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). - -Whether a particular disagreement is reported -as a warning or an error -can depend on the relative order -of the disagreeing portions of the source file. - -Disagreements between a procedure invocation -and the @emph{subsequent} procedure itself -are, usually, diagnosed as errors -when the procedure itself @emph{precedes} the invocation. -Other disagreements are diagnosed via warnings. - -@cindex forward references -@cindex in-line code -@cindex compilation, in-line -This distinction, between warnings and errors, -is due primarily to the present tendency of the @command{gcc} back end -to inline only those procedure invocations that are -@emph{preceded} by the corresponding procedure definitions. -If the @command{gcc} back end is changed -to inline ``forward references'', -in which invocations precede definitions, -the @command{g77} front end will be changed -to treat both orderings as errors, accordingly. - -The sorts of disagreements that are diagnosed by @command{g77} include -whether a procedure is a subroutine or function; -if it is a function, the type of the return value of the procedure; -the number of arguments the procedure accepts; -and the type of each argument. - -Disagreements regarding global names among program units -in a Fortran program @emph{should} be fixed in the 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 with the @option{-fno-globals} option. - -The @option{-fno-globals} option -causes these diagnostics to all be warnings -and disables all inlining of references to global procedures -(to avoid subsequent compiler crashes and bad-code generation). -Use of the @option{-Wno-globals} option as well as @option{-fno-globals} -suppresses all of these diagnostics. -(@option{-Wno-globals} by itself disables only the warnings, -not the errors.) - -After using @option{-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. - -@node LINKFAIL -@section @code{LINKFAIL} - -@noindent -On AIX 4.1, @command{g77} might not build with the native (non-GNU) tools -due to a linker bug in coping with the @option{-bbigtoc} option which -leads to a @samp{Relocation overflow} error. The GNU linker is not -recommended on current AIX versions, though; it was developed under a -now-unsupported version. This bug is said to be fixed by `update PTF -U455193 for APAR IX75823'. - -Compiling with @option{-mminimal-toc} -might solve this problem, e.g.@: by adding -@smallexample -BOOT_CFLAGS='-mminimal-toc -O2 -g' -@end smallexample -to the @code{make bootstrap} command line. - -@node Y2KBAD -@section @code{Y2KBAD} -@cindex Y2K compliance -@cindex Year 2000 compliance - -@noindent -@smallexample -Intrinsic `@var{name}', invoked at (^), known to be non-Y2K-compliant@dots{} -@end smallexample - -This diagnostic indicates that -the specific intrinsic invoked by the name @var{name} -is known to have an interface -that is not Year-2000 (Y2K) compliant. - -@xref{Year 2000 (Y2K) Problems}. - -@end ifset - -@node Keyword Index -@unnumbered Keyword Index - -@printindex cp -@bye diff --git a/contrib/gcc-3.4/gcc/f/g77spec.c b/contrib/gcc-3.4/gcc/f/g77spec.c deleted file mode 100644 index ce1bc698f4..0000000000 --- a/contrib/gcc-3.4/gcc/f/g77spec.c +++ /dev/null @@ -1,541 +0,0 @@ -/* Specific flags and argument handling of the Fortran front-end. - Copyright (C) 1997, 1999, 2000, 2001, 2002, 2003, 2004, 2006 - Free Software Foundation, Inc. - -This file is part of GCC. - -GCC 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. - -GCC 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 GCC; see the file COPYING. If not, write to -the Free Software Foundation, 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - -/* This file contains a filter for the main `gcc' driver, which is - replicated for the `g77' driver by adding this filter. The purpose - of this filter 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. Make sure `-lg2c -lm' is at the end of the list. - - 2. Make sure each time `-lg2c' or `-lm' is seen, it forms - part of the series `-lg2c -lm'. - - #1 and #2 are not done if `-nostdlib' or any option that disables - the linking phase is present, or if `-xfoo' is in effect. Note that - a lack of source files or -l options disables linking. - - This program was originally made out of gcc/cp/g++spec.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. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "tm.h" -#include "gcc.h" -#include "intl.h" - -#ifndef MATH_LIBRARY -#define MATH_LIBRARY "-lm" -#endif - -#ifndef FORTRAN_INIT -#define FORTRAN_INIT "-lfrtbegin" -#endif - -#ifndef FORTRAN_LIBRARY -#define FORTRAN_LIBRARY "-lg2c" -#endif - -/* 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_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_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 original argument list and related info is copied here. */ -static int g77_xargc; -static const char *const *g77_xargv; -static void lookup_option (Option *, int *, const char **, const char *); -static void append_arg (const char *); - -/* The new argument list will be built here. */ -static int g77_newargc; -static const char **g77_newargv; - -#ifndef SWITCH_TAKES_ARG -#define SWITCH_TAKES_ARG(CHAR) DEFAULT_SWITCH_TAKES_ARG(CHAR) -#endif - -#ifndef WORD_SWITCH_TAKES_ARG -#define WORD_SWITCH_TAKES_ARG(STR) DEFAULT_WORD_SWITCH_TAKES_ARG (STR) -#endif - -/* 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). - - Note that this also assumes gcc.c's pass converting long options - to short ones, where available, has already been run. */ - -static void -lookup_option (Option *xopt, int *xskip, const char **xarg, const char *text) -{ - Option opt = OPTION_; - int skip; - const char *arg = NULL; - - if ((skip = SWITCH_TAKES_ARG (text[1]))) - skip -= (text[2] != '\0'); /* See gcc.c. */ - - 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, 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] == 'x') - opt = OPTION_x, arg = text + 2; - else - { - if ((skip = WORD_SWITCH_TAKES_ARG (text + 1)) != 0) /* See gcc.c. */ - ; - else if (! strncmp (text, "-fdriver", 8)) /* Really --driver!! */ - opt = OPTION_driver; /* Never mind arg, this is unsupported. */ - else if (! strcmp (text, "-fhelp")) /* Really --help!! */ - opt = OPTION_help; - else if (! strcmp (text, "-M")) - opt = OPTION_M; - else if (! strcmp (text, "-MM")) - opt = OPTION_MM; - else if (! strcmp (text, "-nostdlib") - || ! strcmp (text, "-nodefaultlibs")) - opt = OPTION_nostdlib; - else if (! strcmp (text, "-fsyntax-only")) - opt = OPTION_syntax_only; - else if (! strcmp (text, "-dumpversion")) - opt = OPTION_version; - else if (! strcmp (text, "-fversion")) /* Really --version!! */ - opt = OPTION_version; - else if (! strcmp (text, "-Xlinker") - || ! strcmp (text, "-specs")) - skip = 1; - 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; - } -} - -/* Append another argument to the list being built. As long as it is - identical to the corresponding arg in the original list, just increment - the new arg count. Otherwise allocate a new list, etc. */ - -static void -append_arg (const char *arg) -{ - static int newargsize; - -#if 0 - fprintf (stderr, "`%s'\n", arg); -#endif - - if (g77_newargv == g77_xargv - && g77_newargc < g77_xargc - && (arg == g77_xargv[g77_newargc] - || ! strcmp (arg, g77_xargv[g77_newargc]))) - { - ++g77_newargc; - return; /* Nothing new here. */ - } - - if (g77_newargv == g77_xargv) - { /* Make new arglist. */ - int i; - - newargsize = (g77_xargc << 2) + 20; /* This should handle all. */ - g77_newargv = xmalloc (newargsize * sizeof (char *)); - - /* Copy what has been done so far. */ - for (i = 0; i < g77_newargc; ++i) - g77_newargv[i] = g77_xargv[i]; - } - - if (g77_newargc == newargsize) - fatal ("overflowed output arg list for `%s'", arg); - - g77_newargv[g77_newargc++] = arg; -} - -void -lang_specific_driver (int *in_argc, const char *const **in_argv, - int *in_added_libraries ATTRIBUTE_UNUSED) -{ - int argc = *in_argc; - const char *const *argv = *in_argv; - int i; - int verbose = 0; - Option opt; - int skip; - const char *arg; - - /* This will be NULL if we encounter a situation where we should not - link in libf2c. */ - const char *library = FORTRAN_LIBRARY; - - /* 0 => -xnone in effect. - 1 => -xfoo in effect. */ - int saw_speclang = 0; - - /* 0 => initial/reset state - 1 => last arg was -l - 2 => last two args were -l -lm. */ - int saw_library = 0; - - /* 0 => initial/reset state - 1 => FORTRAN_INIT linked in */ - int use_init = 0; - /* By default, we throw on the math library if we have one. */ - int need_math = (MATH_LIBRARY[0] != '\0'); - - /* The number of input and output files in the incoming arg list. */ - int n_infiles = 0; - int n_outfiles = 0; - -#if 0 - fprintf (stderr, "Incoming:"); - for (i = 0; i < argc; i++) - fprintf (stderr, " %s", argv[i]); - fprintf (stderr, "\n"); -#endif - - g77_xargc = argc; - g77_xargv = argv; - g77_newargc = 0; - g77_newargv = (const char **) argv; - - /* 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')) - { - continue; - } - - if ((argv[i][0] != '-') || (argv[i][1] == '\0')) - { - ++n_infiles; - 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 = 0; - break; - - case OPTION_l: - ++n_infiles; - break; - - case OPTION_o: - ++n_outfiles; - break; - - case OPTION_v: - verbose = 1; - break; - - case OPTION_b: - case OPTION_B: - case OPTION_L: - 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 (GCC) %s\n", version_string); - printf ("Copyright %s 2006 Free Software Foundation, Inc.\n", - _("(C)")); - printf ("\n"); - printf (_("\ -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\ -")); - exit (0); - break; - - case OPTION_help: - /* Let gcc.c handle this, as it has a really - cool facility for handling --help and --verbose --help. */ - return; - - case OPTION_driver: - fatal ("--driver no longer supported"); - break; - - default: - 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", argv[i]); - } - - if ((n_outfiles != 0) && (n_infiles == 0)) - fatal ("no input files; unwilling to write output files"); - - /* If there are no input files, no need for the library. */ - if (n_infiles == 0) - library = 0; - - /* Second pass through arglist, transforming arguments as appropriate. */ - - append_arg (argv[0]); /* Start with command name, of course. */ - - for (i = 1; i < argc; ++i) - { - if (argv[i][0] == '\0') - { - append_arg (argv[i]); /* Interesting. Just append as is. */ - continue; - } - - if ((argv[i][0] == '-') && (argv[i][1] != 'l')) - { - /* Not a filename or library. */ - - if (saw_library == 1 && need_math) /* -l. */ - append_arg (MATH_LIBRARY); - - saw_library = 0; - - lookup_option (&opt, &skip, &arg, argv[i]); - - if (argv[i][1] == '\0') - { - append_arg (argv[i]); /* "-" == Standard input. */ - continue; - } - - if (opt == OPTION_x) - { - /* Track input language. */ - const char *lang; - - if (arg == NULL) - lang = argv[i+1]; - else - lang = arg; - - saw_speclang = (strcmp (lang, "none") != 0); - } - - append_arg (argv[i]); - - for (; skip != 0; --skip) - append_arg (argv[++i]); - - continue; - } - - /* A filename/library, not an option. */ - - if (saw_speclang) - saw_library = 0; /* -xfoo currently active. */ - else - { /* -lfoo or filename. */ - if (strcmp (argv[i], MATH_LIBRARY) == 0) - { - if (saw_library == 1) - saw_library = 2; /* -l -lm. */ - else - { - if (0 == use_init) - { - append_arg (FORTRAN_INIT); - use_init = 1; - } - append_arg (FORTRAN_LIBRARY); - } - } - else if (strcmp (argv[i], FORTRAN_LIBRARY) == 0) - saw_library = 1; /* -l. */ - else - { /* Other library, or filename. */ - if (saw_library == 1 && need_math) - append_arg (MATH_LIBRARY); - saw_library = 0; - } - } - append_arg (argv[i]); - } - - /* Append `-lg2c -lm' as necessary. */ - - if (library) - { /* Doing a link and no -nostdlib. */ - if (saw_speclang) - append_arg ("-xnone"); - - switch (saw_library) - { - case 0: - if (0 == use_init) - { - append_arg (FORTRAN_INIT); - use_init = 1; - } - append_arg (library); - case 1: - if (need_math) - append_arg (MATH_LIBRARY); - default: - break; - } - } - -#ifdef ENABLE_SHARED_LIBGCC - if (library) - { - int i; - - for (i = 1; i < g77_newargc; i++) - if (g77_newargv[i][0] == '-') - if (strcmp (g77_newargv[i], "-static-libgcc") == 0 - || strcmp (g77_newargv[i], "-static") == 0) - break; - - if (i == g77_newargc) - append_arg ("-shared-libgcc"); - } - -#endif - - if (verbose - && g77_newargv != g77_xargv) - { - fprintf (stderr, "Driving:"); - for (i = 0; i < g77_newargc; i++) - fprintf (stderr, " %s", g77_newargv[i]); - fprintf (stderr, "\n"); - } - - *in_argc = g77_newargc; - *in_argv = g77_newargv; -} - -/* Called before linking. Returns 0 on success and -1 on failure. */ -int lang_specific_pre_link (void) /* Not used for F77. */ -{ - return 0; -} - -/* Number of extra output files that lang_specific_pre_link may generate. */ -int lang_specific_extra_outfiles = 0; /* Not used for F77. */ - -/* Table of language-specific spec functions. */ -const struct spec_function lang_specific_spec_functions[] = -{ - { 0, 0 } -}; diff --git a/contrib/gcc-3.4/gcc/f/global.c b/contrib/gcc-3.4/gcc/f/global.c deleted file mode 100644 index 8793f62c4a..0000000000 --- a/contrib/gcc-3.4/gcc/f/global.c +++ /dev/null @@ -1,1586 +0,0 @@ -/* global.c -- Implementation File (module.c template V1.0) - Copyright (C) 1995, 1997, 2003 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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 const char *const 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) (ffeglobal)) -{ - 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 = malloc_new_ks (malloc_pool_image (), "FFEGLOBAL", sizeof (*g)); - g->n = n; - g->hook = FFECOM_globalNULL; - g->tick = 0; - - ffename_set_global (n, g); - - return g; -} - -#endif -/* ffeglobal_init_1 -- Initialize per file - - ffeglobal_init_1(); */ - -void -ffeglobal_init_1 (void) -{ -#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) - { - /* Not supposed to initialize blank common, though it works. */ - 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) - { - /* The names match, so the "blankness" should match too! */ - assert (g->u.common.blank == blank); - } - else - { - /* This global name has already been established, - but as something other than a common block. */ - 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 ()) - { - /* Common name previously used as intrinsic. Though it works, - warn, because the intrinsic reference might have been intended - as a ref to an external procedure, but g77's vast list of - intrinsics happened to snarf the name. */ - 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_typeMAIN) - || (g->type == FFEGLOBAL_typeSUBR) - || (g->type == FFEGLOBAL_typeFUNC) - || (g->type == FFEGLOBAL_typeBDATA)) - && g->u.proc.defined) - { - /* This program unit has already been 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->type != FFEGLOBAL_typeNONE) - && (g->type != FFEGLOBAL_typeEXT) - && (g->type != type)) - { - /* A reference to this program unit has been seen, but its - context disagrees about the new definition regarding - what kind of program unit it is. (E.g. `call foo' followed - by `function foo'.) But `external foo' alone doesn't mean - disagreement with either a function or subroutine, though - g77 normally interprets it as a request to force-load - a block data program unit by that name (to cope with libs). */ - if (ffe_is_globals () || ffe_is_warn_globals ()) - { - ffebad_start (ffe_is_globals () - ? FFEBAD_FILEWIDE_DISAGREEMENT - : 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; - } - 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) - && (g->type == FFEGLOBAL_typeFUNC) - && ((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)))) - { - /* The previous reference and this new function definition - disagree about the type of the function. I (Burley) think - this rarely occurs, because when this code is reached, - the type info doesn't appear to be filled in yet. */ - 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 ()) - { - /* This name, previously used as an intrinsic, now is known - to also be a global procedure name. Warn, since the previous - use as an intrinsic might have been intended to refer to - this procedure. */ - 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); - } - /* If there's a known disagreement about the kind of program - unit, then don't even bother tracking arglist argreement. */ - if ((g->tick != 0) - && (g->type != type)) - g->u.proc.n_args = -1; - g->tick = ffe_count_2; - 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); - - if (pad != 0) - { - 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 (); - } - } - 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 (); - } - - if (g->u.common.pad < pad) - { - 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); - } - } -#endif -} - -/* Collect info for a global's argument. */ - -void -ffeglobal_proc_def_arg (ffesymbol s, int argno, const 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 ()) - { - const char *refwhy = NULL; - const 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; - -#if 0 - case FFEGLOBAL_argsummaryPTR: - defwhy = "a pointer"; - break; -#endif - - 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 = 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) - { - const char *refwhy = NULL; - const 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; - -#if 0 - case FFEGLOBAL_argsummaryPTR: - if ((ai->as != FFEGLOBAL_argsummaryPTR) - && (ai->as != FFEGLOBAL_argsummaryNONE)) - { - fail = TRUE; - refwhy = "a pointer"; - } - break; -#endif - - 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; - -#if 0 - case FFEGLOBAL_argsummaryPTR: - defwhy = "a pointer"; - break; -#endif - - 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 = 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 ()) - { - /* This name, previously used as a global, now is used - for an intrinsic. Warn, since this new use as an - intrinsic might have been intended to refer to - the global procedure. */ - 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 ()) - { - /* An earlier reference to this intrinsic disagrees with - this reference vis-a-vis explicit `intrinsic foo', - which suggests that the one relying on implicit - intrinsicacity might have actually intended to refer - to a global of the same name. */ - 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; - - /* It is never really _known_ that an EXTERNAL statement - names a BLOCK DATA by just looking at the program unit, - so override a different notion here. */ - if (type == FFEGLOBAL_typeBDATA) - type = FFEGLOBAL_typeEXT; - - 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 != FFEGLOBAL_typeEXT) - && (g->type != type) - && (type != FFEGLOBAL_typeEXT)) - { - /* Disagreement about (fully refined) class of program unit - (main, subroutine, function, block data). Treat EXTERNAL/ - COMMON disagreements distinctly. */ - 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 ()) - { - /* Warn about EXTERNAL of a COMMON name, though it works. */ - 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 - } - else if (ffe_is_globals () || ffe_is_warn_globals ()) - { - ffebad_start (ffe_is_globals () - ? FFEBAD_FILEWIDE_DISAGREEMENT - : 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 (! ffe_is_globals ()); - } - } - - 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); - } - /* Make sure there is type agreement. */ - if (g->type == FFEGLOBAL_typeFUNC - && 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 - /* CHARACTER*n disagreements matter only once a - definition is involved, since the definition might - be CHARACTER*(*), which accepts all references. */ - || (g->u.proc.defined - && ffesymbol_size (s) != g->u.proc.sz - && ffesymbol_size (s) != FFETARGET_charactersizeNONE - && g->u.proc.sz != FFETARGET_charactersizeNONE))) - { - int error; - - /* Type mismatch between function reference/definition and - this subsequent reference (which might just be the filling-in - of type info for the definition, but we can't reach here - if that's the case and there was a previous definition). - - It's an error given a previous definition, since that - implies inlining can crash the compiler, unless the user - asked for no such inlining. */ - error = (g->tick != ffe_count_2 - && g->u.proc.defined - && ffe_is_globals ()); - if (error || ffe_is_warn_globals ()) - { - ffebad_start (error - ? FFEBAD_FILEWIDE_TYPE_MISMATCH - : FFEBAD_FILEWIDE_TYPE_MISMATCH_W); - ffebad_string (ffelex_token_text (t)); - if (g->tick == ffe_count_2) - { - /* Current reference fills in type info for definition. - The current token doesn't necessarily point to the actual - definition of the function, so use the definition pointer - and the pointer to the pre-definition type info. */ - ffebad_here (0, ffelex_token_where_line (g->t), - ffelex_token_where_column (g->t)); - ffebad_here (1, ffelex_token_where_line (g->u.proc.other_t), - ffelex_token_where_column (g->u.proc.other_t)); - } - else - { - /* Current reference is not a filling-in of a current - definition. The current token is fine, as is - the previous-mention token. */ - 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 (error) - g->type = FFEGLOBAL_typeANY; - return FALSE; - } - } - } - - 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 ()) - { - /* Now known as a global, this name previously was seen as an - intrinsic. Warn, in case the previous reference was intended - for the same global. */ - 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->hook = FFECOM_globalNULL; /* Discard previous _DECL. */ - 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 - ffetargetOffset 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, ffetargetOffset 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->tick > 0) && (g->tick < ffe_count_2) - && (g->u.common.size < size)) - { - char oldsize[40]; - char newsize[40]; - - /* Common block initialized in a previous program unit, which - effectively freezes its size, but now the program is trying - to enlarge it. */ - - sprintf (&oldsize[0], "%" ffetargetOffset_f "d", g->u.common.size); - sprintf (&newsize[0], "%" ffetargetOffset_f "d", 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], "%" ffetargetOffset_f "d", g->u.common.size); - sprintf (&newsize[0], "%" ffetargetOffset_f "d", 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 (void) -{ -} diff --git a/contrib/gcc-3.4/gcc/f/global.h b/contrib/gcc-3.4/gcc/f/global.h deleted file mode 100644 index dc499df9eb..0000000000 --- a/contrib/gcc-3.4/gcc/f/global.h +++ /dev/null @@ -1,193 +0,0 @@ -/* global.h -- Public #include File (module.h template V1.0) - Copyright (C) 1995, 1997, 2003 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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 GCC_F_GLOBAL_H -#define GCC_F_GLOBAL_H - -/* 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_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; - ffecomGlobal hook; - 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? */ - ffetargetOffset 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) (ffeglobal)); -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, const 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, ffetargetOffset size); -void ffeglobal_terminate_1 (void); - -/* Define macros. */ - -#define FFEGLOBAL_ENABLED 1 - -#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_pad(g) ((g)->u.common.pad) -#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_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 /* ! GCC_F_GLOBAL_H */ - diff --git a/contrib/gcc-3.4/gcc/f/implic.c b/contrib/gcc-3.4/gcc/f/implic.c deleted file mode 100644 index c7a28cbc42..0000000000 --- a/contrib/gcc-3.4/gcc/f/implic.c +++ /dev/null @@ -1,383 +0,0 @@ -/* implic.c -- Implementation File (module.c template V1.0) - Copyright (C) 1995, 2002, 2003 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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 "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_ (unsigned 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_ (unsigned char c) -{ - /* NOTE: This is definitely ASCII-specific!! */ - if (ISIDST (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 ()) - { - /* xgettext:no-c-format */ - 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 (void) -{ - 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 (void) -{ - 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; - const 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, const 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 (void) -{ -} diff --git a/contrib/gcc-3.4/gcc/f/implic.h b/contrib/gcc-3.4/gcc/f/implic.h deleted file mode 100644 index 44fbfac4e4..0000000000 --- a/contrib/gcc-3.4/gcc/f/implic.h +++ /dev/null @@ -1,74 +0,0 @@ -/* implic.h -- Public #include File (module.h template V1.0) - Copyright (C) 1995 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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 GCC_F_IMPLIC_H -#define GCC_F_IMPLIC_H - -/* 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, const 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 /* ! GCC_F_IMPLIC_H */ diff --git a/contrib/gcc-3.4/gcc/f/info-b.def b/contrib/gcc-3.4/gcc/f/info-b.def deleted file mode 100644 index 088d108f05..0000000000 --- a/contrib/gcc-3.4/gcc/f/info-b.def +++ /dev/null @@ -1,36 +0,0 @@ -/* info-b.def -- Public #include File (module.h template V1.0) - Copyright (C) 1995 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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/contrib/gcc-3.4/gcc/f/info-k.def b/contrib/gcc-3.4/gcc/f/info-k.def deleted file mode 100644 index 9e6052d615..0000000000 --- a/contrib/gcc-3.4/gcc/f/info-k.def +++ /dev/null @@ -1,41 +0,0 @@ -/* info-k.def -- Public #include File (module.h template V1.0) - Copyright (C) 1995, 2002 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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: -*/ - -# -/* Kind messages are used in diagnostic location reports of the - form ": In function `foo': ". */ - -FFEINFO_KIND (FFEINFO_kindNONE, "In unknown kind", "") -FFEINFO_KIND (FFEINFO_kindENTITY, "In entity", "e") -FFEINFO_KIND (FFEINFO_kindFUNCTION, "In function", "f") -FFEINFO_KIND (FFEINFO_kindSUBROUTINE, "In subroutine", "u") -FFEINFO_KIND (FFEINFO_kindPROGRAM, "In program", "p") -FFEINFO_KIND (FFEINFO_kindBLOCKDATA, "In block-data unit", "b") -FFEINFO_KIND (FFEINFO_kindCOMMON, "In common block", "c") -FFEINFO_KIND (FFEINFO_kindCONSTRUCT, "In construct", ":") -FFEINFO_KIND (FFEINFO_kindNAMELIST, "In namelist", "n") -FFEINFO_KIND (FFEINFO_kindANY, "In anything", "~") diff --git a/contrib/gcc-3.4/gcc/f/info-w.def b/contrib/gcc-3.4/gcc/f/info-w.def deleted file mode 100644 index 57e3f8c6d6..0000000000 --- a/contrib/gcc-3.4/gcc/f/info-w.def +++ /dev/null @@ -1,41 +0,0 @@ -/* info-w.def -- Public #include File (module.h template V1.0) - Copyright (C) 1995 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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/contrib/gcc-3.4/gcc/f/info.c b/contrib/gcc-3.4/gcc/f/info.c deleted file mode 100644 index 3c0030f27f..0000000000 --- a/contrib/gcc-3.4/gcc/f/info.c +++ /dev/null @@ -1,303 +0,0 @@ -/* info.c -- Implementation File (module.c template V1.0) - Copyright (C) 1995, 2002, 2003 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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 const char *const ffeinfo_basictype_string_[] -= -{ -#define FFEINFO_BASICTYPE(KWD,LNAM,SNAM) SNAM, -#include "info-b.def" -#undef FFEINFO_BASICTYPE -}; -static const char *const ffeinfo_kind_message_[] -= -{ -#define FFEINFO_KIND(kwd,msgid,snam) msgid, -#include "info-k.def" -#undef FFEINFO_KIND -}; -static const char *const 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 const char *const ffeinfo_kindtype_string_[] -= -{ - "", - "1", - "2", - "3", - "4", - "5", - "6", - "7", - "8", - "*", -}; -static const char *const 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]; - -/* 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. */ - -const 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 (void) -{ - 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. */ - -const 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. */ - -const 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. */ - -const 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); - - 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. */ - -const 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/contrib/gcc-3.4/gcc/f/info.h b/contrib/gcc-3.4/gcc/f/info.h deleted file mode 100644 index 69defd27ab..0000000000 --- a/contrib/gcc-3.4/gcc/f/info.h +++ /dev/null @@ -1,186 +0,0 @@ -/* info.h -- Public #include File (module.h template V1.0) - Copyright (C) 1995 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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 GCC_F_INFO_H -#define GCC_F_INFO_H - -/* 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); -const char *ffeinfo_basictype_string (ffeinfoBasictype basictype); -void ffeinfo_init_0 (void); -const char *ffeinfo_kind_message (ffeinfoKind kind); -const char *ffeinfo_kind_string (ffeinfoKind kind); -ffeinfoKindtype ffeinfo_kindtype_max(ffeinfoBasictype bt, - ffeinfoKindtype k1, - ffeinfoKindtype k2); -const char *ffeinfo_kindtype_string (ffeinfoKindtype kind_type); -const 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 /* ! GCC_F_INFO_H */ diff --git a/contrib/gcc-3.4/gcc/f/intdoc.c b/contrib/gcc-3.4/gcc/f/intdoc.c deleted file mode 100644 index b24c79a481..0000000000 --- a/contrib/gcc-3.4/gcc/f/intdoc.c +++ /dev/null @@ -1,1325 +0,0 @@ -/* intdoc.c - Copyright (C) 1997, 2000, 2001, 2003 - Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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 "bconfig.h" -#include "system.h" -#include "coretypes.h" -#include "tm.h" -#include "assert.h" - -/* Pull in the intrinsics info, but only the doc parts. */ -#define FFEINTRIN_DOC 1 -#include "intrin.h" - -const 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, const char *name, const char *name_uc, - ffeintrinGen gen); -static void dumpspec (int menu, const char *name, const char *name_uc, - ffeintrinSpec spec); -static void dumpimp (int menu, const char *name, const char *name_uc, size_t genno, ffeintrinFamily family, - ffeintrinImp imp, ffeintrinSpec spec); -static const char *argument_info_ptr (ffeintrinImp imp, int argno); -static const char *argument_info_string (ffeintrinImp imp, int argno); -static const char *argument_name_ptr (ffeintrinImp imp, int argno); -static const char *argument_name_string (ffeintrinImp imp, int argno); -#if 0 -static const char *elaborate_if_complex (ffeintrinImp imp, int argno); -static const char *elaborate_if_maybe_complex (ffeintrinImp imp, int argno); -static const char *elaborate_if_real (ffeintrinImp imp, int argno); -#endif -static void print_type_string (const char *c); - -int -main (int argc, char **argv ATTRIBUTE_UNUSED) -{ - if (argc != 1) - { - fprintf (stderr, "\ -Usage: intdoc > intdoc.texi\n\ - Collects and dumps documentation on g77 intrinsics\n\ - to the file named intdoc.texi.\n"); - exit (1); - } - - dumpem (); - return 0; -} - -struct _ffeintrin_name_ - { - const char *const name_uc; - const char *const name_lc; - const char *const name_ic; - const ffeintrinGen generic; - const ffeintrinSpec specific; - }; - -struct _ffeintrin_gen_ - { - const char *const name; /* Name as seen in program. */ - const ffeintrinSpec specs[2]; - }; - -struct _ffeintrin_spec_ - { - const char *const name; /* Uppercase name as seen in source code, - lowercase if no source name, "none" if no - name at all (NONE case). */ - const bool is_actualarg; /* Ok to pass as actual arg if -pedantic. */ - const ffeintrinFamily family; - const ffeintrinImp implementation; - }; - -struct _ffeintrin_imp_ - { - const char *const name; /* Name of implementation. */ - const char *const control; - }; - -static const 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) -#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD) -#include "intrin.def" -#undef DEFNAME -#undef DEFGEN -#undef DEFSPEC -#undef DEFIMP -#undef DEFIMPY -}; - -static const 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) -#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD) -#include "intrin.def" -#undef DEFNAME -#undef DEFGEN -#undef DEFSPEC -#undef DEFIMP -#undef DEFIMPY -}; - -static const struct _ffeintrin_imp_ imps[] = { -#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) \ - { NAME, CONTROL }, -#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD) \ - { NAME, CONTROL }, -#include "intrin.def" -#undef DEFNAME -#undef DEFGEN -#undef DEFSPEC -#undef DEFIMP -#undef DEFIMPY -}; - -static const 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) -#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD) -#include "intrin.def" -#undef DEFGEN -#undef DEFSPEC -#undef DEFIMP -#undef DEFIMPY -}; - -struct cc_pair { const ffeintrinImp imp; const char *const text; }; - -static const char *descriptions[FFEINTRIN_imp] = { 0 }; -static const struct cc_pair cc_descriptions[] = { -#define DEFDOC(IMP,SUMMARY,DESCRIPTION) { FFEINTRIN_imp ## IMP, DESCRIPTION }, -#include "intdoc.h0" -#undef DEFDOC -}; - -static const char *summaries[FFEINTRIN_imp] = { 0 }; -static const struct cc_pair cc_summaries[] = { -#define DEFDOC(IMP,SUMMARY,DESCRIPTION) { FFEINTRIN_imp ## IMP, SUMMARY }, -#include "intdoc.h0" -#undef DEFDOC -}; - -const 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 (void) -{ - in_ifset = 2; -} - -static void -dumpclearif (void) -{ - if ((in_ifset == 2) - || (latest_family != FFEINTRIN_familyNONE)) - printf ("@end ifset\n"); - latest_family = FFEINTRIN_familyNONE; - in_ifset = 0; -} - -static void -dumpem (void) -{ - 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 ("@c This file is automatically derived from intdoc.c, intdoc.in,\n"); - printf ("@c ansify.c, intrin.def, and intrin.h. Edit those files instead.\n"); - 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, const char *name, const char *name_uc, ffeintrinGen gen) -{ - size_t i; - int total = 0; - - if (!menu) - { - for (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, const char *name, const 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, const char *name, const char *name_uc, size_t genno, - ffeintrinFamily family, ffeintrinImp imp, ffeintrinSpec spec) -{ - const char *c; - bool subr; - const char *argc; - const 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); - const 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] == '@' && ISDIGIT (c[1])) - { - int argno = c[1] - '0'; - - c += 2; - while (ISDIGIT (c[0])) - { - 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 ("\n\ -This intrinsic is not yet implemented.\n\ -The name is, however, reserved as an intrinsic.\n\ -Use @samp{EXTERNAL %s} to use this name for an\n\ -external procedure.\n\ -\n\ -", - name); - return; - } - - c = imps[imp].control; - subr = (c[0] == '-'); - colon = (c[2] == ':') ? 2 : 3; - - printf ("\n\ -@noindent\n\ -@example\n\ -%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 (")\n\ -@end example\n\ -\n\ -"); - - if (!subr) - { - int other_arg; - const char *arg_string; - const char *arg_info; - - if (ISDIGIT (c[colon + 1])) - { - 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\n\ -%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 (".\n\ -The exact type is @samp{REAL(KIND=1)} when argument @var{%s} is\n\ -any type other than @code{COMPLEX}, or when it is @code{COMPLEX(KIND=1)}.\n\ -When @var{%s} is any @code{COMPLEX} type other than @code{COMPLEX(KIND=1)},\n\ -this intrinsic is valid only when used as the argument to\n\ -@code{REAL()}, as explained below.\n\n", - arg_string, - arg_string); - else - printf (".\n\ -This intrinsic is valid when argument @var{%s} is\n\ -@code{COMPLEX(KIND=1)}.\n\ -When @var{%s} is any other @code{COMPLEX} type,\n\ -this intrinsic is valid only when used as the argument to\n\ -@code{REAL()}, as explained below.\n\n", - arg_string, - arg_string); - } -#if 0 - else if ((c[0] == 'I') - && (c[1] == '7')) - printf (", the exact type being wide enough to hold a pointer\n\ -on the target system (typically @code{INTEGER(KIND=1)} or @code{INTEGER(KIND=4)}).\n\n"); -#endif - else if (c[1] == '=' && ISDIGIT (c[colon + 1])) - { - 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 (".\n\ -The exact type depends on that of argument @var{%s}---if @var{%s} is\n\ -@code{COMPLEX}, this function's type is @code{REAL}\n\ -with the same @samp{KIND=} value as the type of @var{%s}.\n\ -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\n\ -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\n\ -@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 'N': - printf ("@code{INTEGER} not wider than the default kind"); - 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; - - case 'N': - printf ("@code{LOGICAL} not wider than the default kind"); - 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; - - case 'N': - printf ("@code{INTEGER} or @code{LOGICAL} not wider than the default kind"); - 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\n\ -of an executable statement"); - break; - - case 's': - printf ("Signal handler (@code{INTEGER FUNCTION} or @code{SUBROUTINE})\n\ -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\n\ -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) - { - const char *c = descriptions[imp]; - - printf ("\ -@noindent\n\ -Description:\n\ -\n"); - - while (c[0] != '\0') - { - if (c[0] == '@' && ISDIGIT (c[1])) - { - int argno = c[1] - '0'; - - c += 2; - while (ISDIGIT (c[0])) - { - 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 const char * -argument_info_ptr (ffeintrinImp imp, int argno) -{ - const 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 const char * -argument_info_string (ffeintrinImp imp, int argno) -{ - const char *p; - - p = argument_info_ptr (imp, argno); - assert (p != NULL); - return p; -} - -static const char * -argument_name_ptr (ffeintrinImp imp, int argno) -{ - const 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 const char * -argument_name_string (ffeintrinImp imp, int argno) -{ - const char *p; - - p = argument_name_ptr (imp, argno); - assert (p != NULL); - return p; -} - -static void -print_type_string (const 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; - - 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 ("type?" == NULL); - break; - } -} diff --git a/contrib/gcc-3.4/gcc/f/intdoc.in b/contrib/gcc-3.4/gcc/f/intdoc.in deleted file mode 100644 index 6f2423f6ca..0000000000 --- a/contrib/gcc-3.4/gcc/f/intdoc.in +++ /dev/null @@ -1,2705 +0,0 @@ -/* Copyright (C) 1997, 1999, 2003 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! - -*/ - -#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 @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 `common' (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, "Common logarithm.", "\ -Returns the common logarithm (base 10) of @var{@1@}, which must -be greater than zero. - -The inverse of this function is @samp{10. ** LOG10(@var{@1@})}. - -@xref{Log Intrinsic}, for the natural logarithm function. -") - -DEFDOC (ALOG10, "Common logarithm (archaic).", ARCHAIC (LOG10, Log10)) - -DEFDOC (DLOG10, "Common 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, Conjg)) - -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 (DIM, DiM)) - -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 disregarded. - -@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 disregarded. - -@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 disregarded. - -@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 (SIGN, Sign)) - -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{Dble Intrinsic}, for information on the standard FORTRAN 77 -replacement for @code{DREAL()}. - -@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{@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 in @var{@2@}. - -@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}. - -@cindex Y2K compliance -@cindex Year 2000 compliance -This intrinsic is not recommended, due to the year 2000 approaching. -Therefore, programs making use of this intrinsic -might not be Year 2000 (Y2K) compliant. -@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. - -@cindex wraparound, timings -@cindex limits, timings -On some systems, the underlying timings are represented -using types with sufficiently small limits that overflows -(wraparounds) are possible, such as 32-bit types. -Therefore, the values returned by this intrinsic -might be, or become, negative, -or numerically less than previous values, -during a single run of the compiled program. - -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{@2@}, -and the user and system components of this in @samp{@var{@1@}(1)} -and @samp{@var{@1@}(2)} respectively. -The value of @var{@2@} is equal to @samp{@var{@1@}(1) + @var{@1@}(2)}. - -Subsequent invocations of @samp{@0@()} set values based on accumulations -since the previous invocation. - -@cindex wraparound, timings -@cindex limits, timings -On some systems, the underlying timings are represented -using types with sufficiently small limits that overflows -(wraparounds) are possible, such as 32-bit types. -Therefore, the values returned by this intrinsic -might be, or become, negative, -or numerically less than previous values, -during a single run of the compiled program. - -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)}. - -@cindex wraparound, timings -@cindex limits, timings -On some systems, the underlying timings are represented -using types with sufficiently small limits that overflows -(wraparounds) are possible, such as 32-bit types. -Therefore, the values returned by this intrinsic -might be, or become, negative, -or numerically less than previous values, -during a single run of the compiled program. -") - -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{@2@}, -and the user and system components of this in @samp{@var{@1@}(1)} -and @samp{@var{@1@}(2)} respectively. -The value of @var{@2@} is equal to @samp{@var{@1@}(1) + @var{@1@}(2)}. - -@cindex wraparound, timings -@cindex limits, timings -On some systems, the underlying timings are represented -using types with sufficiently small limits that overflows -(wraparounds) are possible, such as 32-bit types. -Therefore, the values returned by this intrinsic -might be, or become, negative, -or numerically less than previous values, -during a single run of the compiled program. - -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 - -@cindex Y10K compliance -@cindex Year 10000 compliance -@cindex wraparound, Y10K -@cindex limits, Y10K -Programs making use of this intrinsic -might not be Year 10000 (Y10K) compliant. -For example, the date might appear, -to such programs, to wrap around -(change from a larger value to a smaller one) -as of the Year 10000. - -@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 - -@cindex Y10K compliance -@cindex Year 10000 compliance -@cindex wraparound, Y10K -@cindex limits, Y10K -Programs making use of this intrinsic -might not be Year 10000 (Y10K) compliant. -For example, the date might appear, -to such programs, to wrap around -(change from a larger value to a smaller one) -as of the Year 10000. - -@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. -The day (in the range 1--31), month (in the range 1--12), -and year appear in elements 1, 2, and 3 of @var{@1@}, respectively. -The year has four significant digits. - -@cindex Y10K compliance -@cindex Year 10000 compliance -@cindex wraparound, Y10K -@cindex limits, Y10K -Programs making use of this intrinsic -might not be Year 10000 (Y10K) compliant. -For example, the date might appear, -to such programs, to wrap around -(change from a larger value to a smaller one) -as of the Year 10000. -") - -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--31) in @var{@2@}, -and the year in @var{@3@} (in the range 0--99). - -@cindex Y2K compliance -@cindex Year 2000 compliance -@cindex wraparound, Y2K -@cindex limits, Y2K -This intrinsic is not recommended, due to the fact that -its return value for year wraps around century boundaries -(change from a larger value to a smaller one). -Therefore, programs making use of this intrinsic, for -instance, might not be Year 2000 (Y2K) compliant. -For example, the date might appear, -to such programs, to wrap around -as of the Year 2000. - -@xref{IDate Intrinsic (UNIX)}, for information on obtaining more digits -for the current date. -") - -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.). - -@cindex wraparound, timings -@cindex limits, timings -This intrinsic is not fully portable, such as to systems -with 32-bit @code{INTEGER} types but supporting times -wider than 32 bits. -Therefore, the values returned by this intrinsic -might be, or become, negative, -or numerically less than previous values, -during a single run of the compiled program. - -@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.). - -@cindex wraparound, timings -@cindex limits, timings -@emph{Warning:} this intrinsic does not increase the range -of the timing values over that returned by @code{clock(3)}. -On a system with a 32-bit @code{clock(3)}, -@code{@0@} will return a 32-bit value, -even though converted to an @samp{INTEGER(KIND=2)} value. -That means overflows of the 32-bit value can still occur. -Therefore, the values returned by this intrinsic -might be, or become, negative, -or numerically less than previous values, -during a single run of the compiled program. - -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@}. - -@cindex wraparound, timings -@cindex limits, timings -This values returned by this intrinsic -become numerically less than previous values -(they wrap around) during a single run of the -compiler program, under normal circumstances -(such as running through the midnight hour). -") - -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. - -@cindex wraparound, timings -@cindex limits, timings -On some systems, the underlying timings are represented -using types with sufficiently small limits that overflows -(wraparounds) are possible, such as 32-bit types. -Therefore, the values returned by this intrinsic -might be, or become, negative, -or numerically less than previous values, -during a single run of the compiled program. -") - -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. - -@cindex wraparound, timings -@cindex limits, timings -On some systems, the underlying timings are represented -using types with sufficiently small limits that overflows -(wraparounds) are possible, such as 32-bit types. -Therefore, the values returned by this intrinsic -might be, or become, negative, -or numerically less than previous values, -during a single run of the compiled program. - -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. - -@cindex wraparound, timings -@cindex limits, timings -On some systems, the underlying timings are represented -using types with sufficiently small limits that overflows -(wraparounds) are possible, such as 32-bit types. -Therefore, the values returned by this intrinsic -might be, or become, negative, -or numerically less than previous values, -during a single run of the compiled program. -") - -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)}. - -@cindex wraparound, timings -@cindex limits, timings -On some systems, the underlying timings are represented -using types with sufficiently small limits that overflows -(wraparounds) are possible, such as 32-bit types. -Therefore, the values returned by this intrinsic -might be, or become, negative, -or numerically less than previous values, -during a single run of the compiled program. -") - -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}. - -@cindex wraparound, timings -@cindex limits, timings -@emph{Warning:} this intrinsic does not increase the range -of the timing values over that returned by @code{time(3)}. -On a system with a 32-bit @code{time(3)}, -@code{@0@} will return a 32-bit value, -even though converted to an @samp{INTEGER(KIND=2)} value. -That means overflows of the 32-bit value can still occur. -Therefore, the values returned by this intrinsic -might be, or become, negative, -or numerically less than previous values, -during a single run of the compiled program. - -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}. - -@cindex wraparound, timings -@cindex limits, timings -This intrinsic is not fully portable, such as to systems -with 32-bit @code{INTEGER} types but supporting times -wider than 32 bits. -Therefore, the values returned by this intrinsic -might be, or become, negative, -or numerically less than previous values, -during a single run of the compiled program. - -@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 might 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.", "\ -Reinitializes 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 nonzero error code otherwise upon return. -See @code{chdir(3)}. - -@emph{Caution:} Using this routine during I/O to a unit connected with a -non-absolute file name can cause subsequent I/O on such a unit to fail -because the I/O library might reopen files by name. - -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 nonzero error code. -See @code{chdir(3)}. - -@emph{Caution:} Using this routine during I/O to a unit connected with a -non-absolute file name can cause subsequent I/O on such a unit to fail -because the I/O library might reopen files by name. - -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 nonzero 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 might 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 nonzero 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 might 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 nonzero 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 nonzero 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 -Device ID - -@item -Inode number - -@item -File mode - -@item -Number of links - -@item -Owner's uid - -@item -Owner's gid - -@item -ID of device containing directory entry for file -(0 if not available) - -@item -File size (bytes) - -@item -Last access time - -@item -Last modification time - -@item -Last file status change time - -@item -Preferred I/O block size (-1 if not available) - -@item -Number of blocks allocated (-1 if not available) -@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 nonzero 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 -Device ID - -@item -Inode number - -@item -File mode - -@item -Number of links - -@item -Owner's uid - -@item -Owner's gid - -@item -ID of device containing directory entry for file -(0 if not available) - -@item -File size (bytes) - -@item -Last access time - -@item -Last modification time - -@item -Last file status change time - -@item -Preferred I/O block size (-1 if not available) - -@item -Number of blocks allocated (-1 if not available) -@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 nonzero 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 -Device ID - -@item -Inode number - -@item -File mode - -@item -Number of links - -@item -Owner's uid - -@item -Owner's gid - -@item -ID of device containing directory entry for file -(0 if not available) - -@item -File size (bytes) - -@item -Last access time - -@item -Last modification time - -@item -Last file status change time - -@item -Preferred I/O block size (-1 if not available) - -@item -Number of blocks allocated (-1 if not available) -@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 nonzero 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 -Device ID - -@item -Inode number - -@item -File mode - -@item -Number of links - -@item -Owner's uid - -@item -Owner's gid - -@item -ID of device containing directory entry for file -(0 if not available) - -@item -File size (bytes) - -@item -Last access time - -@item -Last modification time - -@item -Last file status change time - -@item -Preferred I/O block size (-1 if not available) - -@item -Number of blocks allocated (-1 if not available) -@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 nonzero 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 -Device ID - -@item -Inode number - -@item -File mode - -@item -Number of links - -@item -Owner's uid - -@item -Owner's gid - -@item -ID of device containing directory entry for file -(0 if not available) - -@item -File size (bytes) - -@item -Last access time - -@item -Last modification time - -@item -Last file status change time - -@item -Preferred I/O block size (-1 if not available) - -@item -Number of blocks allocated (-1 if not available) -@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 nonzero 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 -Device ID - -@item -Inode number - -@item -File mode - -@item -Number of links - -@item -Owner's uid - -@item -Owner's gid - -@item -ID of device containing directory entry for file -(0 if not available) - -@item -File size (bytes) - -@item -Last access time - -@item -Last modification time - -@item -Last file status change time - -@item -Preferred I/O block size (-1 if not available) - -@item -Number of blocks allocated (-1 if not available) -@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 nonzero 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 nonzero 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 nonzero 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 nonzero 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 nonzero 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 nonzero 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 nonzero 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 nonzero 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 nonzero 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@}. - -@emph{Caution:} On some systems, the @code{getlogin(3)} -function, which this intrinsic calls at run time, -is either not implemented or returns a null pointer. -In the latter case, this intrinsic returns blanks -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 nonzero error code -(@code{ENOSYS} if the system does not provide @code{gethostname(2)}). - -On some systems (specifically SCO) it might be necessary to link the -``socket'' library if you call this routine. -Typically this means adding @samp{-lg2c -lsocket -lm} -to the @code{g77} command line when linking the program. -") - -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 nonzero error code upon return -(@code{ENOSYS} if the system does not provide @code{gethostname(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. - -On some systems (specifically SCO) it might be necessary to link the -``socket'' library if you call this routine. -Typically this means adding @samp{-lg2c -lsocket -lm} -to the @code{g77} command line when linking the program. -") - -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{@2@}: absolute offset if @var{@3@}=0; relative to the -current offset if @var{@3@}=1; relative to the end of the file if -@var{@3@}=2. -It branches to label @var{@4@} 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{@2@} to the name of the terminal device open on logical unit -@var{@1@} or to a blank string if @var{@1@} 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{@2@} is an integer, it can be -used to turn off handling of signal @var{@1@} or revert to its default -action. -See @code{signal(2)}. - -Note that @var{@2@} will be called using C conventions, -so the value of its argument in Fortran terms -Fortran terms is obtained by applying @code{%LOC()} (or @code{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. - -@emph{Warning:} Use of the @code{libf2c} run-time library function -@samp{signal_} directly -(such as via @samp{EXTERNAL SIGNAL}) -requires use of the @code{%VAL()} construct -to pass an @code{INTEGER} value -(such as @samp{SIG_IGN} or @samp{SIG_DFL}) -for the @var{@2@} argument. - -However, while @samp{CALL SIGNAL(@var{signum}, %VAL(SIG_IGN))} -works when @samp{SIGNAL} is treated as an external procedure -(and resolves, at link time, to @code{libf2c}'s @samp{signal_} routine), -this construct is not valid when @samp{SIGNAL} is recognized -as the intrinsic of that name. - -Therefore, for maximum portability and reliability, -code such references to the @samp{SIGNAL} facility as follows: - -@smallexample -INTRINSIC SIGNAL -@dots{} -CALL SIGNAL(@var{signum}, SIG_IGN) -@end smallexample - -@code{g77} will compile such a call correctly, -while other compilers will generally either do so as well -or reject the @samp{INTRINSIC SIGNAL} statement via a diagnostic, -allowing you to take appropriate action. -") - -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{@2@} is an integer, it can be -used to turn off handling of signal @var{@1@} or revert to its default -action. -See @code{signal(2)}. - -Note that @var{@2@} will be called using C conventions, -so the value of its argument in Fortran terms -is obtained by applying @code{%LOC()} (or @code{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. - -@emph{Warning:} If the returned value is stored in -an @code{INTEGER(KIND=1)} (default @code{INTEGER}) argument, -truncation of the original return value occurs on some systems -(such as Alphas, which have 64-bit pointers but 32-bit default integers), -with no warning issued by @code{g77} under normal circumstances. - -Therefore, the following code fragment might silently fail on -some systems: - -@smallexample -INTEGER RTN -EXTERNAL MYHNDL -RTN = SIGNAL(@var{signum}, MYHNDL) -@dots{} -! Restore original handler: -RTN = SIGNAL(@var{signum}, RTN) -@end smallexample - -The reason for the failure is that @samp{RTN} might not hold -all the information on the original handler for the signal, -thus restoring an invalid handler. -This bug could manifest itself as a spurious run-time failure -at an arbitrary point later during the program's execution, -for example. - -@emph{Warning:} Use of the @code{libf2c} run-time library function -@samp{signal_} directly -(such as via @samp{EXTERNAL SIGNAL}) -requires use of the @code{%VAL()} construct -to pass an @code{INTEGER} value -(such as @samp{SIG_IGN} or @samp{SIG_DFL}) -for the @var{@2@} argument. - -However, while @samp{RTN = SIGNAL(@var{signum}, %VAL(SIG_IGN))} -works when @samp{SIGNAL} is treated as an external procedure -(and resolves, at link time, to @code{libf2c}'s @samp{signal_} routine), -this construct is not valid when @samp{SIGNAL} is recognized -as the intrinsic of that name. - -Therefore, for maximum portability and reliability, -code such references to the @samp{SIGNAL} facility as follows: - -@smallexample -INTRINSIC SIGNAL -@dots{} -RTN = SIGNAL(@var{signum}, SIG_IGN) -@end smallexample - -@code{g77} will compile such a call correctly, -while other compilers will generally either do so as well -or reject the @samp{INTRINSIC SIGNAL} statement via a diagnostic, -allowing you to take appropriate action. -") - -DEFDOC (KILL_func, "Signal a process.", "\ -Sends the signal specified by @var{@2@} to the process @var{@1@}. -Returns 0 on success or a nonzero 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 nonzero 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)}. - -@cindex Y10K compliance -@cindex Year 10000 compliance -@cindex wraparound, Y10K -@cindex limits, Y10K -Programs making use of this intrinsic -might not be Year 10000 (Y10K) compliant. -For example, the date might appear, -to such programs, to wrap around -(change from a larger value to a smaller one) -as of the Year 10000. - -@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 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. -") - -DEFDOC (ALARM, "Execute a routine after a given delay.", "\ -Causes external subroutine @var{@2@} to be executed after a delay of -@var{@1@} seconds by using @code{alarm(1)} to set up a signal and -@code{signal(2)} to catch it. -If @var{@3@} is supplied, it will be -returned with the number of seconds remaining until any previously -scheduled alarm was due to be delivered, or zero if there was no -previously scheduled alarm. -@xref{Signal Intrinsic (subroutine)}. -") - -DEFDOC (DATE_AND_TIME, "Get the current date and time.", "\ -Returns: -@table @var -@item @1@ -The date in the form @var{ccyymmdd}: century, year, month and day; -@item @2@ -The time in the form @samp{@var{hhmmss.ss}}: hours, minutes, seconds -and milliseconds; -@item @3@ -The difference between local time and UTC (GMT) in the form @var{Shhmm}: -sign, hours and minutes, e.g.@: @samp{-0500} (winter in New York); -@item @4@ -The year, month of the year, day of the month, time difference in -minutes from UTC, hour of the day, minutes of the hour, seconds -of the minute, and milliseconds -of the second in successive values of the array. -@end table - -@cindex Y10K compliance -@cindex Year 10000 compliance -@cindex wraparound, Y10K -@cindex limits, Y10K -Programs making use of this intrinsic -might not be Year 10000 (Y10K) compliant. -For example, the date might appear, -to such programs, to wrap around -(change from a larger value to a smaller one) -as of the Year 10000. - -On systems where a millisecond timer isn't available, the millisecond -value is returned as zero. -") diff --git a/contrib/gcc-3.4/gcc/f/intdoc.texi b/contrib/gcc-3.4/gcc/f/intdoc.texi deleted file mode 100644 index e657510a06..0000000000 --- a/contrib/gcc-3.4/gcc/f/intdoc.texi +++ /dev/null @@ -1,10931 +0,0 @@ -@c This file is automatically derived from intdoc.c, intdoc.in, -@c ansify.c, intrin.def, and intrin.h. Edit those files instead. -@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:: Execute a routine after a given delay. -@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:: Common 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:: Get the current date and time. -@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:: Common 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:: Common 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 @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}. - -@noindent -Description: - -Causes external subroutine @var{Handler} to be executed after a delay of -@var{Seconds} seconds by using @code{alarm(1)} to set up a signal and -@code{signal(2)} to catch it. -If @var{Status} is supplied, it will be -returned with the number of seconds remaining until any previously -scheduled alarm was due to be delivered, or zero if there was no -previously scheduled alarm. -@xref{Signal Intrinsic (subroutine)}. - -@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} not wider than the default kind; 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} not wider than the default kind; 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 nonzero error code otherwise upon return. -See @code{chdir(3)}. - -@emph{Caution:} Using this routine during I/O to a unit connected with a -non-absolute file name can cause subsequent I/O on such a unit to fail -because the I/O library might reopen files by name. - -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 nonzero error code. -See @code{chdir(3)}. - -@emph{Caution:} Using this routine during I/O to a unit connected with a -non-absolute file name can cause subsequent I/O on such a unit to fail -because the I/O library might reopen files by name. - -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 nonzero 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 might 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 nonzero 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 might 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}; 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)}. - -@cindex wraparound, timings -@cindex limits, timings -On some systems, the underlying timings are represented -using types with sufficiently small limits that overflows -(wraparounds) are possible, such as 32-bit types. -Therefore, the values returned by this intrinsic -might be, or become, negative, -or numerically less than previous values, -during a single run of the compiled program. - -@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{STime}, @var{Result}) -@end example - -@noindent -@var{STime}: @code{INTEGER}; scalar; INTENT(IN). - -@noindent -@var{Result}: @code{CHARACTER}; scalar; INTENT(OUT). - -@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}. - -@cindex Y2K compliance -@cindex Year 2000 compliance -This intrinsic is not recommended, due to the year 2000 approaching. -Therefore, programs making use of this intrinsic -might not be Year 2000 (Y2K) compliant. -@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 - -@noindent -@example -CALL Date_and_Time(@var{Date}, @var{Time}, @var{Zone}, @var{Values}) -@end example - -@noindent -@var{Date}: @code{CHARACTER}; scalar; INTENT(OUT). - -@noindent -@var{Time}: @code{CHARACTER}; OPTIONAL; scalar; INTENT(OUT). - -@noindent -@var{Zone}: @code{CHARACTER}; OPTIONAL; scalar; INTENT(OUT). - -@noindent -@var{Values}: @code{INTEGER(KIND=1)}; OPTIONAL; DIMENSION(8); INTENT(OUT). - -@noindent -Intrinsic groups: @code{f90}. - -@noindent -Description: - -Returns: -@table @var -@item Date -The date in the form @var{ccyymmdd}: century, year, month and day; -@item Time -The time in the form @samp{@var{hhmmss.ss}}: hours, minutes, seconds -and milliseconds; -@item Zone -The difference between local time and UTC (GMT) in the form @var{Shhmm}: -sign, hours and minutes, e.g.@: @samp{-0500} (winter in New York); -@item Values -The year, month of the year, day of the month, time difference in -minutes from UTC, hour of the day, minutes of the hour, seconds -of the minute, and milliseconds -of the second in successive values of the array. -@end table - -@cindex Y10K compliance -@cindex Year 10000 compliance -@cindex wraparound, Y10K -@cindex limits, Y10K -Programs making use of this intrinsic -might not be Year 10000 (Y10K) compliant. -For example, the date might appear, -to such programs, to wrap around -(change from a larger value to a smaller one) -as of the Year 10000. - -On systems where a millisecond timer isn't available, the millisecond -value is returned as zero. - -@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} not wider than the default kind; 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} not wider than the default kind; 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{Conjg 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{Dble Intrinsic}, for information on the standard FORTRAN 77 -replacement for @code{DREAL()}. - -@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{TArray}, @var{Result}) -@end example - -@noindent -@var{TArray}: @code{REAL(KIND=1)}; DIMENSION(2); INTENT(OUT). - -@noindent -@var{Result}: @code{REAL(KIND=1)}; scalar; 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. - -@cindex wraparound, timings -@cindex limits, timings -On some systems, the underlying timings are represented -using types with sufficiently small limits that overflows -(wraparounds) are possible, such as 32-bit types. -Therefore, the values returned by this intrinsic -might be, or become, negative, -or numerically less than previous values, -during a single run of the compiled program. - -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. - -@cindex wraparound, timings -@cindex limits, timings -On some systems, the underlying timings are represented -using types with sufficiently small limits that overflows -(wraparounds) are possible, such as 32-bit types. -Therefore, the values returned by this intrinsic -might be, or become, negative, -or numerically less than previous values, -during a single run of the compiled program. - -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 might 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{TArray}, @var{Result}) -@end example - -@noindent -@var{TArray}: @code{REAL(KIND=1)}; DIMENSION(2); INTENT(OUT). - -@noindent -@var{Result}: @code{REAL(KIND=1)}; scalar; 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)}. - -@cindex wraparound, timings -@cindex limits, timings -On some systems, the underlying timings are represented -using types with sufficiently small limits that overflows -(wraparounds) are possible, such as 32-bit types. -Therefore, the values returned by this intrinsic -might be, or become, negative, -or numerically less than previous values, -during a single run of the compiled program. - -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)}. - -@cindex wraparound, timings -@cindex limits, timings -On some systems, the underlying timings are represented -using types with sufficiently small limits that overflows -(wraparounds) are possible, such as 32-bit types. -Therefore, the values returned by this intrinsic -might be, or become, negative, -or numerically less than previous values, -during a single run of the compiled program. - -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} not wider than the default kind; 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 - -@cindex Y10K compliance -@cindex Year 10000 compliance -@cindex wraparound, Y10K -@cindex limits, Y10K -Programs making use of this intrinsic -might not be Year 10000 (Y10K) compliant. -For example, the date might appear, -to such programs, to wrap around -(change from a larger value to a smaller one) -as of the Year 10000. - -@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 - -@cindex Y10K compliance -@cindex Year 10000 compliance -@cindex wraparound, Y10K -@cindex limits, Y10K -Programs making use of this intrinsic -might not be Year 10000 (Y10K) compliant. -For example, the date might appear, -to such programs, to wrap around -(change from a larger value to a smaller one) -as of the Year 10000. - -@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{Whence}=0; relative to the -current offset if @var{Whence}=1; relative to the end of the file if -@var{Whence}=2. -It branches to label @var{ErrLab} 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 -Device ID - -@item -Inode number - -@item -File mode - -@item -Number of links - -@item -Owner's uid - -@item -Owner's gid - -@item -ID of device containing directory entry for file -(0 if not available) - -@item -File size (bytes) - -@item -Last access time - -@item -Last modification time - -@item -Last file status change time - -@item -Preferred I/O block size (-1 if not available) - -@item -Number of blocks allocated (-1 if not available) -@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 nonzero 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 -Device ID - -@item -Inode number - -@item -File mode - -@item -Number of links - -@item -Owner's uid - -@item -Owner's gid - -@item -ID of device containing directory entry for file -(0 if not available) - -@item -File size (bytes) - -@item -Last access time - -@item -Last modification time - -@item -Last file status change time - -@item -Preferred I/O block size (-1 if not available) - -@item -Number of blocks allocated (-1 if not available) -@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 nonzero 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} not wider than the default kind; 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 nonzero 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 nonzero 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}. - -@emph{Caution:} On some systems, the @code{getlogin(3)} -function, which this intrinsic calls at run time, -is either not implemented or returns a null pointer. -In the latter case, this intrinsic returns blanks -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 nonzero error code upon return -(@code{ENOSYS} if the system does not provide @code{gethostname(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. - -On some systems (specifically SCO) it might be necessary to link the -``socket'' library if you call this routine. -Typically this means adding @samp{-lg2c -lsocket -lm} -to the @code{g77} command line when linking the program. - -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 nonzero error code -(@code{ENOSYS} if the system does not provide @code{gethostname(2)}). - -On some systems (specifically SCO) it might be necessary to link the -``socket'' library if you call this routine. -Typically this means adding @samp{-lg2c -lsocket -lm} -to the @code{g77} command line when linking the program. - -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. -The day (in the range 1--31), month (in the range 1--12), -and year appear in elements 1, 2, and 3 of @var{TArray}, respectively. -The year has four significant digits. - -@cindex Y10K compliance -@cindex Year 10000 compliance -@cindex wraparound, Y10K -@cindex limits, Y10K -Programs making use of this intrinsic -might not be Year 10000 (Y10K) compliant. -For example, the date might appear, -to such programs, to wrap around -(change from a larger value to a smaller one) -as of the Year 10000. - -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--31) in @var{D}, -and the year in @var{Y} (in the range 0--99). - -@cindex Y2K compliance -@cindex Year 2000 compliance -@cindex wraparound, Y2K -@cindex limits, Y2K -This intrinsic is not recommended, due to the fact that -its return value for year wraps around century boundaries -(change from a larger value to a smaller one). -Therefore, programs making use of this intrinsic, for -instance, might not be Year 2000 (Y2K) compliant. -For example, the date might appear, -to such programs, to wrap around -as of the Year 2000. - -@xref{IDate Intrinsic (UNIX)}, for information on obtaining more digits -for the current date. - -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{DIM()} that is specific -to one type for @var{X} and @var{Y}. -@xref{DiM 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}, @code{REAL}, or @code{COMPLEX}; 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 disregarded. - -@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}, @code{REAL}, or @code{COMPLEX}; 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 disregarded. - -@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 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{SIGN()} that is specific -to one type for @var{A} and @var{B}. -@xref{Sign 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 nonzero 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 nonzero 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 nonzero 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 nonzero 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=7)} 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 `common' (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 common logarithm (base 10) of @var{X}, which must -be greater than 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 -Device ID - -@item -Inode number - -@item -File mode - -@item -Number of links - -@item -Owner's uid - -@item -Owner's gid - -@item -ID of device containing directory entry for file -(0 if not available) - -@item -File size (bytes) - -@item -Last access time - -@item -Last modification time - -@item -Last file status change time - -@item -Preferred I/O block size (-1 if not available) - -@item -Number of blocks allocated (-1 if not available) -@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 nonzero 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 -Device ID - -@item -Inode number - -@item -File mode - -@item -Number of links - -@item -Owner's uid - -@item -Owner's gid - -@item -ID of device containing directory entry for file -(0 if not available) - -@item -File size (bytes) - -@item -Last access time - -@item -Last modification time - -@item -Last file status change time - -@item -Preferred I/O block size (-1 if not available) - -@item -Number of blocks allocated (-1 if not available) -@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 nonzero 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.). - -@cindex wraparound, timings -@cindex limits, timings -This intrinsic is not fully portable, such as to systems -with 32-bit @code{INTEGER} types but supporting times -wider than 32 bits. -Therefore, the values returned by this intrinsic -might be, or become, negative, -or numerically less than previous values, -during a single run of the compiled program. - -@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.). - -@cindex wraparound, timings -@cindex limits, timings -@emph{Warning:} this intrinsic does not increase the range -of the timing values over that returned by @code{clock(3)}. -On a system with a 32-bit @code{clock(3)}, -@code{MCLOCK8} will return a 32-bit value, -even though converted to an @samp{INTEGER(KIND=2)} value. -That means overflows of the 32-bit value can still occur. -Therefore, the values returned by this intrinsic -might be, or become, negative, -or numerically less than previous values, -during a single run of the compiled program. - -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 nonzero 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 nonzero 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}. - -@cindex wraparound, timings -@cindex limits, timings -This values returned by this intrinsic -become numerically less than previous values -(they wrap around) during a single run of the -compiler program, under normal circumstances -(such as running through the midnight hour). - -@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. - -@cindex wraparound, timings -@cindex limits, timings -On some systems, the underlying timings are represented -using types with sufficiently small limits that overflows -(wraparounds) are possible, such as 32-bit types. -Therefore, the values returned by this intrinsic -might be, or become, negative, -or numerically less than previous values, -during a single run of the compiled program. - -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}; 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. - -@cindex wraparound, timings -@cindex limits, timings -On some systems, the underlying timings are represented -using types with sufficiently small limits that overflows -(wraparounds) are possible, such as 32-bit types. -Therefore, the values returned by this intrinsic -might be, or become, negative, -or numerically less than previous values, -during a single run of the compiled program. - -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 disregarded. - -@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=7)}; 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{Handler} is an integer, it can be -used to turn off handling of signal @var{Number} or revert to its default -action. -See @code{signal(2)}. - -Note that @var{Handler} will be called using C conventions, -so the value of its argument in Fortran terms -Fortran terms is obtained by applying @code{%LOC()} (or @code{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. - -@emph{Warning:} Use of the @code{libf2c} run-time library function -@samp{signal_} directly -(such as via @samp{EXTERNAL SIGNAL}) -requires use of the @code{%VAL()} construct -to pass an @code{INTEGER} value -(such as @samp{SIG_IGN} or @samp{SIG_DFL}) -for the @var{Handler} argument. - -However, while @samp{CALL SIGNAL(@var{signum}, %VAL(SIG_IGN))} -works when @samp{SIGNAL} is treated as an external procedure -(and resolves, at link time, to @code{libf2c}'s @samp{signal_} routine), -this construct is not valid when @samp{SIGNAL} is recognized -as the intrinsic of that name. - -Therefore, for maximum portability and reliability, -code such references to the @samp{SIGNAL} facility as follows: - -@smallexample -INTRINSIC SIGNAL -@dots{} -CALL SIGNAL(@var{signum}, SIG_IGN) -@end smallexample - -@code{g77} will compile such a call correctly, -while other compilers will generally either do so as well -or reject the @samp{INTRINSIC SIGNAL} statement via a diagnostic, -allowing you to take appropriate action. - -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=7)} 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{Handler} is an integer, it can be -used to turn off handling of signal @var{Number} or revert to its default -action. -See @code{signal(2)}. - -Note that @var{Handler} will be called using C conventions, -so the value of its argument in Fortran terms -is obtained by applying @code{%LOC()} (or @code{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. - -@emph{Warning:} If the returned value is stored in -an @code{INTEGER(KIND=1)} (default @code{INTEGER}) argument, -truncation of the original return value occurs on some systems -(such as Alphas, which have 64-bit pointers but 32-bit default integers), -with no warning issued by @code{g77} under normal circumstances. - -Therefore, the following code fragment might silently fail on -some systems: - -@smallexample -INTEGER RTN -EXTERNAL MYHNDL -RTN = SIGNAL(@var{signum}, MYHNDL) -@dots{} -! Restore original handler: -RTN = SIGNAL(@var{signum}, RTN) -@end smallexample - -The reason for the failure is that @samp{RTN} might not hold -all the information on the original handler for the signal, -thus restoring an invalid handler. -This bug could manifest itself as a spurious run-time failure -at an arbitrary point later during the program's execution, -for example. - -@emph{Warning:} Use of the @code{libf2c} run-time library function -@samp{signal_} directly -(such as via @samp{EXTERNAL SIGNAL}) -requires use of the @code{%VAL()} construct -to pass an @code{INTEGER} value -(such as @samp{SIG_IGN} or @samp{SIG_DFL}) -for the @var{Handler} argument. - -However, while @samp{RTN = SIGNAL(@var{signum}, %VAL(SIG_IGN))} -works when @samp{SIGNAL} is treated as an external procedure -(and resolves, at link time, to @code{libf2c}'s @samp{signal_} routine), -this construct is not valid when @samp{SIGNAL} is recognized -as the intrinsic of that name. - -Therefore, for maximum portability and reliability, -code such references to the @samp{SIGNAL} facility as follows: - -@smallexample -INTRINSIC SIGNAL -@dots{} -RTN = SIGNAL(@var{signum}, SIG_IGN) -@end smallexample - -@code{g77} will compile such a call correctly, -while other compilers will generally either do so as well -or reject the @samp{INTRINSIC SIGNAL} statement via a diagnostic, -allowing you to take appropriate action. - -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: - -Reinitializes 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 -Device ID - -@item -Inode number - -@item -File mode - -@item -Number of links - -@item -Owner's uid - -@item -Owner's gid - -@item -ID of device containing directory entry for file -(0 if not available) - -@item -File size (bytes) - -@item -Last access time - -@item -Last modification time - -@item -Last file status change time - -@item -Preferred I/O block size (-1 if not available) - -@item -Number of blocks allocated (-1 if not available) -@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 nonzero 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 -Device ID - -@item -Inode number - -@item -File mode - -@item -Number of links - -@item -Owner's uid - -@item -Owner's gid - -@item -ID of device containing directory entry for file -(0 if not available) - -@item -File size (bytes) - -@item -Last access time - -@item -Last modification time - -@item -Last file status change time - -@item -Preferred I/O block size (-1 if not available) - -@item -Number of blocks allocated (-1 if not available) -@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 nonzero 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 nonzero 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 nonzero 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)}; OPTIONAL; scalar; INTENT(OUT). - -@noindent -@var{Max}: @code{INTEGER(KIND=1)}; OPTIONAL; 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. - -@cindex wraparound, timings -@cindex limits, timings -On some systems, the underlying timings are represented -using types with sufficiently small limits that overflows -(wraparounds) are possible, such as 32-bit types. -Therefore, the values returned by this intrinsic -might be, or become, negative, -or numerically less than previous values, -during a single run of the compiled program. - -@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}. - -@cindex wraparound, timings -@cindex limits, timings -This intrinsic is not fully portable, such as to systems -with 32-bit @code{INTEGER} types but supporting times -wider than 32 bits. -Therefore, the values returned by this intrinsic -might be, or become, negative, -or numerically less than previous values, -during a single run of the compiled program. - -@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)}. - -@cindex Y10K compliance -@cindex Year 10000 compliance -@cindex wraparound, Y10K -@cindex limits, Y10K -Programs making use of this intrinsic -might not be Year 10000 (Y10K) compliant. -For example, the date might appear, -to such programs, to wrap around -(change from a larger value to a smaller one) -as of the Year 10000. - -@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}. - -@cindex wraparound, timings -@cindex limits, timings -@emph{Warning:} this intrinsic does not increase the range -of the timing values over that returned by @code{time(3)}. -On a system with a 32-bit @code{time(3)}, -@code{TIME8} will return a 32-bit value, -even though converted to an @samp{INTEGER(KIND=2)} value. -That means overflows of the 32-bit value can still occur. -Therefore, the values returned by this intrinsic -might be, or become, negative, -or numerically less than previous values, -during a single run of the compiled program. - -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{Unit}, @var{Name}) -@end example - -@noindent -@var{Unit}: @code{INTEGER}; scalar; INTENT(IN). - -@noindent -@var{Name}: @code{CHARACTER}; scalar; INTENT(OUT). - -@noindent -Intrinsic groups: @code{unix}. - -@noindent -Description: - -Sets @var{Name} to the name of the terminal device open on logical unit -@var{Unit} or to 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 nonzero 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 nonzero 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/contrib/gcc-3.4/gcc/f/intrin.c b/contrib/gcc-3.4/gcc/f/intrin.c deleted file mode 100644 index a379684ae4..0000000000 --- a/contrib/gcc-3.4/gcc/f/intrin.c +++ /dev/null @@ -1,2119 +0,0 @@ -/* intrin.c -- Recognize references to intrinsics - Copyright (C) 1995, 1996, 1997, 1998, 2002, - 2003 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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 "intrin.h" -#include "expr.h" -#include "info.h" -#include "src.h" -#include "symbol.h" -#include "target.h" -#include "top.h" - -struct _ffeintrin_name_ - { - const char *const name_uc; - const char *const name_lc; - const char *const name_ic; - const ffeintrinGen generic; - const ffeintrinSpec specific; - }; - -struct _ffeintrin_gen_ - { - const char *const name; /* Name as seen in program. */ - const ffeintrinSpec specs[2]; - }; - -struct _ffeintrin_spec_ - { - const char *const name; /* Uppercase name as seen in source code, - lowercase if no source name, "none" if no - name at all (NONE case). */ - const bool is_actualarg; /* Ok to pass as actual arg if -pedantic. */ - const ffeintrinFamily family; - const ffeintrinImp implementation; - }; - -struct _ffeintrin_imp_ - { - const char *const name; /* Name of implementation. */ - const ffecomGfrt gfrt_direct;/* library routine, direct-callable form. */ - const ffecomGfrt gfrt_f2c; /* library routine, f2c-callable form. */ - const ffecomGfrt gfrt_gnu; /* library routine, gnu-callable form. */ - const char *const control; - const char y2kbad; - }; - -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 const 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) -#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD) -#include "intrin.def" -#undef DEFNAME -#undef DEFGEN -#undef DEFSPEC -#undef DEFIMP -#undef DEFIMPY -}; - -static const 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) -#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD) -#include "intrin.def" -#undef DEFNAME -#undef DEFGEN -#undef DEFSPEC -#undef DEFIMP -#undef DEFIMPY -}; - -static const 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) -#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) \ - { NAME, FFECOM_gfrt ## GFRTDIRECT, FFECOM_gfrt ## GFRTF2C, \ - FFECOM_gfrt ## GFRTGNU, CONTROL, FALSE }, -#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD) \ - { NAME, FFECOM_gfrt ## GFRTDIRECT, FFECOM_gfrt ## GFRTF2C, \ - FFECOM_gfrt ## GFRTGNU, CONTROL, Y2KBAD }, -#include "intrin.def" -#undef DEFNAME -#undef DEFGEN -#undef DEFSPEC -#undef DEFIMP -#undef DEFIMPY -}; - -static const 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) -#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD) -#include "intrin.def" -#undef DEFGEN -#undef DEFSPEC -#undef DEFIMP -#undef DEFIMPY -}; - - -static ffebad -ffeintrin_check_ (ffeintrinImp imp, ffebldOp op, - ffebld args, ffeinfoBasictype *xbt, - ffeinfoKindtype *xkt, - ffetargetCharacterSize *xsz, - bool *check_intrin, - ffelexToken t, - bool commit) -{ - const char *c = ffeintrin_imps_[imp].control; - bool subr = (c[0] == '-'); - const 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; - - case 7: - akt = ffecom_pointer_kind (); - 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 'N': - /* Accept integers and logicals not wider than the default integer/logical. */ - if (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER) - { - okay &= anynum || (ffeinfo_kindtype (i) == FFEINFO_kindtypeINTEGER1 - || ffeinfo_kindtype (i) == FFEINFO_kindtypeINTEGER2 - || ffeinfo_kindtype (i) == FFEINFO_kindtypeINTEGER3); - akt = FFEINFO_kindtypeINTEGER1; /* The default. */ - } - else if (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL) - { - okay &= anynum || (ffeinfo_kindtype (i) == FFEINFO_kindtypeLOGICAL1 - || ffeinfo_kindtype (i) == FFEINFO_kindtypeLOGICAL2 - || ffeinfo_kindtype (i) == FFEINFO_kindtypeLOGICAL3); - akt = FFEINFO_kindtypeLOGICAL1; /* The default. */ - } - 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); - } - - 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; - - case 7: - kt = ffecom_pointer_kind (); - break; - } - } - break; - - case 'C': - if (ffe_is_90 ()) - need_col = TRUE; - kt = 1; - 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; - int arg_count=0; - - for (arg = args, arg_count=0; - arg != NULL; - arg = ffebld_trail (arg), arg_count++ ) - { - ffebld a = ffebld_head (arg); - ffeinfo i; - bool anynum; - - if (a == NULL) - continue; - i = ffebld_info (a); - - if ( c[colon+1] != '*' && (c[colon+1]-'0') != arg_count ) - continue; - - 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; - - case 7: - akt = ffecom_pointer_kind (); - 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 a forced-to-uppercase name with a known-upper-case name. */ - -static int -upcasecmp_ (const char *name, const char *ucname) -{ - for ( ; *name != 0 && *ucname != 0; name++, ucname++) - { - int i = TOUPPER(*name) - *ucname; - - if (i != 0) - return i; - } - - return *name - *ucname; -} - -/* Compare name to intrinsic's name. - The intrinsics table is sorted on the upper case entries; so first - compare irrespective of case on the `uc' entry. If it matches, - compare according to the setting of intrinsics case comparison mode. */ - -static int -ffeintrin_cmp_name_ (const void *name, const void *intrinsic) -{ - const char *const uc = ((const struct _ffeintrin_name_ *) intrinsic)->name_uc; - const char *const lc = ((const struct _ffeintrin_name_ *) intrinsic)->name_lc; - const char *const ic = ((const struct _ffeintrin_name_ *) intrinsic)->name_ic; - int i; - - if ((i = upcasecmp_ (name, uc)) == 0) - { - switch (ffe_case_intrin ()) - { - case FFE_caseLOWER: - return strcmp(name, lc); - case FFE_caseINITCAP: - return strcmp(name, ic); - default: - return 0; - } - } - - return i; -} - -/* 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) input_line, - 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 != FFETARGET_charactersizeNONE) - && (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 (); - } - if (ffeintrin_imps_[imp].y2kbad) - { - ffebad_start (FFEBAD_INTRINSIC_Y2KBAD); - 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; - const 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 (); - } - if (ffeintrin_imps_[imp].y2kbad) - { - ffebad_start (FFEBAD_INTRINSIC_Y2KBAD); - 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. */ - -ffecomGfrt -ffeintrin_gfrt_direct (ffeintrinImp imp) -{ - assert (imp < FFEINTRIN_imp); - - return ffeintrin_imps_[imp].gfrt_direct; -} - -/* Return run-time index of intrinsic implementation as actual argument. */ - -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; -} - -void -ffeintrin_init_0 (void) -{ - int i; - const char *p1; - const char *p2; - const 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 ((ISDIGIT (*p1) || (*p1 == '_')) && (*p1 == *p2) && (*p1 == *p3)) - continue; - if (! ISUPPER ((unsigned char)*p1) || ! ISLOWER ((unsigned char)*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) - { - const 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')) - { - 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] != '*') - && (! ISDIGIT (c[colon + 1]))) - { - 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] == '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')) - { - fprintf (stderr, "%s: bad arg-base-type\n", - ffeintrin_imps_[i].name); - break; - } - if ((c[2] != '*') - && ((c[2] < '1') - || (c[2] > '9')) - && (c[2] != 'A')) - { - fprintf (stderr, "%s: bad arg-kind-type\n", - ffeintrin_imps_[i].name); - break; - } - if (c[3] == '[') - { - if ((! ISDIGIT (c[4])) - || ((c[5] != ']') - && (++c, ! ISDIGIT (c[4]) - || (c[5] != ']')))) - { - fprintf (stderr, "%s: bad arg-len\n", - ffeintrin_imps_[i].name); - break; - } - c += 3; - } - if (c[3] == '(') - { - if ((! ISDIGIT (c[4])) - || ((c[5] != ')') - && (++c, ! ISDIGIT (c[4]) - || (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; - continue; - } - 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) - && (ffe_is_f2c () - ? (ffeintrin_imps_[ffeintrin_specs_[spec].implementation].gfrt_f2c - != FFECOM_gfrt) - : (ffeintrin_imps_[ffeintrin_specs_[spec].implementation].gfrt_gnu - != FFECOM_gfrt)) - && ((state == FFE_intrinsicstateENABLED) - || (state == FFE_intrinsicstateHIDDEN)); -} - -/* Determine if name is intrinsic, return info. - - const 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 (const 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. */ - -const char * -ffeintrin_name_generic (ffeintrinGen gen) -{ - assert (gen < FFEINTRIN_gen); - return ffeintrin_gens_[gen].name; -} - -/* Return name of intrinsic implementation. */ - -const char * -ffeintrin_name_implementation (ffeintrinImp imp) -{ - assert (imp < FFEINTRIN_imp); - return ffeintrin_imps_[imp].name; -} - -/* Return external/internal name of specific intrinsic. */ - -const 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/contrib/gcc-3.4/gcc/f/intrin.def b/contrib/gcc-3.4/gcc/f/intrin.def deleted file mode 100644 index 5d712ba21c..0000000000 --- a/contrib/gcc-3.4/gcc/f/intrin.def +++ /dev/null @@ -1,3358 +0,0 @@ -/* 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_impDATE_AND_TIME - ) -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 DEFIMPY macro specifies the above, plus: - - Y2KBAD -- TRUE if the intrinsic is known to be non-Y2K-compliant, - FALSE if it is known to be Y2K-compliant. (In terms of - interface and libg2c implementation.) - -*/ - -/* 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) - 7 (Same size as `char *') - C Like 1 (F77), except (F90), if COL is COMPLEX, uses kind type of COL - - 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 - N Not wider than the default kind - - 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", L_LOG10,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", L_FMOD,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", L_LOG10,DLOG10,,"R2:-:X=R2") -DEFIMP (DMAX1, "DMAX1", ,,, "R2:*:A=pR2") -DEFIMP (DMIN1, "DMIN1", ,,, "R2:*:A=pR2") -DEFIMP (DMOD, "DMOD", L_FMOD,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", L_LOG10,ALOG10,,"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=IN,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=IN,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", SECOND,,, "--:-:Seconds=R*w") -DEFIMP (CTIME_func, "CTIME_func", CTIME,,, "A1*:-:STime=I*") -DEFIMP (CTIME_subr, "CTIME_subr", CTIME,,, "--:-:STime=I*,Result=A1w") -DEFIMPY (DATE, "DATE", DATE,,, "--:-:Date=A1w", TRUE) -DEFIMP (DATE_AND_TIME, "DATE_AND_TIME", DATE_AND_TIME,,, "--:-:Date=A1w,Time=?A1w,Zone=?A1w,Values=?I1(8)w") -DEFIMP (DBESJ0, "DBESJ0", L_BESJ0,,, "R2:-:X=R2") -DEFIMP (DBESJ1, "DBESJ1", L_BESJ1,,, "R2:-:X=R2") -DEFIMP (DBESJN, "DBESJN", L_BESJN,,, "R2:-:N=IN,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=IN,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,,, "--:-:TArray=R1(2)w,Result=R1w") -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,,, "--:-:TArray=R1(2)w,Result=R1w") -DEFIMP (EXIT, "EXIT", EXIT,,, "--:-:Status=?IN") -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=IN,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") -DEFIMPY (IDATE_vxt, "IDATE_vxt", VXTIDATE,,, "--:-:M=I1w,D=I1w,Y=I1w", TRUE) -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=N*") -DEFIMP (INT8, "INT8", ,,, "I2:-:A=N*") -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", ,,, "I7:-: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=R*w") -DEFIMP (SHORT, "SHORT", ,,, "I6:-:A=I*") -DEFIMP (SIGNAL_func, "SIGNAL_func", L_SIGNAL,,, "I7:-:Number=I*,Handler=s*") -DEFIMP (SIGNAL_subr, "SIGNAL_subr", L_SIGNAL,,, "--:-:Number=I*,Handler=s*,Status=?I7w") -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,,, "--:-:Unit=I*,Name=A1w") -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/contrib/gcc-3.4/gcc/f/intrin.h b/contrib/gcc-3.4/gcc/f/intrin.h deleted file mode 100644 index e741e69b4e..0000000000 --- a/contrib/gcc-3.4/gcc/f/intrin.h +++ /dev/null @@ -1,135 +0,0 @@ -/* intrin.h -- Public interface for intrin.c - Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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 GCC_F_INTRIN_H -#define GCC_F_INTRIN_H - -#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) -#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD) -#include "intrin.def" -#undef DEFNAME -#undef DEFGEN -#undef DEFSPEC -#undef DEFIMP -#undef DEFIMPY - 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) -#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD) -#include "intrin.def" -#undef DEFNAME -#undef DEFGEN -#undef DEFSPEC -#undef DEFIMP -#undef DEFIMPY - 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, -#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD) \ - FFEINTRIN_imp ## CODE, -#include "intrin.def" -#undef DEFNAME -#undef DEFGEN -#undef DEFSPEC -#undef DEFIMP -#undef DEFIMPY - 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); -ffecomGfrt ffeintrin_gfrt_direct (ffeintrinImp imp); -ffecomGfrt ffeintrin_gfrt_indirect (ffeintrinImp imp); -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 (const 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); -const char *ffeintrin_name_generic (ffeintrinGen gen); -const char *ffeintrin_name_implementation (ffeintrinImp imp); -const 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 /* ! GCC_F_INTRIN_H */ diff --git a/contrib/gcc-3.4/gcc/f/invoke.texi b/contrib/gcc-3.4/gcc/f/invoke.texi deleted file mode 100644 index fd1b80412a..0000000000 --- a/contrib/gcc-3.4/gcc/f/invoke.texi +++ /dev/null @@ -1,2233 +0,0 @@ -@c Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2004 -@c Free Software Foundation, Inc. -@c This is part of the G77 manual. -@c For copying conditions, see the file g77.texi. - -@ignore -@c man begin COPYRIGHT -Copyright @copyright{} 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2004 -Free Software Foundation, Inc. - -Permission is granted to copy, distribute and/or modify this document -under the terms of the GNU Free Documentation License, Version 1.2 or -any later version published by the Free Software Foundation; with the -Invariant Sections being ``GNU General Public License'' and ``Funding -Free Software'', the Front-Cover texts being (a) (see below), and with -the Back-Cover Texts being (b) (see below). A copy of the license is -included in the gfdl(7) man page. - -(a) The FSF's Front-Cover Text is: - - A GNU Manual - -(b) The FSF's Back-Cover Text is: - - You have freedom to copy and modify this GNU Manual, like GNU - software. Copies published by the Free Software Foundation raise - funds for GNU development. -@c man end -@c Set file name and title for the man page. -@setfilename g77 -@settitle GNU project Fortran 77 compiler. -@c man begin SYNOPSIS -g77 [@option{-c}|@option{-S}|@option{-E}] - [@option{-g}] [@option{-pg}] [@option{-O}@var{level}] - [@option{-W}@var{warn}@dots{}] [@option{-pedantic}] - [@option{-I}@var{dir}@dots{}] [@option{-L}@var{dir}@dots{}] - [@option{-D}@var{macro}[=@var{defn}]@dots{}] [@option{-U}@var{macro}] - [@option{-f}@var{option}@dots{}] [@option{-m}@var{machine-option}@dots{}] - [@option{-o} @var{outfile}] @var{infile}@dots{} - -Only the most useful options are listed here; see below for the -remainder. -@c man end -@c man begin SEEALSO -gpl(7), gfdl(7), fsf-funding(7), -cpp(1), gcov(1), gcc(1), as(1), ld(1), gdb(1), adb(1), dbx(1), sdb(1) -and the Info entries for @file{gcc}, @file{cpp}, @file{g77}, @file{as}, -@file{ld}, @file{binutils} and @file{gdb}. -@c man end -@c man begin BUGS -For instructions on reporting bugs, see -@w{@uref{http://gcc.gnu.org/bugs.html}}. Use of the @command{gccbug} -script to report bugs is recommended. -@c man end -@c man begin AUTHOR -See the Info entry for @command{g77} for contributors to GCC and G77@. -@c man end -@end ignore - -@node Invoking G77 -@chapter GNU Fortran Command Options -@cindex GNU Fortran command options -@cindex command options -@cindex options, GNU Fortran command - -@c man begin DESCRIPTION - -The @command{g77} command supports all the options supported by the -@command{gcc} command. -@xref{Invoking GCC,,GCC Command Options,gcc,Using the GNU Compiler -Collection (GCC)}, for information -on the non-Fortran-specific aspects of the @command{gcc} command (and, -therefore, the @command{g77} command). - -@cindex options, negative forms -@cindex negative forms of options -All @command{gcc} and @command{g77} options -are accepted both by @command{g77} and by @command{gcc} -(as well as any other drivers built at the same time, -such as @command{g++}), -since adding @command{g77} to the @command{gcc} distribution -enables acceptance of @command{g77} options -by all of the relevant drivers. - -In some cases, options have positive and negative forms; -the negative form of @option{-ffoo} would be @option{-fno-foo}. -This manual documents only one of these two forms, whichever -one is not the default. - -@c man end - -@menu -* Option Summary:: Brief list of all @command{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 - -@c man begin OPTIONS - -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}. -@gccoptlist{ --fversion -fset-g77-defaults -fno-silent} - -@item Shorthand Options -@xref{Shorthand Options}. -@gccoptlist{ --ff66 -fno-f66 -ff77 -fno-f77 -fno-ugly} - -@item Fortran Language Options -@xref{Fortran Dialect Options,,Options Controlling Fortran Dialect}. -@gccoptlist{ --ffree-form -fno-fixed-form -ff90 @gol --fvxt -fdollar-ok -fno-backslash @gol --fno-ugly-args -fno-ugly-assign -fno-ugly-assumed @gol --fugly-comma -fugly-complex -fugly-init -fugly-logint @gol --fonetrip -ftypeless-boz @gol --fintrin-case-initcap -fintrin-case-upper @gol --fintrin-case-lower -fintrin-case-any @gol --fmatch-case-initcap -fmatch-case-upper @gol --fmatch-case-lower -fmatch-case-any @gol --fsource-case-upper -fsource-case-lower @gol --fsource-case-preserve @gol --fsymbol-case-initcap -fsymbol-case-upper @gol --fsymbol-case-lower -fsymbol-case-any @gol --fcase-strict-upper -fcase-strict-lower @gol --fcase-initcap -fcase-upper -fcase-lower -fcase-preserve @gol --ff2c-intrinsics-delete -ff2c-intrinsics-hide @gol --ff2c-intrinsics-disable -ff2c-intrinsics-enable @gol --fbadu77-intrinsics-delete -fbadu77-intrinsics-hide @gol --fbadu77-intrinsics-disable -fbadu77-intrinsics-enable @gol --ff90-intrinsics-delete -ff90-intrinsics-hide @gol --ff90-intrinsics-disable -ff90-intrinsics-enable @gol --fgnu-intrinsics-delete -fgnu-intrinsics-hide @gol --fgnu-intrinsics-disable -fgnu-intrinsics-enable @gol --fmil-intrinsics-delete -fmil-intrinsics-hide @gol --fmil-intrinsics-disable -fmil-intrinsics-enable @gol --funix-intrinsics-delete -funix-intrinsics-hide @gol --funix-intrinsics-disable -funix-intrinsics-enable @gol --fvxt-intrinsics-delete -fvxt-intrinsics-hide @gol --fvxt-intrinsics-disable -fvxt-intrinsics-enable @gol --ffixed-line-length-@var{n} -ffixed-line-length-none} - -@item Warning Options -@xref{Warning Options,,Options to Request or Suppress Warnings}. -@gccoptlist{ --fsyntax-only -pedantic -pedantic-errors -fpedantic @gol --w -Wno-globals -Wimplicit -Wunused -Wuninitialized @gol --Wall -Wsurprising @gol --Werror -W} - -@item Debugging Options -@xref{Debugging Options,,Options for Debugging Your Program or GCC}. -@gccoptlist{ --g} - -@item Optimization Options -@xref{Optimize Options,,Options that Control Optimization}. -@gccoptlist{ --malign-double @gol --ffloat-store -fforce-mem -fforce-addr -fno-inline @gol --ffast-math -fstrength-reduce -frerun-cse-after-loop @gol --funsafe-math-optimizations -ffinite-math-only -fno-trapping-math @gol --fexpensive-optimizations -fdelayed-branch @gol --fschedule-insns -fschedule-insn2 -fcaller-saves @gol --funroll-loops -funroll-all-loops @gol --fno-move-all-movables -fno-reduce-all-givs @gol --fno-rerun-loop-opt} - -@item Directory Options -@xref{Directory Options,,Options for Directory Search}. -@gccoptlist{ --I@var{dir} -I-} - -@item Code Generation Options -@xref{Code Gen Options,,Options for Code Generation Conventions}. -@gccoptlist{ --fno-automatic -finit-local-zero -fno-f2c @gol --ff2c-library -fno-underscoring -fno-ident @gol --fpcc-struct-return -freg-struct-return @gol --fshort-double -fno-common -fpack-struct @gol --fzeros -fno-second-underscore @gol --femulate-complex @gol --falias-check -fargument-alias @gol --fargument-noalias -fno-argument-noalias-global @gol --fno-globals -fflatten-arrays @gol --fbounds-check -ffortran-bounds-check} -@end table - -@c man end - -@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 - -@c man begin OPTIONS - -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,,Options Controlling the Kind of -Output,gcc,Using the GNU Compiler Collection (GCC)}, for -information on suffixes recognized by GCC. - -@table @gcctabopt -@cindex .f filename suffix -@cindex .for filename suffix -@cindex .FOR filename suffix -@item @var{file}.f -@item @var{file}.for -@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. - -You can force @samp{.f} files to be preprocessed by @command{cpp} by using -@option{-x f77-cpp-input}. -@xref{LEX}. - -@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 -@cindex .FPP filename suffix -@item @var{file}.F -@item @var{file}.fpp -@item @var{file}.FPP -Fortran source code that must be preprocessed (by the C preprocessor -@command{cpp}, which is part of GCC). - -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, @command{ratfor} -@cindex @samp{.r} filename suffix -@cindex @command{ratfor} -@item @var{file}.r -Ratfor source code, which must be preprocessed by the @command{ratfor} -command, which is available separately (as it is not yet part of the GNU -Fortran distribution). -A public domain version in C is at -@uref{http://sepwww.stanford.edu/sep/prof/ratfor.shar.2}. -@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 @command{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. - -Another example of a problem that results from using the C preprocessor -is that a Fortran comment line that happens to contain any -characters ``interesting'' to the C preprocessor, -such as a backslash at the end of the line, -is not recognized by the preprocessor as a comment line, -so instead of being passed through ``raw'', -the line is edited according to the rules for the preprocessor. -For example, the backslash at the end of the line is removed, -along with the subsequent newline, resulting in the next -line being effectively commented out---unfortunate if that -line is a non-comment line of important code! - -@emph{Note:} The @option{-traditional} and @option{-undef} flags are supplied -to @command{cpp} by default, to help avoid unpleasant surprises. -@xref{Preprocessor Options,,Options Controlling the Preprocessor, -gcc,Using the GNU Compiler Collection (GCC)}. -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 @option{-v} option to see exactly how the preprocessor is invoked. - -@cindex /* -Unfortunately, the @option{-traditional} flag will not avoid an error from -anything that @command{cpp} sees as an unterminated C comment, such as: -@smallexample -C Some Fortran compilers accept /* as starting -C an inline comment. -@end smallexample -@xref{Trailing Comment}. - -The following options that affect overall processing are recognized -by the @command{g77} and @command{gcc} commands in a GNU Fortran installation: - -@table @gcctabopt -@cindex -fversion option -@cindex options, -fversion -@cindex printing version information -@cindex version information, printing -@cindex consistency checks -@cindex internal consistency checks -@cindex checks, of internal consistency -@item -fversion -Ensure that the @command{g77} version of the compiler phase is reported, -if run, -and, starting in @code{egcs} version 1.1, -that internal consistency checks in the @file{f771} program are run. - -This option is supplied automatically when @option{-v} or @option{--verbose} -is specified as a command-line option for @command{g77} or @command{gcc} -and when the resulting commands compile Fortran source files. - -In GCC 3.1, this is changed back to the behavior @command{gcc} displays -for @samp{.c} files. - -@cindex -fset-g77-defaults option -@cindex options, -fset-g77-defaults -@item -fset-g77-defaults -@emph{Version info:} -This option was obsolete as of @code{egcs} -version 1.1. -The effect is instead achieved -by the @code{lang_init_options} routine -in @file{gcc/gcc/f/com.c}. - -@cindex consistency checks -@cindex internal consistency checks -@cindex checks, of internal consistency -Set up whatever @command{gcc} options are to apply to Fortran -compilations, and avoid running internal consistency checks -that might take some time. - -This option is supplied automatically when compiling Fortran code -via the @command{g77} or @command{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 @command{g77} -@cindex @command{g77}, 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 @command{g77} or @command{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---@command{g77} will crash -with a diagnostic if it detects an inconsistency. - -@cindex -fno-silent option -@cindex options, -fno-silent -@cindex f2c compatibility -@cindex compatibility, 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 @command{f77} implementations and @command{f2c} -@end table - -@xref{Overall Options,,Options Controlling the Kind of Output, -gcc,Using the GNU Compiler Collection (GCC)}, for information -on more options that control the overall operation of the @command{gcc} command -(and, by extension, the @command{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 @gcctabopt -@cindex -fugly option -@cindex options, -fugly -@item -fugly -@cindex ugly features -@cindex features, ugly -@emph{Note:} This option is no longer supported. -The information, below, is provided to aid -in the conversion of old scripts. - -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. - -@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 @option{-fno-f66} option is the inverse of @option{-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 @command{g77} provide more compatibility with other -existing and obsolete Fortran implementations. - -@cindex -ff77 option -@cindex options, -ff77 -@item -ff77 -@cindex UNIX f77 -@cindex f2c compatibility -@cindex compatibility, f2c -@cindex f77 compatibility -@cindex compatibility, f77 -Specify that the program is written in idiomatic UNIX FORTRAN 77 -and/or the dialect accepted by the @command{f2c} product. -Same as @samp{-fbackslash -fno-typeless-boz}. - -The meaning of this option is likely to be refined as future -versions of @command{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 @option{-fno-f77} option is @emph{not} the inverse -of @option{-ff77}. -It specifies that the program is not written in idiomatic UNIX -FORTRAN 77 or @command{f2c} but in a more widely portable dialect. -@option{-fno-f77} is the same as @option{-fno-backslash}. - -The meaning of this option is likely to be refined as future -versions of @command{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 @gcctabopt -@cindex -ffree-form option -@cindex options, -ffree-form -@cindex -fno-fixed-form option -@cindex options, -fno-fixed-form -@cindex source file format -@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 -@option{-fvxt}, @option{-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 extensions -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 @option{-fno-vxt}. -@option{-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 @option{-fbackslash} in effect, @samp{A\nB} specifies -three characters, with the second one being newline. -With @option{-fno-backslash}, it specifies four characters, -@samp{A}, @samp{\}, @samp{n}, and @samp{B}. - -Note that @command{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 @command{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 @option{-fbackslash} is the default -instead of @option{-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 -In an external-procedure invocation, -treat a trailing comma in the 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 @option{-fugly-comma} is in force. -And @samp{F = FUNC()} is treated as @samp{F = FUNC(%VAL(0))}. - -The default behavior, @option{-fno-ugly-comma}, is to ignore -a single trailing comma in an argument list. -So, by default, @samp{CALL FOO(X,)} is treated -exactly the same as @samp{CALL FOO(X)}. - -@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 @option{-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 -@option{-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 @code{DO} loops, one-trip -@cindex one-trip @code{DO} loops -@cindex @code{DO} loops, zero-trip -@cindex zero-trip @code{DO} loops -@cindex compatibility, FORTRAN 66 -Executable iterative @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 iterative @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 @option{-fonetrip} option specifies that the source file(s) being -compiled require one-trip loops. - -This option affects only those loops specified by the (iterative) @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. -@option{-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. -@option{-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. -@option{-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. -@option{-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 -fbadu77-intrinsics-delete option -@cindex options, -fbadu77-intrinsics-delete -@item -fbadu77-intrinsics-delete -@cindex -fbadu77-intrinsics-hide option -@cindex options, -fbadu77-intrinsics-hide -@item -fbadu77-intrinsics-hide -@cindex -fbadu77-intrinsics-disable option -@cindex options, -fbadu77-intrinsics-disable -@item -fbadu77-intrinsics-disable -@cindex -fbadu77-intrinsics-enable option -@cindex options, -fbadu77-intrinsics-enable -@item -fbadu77-intrinsics-enable -@cindex @code{badu77} intrinsics -@cindex intrinsics, @code{badu77} -Specify status of UNIX intrinsics having inappropriate forms. -@option{-fbadu77-intrinsics-enable} is the default. -@xref{Intrinsic Groups}. - -@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 @command{f2c} intrinsics -@cindex intrinsics, @command{f2c} -Specify status of f2c-specific intrinsics. -@option{-ff2c-intrinsics-enable} is the default. -@xref{Intrinsic Groups}. - -@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. -@option{-ff90-intrinsics-enable} is the default. -@xref{Intrinsic Groups}. - -@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 @code{COMPLEX} intrinsics -@cindex intrinsics, @code{COMPLEX} -Specify status of Digital's COMPLEX-related intrinsics. -@option{-fgnu-intrinsics-enable} is the default. -@xref{Intrinsic Groups}. - -@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. -@option{-fmil-intrinsics-enable} is the default. -@xref{Intrinsic Groups}. - -@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. -@option{-funix-intrinsics-enable} is the default. -@xref{Intrinsic Groups}. - -@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. -@option{-fvxt-intrinsics-enable} is the default. -@xref{Intrinsic Groups}. - -@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 lines, length -@cindex length of source lines -@cindex fixed form -@cindex limits, lengths of source lines -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. -@option{-ffixed-line-length-0} means the same thing as -@option{-ffixed-line-length-none}. - -@xref{Source Form}, for more information. -@end table - -@node Warning Options -@section Options to Request or Suppress Warnings -@cindex options, warnings -@cindex warnings, suppressing -@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 @option{-W}, -for example @option{-Wimplicit} to request warnings on implicit -declarations. Each of these specific warning options also has a -negative form beginning @option{-Wno-} to turn off warnings; -for example, @option{-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 @gcctabopt -@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. -@option{-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 @option{-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 @command{g77} in this area are welcome. - -@cindex -pedantic-errors option -@cindex options, -pedantic-errors -@item -pedantic-errors -Like @option{-pedantic}, except that errors are produced rather than -warnings. - -@cindex -fpedantic option -@cindex options, -fpedantic -@item -fpedantic -Like @option{-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 @option{-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 @option{-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 @option{-Wunused} and @option{-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 @command{g77} some might -be added to the list enabled by @option{-Wall}.) -@end table - -The remaining @option{-W@dots{}} options are not implied by @option{-Wall} -because they warn about constructions that we consider reasonable to -use, on occasion, in clean programs. - -@table @gcctabopt -@c @item -W -@c Print extra warning messages for these events: -@c -@c @itemize @bullet -@c @item -@c If @option{-Wall} or @option{-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}. -@command{g77} along with many other compilers, interprets -this example differently than many programmers, and a few -other compilers. -Specifically, @command{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 @command{g77} evaluates to .25, while others might evaluate -it to 0., the difference resulting from the way precedence affects -type promotion. - -(The @option{-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 @command{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 @option{-O}, the @option{-Wuninitialized} option. -(This might change in future versions of @command{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 @option{-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 the GNU Compiler Collection (GCC)}, for information on more -options offered -by the GBE shared by @command{g77} @command{gcc} and other GNU compilers. - -Some of these have no effect when compiling programs written in Fortran: - -@table @gcctabopt -@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 -Wswitch-default option -@cindex options, -Wswitch-default -@item -Wswitch-default -@cindex -Wswitch-enum option -@cindex options, -Wswitch-enum -@item -Wswitch-enum -@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 @command{g77} - -@table @gcctabopt -@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. - -A sample debugging session looks like this (note the use of the breakpoint): -@smallexample -$ cat gdb.f - PROGRAM PROG - DIMENSION A(10) - DATA A /1.,2.,3.,4.,5.,6.,7.,8.,9.,10./ - A(5) = 4. - PRINT*,A - END -$ g77 -g -O gdb.f -$ gdb a.out -... -(gdb) break MAIN__ -Breakpoint 1 at 0x8048e96: file gdb.f, line 4. -(gdb) run -Starting program: /home/toon/g77-bugs/./a.out -Breakpoint 1, MAIN__ () at gdb.f:4 -4 A(5) = 4. -Current language: auto; currently fortran -(gdb) print a(5) -$1 = 5 -(gdb) step -5 PRINT*,A -(gdb) print a(5) -$2 = 4 -... -@end smallexample -One could also add the setting of the breakpoint and the first run command -to the file @file{.gdbinit} in the current directory, to simplify the debugging -session. -@end table - -@xref{Debugging Options,,Options for Debugging Your Program or GCC, -gcc,Using the GNU Compiler Collection (GCC)}, 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 @option{-O} or @option{-O2} when -compiling programs for late-cycle testing and for production use. -However, note that certain diagnostics---such as for uninitialized -variables---depend on the flow analysis done by @option{-O}, i.e.@: you -must use @option{-O} or @option{-O2} to get such diagnostics. - -The following flags have particular applicability when -compiling Fortran programs: - -@table @gcctabopt -@cindex -malign-double option -@cindex options, -malign-double -@item -malign-double -(Intel x86 architecture only.) - -Noticeably improves performance of @command{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 @command{gcc} documentation about -this option does not apply, generally speaking, to Fortran -code compiled by @command{g77} - -@xref{Aligned Data}, for more information on alignment issues. - -@emph{Also also note:} The negative form of @option{-malign-double} -is @option{-mno-align-double}, not @option{-benign-double}. - -@cindex -ffloat-store option -@cindex options, -ffloat-store -@item -ffloat-store -@cindex IEEE 754 conformance -@cindex conformance, IEEE 754 -@cindex floating-point, precision -Might help a Fortran program that depends on exact IEEE conformance on -some machines, but might slow down a program that doesn't. - -This option is effective when the floating-point unit is set to work in -IEEE 854 `extended precision'---as it typically is on x86 and m68k GNU -systems---rather than IEEE 754 double precision. @option{-ffloat-store} -tries to remove the extra precision by spilling data from floating-point -registers into memory and this typically involves a big performance -hit. However, it doesn't affect intermediate results, so that it is -only partially effective. `Excess precision' is avoided in code like: -@smallexample -a = b + c -d = a * e -@end smallexample -but not in code like: -@smallexample - d = (b + c) * e -@end smallexample - -For another, potentially better, way of controlling the precision, -see @ref{Floating-point precision}. - -@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 speed, of loops -Might improve optimization of loops. - -@cindex -fno-inline option -@cindex options, -fno-inline -@item -fno-inline -@cindex in-line code -@cindex compilation, in-line -@c DL: Only relevant for -O3? TM: No, statement functions are -@c inlined even at -O1. -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 754 conformance -@cindex conformance, IEEE 754 -Might allow some programs designed to not be too dependent -on IEEE behavior for floating-point to run faster, or die trying. -Sets @option{-funsafe-math-optimizations}, @option{-ffinite-math-only}, -and @option{-fno-trapping-math}. - -@cindex -funsafe-math-optimizations option -@cindex options, -funsafe-math-optimizations -@item -funsafe-math-optimizations -Allow optimizations that may be give incorrect results -for certain IEEE inputs. - -@cindex -ffinite-math-only option -@cindex options, -ffinite-math-only -@item -ffinite-math-only -Allow optimizations for floating-point arithmetic that assume -that arguments and results are not NaNs or +-Infs. - -This option should never be turned on by any @option{-O} option since -it can result in incorrect output for programs which depend on -an exact implementation of IEEE or ISO rules/specifications. - -The default is @option{-fno-finite-math-only}. - -@cindex -fno-trapping-math option -@cindex options, -fno-trapping-math -@item -fno-trapping-math -Allow the compiler to assume that floating-point arithmetic -will not generate traps on any inputs. This is useful, for -example, when running a program using IEEE "non-stop" -floating-point arithmetic. - -@cindex -fstrength-reduce option -@cindex options, -fstrength-reduce -@item -fstrength-reduce -@cindex loops, speeding up -@cindex speed, of loops -@c DL: normally defaulted? -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 -@c DL: This is -O2? -@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 -@cindex loops, optimizing -@cindex indexed (iterative) @code{DO} -@cindex iterative @code{DO} -@c DL: fixme: Craig doesn't like `indexed' but f95 doesn't seem to -@c provide a suitable term -@c CB: I've decided on `iterative', for the time being, and changed -@c my previous, rather bizarre, use of `imperative' to that -@c (though `precomputed-trip' would be a more precise adjective) -Typically improves performance on code using iterative @code{DO} loops by -unrolling them and is probably generally appropriate for Fortran, though -it is not turned on at any optimization level. -Note that outer loop unrolling isn't done specifically; decisions about -whether to unroll a loop are made on the basis of its instruction count. - -@c DL: Fixme: This should obviously go somewhere else... -Also, no `loop discovery'@footnote{@dfn{loop discovery} refers to the -process by which a compiler, or indeed any reader of a program, -determines which portions of the program are more likely to be executed -repeatedly as it is being run. Such discovery typically is done early -when compiling using optimization techniques, so the ``discovered'' -loops get more attention---and more run-time resources, such as -registers---from the compiler. It is easy to ``discover'' loops that are -constructed out of looping constructs in the language -(such as Fortran's @code{DO}). For some programs, ``discovering'' loops -constructed out of lower-level constructs (such as @code{IF} and -@code{GOTO}) can lead to generation of more optimal code -than otherwise.} is done, so only loops written with @code{DO} -benefit from loop optimizations, including---but not limited -to---unrolling. Loops written with @code{IF} and @code{GOTO} are not -currently recognized as such. This option unrolls only iterative -@code{DO} loops, not @code{DO WHILE} loops. - -@cindex -funroll-all-loops option -@cindex options, -funroll-all-loops -@cindex DO WHILE -@item -funroll-all-loops -@c DL: Check my understanding of -funroll-all-loops v. -funroll-loops is correct. -Probably improves performance on code using @code{DO WHILE} loops by -unrolling them in addition to iterative @code{DO} loops. In the absence -of @code{DO WHILE}, this option is equivalent to @option{-funroll-loops} -but possibly slower. - -@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 -In general, the optimizations enabled with these options will lead to -faster code being generated by GNU Fortran; hence they are enabled by default -when issuing the @command{g77} command. - -@option{-fmove-all-movables} and @option{-freduce-all-givs} will enable -loop optimization to move all loop-invariant index computations in nested -loops over multi-rank array dummy arguments out of these loops. - -@option{-frerun-loop-opt} will move offset calculations resulting -from the fact that Fortran arrays by default have a lower bound of 1 -out of the loops. - -These three options are intended to be removed someday, once -loop optimization is sufficiently advanced to perform all those -transformations without help from these options. -@end table - -@xref{Optimize Options,,Options That Control Optimization, -gcc,Using the GNU Compiler Collection (GCC)}, 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 the GNU Compiler Collection (GCC)}, for information on C -preprocessor options. - -@cindex INCLUDE directive -@cindex directive, INCLUDE -Some of these options also affect how @command{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 @command{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 @command{cpp} preprocessor searches -for files specified via the @code{#include} directive. -Therefore, when compiling Fortran programs, they are meaningful -when the preprocessor is used. - -@cindex INCLUDE directive -@cindex directive, INCLUDE -Some of these options also affect how @command{g77} searches -for files specified via the @code{INCLUDE} directive, -although files included by that directive are not, -themselves, preprocessed. -These options are: - -@table @gcctabopt -@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 search paths, for included files -@cindex paths, search -These affect interpretation of the @code{INCLUDE} directive -(as well as of the @code{#include} directive of the @command{cpp} -preprocessor). - -Note that @option{-I@var{dir}} must be specified @emph{without} any -spaces between @option{-I} and the directory name---that is, -@option{-Ifoo/bar} is valid, but @option{-I foo/bar} -is rejected by the @command{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 @option{-I} and -@code{INCLUDE} is pretty much the same as of @option{-I} with -@code{#include} in the @command{cpp} preprocessor, with regard to -looking for @file{header.gcc} files and other such things. - -@xref{Directory Options,,Options for Directory Search, -gcc,Using the GNU Compiler Collection (GCC)}, for information on the -@option{-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 @option{-ffoo} would be @option{-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 @option{no-} or adding -it. - -@table @gcctabopt -@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 @option{-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 @option{-fno-automatic} with @option{-finit-local-zero}. - -@cindex -fno-f2c option -@cindex options, -fno-f2c -@item -fno-f2c -@cindex @command{f2c} compatibility -@cindex compatibility, @command{f2c} -Do not generate code designed to be compatible with code generated -by @command{f2c} use the GNU calling conventions instead. - -The @command{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{libg2c} library. - -However, because the @code{libg2c} library uses @command{f2c} -calling conventions, @command{g77} rejects attempts to pass -intrinsics implemented by routines in this library as actual -arguments when @option{-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 @option{-fno-f2c} is in force. -(Future versions of the @command{g77} run-time library might -offer routines that provide GNU-callable versions of the -routines that implement the @command{f2c} intrinsics -that may be passed as actual arguments, so that -valid programs need not be rejected when @option{-fno-f2c} -is used.) - -@strong{Caution:} If @option{-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{libg2c} (or the original @code{libf2c}) -is required. -This is the default for the current version of @command{g77} - -Currently it is not -valid to specify @option{-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 @command{g77} that might otherwise default to -generating code for an incompatible library. - -@cindex -fno-underscoring option -@cindex options, -fno-underscoring -@item -fno-underscoring -@cindex underscore -@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 @option{-funderscoring} in effect, @command{g77} appends two underscores -to names with underscores and one underscore to external names with -no underscores. (@command{g77} also appends two underscores to internal -names with underscores to avoid naming collisions with external names. -The @option{-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 @command{f2c} which perform the -same transformations. - -Use of @option{-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 @option{-funderscoring}, and assuming other defaults like -@option{-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 @option{-fno-underscoring}, the same statement is implemented as: - -@smallexample -i = j() + max_count(&my_var, &lvar); -@end smallexample - -Use of @option{-fno-underscoring} allows direct specification of -user-defined names while debugging and when interfacing @command{g77} -code with other languages. - -Note that just because the names match does @emph{not} mean that the -interface implemented by @command{g77} for an external name matches the -interface implemented by some other language for that same name. -That is, getting code produced by @command{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 @option{-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 @command{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 underscore -@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 @option{-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, @command{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 @option{-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 @command{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 -femulate-complex option -@cindex options, -femulate-complex -@item -femulate-complex -Implement @code{COMPLEX} arithmetic via emulation, -instead of using the facilities of -the @command{gcc} back end that provide direct support of -@code{complex} arithmetic. - -(@command{gcc} had some bugs in its back-end support -for @code{complex} arithmetic, due primarily to the support not being -completed as of version 2.8.1 and @code{egcs} 1.1.2.) - -Use @option{-femulate-complex} if you suspect code-generation bugs, -or experience compiler crashes, -that might result from @command{g77} using the @code{COMPLEX} support -in the @command{gcc} back end. -If using that option fixes the bugs or crashes you are seeing, -that indicates a likely @command{g77} bugs -(though, all compiler crashes are considered bugs), -so, please report it. -(Note that the known bugs, now believed fixed, produced compiler crashes -rather than causing the generation of incorrect code.) - -Use of this option should not affect how Fortran code compiled -by @command{g77} works in terms of its interfaces to other code, -e.g. that compiled by @command{f2c} - -As of GCC version 3.0, this option is not necessary anymore. - -@emph{Caution:} Future versions of @command{g77} might ignore both forms -of this option. - -@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 -@emph{Version info:} -These options are not supported by -versions of @command{g77} based on @command{gcc} version 2.8. - -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 @option{-fargument-noalias-global}. -The default for code written in the C language family is -@option{-fargument-alias}. - -Note that, on some systems, compiling with @option{-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 -@cindex in-line code -@cindex compilation, in-line -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 @option{-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 which @command{g77} diagnoses. - -Use of this option therefore has the effect of -instructing @command{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, @command{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 as (fatal) errors, -and warns about similar disagreements -that are currently believed to not -likely to result in the compiler later crashing -or producing incorrect code. - -@cindex -fflatten-arrays option -@item -fflatten-arrays -@cindex array performance -@cindex arrays, flattening -Use back end's C-like constructs -(pointer plus offset) -instead of its @code{ARRAY_REF} construct -to handle all array references. - -@emph{Note:} This option is not supported. -It is intended for use only by @command{g77} developers, -to evaluate code-generation issues. -It might be removed at any time. - -@cindex -fbounds-check option -@cindex -ffortran-bounds-check option -@item -fbounds-check -@itemx -ffortran-bounds-check -@cindex bounds checking -@cindex range checking -@cindex array bounds checking -@cindex subscript checking -@cindex substring checking -@cindex checking subscripts -@cindex checking substrings -Enable generation of run-time checks for array subscripts -and substring start and end points -against the (locally) declared minimum and maximum values. - -The current implementation uses the @code{libf2c} -library routine @code{s_rnge} to print the diagnostic. - -However, whereas @command{f2c} generates a single check per -reference for a multi-dimensional array, of the computed -offset against the valid offset range (0 through the size of the array), -@command{g77} generates a single check per @emph{subscript} expression. -This catches some cases of potential bugs that @command{f2c} does not, -such as references to below the beginning of an assumed-size array. - -@command{g77} also generates checks for @code{CHARACTER} substring references, -something @command{f2c} currently does not do. - -Use the new @option{-ffortran-bounds-check} option -to specify bounds-checking for only the Fortran code you are compiling, -not necessarily for code written in other languages. - -@emph{Note:} To provide more detailed information on the offending subscript, -@command{g77} provides the @code{libg2c} run-time library routine @code{s_rnge} -with somewhat differently-formatted information. -Here's a sample diagnostic: - -@smallexample -Subscript out of range on file line 4, procedure rnge.f/bf. -Attempt to access the -6-th element of variable b[subscript-2-of-2]. -Aborted -@end smallexample - -The above message indicates that the offending source line is -line 4 of the file @file{rnge.f}, -within the program unit (or statement function) named @samp{bf}. -The offended array is named @samp{b}. -The offended array dimension is the second for a two-dimensional array, -and the offending, computed subscript expression was @samp{-6}. - -For a @code{CHARACTER} substring reference, the second line has -this appearance: - -@smallexample -Attempt to access the 11-th element of variable a[start-substring]. -@end smallexample - -This indicates that the offended @code{CHARACTER} variable or array -is named @samp{a}, -the offended substring position is the starting (leftmost) position, -and the offending substring expression is @samp{11}. - -(Though the verbage of @code{s_rnge} is not ideal -for the purpose of the @command{g77} compiler, -the above information should provide adequate diagnostic abilities -to it users.) -@end table - -@xref{Code Gen Options,,Options for Code Generation Conventions, -gcc,Using the GNU Compiler Collection (GCC)}, for information on more options -offered by the GBE -shared by @command{g77} @command{gcc} and other GNU compilers. - -Some of these do @emph{not} work when compiling programs written in Fortran: - -@table @gcctabopt -@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{libg2c} with which -you will be linking all code compiled by @command{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{libg2c} library, -at the very least, even if it is built with the same option. -@end table - -@c man end - -@node Environment Variables -@section Environment Variables Affecting GNU Fortran -@cindex environment variables - -@c man begin ENVIRONMENT - -GNU Fortran currently does not make use of any environment -variables to control its operation above and beyond those -that affect the operation of @command{gcc}. - -@xref{Environment Variables,,Environment Variables Affecting GCC, -gcc,Using the GNU Compiler Collection (GCC)}, for information on environment -variables. - -@c man end diff --git a/contrib/gcc-3.4/gcc/f/lab.c b/contrib/gcc-3.4/gcc/f/lab.c deleted file mode 100644 index 1d278748b2..0000000000 --- a/contrib/gcc-3.4/gcc/f/lab.c +++ /dev/null @@ -1,157 +0,0 @@ -/* lab.c -- Implementation File (module.c template V1.0) - Copyright (C) 1995, 2003 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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 (void) -{ - 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 (void) -{ - 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 = malloc_new_ks (ffe_pool_any_unit (), "FFELAB label", sizeof (*l)); - l->next = ffelab_list_; - l->hook = FFECOM_labelNULL; - 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/contrib/gcc-3.4/gcc/f/lab.h b/contrib/gcc-3.4/gcc/f/lab.h deleted file mode 100644 index f3f89868a5..0000000000 --- a/contrib/gcc-3.4/gcc/f/lab.h +++ /dev/null @@ -1,152 +0,0 @@ -/* lab.h -- Public #include File (module.h template V1.0) - Copyright (C) 1995, 2003 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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 GCC_F_LAB_H -#define GCC_F_LAB_H - -/* 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; - ffecomLabel hook; - 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 /* ! GCC_F_LAB_H */ diff --git a/contrib/gcc-3.4/gcc/f/lang-specs.h b/contrib/gcc-3.4/gcc/f/lang-specs.h deleted file mode 100644 index 9ed51ef5a6..0000000000 --- a/contrib/gcc-3.4/gcc/f/lang-specs.h +++ /dev/null @@ -1,47 +0,0 @@ -/* lang-specs.h file for Fortran - Copyright (C) 1995, 1996, 1997, 1999, 2000, 2002, 2003 - Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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. */ - - {".F", "@f77-cpp-input", 0}, - {".fpp", "@f77-cpp-input", 0}, - {".FPP", "@f77-cpp-input", 0}, - {"@f77-cpp-input", - "cc1 -E -traditional-cpp -D_LANGUAGE_FORTRAN %(cpp_options) \ - %{E|M|MM:%(cpp_debug_options)}\ - %{!M:%{!MM:%{!E: -o %|.f |\n\ - f771 %|.f %(cc1_options) %{I*} %{!fsyntax-only:%(invoke_as)}}}}", 0}, - {".r", "@ratfor", 0}, - {"@ratfor", - "%{C:%{!E:%eGCC does not support -C without using -E}}\ - %{CC:%{!E:%eGCC does not support -CC without using -E}}\ - ratfor %{C} %{CC} %{v} %{E:%W{o*}} %{!E: %{!pipe:-o %g.f} %i |\n\ - f771 %m.f %(cc1_options) %{I*} %{!fsyntax-only:%(invoke_as)}}", 0}, - {".f", "@f77", 0}, - {".for", "@f77", 0}, - {".FOR", "@f77", 0}, - {"@f77", - "%{!M:%{!MM:%{!E:f771 %i %(cc1_options) %{I*}\ - %{!fsyntax-only:%(invoke_as)}}}}", 0}, diff --git a/contrib/gcc-3.4/gcc/f/lang.opt b/contrib/gcc-3.4/gcc/f/lang.opt deleted file mode 100644 index d6a53b7dcd..0000000000 --- a/contrib/gcc-3.4/gcc/f/lang.opt +++ /dev/null @@ -1,402 +0,0 @@ -; Options for the Fortran 77 front end. -; Copyright (C) 2003 Free Software Foundation, Inc. -; -; This file is part of GCC. -; -; GCC 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. -; -; GCC 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 GCC; see the file COPYING. If not, write to the Free -; Software Foundation, 59 Temple Place - Suite 330, Boston, MA -; 02111-1307, USA. - -; See c.opt for a description of this file's format. - -; Please try to keep this file in ASCII collating order. - -Language -F77 - -I -F77 Joined -Add a directory for INCLUDE searching - -Wall -F77 -; Documented in C - -Wcomment -F77 - -Wcomments -F77 - -Wglobals -F77 -Enable warnings about inter-procedural problems - -Wimplicit -F77 - -Wimport -F77 - -Wsurprising -F77 -Warn about constructs with surprising meanings - -Wtrigraphs -F77 - -fautomatic -F77 -Do not treat local variables and COMMON blocks as if they were named in SAVE statements - -fbackslash -F77 -Backslashes in character and hollerith constants are special (not C-style) - -fbadu77-intrinsics-delete -F77 RejectNegative -Delete libU77 intrinsics with bad interfaces - -fbadu77-intrinsics-disable -F77 RejectNegative -Disable libU77 intrinsics with bad interfaces - -fbadu77-intrinsics-enable -F77 RejectNegative -Enable libU77 intrinsics with bad interfaces - -fbadu77-intrinsics-hide -F77 RejectNegative -Hide libU77 intrinsics with bad interfaces - -fcase-initcap -F77 RejectNegative -Program written in strict mixed-case - -fcase-lower -F77 RejectNegative -Compile as if program written in lowercase - -fcase-preserve -F77 RejectNegative -Preserve case used in program - -fcase-strict-lower -F77 RejectNegative -Program written in lowercase - -fcase-strict-upper -F77 RejectNegative -Program written in uppercase - -fcase-upper -F77 RejectNegative -Compile as if program written in uppercase - -fdebug-kludge -F77 -Emit special debugging information for COMMON and EQUIVALENCE (disabled) - -fdollar-ok -F77 -Allow '$' in symbol names - -femulate-complex -F77 -Have front end emulate COMPLEX arithmetic to avoid bugs - -ff2c -F77 -f2c-compatible code can be generated - -ff2c-intrinsics-delete -F77 RejectNegative -Delete non-FORTRAN-77 intrinsics f2c supports - -ff2c-intrinsics-disable -F77 RejectNegative -Disable non-FORTRAN-77 intrinsics f2c supports - -ff2c-intrinsics-enable -F77 RejectNegative -Enable non-FORTRAN-77 intrinsics f2c supports - -ff2c-intrinsics-hide -F77 RejectNegative -Hide non-FORTRAN-77 intrinsics f2c supports - -ff2c-library -F77 -Unsupported; generate libf2c-calling code - -ff66 -F77 -Program is written in typical FORTRAN 66 dialect - -ff77 -F77 -Program is written in typical Unix-f77 dialect - -ff90 -F77 -Program is written in Fortran-90-ish dialect - -ff90-intrinsics-delete -F77 RejectNegative -Delete non-FORTRAN-77 intrinsics F90 supports - -ff90-intrinsics-disable -F77 RejectNegative -Disable non-FORTRAN-77 intrinsics F90 supports - -ff90-intrinsics-enable -F77 RejectNegative -Enable non-FORTRAN-77 intrinsics F90 supports - -ff90-intrinsics-hide -F77 RejectNegative -Hide non-FORTRAN-77 intrinsics F90 supports - -ff90-not-vxt -F77 RejectNegative - -ffixed-form -F77 - -ffixed-line-length- -F77 Joined -ffixed-line-length- Set the maximum line length to - -fflatten-arrays -F77 -Unsupported; affects code generation of arrays - -ffortran-bounds-check -F77 -Generate code to check subscript and substring bounds - -ffree-form -F77 -Program is written in Fortran-90-ish free form - -fglobals -F77 -Enable fatal diagnostics about inter-procedural problems - -fgnu-intrinsics-delete -F77 RejectNegative -Delete non-FORTRAN-77 intrinsics g77 supports - -fgnu-intrinsics-disable -F77 RejectNegative -Disable non-FORTRAN 77 intrinsics F90 supports - -fgnu-intrinsics-enable -F77 RejectNegative -Enable non-FORTRAN 77 intrinsics F90 supports - -fgnu-intrinsics-hide -F77 RejectNegative -Hide non-FORTRAN 77 intrinsics F90 supports - -finit-local-zero -F77 -Initialize local vars and arrays to zero - -fintrin-case-any -F77 RejectNegative -Intrinsics letters in arbitrary cases - -fintrin-case-initcap -F77 RejectNegative -Intrinsics spelled as e.g. SqRt - -fintrin-case-lower -F77 RejectNegative -Intrinsics in lowercase - -fintrin-case-upper -F77 RejectNegative -Intrinsics in uppercase - -fmatch-case-any -F77 RejectNegative -Language keyword letters in arbitrary cases - -fmatch-case-initcap -F77 RejectNegative -Language keywords spelled as e.g. IOStat - -fmatch-case-lower -F77 RejectNegative -Language keywords in lowercase - -fmatch-case-upper -F77 RejectNegative -Language keywords in uppercase - -fmil-intrinsics-delete -F77 RejectNegative -Delete MIL-STD 1753 intrinsics - -fmil-intrinsics-disable -F77 RejectNegative -Disable MIL-STD 1753 intrinsics - -fmil-intrinsics-enable -F77 RejectNegative -Enable MIL-STD 1753 intrinsics - -fmil-intrinsics-hide -F77 RejectNegative -Hide MIL-STD 1753 intrinsics - -fonetrip -F77 -Take at least one trip through each iterative DO loop - -fpedantic -F77 -Warn about use of (only a few for now) Fortran extensions - -fpreprocessed -F77 - -fsecond-underscore -F77 -Allow appending a second underscore to externals - -fsilent -F77 -Do not print names of program units as they are compiled - -fsource-case-lower -F77 RejectNegative -Internally convert most source to lowercase - -fsource-case-preserve -F77 RejectNegative -Internally preserve source case - -fsource-case-upper -F77 RejectNegative -Internally convert most source to uppercase - -fsymbol-case-any -F77 RejectNegative - -fsymbol-case-initcap -F77 RejectNegative -Symbol names spelled in mixed case - -fsymbol-case-lower -F77 RejectNegative -Symbol names in lowercase - -fsymbol-case-upper -F77 RejectNegative -Symbol names in uppercase - -ftypeless-boz -F77 -Make prefix-radix non-decimal constants be typeless - -fugly -F77 -Allow all ugly features - -fugly-args -F77 -Hollerith and typeless can be passed as arguments - -fugly-assign -F77 -Allow ordinary copying of ASSIGN'ed vars - -fugly-assumed -F77 -Dummy array dimensioned to (1) is assumed-size - -fugly-comma -F77 -Trailing comma in procedure call denotes null argument - -fugly-complex -F77 -Allow REAL(Z) and AIMAG(Z) given DOUBLE COMPLEX Z - -fugly-init -F77 -Initialization via DATA and PARAMETER is not type-compatible - -fugly-logint -F77 -Allow INTEGER and LOGICAL interchangeability - -funderscoring -F77 -Append underscores to externals - -funix-intrinsics-delete -F77 RejectNegative -Delete libU77 intrinsics - -funix-intrinsics-disable -F77 RejectNegative -Disable libU77 intrinsics - -funix-intrinsics-enable -F77 RejectNegative -Enable libU77 intrinsics - -funix-intrinsics-hide -F77 RejectNegative -Hide libU77 intrinsics - -fversion -F77 RejectNegative -Print g77-specific version information and run internal tests - -fvxt -F77 -Program is written in VXT (Digital-like) FORTRAN - -fvxt-intrinsics-delete -F77 RejectNegative -Delete non-FORTRAN-77 intrinsics VXT FORTRAN supports - -fvxt-intrinsics-disable -F77 RejectNegative -Disable non-FORTRAN-77 intrinsics VXT FORTRAN supports - -fvxt-intrinsics-enable -F77 RejectNegative -Enable non-FORTRAN-77 intrinsics VXT FORTRAN supports - -fvxt-intrinsics-hide -F77 RejectNegative -Hide non-FORTRAN-77 intrinsics VXT FORTRAN supports - -fvxt-not-f90 -F77 RejectNegative - -fxyzzy -F77 -Print internal debugging-related information - -fzeros -F77 -Treat initial values of 0 like non-zero values - -; This comment is to ensure we retain the blank line above. diff --git a/contrib/gcc-3.4/gcc/f/lex.c b/contrib/gcc-3.4/gcc/f/lex.c deleted file mode 100644 index 8475d2ff2c..0000000000 --- a/contrib/gcc-3.4/gcc/f/lex.c +++ /dev/null @@ -1,4571 +0,0 @@ -/* Implementation of Fortran lexer - Copyright (C) 1995, 1996, 1997, 1998, 2001, 2002, 2003 - Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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 "top.h" -#include "bad.h" -#include "com.h" -#include "lex.h" -#include "malloc.h" -#include "src.h" -#include "debug.h" -#include "flags.h" -#include "input.h" -#include "toplev.h" -#include "output.h" -#include "ggc.h" - -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); -static int ffelex_get_directive_line_ (char **text, FILE *finput); -static int ffelex_hash_ (FILE *f); -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 GTY (()) 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 GTY(()) 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); - } - 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 - - 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': - 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': - return TARGET_BELL; - - case 'v': - return TARGET_VT; - - case 'e': - case 'E': - case '(': - case '{': - case '[': - case '%': - if (pedantic) - { - char m[2]; - - m[0] = c; - m[1] = '\0'; - /* xgettext:no-c-format */ - ffebad_start_msg_lex ("Non-ISO-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'; - /* xgettext:no-c-format */ - 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) - { - /* xgettext:no-c-format */ - 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); - /* xgettext:no-c-format */ - 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 (ISXDIGIT (c)) - { - code = (code * 16) + hex_value (c); - if (code != 0 || count != 0) - { - if (count == 0) - firstdig = code; - count++; - } - nonnull = 1; - return EOF; - } - - state = 0; - - if (! nonnull) - { - /* xgettext:no-c-format */ - 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))) - { - /* xgettext:no-c-format */ - 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))) - { - /* xgettext:no-c-format */ - 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); -} - -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); -} - -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': - code = 0; - count = 0; - nonnull = 0; - while (1) - { - c = getc (finput); - if (! ISXDIGIT (c)) - { - *use_d = 1; - *d = c; - break; - } - code = (code * 16) + hex_value (c); - 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': - return TARGET_BELL; - - case 'v': - 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-ISO 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; -} - -/* A miniature version of the C front-end lexer. */ - -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; - if (q == &buff[0]) - { - q = xmalloc (buffer_length); - memcpy (q, buff, bytes_used); - } - else - q = 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 = 0; - - switch (c) - { - case '\"': - c = getc (finput); - done = TRUE; - break; - - case '\\': /* ~~~~~ */ - c = ffelex_cfebackslash_ (&use_d, &d, finput); - break; - - case EOF: - case '\n': - error ("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; - if (q == &buff[0]) - { - q = xmalloc (buffer_length); - memcpy (q, buff, bytes_used); - } - else - q = 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; -} - -static void -ffelex_file_pop_ (const char *filename) -{ - if (input_file_stack->next) - { - struct file_stack *p = input_file_stack; - input_file_stack = p->next; - free (p); - input_file_stack_tick++; - (*debug_hooks->end_source_file) (input_file_stack->location.line); - } - 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->location.file = filename; -} - -static void -ffelex_file_push_ (int old_lineno, const char *filename) -{ - struct file_stack *p = xmalloc (sizeof (struct file_stack)); - - input_file_stack->location.line = old_lineno; - p->next = input_file_stack; - p->location.file = filename; - input_file_stack = p; - input_file_stack_tick++; - - (*debug_hooks->start_source_file) (0, filename); - - /* Now that we've pushed or popped the input stack, - update the name in the top element. */ - if (input_file_stack) - input_file_stack->location.file = filename; -} - -/* 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_ (void) -{ - 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_ (void) -{ - 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. */ - -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 = 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 = 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) - error ("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 - one of these (or an EOF). */ - - /* Handle backslash. */ - char_escaped = (c == '\\' && ! char_escaped); - } -} - -/* 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. */ - -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 (ISALPHA(c)) - { - 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; - } - } - 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); - - if (debug_info_level == DINFO_LEVEL_VERBOSE) - (*debug_hooks->define) (input_line, text); - - 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); - - if (debug_info_level == DINFO_LEVEL_VERBOSE) - (*debug_hooks->undef) (input_line, text); - - 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 cpp. */ - - /* 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 (! flag_no_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)) - { - location_t old_loc = input_location; - 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. */ - input_line = 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; - } - - input_line = l; - - if (ffelex_kludge_flag_) - input_filename = ggc_strdup (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->location.file = 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_) - { - input_line = 1; - input_filename = old_loc.file; - error ("use `#line ...' instead of `# ...' in first line"); - } - - if (num == 1) - { - /* Pushing to a new file. */ - ffelex_file_push_ (old_loc.line, 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_) - { - input_line = 1; - input_filename = old_loc.file; - error ("use `#line ...' instead of `# ...' in first line"); - } - if (c == '\n' || c == EOF) - { - if (token != NULL && !ffelex_kludge_flag_) - ffelex_token_kill (token); - return c; - } - } - 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; -} - -/* "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; - /* xgettext:no-c-format */ - 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_ (void) -{ - 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); - location_t old_loc = input_location; - - 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); - - ffelex_file_push_ (old_loc.line, ffewhere_file_name (include_wherefile)); - - if (ffelex_include_free_form_) - ffelex_file_free (include_wherefile, include_file); - else - ffelex_file_fixed (include_wherefile, include_file); - - ffelex_file_pop_ (ffewhere_file_name (current_wf)); - - ffewhere_file_set (current_wf, TRUE, linecount_offset); - - ffecom_close_include (include_file); - - if (card_length != 0) - { - assert (ffelex_card_size_ >= card_length); /* It shrunk?? */ - memcpy (ffelex_card_image_, card_image, card_length); - } - ffelex_card_image_[card_length] = '\0'; - - input_location = old_loc; - 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_ (void) -{ - ffelex_linecount_current_ = ffelex_linecount_next_; - ++ffelex_linecount_next_; - ++input_line; -} - -static void -ffelex_send_token_ (void) -{ - ++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_ (void) -{ - ffelexToken t; - - ++ffelex_total_tokens_; - - t = malloc_new_ks (malloc_pool_image (), "FFELEX token", sizeof (*t)); - t->id_ = ffelex_token_nextid_++; - return t; -} - -static const char * -ffelex_type_string_ (ffelexType type) -{ - static const char *const 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 (void) -{ - 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 = 0; /* Character currently under consideration. */ - register ffewhereColumnNumber column = 0; /* Not really; 0 means column 1... */ - bool disallow_continuation_line; - bool ignore_disallowed_continuation = FALSE; - 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); - - input_line = 0; - input_filename = ffewhere_file_name (wf); - 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: /* :::::::::::::::::::: */ - - 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); - } - else if (lextype == FFELEX_typeHASH) - c = ffelex_hash_ (f); - 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 = 0; /* Character currently under consideration. */ - register ffewhereColumnNumber column = 0; /* Not really; 0 means column 1... */ - bool continuation_line = FALSE; - ffewhereColumnNumber continuation_column; - int latest_char_in_file = 0; /* 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); - - input_line = 0; - input_filename = ffewhere_file_name (wf); - 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 == '#') - c = ffelex_hash_ (f); - - 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. */ - -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 const char match[] = "# 1 \""; - static int kludge[ARRAY_SIZE (match) + 1]; - int c; - const 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; - } -} - -void -ffelex_init_1 (void) -{ - 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 (void) -{ - return ffelex_names_; -} - -/* Current card image, which has the master linecount number - ffelex_linecount_current_. */ - -char * -ffelex_line (void) -{ - 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 (void) -{ - return ffelex_card_length_; -} - -/* Master line count of current card image, or 0 if no card image - is current. */ - -ffewhereLineNumber -ffelex_line_number (void) -{ - 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) -{ - unsigned 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 ((unsigned char)(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 ((unsigned char)(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 (const 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 (void) -{ - 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 (const char *s, ffewhereLine l, ffewhereColumn c) -{ - ffelexToken t; - - assert (ffelex_is_firstnamechar ((unsigned char)*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 (const char *s, ffewhereLine l, ffewhereColumn c) -{ - ffelexToken t; - - assert (ffelex_is_firstnamechar ((unsigned char)*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 (const 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; -} - -#include "gt-f-lex.h" diff --git a/contrib/gcc-3.4/gcc/f/lex.h b/contrib/gcc-3.4/gcc/f/lex.h deleted file mode 100644 index 04dfbed426..0000000000 --- a/contrib/gcc-3.4/gcc/f/lex.h +++ /dev/null @@ -1,200 +0,0 @@ -/* lex.h -- Public #include File (module.h template V1.0) - Copyright (C) 1995 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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 GCC_F_LEX_H -#define GCC_F_LEX_H - -/* 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 "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 (const char *s, ffewhereLine l, - ffewhereColumn c); -ffelexToken ffelex_token_new_eof (void); -ffelexToken ffelex_token_new_name (const char *s, ffewhereLine l, - ffewhereColumn c); -ffelexToken ffelex_token_new_names (const char *s, ffewhereLine l, - ffewhereColumn c); -ffelexToken ffelex_token_new_number (const 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) ISIDST (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 /* ! GCC_F_LEX_H */ diff --git a/contrib/gcc-3.4/gcc/f/malloc.c b/contrib/gcc-3.4/gcc/f/malloc.c deleted file mode 100644 index b9addb8606..0000000000 --- a/contrib/gcc-3.4/gcc/f/malloc.c +++ /dev/null @@ -1,559 +0,0 @@ -/* malloc.c -- Implementation File (module.c template V1.0) - Copyright (C) 1995, 2003 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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" - -/* 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, { '/' } -#else - { 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 const char *const 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. */ - -struct max_alignment { - char c; - union { - HOST_WIDEST_INT i; - long double d; - } u; -}; - -#define MAX_ALIGNMENT (offsetof (struct max_alignment, u)) -#define ROUNDED_AREA_SIZE (MAX_ALIGNMENT * ((sizeof(mallocArea_) + MAX_ALIGNMENT - 1) / MAX_ALIGNMENT)) - -#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 - ROUNDED_AREA_SIZE, 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 (void) -{ - if (malloc_reserve_ != NULL) - return; - malloc_reserve_ = xmalloc (20 * 1024); /* In case of crash, free this first. */ -} - -/* 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 (const 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 UNUSED, void *ptr) -{ - mallocArea_ *t; - t = (mallocArea_ *) (ptr - ROUNDED_AREA_SIZE); - return *t; -} - -/* 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; - unsigned ss = s; - -#if MALLOC_DEBUG && 0 - assert (s == (mallocSize) ss);/* Else alloc is too big for this - library/sys. */ -#endif - - ptr = xmalloc (ss); -#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, const char *name, mallocSize s) -{ - void *ptr; - mallocArea_ a; - unsigned short i; - mallocArea_ *temp; - - 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_ (ROUNDED_AREA_SIZE + 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); - temp = (mallocArea_ *) ptr; - *temp = a; - ptr = ptr + ROUNDED_AREA_SIZE; - 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, const 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; - mallocArea_ *temp; - - 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 - ROUNDED_AREA_SIZE, ROUNDED_AREA_SIZE + ns + (MALLOC_DEBUG ? strlen (a->name) + 1: 0)); - temp = (mallocArea_ *) ptr; - *temp = a; - ptr = ptr + ROUNDED_AREA_SIZE; - 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) -{ - int ss = s; - -#if MALLOC_DEBUG && 0 - assert (s == (mallocSize) ss);/* Too big if failure here. */ -#endif - - ptr = xrealloc (ptr, ss); - 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/contrib/gcc-3.4/gcc/f/malloc.h b/contrib/gcc-3.4/gcc/f/malloc.h deleted file mode 100644 index 1c827209f2..0000000000 --- a/contrib/gcc-3.4/gcc/f/malloc.h +++ /dev/null @@ -1,183 +0,0 @@ -/* malloc.h -- Public #include File (module.h template V1.0) - Copyright (C) 1995 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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 GCC_F_MALLOC_H -#define GCC_F_MALLOC_H - -#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, const char *name, - mallocSize size); -void *malloc_new_zinpool_ (mallocPool pool, mallocType_ type, const 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 (const 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 /* ! GCC_F_MALLOC_H */ diff --git a/contrib/gcc-3.4/gcc/f/name.c b/contrib/gcc-3.4/gcc/f/name.c deleted file mode 100644 index 26f713ef32..0000000000 --- a/contrib/gcc-3.4/gcc/f/name.c +++ /dev/null @@ -1,241 +0,0 @@ -/* name.c -- Implementation File (module.c template V1.0) - Copyright (C) 1995 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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 = 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) (ffeglobal)) -{ - 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) (ffesymbol)) -{ - 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 = 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/contrib/gcc-3.4/gcc/f/name.h b/contrib/gcc-3.4/gcc/f/name.h deleted file mode 100644 index 4b18805d3d..0000000000 --- a/contrib/gcc-3.4/gcc/f/name.h +++ /dev/null @@ -1,109 +0,0 @@ -/* name.h -- Public #include File (module.h template V1.0) - Copyright (C) 1995 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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 GCC_F_NAME_H -#define GCC_F_NAME_H - -/* 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) (ffeglobal)); -void ffename_space_drive_symbol (ffenameSpace ns, ffesymbol (*fn) (ffesymbol)); -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 /* ! GCC_F_NAME_H */ diff --git a/contrib/gcc-3.4/gcc/f/news.texi b/contrib/gcc-3.4/gcc/f/news.texi deleted file mode 100644 index fcba273c85..0000000000 --- a/contrib/gcc-3.4/gcc/f/news.texi +++ /dev/null @@ -1,3177 +0,0 @@ -@c Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002 -@c 2003, 2004 -@c 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 NEWS -@c in the G77 distribution, as well as in the G77 manual. - -@c Keep this the same as the dates above, since it's used -@c in the standalone derivations of this file (e.g. NEWS). -@set copyrights-news 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004 - -@set last-update-news 2004-12-29 - -@ifset DOC-NEWS -@include root.texi -@c The immediately following lines apply to the NEWS file -@c which is derived from this file. -@emph{Note:} This file is automatically generated from the files -@file{news0.texi} and @file{news.texi}. -@file{NEWS} is @emph{not} a source file, -although it is normally included within source distributions. - -This file lists news about the @value{which-g77} version -(and some other versions) of the GNU Fortran compiler. -Copyright (C) @value{copyrights-news} 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 -@end ifset - -@ifset DOC-G77 -@ifset USERVISONLY -@node Changes -@chapter User-visible Changes -@cindex versions, recent -@cindex recent versions -@cindex changes, user-visible -@cindex user-visible changes - -This chapter describes changes to @command{g77} that are visible -to the programmers who actually write and maintain Fortran -code they compile with @command{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 @command{g77}. -@xref{News,,News About GNU Fortran}, for information on -such changes to @command{g77}. -@end ifset - -@ifclear USERVISONLY -@node News -@chapter News About GNU Fortran -@cindex versions, recent -@cindex recent versions -@end ifclear -@end ifset - -@ifclear USERVISONLY - -@emph{@code{GCC} 3.4.x is the last edition of @code{GCC} to contain @command{g77} - from @code{GCC} 4.0 onwards, use @command{gfortran}} - -Changes made to recent versions of GNU Fortran are listed -below, with the most recent version first. - -The changes are generally listed in order: - -@enumerate -@item -Code-generation and run-time-library bug-fixes - -@item -Compiler and run-time-library crashes involving valid code -that have been fixed - -@item -New features - -@item -Fixes and enhancements to existing features - -@item -New diagnostics - -@item -Internal improvements - -@item -Miscellany -@end enumerate - -This order is not strict---for example, some items -involve a combination of these elements. -@end ifclear - -Note that two variants of @command{g77} are tracked below. -The @code{egcs} variant is described vis-a-vis -previous versions of @code{egcs} and/or -an official FSF version, as appropriate. -Note that all such variants are obsolete @emph{as of July 1999} - -the information is retained here only for its historical value. - -Therefore, @code{egcs} versions sometimes have multiple listings -to help clarify how they differ from other versions, -though this can make getting a complete picture -of what a particular @code{egcs} version contains -somewhat more difficult. - -@ifset DOC-G77 -For information on bugs in the @value{which-g77} version of @command{g77}, -see @ref{Known Bugs,,Known Bugs In GNU Fortran}. -@end ifset - -@ifset DOC-BUGS -For information on bugs in the @value{which-g77} version of @command{g77}, -see @file{@value{path-g77}/BUGS}. -@end ifset - -@ifset DEVELOPMENT -@emph{Warning:} The information below is still under development, -and might not accurately reflect the @command{g77} code base -of which it is a part. -Efforts are made to keep it somewhat up-to-date, -but they are particularly concentrated -on any version of this information -that is distributed as part of a @emph{released} @command{g77}. - -In particular, while this information is intended to apply to -the @value{which-g77} version of @command{g77}, -only an official @emph{release} of that version -is expected to contain documentation that is -most consistent with the @command{g77} product in that version. - -Nevertheless, information on @emph{previous} releases of @command{g77}, below, -is likely to be more up-to-date and accurate -than the equivalent information that accompanied -those releases, -assuming the last-updated date of the information below -is later than the dates of those releases. - -That's due to attempts to keep this development version -of news about previous @command{g77} versions up-to-date. -@end ifset - -The following information was last updated on @value{last-update-news}: - -@heading In @code{GCC} 3.4 versus @code{GCC} 3.3: -@itemize @bullet -@item -Problem Reports fixed (in chronological order of submission): -@table @code -@item 8485 -g77 doesn't accept INTEGER*8 constant in PARAMETER multiplication. -@item 11918 -(libf2c) isatty does not call f_init. -@item 12317 -Incorrect documentation for Fortran debugging features. -@end table -@item -Roger Sayle (@email{roger@@eyesopen.com}) fixed the remaining -problems with regard to the support of INTEGER*8, INTEGER*2 and INTEGER*1 -as a fallout of fixing PR 8485. -@end itemize - -@heading In @code{GCC} 3.3 versus @code{GCC} 3.2: -@itemize @bullet -@item -Problem Reports fixed (in chronological order of submission): -@table @code -@item 1832 --list directed i/o overflow hangs, -fbounds-check doesn't detect -@item 3924 -g77 generates code which is rejected by GAS if COFF debugging info is -requested -@item 6286 -Broken links on web pages -@item 6367 -(libf2c) multiple repeat counts confuse namelist read into array -@item 6491 -Logical operations error on logicals when using -fugly-logint -@item 6742 -Generation of C++ Prototype for FORTRAN and extern "C" -@item 7113 -Failure of g77.f-torture/execute/f90-intrinsic-bit.f -Os on irix6.5 -@item 7236 -(libf2c) OPEN(...,RECL=nnn,...) without ACCESS='DIRECT' should assume a direct -access file -@item 7278 -g77 "bug"; the executable misbehave (use of options -O2 -fno-automatic -gave wrong results) -@item 7384 -(libf2c) DATE_AND_TIME milliseconds field inactive on Windows -@item 7388 -Incorrect output with 0-based array of characters -@item 8587 -Double complex zero ** double precision number -> NaN instead of zero -@item 9038 --ffixed-line-length-none -x f77-cpp-input gives: Warning: unknown register name line-length-none -@item 9263 -ICE caused by invalid PARAMETER in implied DO loop -@item 10197 -Direct access files not unformatted by default -@item 10726 -Documentation for function IDATE Intrinsic (UNIX) is wrong [fixed in 3.3.1]. -@end table -@item -Richard Henderson (@email{rth@@redhat.com}) analyzed and improved the handling -of (no-)aliasing information for dummy arguments and improved the optimization -of induction variables in unrolled loops. -@end itemize - -@heading In @code{GCC} 3.2 versus @code{GCC} 3.1: -@itemize @bullet -@item -Problem Reports fixed (in chronological order of submission): -@table @code -@item 7681 -ICE in compensate_edge, at reg-stack.c:2591 -@item 8308 -gcc-3.x does not compile files with suffix .r (RATFOR) [Fixed in 3.2.1] -@item 9258 -[3.2/3.3/3.4 regression] ICE in compensate_edge, at reg-stack.c:2589 -@end table -@end itemize - -@heading In @code{GCC} 3.1 (formerly known as g77-0.5.27) versus @code{GCC} 3.0: -@itemize @bullet -@item -Problem Reports fixed (in chronological order of submission): -@table @code -@item 947 -Data statement initialization with subscript of kind INTEGER*2 -@item 3743 -Reference to intrinsic `ISHFT' invalid -@item 3807 -Function BESJN(integer,double) problems -@item 3957 -g77 -pipe -xf77-cpp-input sends output to stdout -@item 4279 -g77 -h" gives bogus output -@item 4730 -ICE on valid input using CALL EXIT(%VAL(...)) -@item 4752 -g77 -v -c -xf77-version /dev/null -xnone causes ice -@item 4885 -BACKSPACE example that doesn't work as of gcc/g77-3.0.x -@item 5122 -g77 rejects accepted use of INTEGER*2 as type of DATA statement loop index -@item 5397 -ICE on compiling source with 540 000 000 REAL array -@item 5473 -ICE on BESJN(integer*8,real) -@item 5837 -bug in loop unrolling -@item 6106 -sparc-sun-solaris2.7 gcc-3.1 extra g77 testsuite failures w/-m64 -@item 6138 -Incorrect acces of integer*1 variables on PA -@item 6304 -Failure of LAPACK test dtest on irix6.5 with -mabi=64 -O2 -@end table - -@item -@command{g77} now has its man page generated from the texinfo documentation, -to guarantee that it remains up to date. - -@item -@command{g77} used to reject the following program on 32-bit targets: -@smallexample -PROGRAM PROG -DIMENSION A(140 000 000) -END -@end smallexample -with the message: -@smallexample -prog.f: In program `prog': -prog.f:2: - DIMENSION A(140 000 000) - ^ -Array `a' at (^) is too large to handle -@end smallexample -because 140 000 000 REALs is larger than the largest bit-extent that can be -expressed in 32 bits. However, bit-sizes never play a role after offsets -have been converted to byte addresses. Therefore this check has been removed, -and the limit is now 2 Gbyte of memory (around 530 000 000 REALs). -Note: On GNU/Linux systems one has to compile and link programs that occupy -more than 1 Gbyte statically, i.e.@: @code{g77 -static ...}. - -@item -Based on work done by Juergen Pfeifer (@email{juergen.pfeifer@@gmx.net}) -libf2c is now a shared library. One can still link in all objects with -the program by specifying the @option{-static} option. - -@item -Robert Anderson (@email{rwa@@alumni.princeton.edu}) thought up a two -line change that enables g77 to compile such code as: -@smallexample -SUBROUTINE SUB(A, N) -DIMENSION N(2) -DIMENSION A(N(1),N(2)) -A(1,1) = 1. -END -@end smallexample -Note the use of array elements in the bounds of the adjustable array A. - -@item -George Helffrich (@email{george@@geo.titech.ac.jp}) implemented a change -in substring index checking (when specifying @option{-fbounds-check}) -that permits the use of zero length substrings of the form -@code{string(1:0)}. - -@item -Based on code developed by Pedro Vazquez (@email{vazquez@@penelope.iqm.unicamp.br}), -the @code{libf2c} library is now able to read and write files larger than -2 Gbyte on 32-bit target machines, if the operating system supports this. -@end itemize - -@heading In 0.5.26, @code{GCC} 3.0 versus @code{GCC} 2.95: -@itemize @bullet -@item -When a REWIND was issued after a WRITE statement on an unformatted -file, the implicit truncation was performed by copying the truncated -file to /tmp and copying the result back. This has been fixed by using -the @code{ftruncate} OS function. Thanks go to the GAMESS developers -for bringing this to our attention. - -@item -Using options @option{-g}, @option{-ggdb} or @option{-gdwarf[-2]} (where -appropriate for your target) now also enables debugging information -for COMMON BLOCK and EQUIVALENCE items to be emitted. -Thanks go to Andrew Vaught (@email{andy@@xena.eas.asu.edu}) and -George Helffrich (@email{george@@geology.bristol.ac.uk}) for -fixing this longstanding problem. - -@item -It is not necessary anymore to use the option @option{-femulate-complex} -to compile Fortran code using COMPLEX arithmetic, even on 64-bit machines -(like the Alpha). This will improve code generation. - -@item -INTRINSIC arithmetic functions are now treated as routines that do not -depend on anything but their argument(s). This enables further instruction -scheduling, because it is known that they cannot read or modify arbitrary -locations. - -@ifclear USERVISONLY -@item -Upgrade to @code{libf2c} as of 2000-12-05. - -This fixes a bug where a namelist containing initialization of LOGICAL -items and a variable starting with T or F would be read incorrectly. - -@item -The @code{TtyNam} intrinsics now set @var{Name} to all spaces (at run time) -if the system has no @code{ttyname} implementation available. - -@item -Upgrade to @code{libf2c} as of 1999-06-28. - -This fixes a bug whereby -input to a @code{NAMELIST} read involving a repeat count, -such as @samp{K(5)=10*3}, -was not properly handled by @code{libf2c}. -The first item was written to @samp{K(5)}, -but the remaining nine were written elsewhere (still within the array), -not necessarily starting at @samp{K(6)}. -@end ifclear -@end itemize - -@heading In 0.5.25, @code{GCC} 2.95 (@code{EGCS} 1.2) versus @code{EGCS} 1.1.2: -@itemize @bullet -@ifclear USERVISONLY -@item -@command{g77} no longer generates bad code for assignments, -or other conversions, -of @code{REAL} or @code{COMPLEX} constant expressions -to type @code{INTEGER(KIND=2)} -(often referred to as @code{INTEGER*8}). - -For example, @samp{INTEGER*8 J; J = 4E10} now works as documented. -@end ifclear - -@ifclear USERVISONLY -@item -@command{g77} no longer truncates @code{INTEGER(KIND=2)} -(usually @code{INTEGER*8}) -subscript expressions when evaluating array references -on systems with pointers widers than @code{INTEGER(KIND=1)} -(such as Alphas). -@end ifclear - -@ifclear USERVISONLY -@item -@command{g77} no longer generates bad code -for an assignment to a @code{COMPLEX} variable or array -that partially overlaps one or more of the sources -of the same assignment -(a very rare construction). -It now assigns through a temporary, -in cases where such partial overlap is deemed possible. -@end ifclear - -@ifclear USERVISONLY -@item -@code{libg2c} (@code{libf2c}) no longer loses track -of the file being worked on -during a @code{BACKSPACE} operation. -@end ifclear - -@ifclear USERVISONLY -@item -@code{libg2c} (@code{libf2c}) fixes a bug whereby -input to a @code{NAMELIST} read involving a repeat count, -such as @samp{K(5)=10*3}, -was not properly handled by @code{libf2c}. -The first item was written to @samp{K(5)}, -but the remaining nine were written elsewhere (still within the array), -not necessarily starting at @samp{K(6)}. -@end ifclear - -@ifclear USERVISONLY -@item -@c Tim Prince reported this, regarding the TEST_FPU benchmark. -Automatic arrays now seem to be working on HP-UX systems. -@end ifclear - -@ifclear USERVISONLY -@item -The @code{Date} intrinsic now returns the correct result -on big-endian systems. -@end ifclear - -@ifclear USERVISONLY -@item -Fix @command{g77} so it no longer crashes when compiling -I/O statements using keywords that define @code{INTEGER} values, -such as @samp{IOSTAT=@var{j}}, -where @var{j} is other than default @code{INTEGER} -(such as @code{INTEGER*2}). -Instead, it issues a diagnostic. -@end ifclear - -@ifclear USERVISONLY -@item -Fix @command{g77} so it properly handles @samp{DATA A/@var{rpt}*@var{val}/}, -where @var{rpt} is not default @code{INTEGER}, such as @code{INTEGER*2}, -instead of producing a spurious diagnostic. -Also fix @samp{DATA (A(I),I=1,N)}, -where @samp{N} is not default @code{INTEGER} -to work instead of crashing @command{g77}. -@end ifclear - -@ifclear USERVISONLY -@item -The @option{-ax} option is now obeyed when compiling Fortran programs. -(It is passed to the @file{f771} driver.) -@end ifclear - -@item -The new @option{-fbounds-check} option -causes @command{g77} to compile run-time bounds checks -of array subscripts, as well as of substring start and end points. - -@item -@code{libg2c} now supports building as multilibbed library, -which provides better support for systems -that require options such as @option{-mieee} -to work properly. - -@item -Source file names with the suffixes @samp{.FOR} and @samp{.FPP} -now are recognized by @command{g77} -as if they ended in @samp{.for} and @samp{.fpp}, respectively. - -@item -The order of arguments to the @emph{subroutine} forms of the -@code{CTime}, @code{DTime}, @code{ETime}, and @code{TtyNam} -intrinsics has been swapped. -The argument serving as the returned value -for the corresponding function forms -now is the @emph{second} argument, -making these consistent with the other subroutine forms -of @code{libU77} intrinsics. - -@item -@command{g77} now warns about a reference to an intrinsic -that has an interface that is not Year 2000 (Y2K) compliant. -Also, @code{libg2c} has been changed to increase the likelihood -of catching references to the implementations of these intrinsics -using the @code{EXTERNAL} mechanism -(which would avoid the new warnings). - -@ifset DOC-G77 -@xref{Year 2000 (Y2K) Problems}, for more information. -@end ifset - -@ifclear USERVISONLY -@item -@command{g77} now warns about a reference to a function -when the corresponding @emph{subsequent} function program unit -disagrees with the reference concerning the type of the function. -@end ifclear - -@item -@option{-fno-emulate-complex} is now the default option. -This should result in improved performance -of code that uses the @code{COMPLEX} data type. - -@cindex alignment -@cindex double-precision performance -@cindex -malign-double -@item -The @option{-malign-double} option -now reliably aligns @emph{all} double-precision variables and arrays -on Intel x86 targets. - -@ifclear USERVISONLY -@item -Even without the @option{-malign-double} option, -@command{g77} reliably aligns local double-precision variables -that are not in @code{EQUIVALENCE} areas -and not @code{SAVE}'d. -@end ifclear - -@ifclear USERVISONLY -@item -@command{g77} now open-codes (``inlines'') division of @code{COMPLEX} operands -instead of generating a run-time call to -the @code{libf2c} routines @code{c_div} or @code{z_div}, -unless the @option{-Os} option is specified. -@end ifclear - -@item -@command{g77} no longer generates code to maintain @code{errno}, -a C-language concept, -when performing operations such as the @code{SqRt} intrinsic. - -@ifclear USERVISONLY -@item -@command{g77} developers can temporarily use -the @option{-fflatten-arrays} option -to compare how the compiler handles code generation -using C-like constructs as compared to the -Fortran-like method constructs normally used. -@end ifclear - -@ifclear USERVISONLY -@item -A substantial portion of the @command{g77} front end's code-generation component -was rewritten. -It now generates code using facilities more robustly supported -by the @command{gcc} back end. -One effect of this rewrite is that some codes no longer produce -a spurious ``label @var{lab} used before containing binding contour'' -message. -@end ifclear - -@item -Support for the @option{-fugly} option has been removed. - -@ifclear USERVISONLY -@item -Improve documentation and indexing, -including information on Year 2000 (Y2K) compliance, -and providing more information on internals of the front end. -@end ifclear - -@ifclear USERVISONLY -@item -Upgrade to @code{libf2c} as of 1999-05-10. -@end ifclear -@end itemize - -@heading In 0.5.24 versus 0.5.23: - -There is no @command{g77} version 0.5.24 at this time, -or planned. -0.5.24 is the version number designated for bug fixes and, -perhaps, some new features added, -to 0.5.23. -Version 0.5.23 requires @command{gcc} 2.8.1, -as 0.5.24 was planned to require. - -Due to @code{EGCS} becoming @code{GCC} -(which is now an acronym for ``GNU Compiler Collection''), -and @code{EGCS} 1.2 becoming officially designated @code{GCC} 2.95, -there seems to be no need for an actual 0.5.24 release. - -To reduce the confusion already resulting from use of 0.5.24 -to designate @command{g77} versions within @code{EGCS} versions 1.0 and 1.1, -as well as in versions of @command{g77} documentation and notices -during that period, -``mainline'' @command{g77} version numbering resumes -at 0.5.25 with @code{GCC} 2.95 (@code{EGCS} 1.2), -skipping over 0.5.24 as a placeholder version number. - -To repeat, there is no @command{g77} 0.5.24, but there is now a 0.5.25. -Please remain calm and return to your keypunch units. - -@c 1999-03-15: EGCS 1.1.2 released. -@heading In @code{EGCS} 1.1.2 versus @code{EGCS} 1.1.1: -@ifclear USERVISONLY -@itemize @bullet -@item -Fix the @code{IDate} intrinsic (VXT) (in @code{libg2c}) -so the returned year is in the documented, non-Y2K-compliant range -of 0-99, -instead of being returned as 100 in the year 2000. - -@ifset DOC-G77 -@xref{IDate Intrinsic (VXT)}, -for more information. -@end ifset - -@item -Fix the @code{Date_and_Time} intrinsic (in @code{libg2c}) -to return the milliseconds value properly -in @var{Values}(8). - -@item -Fix the @code{LStat} intrinsic (in @code{libg2c}) -to return device-ID information properly -in @var{SArray}(7). - -@item -Improve documentation. -@end itemize -@end ifclear - -@c 1998-12-04: EGCS 1.1.1 released. -@heading In @code{EGCS} 1.1.1 versus @code{EGCS} 1.1: -@ifclear USERVISONLY -@itemize @bullet -@item -Fix @code{libg2c} so it performs an implicit @code{ENDFILE} operation -(as appropriate) -whenever a @code{REWIND} is done. - -(This bug was introduced in 0.5.23 and @code{egcs} 1.1 in -@command{g77}'s version of @code{libf2c}.) - -@item -Fix @code{libg2c} so it no longer crashes with a spurious diagnostic -upon doing any I/O following a direct formatted write. - -(This bug was introduced in 0.5.23 and @code{egcs} 1.1 in -@command{g77}'s version of @code{libf2c}.) - -@item -Fix @command{g77} so it no longer crashes compiling references -to the @code{Rand} intrinsic on some systems. - -@item -Fix @command{g77} portion of installation process so it works -better on some systems -(those with shells requiring @samp{else true} clauses -on @code{if} constructs -for the completion code to be set properly). -@end itemize -@end ifclear - -@c 1998-09-03: EGCS 1.1 released. -@heading In @code{EGCS} 1.1 versus @code{EGCS} 1.0.3: -@itemize @bullet -@ifclear USERVISONLY -@item -Fix bugs in the @code{libU77} intrinsic @code{HostNm} -that wrote one byte beyond the end of its @code{CHARACTER} -argument, -and in the @code{libU77} intrinsics -@code{GMTime} and @code{LTime} -that overwrote their arguments. -@end ifclear - -@ifclear USERVISONLY -@item -Assumed arrays with negative bounds -(such as @samp{REAL A(-1:*)}) -no longer elicit spurious diagnostics from @command{g77}, -even on systems with pointers having -different sizes than integers. - -This bug is not known to have existed in any -recent version of @command{gcc}. -It was introduced in an early release of @code{egcs}. -@end ifclear - -@ifclear USERVISONLY -@item -Valid combinations of @code{EXTERNAL}, -passing that external as a dummy argument -without explicitly giving it a type, -and, in a subsequent program unit, -referencing that external as -an external function with a different type -no longer crash @command{g77}. -@end ifclear - -@ifclear USERVISONLY -@item -@code{CASE DEFAULT} no longer crashes @command{g77}. -@end ifclear - -@ifclear USERVISONLY -@item -The @option{-Wunused} option no longer issues a spurious -warning about the ``master'' procedure generated by -@command{g77} for procedures containing @code{ENTRY} statements. -@end ifclear - -@item -Support @samp{FORMAT(I<@var{expr}>)} when @var{expr} is a -compile-time constant @code{INTEGER} expression. - -@item -Fix @command{g77} @option{-g} option so procedures that -use @code{ENTRY} can be stepped through, line by line, -in @command{gdb}. - -@item -Allow any @code{REAL} argument to intrinsics -@code{Second} and @code{CPU_Time}. - -@item -Use @code{tempnam}, if available, to open scratch files -(as in @samp{OPEN(STATUS='SCRATCH')}) -so that the @code{TMPDIR} environment variable, -if present, is used. - -@item -@command{g77}'s version of @code{libf2c} separates out -the setting of global state -(such as command-line arguments and signal handling) -from @file{main.o} into distinct, new library -archive members. - -This should make it easier to write portable applications -that have their own (non-Fortran) @code{main()} routine -properly set up the @code{libf2c} environment, even -when @code{libf2c} (now @code{libg2c}) is a shared library. - -@ifclear USERVISONLY -@item -@command{g77} no longer installs the @file{f77} command -and @file{f77.1} man page -in the @file{/usr} or @file{/usr/local} hierarchy, -even if the @file{f77-install-ok} file exists -in the source or build directory. -See the installation documentation for more information. -@end ifclear - -@ifclear USERVISONLY -@item -@command{g77} no longer installs the @file{libf2c.a} library -and @file{f2c.h} include file -in the @file{/usr} or @file{/usr/local} hierarchy, -even if the @file{f2c-install-ok} or @file{f2c-exists-ok} files exist -in the source or build directory. -See the installation documentation for more information. -@end ifclear - -@ifclear USERVISONLY -@item -The @file{libf2c.a} library produced by @command{g77} has been -renamed to @file{libg2c.a}. -It is installed only in the @command{gcc} ``private'' -directory hierarchy, @file{gcc-lib}. -This allows system administrators and users to choose which -version of the @code{libf2c} library from @code{netlib} they -wish to use on a case-by-case basis. -See the installation documentation for more information. -@end ifclear - -@ifclear USERVISONLY -@item -The @file{f2c.h} include (header) file produced by @command{g77} -has been renamed to @file{g2c.h}. -It is installed only in the @command{gcc} ``private'' -directory hierarchy, @file{gcc-lib}. -This allows system administrators and users to choose which -version of the include file from @code{netlib} they -wish to use on a case-by-case basis. -See the installation documentation for more information. -@end ifclear - -@item -The @command{g77} command now expects the run-time library -to be named @code{libg2c.a} instead of @code{libf2c.a}, -to ensure that a version other than the one built and -installed as part of the same @command{g77} version is picked up. - -@ifclear USERVISONLY -@item -During the configuration and build process, -@command{g77} creates subdirectories it needs only as it -needs them. -Other cleaning up of the configuration and build process -has been performed as well. -@end ifclear - -@ifclear USERVISONLY -@item -@code{install-info} now used to update the directory of -Info documentation to contain an entry for @command{g77} -(during installation). -@end ifclear - -@item -Some diagnostics have been changed from warnings to errors, -to prevent inadvertent use of the resulting, probably buggy, -programs. -These mostly include diagnostics about use of unsupported features -in the @code{OPEN}, @code{INQUIRE}, @code{READ}, and -@code{WRITE} statements, -and about truncations of various sorts of constants. - -@ifclear USERVISONLY -@item -Improve compilation of @code{FORMAT} expressions so that -a null byte is appended to the last operand if it -is a constant. -This provides a cleaner run-time diagnostic as provided -by @code{libf2c} for statements like @samp{PRINT '(I1', 42}. -@end ifclear - -@ifclear USERVISONLY -@item -Improve documentation and indexing. -@end ifclear - -@ifclear USERVISONLY -@item -The upgrade to @code{libf2c} as of 1998-06-18 -should fix a variety of problems, including -those involving some uses of the @code{T} format -specifier, and perhaps some build (porting) problems -as well. -@end ifclear -@end itemize - -@c 1998-09-03: EGCS 1.1 released. -@heading In @code{EGCS} 1.1 versus @command{g77} 0.5.23: -@itemize @bullet -@ifclear USERVISONLY -@cindex DNRM2 -@cindex stack, 387 coprocessor -@cindex Intel x86 -@cindex -O2 -@item -Fix a code-generation bug that afflicted -Intel x86 targets when @option{-O2} was specified -compiling, for example, an old version of -the @code{DNRM2} routine. - -The x87 coprocessor stack was being -mismanaged in cases involving assigned @code{GOTO} -and @code{ASSIGN}. -@end ifclear - -@ifclear USERVISONLY -@item -@command{g77} no longer produces incorrect code -and initial values -for @code{EQUIVALENCE} and @code{COMMON} -aggregates that, due to ``unnatural'' ordering of members -vis-a-vis their types, require initial padding. -@end ifclear - -@ifclear USERVISONLY -@item -Fix @command{g77} crash compiling code -containing the construct @samp{CMPLX(0.)} or similar. -@end ifclear - -@ifclear USERVISONLY -@item -@command{g77} no longer crashes when compiling code -containing specification statements such as -@samp{INTEGER(KIND=7) PTR}. -@end ifclear - -@ifclear USERVISONLY -@item -@command{g77} no longer crashes when compiling code -such as @samp{J = SIGNAL(1, 2)}. -@end ifclear - -@item -@command{g77} now treats @samp{%LOC(@var{expr})} and -@samp{LOC(@var{expr})} as ``ordinary'' expressions -when they are used as arguments in procedure calls. -This change applies only to global (filewide) analysis, -making it consistent with -how @command{g77} actually generates code -for these cases. - -Previously, @command{g77} treated these expressions -as denoting special ``pointer'' arguments -for the purposes of filewide analysis. - -@ifclear USERVISONLY -@item -Fix @command{g77} crash -(or apparently infinite run-time) -when compiling certain complicated expressions -involving @code{COMPLEX} arithmetic -(especially multiplication). -@end ifclear - -@cindex alignment -@cindex double-precision performance -@cindex -malign-double -@item -Align static double-precision variables and arrays -on Intel x86 targets -regardless of whether @option{-malign-double} is specified. - -Generally, this affects only local variables and arrays -having the @code{SAVE} attribute -or given initial values via @code{DATA}. - -@item -The @command{g77} driver now ensures that @option{-lg2c} -is specified in the link phase prior to any -occurrence of @option{-lm}. -This prevents accidentally linking to a routine -in the SunOS4 @option{-lm} library -when the generated code wants to link to the one -in @code{libf2c} (@code{libg2c}). - -@item -@command{g77} emits more debugging information when -@option{-g} is used. - -This new information allows, for example, -@kbd{which __g77_length_a} to be used in @command{gdb} -to determine the type of the phantom length argument -supplied with @code{CHARACTER} variables. - -This information pertains to internally-generated -type, variable, and other information, -not to the longstanding deficiencies vis-a-vis -@code{COMMON} and @code{EQUIVALENCE}. - -@item -The F90 @code{Date_and_Time} intrinsic now is -supported. - -@item -The F90 @code{System_Clock} intrinsic allows -the optional arguments (except for the @code{Count} -argument) to be omitted. - -@ifclear USERVISONLY -@item -Upgrade to @code{libf2c} as of 1998-06-18. -@end ifclear - -@ifclear USERVISONLY -@item -Improve documentation and indexing. -@end ifclear -@end itemize - -@ifset DOC-NEWS -@heading In previous versions: - -Information on previous versions is not provided -in this @file{@value{path-g77}/NEWS} file, -to keep it short. -See @file{@value{path-g77}/news.texi}, -or any of its other derivations -(Info, HTML, dvi forms) -for such information. -@end ifset - -@ifclear DOC-NEWS -@c 1998-05-20: 0.5.23 released. -@heading In 0.5.23 versus 0.5.22: -@itemize @bullet -@item -This release contains several regressions against -version 0.5.22 of @command{g77}, due to using the -``vanilla'' @command{gcc} back end instead of patching -it to fix a few bugs and improve performance in a -few cases. - -Features that have been dropped from this version -of @command{g77} due to their being implemented -via @command{g77}-specific patches to the @command{gcc} -back end in previous releases include: - -@itemize @minus -@item -Support for @code{__restrict__} keyword, -the options @option{-fargument-alias}, @option{-fargument-noalias}, -and @option{-fargument-noalias-global}, -and the corresponding alias-analysis code. - -(@code{egcs} has the alias-analysis -code, but not the @code{__restrict__} keyword. -@code{egcs} @command{g77} users benefit from the alias-analysis -code despite the lack of the @code{__restrict__} keyword, -which is a C-language construct.) - -@item -Support for the GNU compiler options -@option{-fmove-all-movables}, -@option{-freduce-all-givs}, -and @option{-frerun-loop-opt}. - -(@code{egcs} supports these options. -@command{g77} users of @code{egcs} benefit from them even if -they are not explicitly specified, -because the defaults are optimized for @command{g77} users.) - -@item -Support for the @option{-W} option warning about -integer division by zero. - -@item -The Intel x86-specific option @option{-malign-double} -applying to stack-allocated data -as well as statically-allocate data. -@end itemize - -@ifclear USERVISONLY -Note that the @file{gcc/f/gbe/} subdirectory has been removed -from this distribution as a result of @command{g77} no longer -including patches for the @command{gcc} back end. -@end ifclear - -@ifclear USERVISONLY -@item -Fix bugs in the @code{libU77} intrinsic @code{HostNm} -that wrote one byte beyond the end of its @code{CHARACTER} -argument, -and in the @code{libU77} intrinsics -@code{GMTime} and @code{LTime} -that overwrote their arguments. -@end ifclear - -@item -Support @command{gcc} version 2.8, -and remove support for prior versions of @command{gcc}. - -@cindex -@w{}-driver option -@cindex @command{g77} options, -@w{}-driver -@cindex options, -@w{}-driver -@item -Remove support for the @option{--driver} option, -as @command{g77} now does all the driving, -just like @command{gcc}. - -@ifclear USERVISONLY -@item -@code{CASE DEFAULT} no longer crashes @command{g77}. -@end ifclear - -@ifclear USERVISONLY -@item -Valid combinations of @code{EXTERNAL}, -passing that external as a dummy argument -without explicitly giving it a type, -and, in a subsequent program unit, -referencing that external as -an external function with a different type -no longer crash @command{g77}. -@end ifclear - -@ifclear USERVISONLY -@item -@command{g77} no longer installs the @file{f77} command -and @file{f77.1} man page -in the @file{/usr} or @file{/usr/local} hierarchy, -even if the @file{f77-install-ok} file exists -in the source or build directory. -See the installation documentation for more information. -@end ifclear - -@ifclear USERVISONLY -@item -@command{g77} no longer installs the @file{libf2c.a} library -and @file{f2c.h} include file -in the @file{/usr} or @file{/usr/local} hierarchy, -even if the @file{f2c-install-ok} or @file{f2c-exists-ok} files exist -in the source or build directory. -See the installation documentation for more information. -@end ifclear - -@ifclear USERVISONLY -@item -The @file{libf2c.a} library produced by @command{g77} has been -renamed to @file{libg2c.a}. -It is installed only in the @command{gcc} ``private'' -directory hierarchy, @file{gcc-lib}. -This allows system administrators and users to choose which -version of the @code{libf2c} library from @code{netlib} they -wish to use on a case-by-case basis. -See the installation documentation for more information. -@end ifclear - -@ifclear USERVISONLY -@item -The @file{f2c.h} include (header) file produced by @command{g77} -has been renamed to @file{g2c.h}. -It is installed only in the @command{gcc} ``private'' -directory hierarchy, @file{gcc-lib}. -This allows system administrators and users to choose which -version of the include file from @code{netlib} they -wish to use on a case-by-case basis. -See the installation documentation for more information. -@end ifclear - -@item -The @command{g77} command now expects the run-time library -to be named @code{libg2c.a} instead of @code{libf2c.a}, -to ensure that a version other than the one built and -installed as part of the same @command{g77} version is picked up. - -@ifclear USERVISONLY -@item -The @option{-Wunused} option no longer issues a spurious -warning about the ``master'' procedure generated by -@command{g77} for procedures containing @code{ENTRY} statements. -@end ifclear - -@item -@command{g77}'s version of @code{libf2c} separates out -the setting of global state -(such as command-line arguments and signal handling) -from @file{main.o} into distinct, new library -archive members. - -This should make it easier to write portable applications -that have their own (non-Fortran) @code{main()} routine -properly set up the @code{libf2c} environment, even -when @code{libf2c} (now @code{libg2c}) is a shared library. - -@ifclear USERVISONLY -@item -During the configuration and build process, -@command{g77} creates subdirectories it needs only as it -needs them, thus avoiding unnecessary creation of, for example, -@file{stage1/f/runtime} when doing a non-bootstrap build. -Other cleaning up of the configuration and build process -has been performed as well. -@end ifclear - -@ifclear USERVISONLY -@item -@code{install-info} now used to update the directory of -Info documentation to contain an entry for @command{g77} -(during installation). -@end ifclear - -@item -Some diagnostics have been changed from warnings to errors, -to prevent inadvertent use of the resulting, probably buggy, -programs. -These mostly include diagnostics about use of unsupported features -in the @code{OPEN}, @code{INQUIRE}, @code{READ}, and -@code{WRITE} statements, -and about truncations of various sorts of constants. - -@ifclear USERVISONLY -@item -Improve documentation and indexing. -@end ifclear - -@ifclear USERVISONLY -@item -Upgrade to @code{libf2c} as of 1998-04-20. - -This should fix a variety of problems, including -those involving some uses of the @code{T} format -specifier, and perhaps some build (porting) problems -as well. -@end ifclear -@end itemize - -@c 1998-03-16: 0.5.22 released. -@heading In 0.5.22 versus 0.5.21: -@itemize @bullet -@ifclear USERVISONLY -@item -Fix code generation for iterative @code{DO} loops that -have one or more references to the iteration variable, -or to aliases of it, in their control expressions. -For example, @samp{DO 10 J=2,J} now is compiled correctly. -@end ifclear - -@ifclear USERVISONLY -@cindex DNRM2 -@cindex stack, 387 coprocessor -@cindex Intel x86 -@cindex -O2 -@item -Fix a code-generation bug that afflicted -Intel x86 targets when @option{-O2} was specified -compiling, for example, an old version of -the @code{DNRM2} routine. - -The x87 coprocessor stack was being -mismanaged in cases involving assigned @code{GOTO} -and @code{ASSIGN}. -@end ifclear - -@ifclear USERVISONLY -@item -Fix @code{DTime} intrinsic so as not to truncate -results to integer values (on some systems). -@end ifclear - -@item -Fix @code{Signal} intrinsic so it offers portable -support for 64-bit systems (such as Digital Alphas -running GNU/Linux). - -@ifclear USERVISONLY -@item -Fix run-time crash involving @code{NAMELIST} on 64-bit -machines such as Alphas. -@end ifclear - -@ifclear USERVISONLY -@item -Fix @command{g77} version of @code{libf2c} so it no longer -produces a spurious @samp{I/O recursion} diagnostic at run time -when an I/O operation (such as @samp{READ *,I}) is interrupted -in a manner that causes the program to be terminated -via the @code{f_exit} routine (such as via @kbd{C-c}). -@end ifclear - -@ifclear USERVISONLY -@item -Fix @command{g77} crash triggered by @code{CASE} statement with -an omitted lower or upper bound. -@end ifclear - -@ifclear USERVISONLY -@item -Fix @command{g77} crash compiling references to @code{CPU_Time} -intrinsic. -@end ifclear - -@ifclear USERVISONLY -@item -Fix @command{g77} crash -(or apparently infinite run-time) -when compiling certain complicated expressions -involving @code{COMPLEX} arithmetic -(especially multiplication). -@end ifclear - -@ifclear USERVISONLY -@item -Fix @command{g77} crash on statements such as -@samp{PRINT *, (REAL(Z(I)),I=1,2)}, where -@samp{Z} is @code{DOUBLE COMPLEX}. -@end ifclear - -@ifclear USERVISONLY -@item -Fix a @command{g++} crash. -@end ifclear - -@item -Support @samp{FORMAT(I<@var{expr}>)} when @var{expr} is a -compile-time constant @code{INTEGER} expression. - -@item -Fix @command{g77} @option{-g} option so procedures that -use @code{ENTRY} can be stepped through, line by line, -in @command{gdb}. - -@ifclear USERVISONLY -@item -Fix a profiling-related bug in @command{gcc} back end for -Intel x86 architecture. -@end ifclear - -@item -Allow any @code{REAL} argument to intrinsics -@code{Second} and @code{CPU_Time}. - -@item -Allow any numeric argument to intrinsics -@code{Int2} and @code{Int8}. - -@item -Use @code{tempnam}, if available, to open scratch files -(as in @samp{OPEN(STATUS='SCRATCH')}) -so that the @code{TMPDIR} environment variable, -if present, is used. - -@item -Rename the @command{gcc} keyword @code{restrict} to -@code{__restrict__}, to avoid rejecting valid, existing, -C programs. -Support for @code{restrict} is now more like support -for @code{complex}. - -@ifclear USERVISONLY -@item -Fix @option{-fpedantic} to not reject procedure invocations -such as @samp{I=J()} and @samp{CALL FOO()}. -@end ifclear - -@item -Fix @option{-fugly-comma} to affect invocations of -only external procedures. -Restore rejection of gratuitous trailing omitted -arguments to intrinsics, as in @samp{I=MAX(3,4,,)}. - -@item -Fix compiler so it accepts @option{-fgnu-intrinsics-*} and -@option{-fbadu77-intrinsics-*} options. - -@ifclear USERVISONLY -@item -Improve diagnostic messages from @code{libf2c} -so it is more likely that the printing of the -active format string is limited to the string, -with no trailing garbage being printed. - -(Unlike @command{f2c}, @command{g77} did not append -a null byte to its compiled form of every -format string specified via a @code{FORMAT} statement. -However, @command{f2c} would exhibit the problem -anyway for a statement like @samp{PRINT '(I)garbage', 1} -by printing @samp{(I)garbage} as the format string.) -@end ifclear - -@ifclear USERVISONLY -@item -Improve compilation of @code{FORMAT} expressions so that -a null byte is appended to the last operand if it -is a constant. -This provides a cleaner run-time diagnostic as provided -by @code{libf2c} for statements like @samp{PRINT '(I1', 42}. -@end ifclear - -@ifclear USERVISONLY -@item -Fix various crashes involving code with diagnosed errors. -@end ifclear - -@ifclear USERVISONLY -@item -Fix cross-compilation bug when configuring @code{libf2c}. -@end ifclear - -@ifclear USERVISONLY -@item -Improve diagnostics. -@end ifclear - -@ifclear USERVISONLY -@item -Improve documentation and indexing. -@end ifclear - -@ifclear USERVISONLY -@item -Upgrade to @code{libf2c} as of 1997-09-23. -This fixes a formatted-I/O bug that afflicted -64-bit systems with 32-bit integers -(such as Digital Alpha running GNU/Linux). -@end ifclear -@end itemize - -@c 1998-03-18: EGCS 1.0.2 released. -@heading In @code{EGCS} 1.0.2 versus @code{EGCS} 1.0.1: -@itemize @bullet -@ifclear USERVISONLY -@item -Fix @command{g77} crash triggered by @code{CASE} statement with -an omitted lower or upper bound. -@end ifclear - -@ifclear USERVISONLY -@item -Fix @command{g77} crash on statements such as -@samp{PRINT *, (REAL(Z(I)),I=1,2)}, where -@samp{Z} is @code{DOUBLE COMPLEX}. -@end ifclear - -@ifclear USERVISONLY -@cindex ELF support -@cindex support, ELF -@cindex -fPIC option -@cindex options, -fPIC -@item -Fix @option{-fPIC} (such as compiling for ELF targets) -on the Intel x86 architecture target -so invalid assembler code is no longer produced. -@end ifclear - -@ifclear USERVISONLY -@item -Fix @option{-fpedantic} to not reject procedure invocations -such as @samp{I=J()} and @samp{CALL FOO()}. -@end ifclear - -@ifclear USERVISONLY -@item -Fix @option{-fugly-comma} to affect invocations of -only external procedures. -Restore rejection of gratuitous trailing omitted -arguments to intrinsics, as in @samp{I=MAX(3,4,,)}. -@end ifclear - -@item -Fix compiler so it accepts @option{-fgnu-intrinsics-*} and -@option{-fbadu77-intrinsics-*} options. -@end itemize - -@c 1998-01-06: EGCS 1.0.1 released. -@heading In @code{EGCS} 1.0.1 versus @code{EGCS} 1.0: -@ifclear USERVISONLY -@itemize @bullet -@item -Fix run-time crash involving @code{NAMELIST} on 64-bit -machines such as Alphas. -@end itemize -@end ifclear - -@c 1997-12-03: EGCS 1.0 released. -@heading In @code{EGCS} 1.0 versus @command{g77} 0.5.21: -@itemize @bullet -@item -Version 1.0 of @code{egcs} -contains several regressions against -version 0.5.21 of @command{g77}, -due to using the -``vanilla'' @command{gcc} back end instead of patching -it to fix a few bugs and improve performance in a -few cases. - -Features that have been dropped from this version -of @command{g77} due to their being implemented -via @command{g77}-specific patches to the @command{gcc} -back end in previous releases include: - -@itemize @minus -@item -Support for the C-language @code{restrict} keyword. - -@item -Support for the @option{-W} option warning about -integer division by zero. - -@item -The Intel x86-specific option @option{-malign-double} -applying to stack-allocated data -as well as statically-allocate data. -@end itemize - -@ifclear USERVISONLY -Note that the @file{gcc/f/gbe/} subdirectory has been removed -from this distribution as a result of @command{g77} -being fully integrated with -the @code{egcs} variant of the @command{gcc} back end. -@end ifclear - -@ifclear USERVISONLY -@item -Fix code generation for iterative @code{DO} loops that -have one or more references to the iteration variable, -or to aliases of it, in their control expressions. -For example, @samp{DO 10 J=2,J} now is compiled correctly. -@end ifclear - -@ifclear USERVISONLY -@item -Fix @code{DTime} intrinsic so as not to truncate -results to integer values (on some systems). -@end ifclear - -@ifclear USERVISONLY -@item -@c Toon Moene discovered these. -Some Fortran code, miscompiled -by @command{g77} built on @command{gcc} version 2.8.1 -on m68k-next-nextstep3 configurations -when using the @option{-O2} option, -is now compiled correctly. -It is believed that a C function known to miscompile -on that configuration -when using the @samp{-O2 -funroll-loops} options -also is now compiled correctly. -@end ifclear - -@ifclear USERVISONLY -@item -Remove support for non-@code{egcs} versions of @command{gcc}. -@end ifclear - -@cindex -@w{}-driver option -@cindex @command{g77} options, -@w{}-driver -@cindex options, -@w{}-driver -@item -Remove support for the @option{--driver} option, -as @command{g77} now does all the driving, -just like @command{gcc}. - -@item -Allow any numeric argument to intrinsics -@code{Int2} and @code{Int8}. - -@ifclear USERVISONLY -@item -Improve diagnostic messages from @code{libf2c} -so it is more likely that the printing of the -active format string is limited to the string, -with no trailing garbage being printed. - -(Unlike @command{f2c}, @command{g77} did not append -a null byte to its compiled form of every -format string specified via a @code{FORMAT} statement. -However, @code{f2c} would exhibit the problem -anyway for a statement like @samp{PRINT '(I)garbage', 1} -by printing @samp{(I)garbage} as the format string.) -@end ifclear - -@ifclear USERVISONLY -@item -Upgrade to @code{libf2c} as of 1997-09-23. -This fixes a formatted-I/O bug that afflicted -64-bit systems with 32-bit integers -(such as Digital Alpha running GNU/Linux). -@end ifclear -@end itemize - -@c 1997-09-09: 0.5.21 released. -@heading In 0.5.21: -@itemize @bullet -@ifclear USERVISONLY -@item -Fix a code-generation bug introduced by 0.5.20 -caused by loop unrolling (by specifying -@option{-funroll-loops} or similar). -This bug afflicted all code compiled by -version 2.7.2.2.f.2 of @command{gcc} (C, C++, -Fortran, and so on). -@end ifclear - -@ifclear USERVISONLY -@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 @option{-fpedantic} -option). -@end ifclear - -@ifclear USERVISONLY -@item -Fix a compiler crash that occurred when an -integer division by a constant zero is detected. -Instead, when the @option{-W} option is specified, -the @command{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 @command{gcc} (C, C++, -Fortran, and so on). -@end ifclear -@ifset USERVISONLY -@item -When the @option{-W} option is specified, @command{gcc}, @command{g77}, -and other GNU compilers that incorporate the @command{gcc} -back end as modified by @command{g77}, issue -a warning about integer division by constant zero. -@end ifset - -@ifclear USERVISONLY -@item -Fix a compiler crash that occurred in some cases -of procedure inlining. -(Such cases became more frequent in 0.5.20.) -@end ifclear - -@ifclear USERVISONLY -@item -Fix a compiler crash resulting from using @code{DATA} -or similar to initialize a @code{COMPLEX} variable or -array to zero. -@end ifclear - -@ifclear USERVISONLY -@item -Fix compiler crashes involving use of @code{AND}, @code{OR}, -or @code{XOR} intrinsics. -@end ifclear - -@ifclear USERVISONLY -@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. -@end ifclear - -@ifclear USERVISONLY -@item -Fix compiler crashes due to using the name of a some -non-standard intrinsics (such as @code{FTell} or -@code{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. -@end ifclear - -@c @command{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 @command{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 @command{g77} as a call to the @code{libf2c} -@c routine @code{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 @code{G77_fputc_0}, -@c which does not conflict with the @code{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 @code{fputc_}, which is -@c simply a jacket routine that calls @code{G77_fputc_0}. - -@ifclear USERVISONLY -@item -Place automatic arrays on the stack, even if -@code{SAVE} or the @option{-fno-automatic} option -is in effect. -This avoids a compiler crash in some cases. -@end ifclear - -@ifclear USERVISONLY -@item -The @option{-malign-double} option now reliably aligns -@code{DOUBLE PRECISION} optimally on Pentium and -Pentium Pro architectures (586 and 686 in @command{gcc}). -@end ifclear - -@item -New option @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 @command{g77}. - -@item -New option @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 @option{-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. - -@ifclear USERVISONLY -@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. -@end ifclear - -@ifclear USERVISONLY -@item -Fix parsing bug whereby @command{g77} rejected a -second initialization specification immediately -following the first's closing @samp{/} without -an intervening comma in a @code{DATA} statement, -and the second specification was an implied-DO list. -@end ifclear - -@ifclear USERVISONLY -@item -Improve performance of the @command{gcc} back end so -certain complicated expressions involving @code{COMPLEX} -arithmetic (especially multiplication) don't appear to -take forever to compile. -@end ifclear - -@ifclear USERVISONLY -@item -Fix a couple of profiling-related bugs in @command{gcc} -back end. -@end ifclear - -@ifclear USERVISONLY -@item -Integrate GNU Ada's (GNAT's) changes to the back end, -which consist almost entirely of bug fixes. -These fixes are circa version 3.10p of GNAT. -@end ifclear - -@ifclear USERVISONLY -@item -Include some other @command{gcc} fixes that seem useful in -@command{g77}'s version of @command{gcc}. -(See @file{gcc/ChangeLog} for details---compare it -to that file in the vanilla @code{gcc-2.7.2.3.tar.gz} -distribution.) -@end ifclear - -@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 @code{Status} argument. - -@ifclear USERVISONLY -@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. -@end ifclear - -@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}. - -@ifclear USERVISONLY -@item -Improve @code{libU77} so it is more portable. -@end ifclear - -@item -Add options @option{-fbadu77-intrinsics-delete}, -@option{-fbadu77-intrinsics-hide}, and so on. - -@ifclear USERVISONLY -@item -Fix crashes involving diagnosed or invalid code. -@end ifclear - -@ifclear USERVISONLY -@item -@command{g77} and @command{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. -@end ifclear - -@ifclear USERVISONLY -@item -Make some fixes to alias analysis code. -@end ifclear - -@ifclear USERVISONLY -@item -Add support for @code{restrict} keyword in @command{gcc} -front end. -@end ifclear - -@ifclear USERVISONLY -@item -Support @command{gcc} version 2.7.2.3 -(modified by @command{g77} into version 2.7.2.3.f.1), -and remove -support for prior versions of @command{gcc}. -@end ifclear - -@ifclear USERVISONLY -@item -Incorporate GNAT's patches to the @command{gcc} back -end into @command{g77}'s, so GNAT users do not need -to apply GNAT's patches to build both GNAT and @command{g77} -from the same source tree. -@end ifclear - -@ifclear USERVISONLY -@item -Modify @command{make} rules and related code so that -generation of Info documentation doesn't require -compilation using @command{gcc}. -Now, any ANSI C compiler should be adequate to -produce the @command{g77} documentation (in particular, -the tables of intrinsics) from scratch. -@end ifclear - -@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)}. - -@ifclear USERVISONLY -@item -Warn when explicit type declaration disagrees with -the type of an intrinsic invocation. -@end ifclear - -@ifclear USERVISONLY -@item -Support @samp{*f771} entry in @command{gcc} @file{specs} file. -@end ifclear - -@ifclear USERVISONLY -@item -Fix typo in @command{make} rule @command{g77-cross}, used only for -cross-compiling. -@end ifclear - -@ifclear USERVISONLY -@item -Fix @code{libf2c} build procedure to re-archive library -if previous attempt to archive was interrupted. -@end ifclear - -@ifclear USERVISONLY -@item -Change @command{gcc} to unroll loops only during the last -invocation (of as many as two invocations) of loop -optimization. -@end ifclear - -@ifclear USERVISONLY -@item -Improve handling of @option{-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 @option{-ff2c} in effect. -@end ifclear - -@ifclear USERVISONLY -@item -Fix @command{g77} driver to recognize @option{-fsyntax-only} -as an option that inhibits linking, just like @option{-c} or -@option{-S}, and to recognize and properly handle the -@option{-nostdlib}, @option{-M}, @option{-MM}, @option{-nodefaultlibs}, -and @option{-Xlinker} options. -@end ifclear - -@ifclear USERVISONLY -@item -Upgrade to @code{libf2c} as of 1997-08-16. -@end ifclear - -@ifclear USERVISONLY -@item -Modify @code{libf2c} to consistently and clearly diagnose -recursive I/O (at run time). -@end ifclear - -@item -@command{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 @command{ratfor} command, available -separately. - -@ifclear USERVISONLY -@item -Fix some aspects of how @command{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. -@end ifclear - -@ifclear USERVISONLY -@item -Improve diagnostics. -@end ifclear - -@ifclear USERVISONLY -@item -Improve documentation and indexing. -@end ifclear - -@ifclear USERVISONLY -@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 @command{g77}'s version of -@code{libf2c} the suffix @samp{.netlib}. -@end ifclear - -@ifclear USERVISONLY -@item -Reserve @code{INTEGER(KIND=0)} for future use. -@end ifclear -@end itemize - -@c 1997-02-28: 0.5.20 released. -@heading In 0.5.20: -@itemize @bullet -@item -The @option{-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 @option{-ftypeless-boz} to cause such -constants to be interpreted as typeless. - -(Version 0.5.19 introduced @option{-fno-typeless-boz} and -its inverse.) - -@ifset DOC-G77 -@xref{Fortran Dialect Options,,Options Controlling Fortran Dialect}, -for information on the @option{-ftypeless-boz} option. -@end ifset - -@item -Options @option{-ff90-intrinsics-enable} and -@option{-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, @option{-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 @code{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 @code{ALWAYS_FLUSH} defined, -you will have to modify @code{libf2c} accordingly before -building it from this and future versions of @command{g77}. - -@ifset DOC-G77 -@xref{Output Assumed To Flush}, for more information. -@end ifset - -@item -Dave Love's implementation of @code{libU77} has been -added to the version of @code{libf2c} distributed with -and built as part of @command{g77}. -@command{g77} now knows about the routines in this library -as intrinsics. - -@item -New option @option{-fvxt} specifies that the -source file is written in VXT Fortran, instead of GNU Fortran. - -@ifset DOC-G77 -@xref{VXT Fortran}, for more information on the constructs -recognized when the @option{-fvxt} option is specified. -@end ifset - -@item -The @option{-fvxt-not-f90} option has been deleted, -along with its inverse, @option{-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 @command{g77}. - -@ifset DOC-G77 -@xref{Other Dialects}, for more information. -@end ifset - -@item -The @option{-fugly} option now issues a warning, as it -likely will be removed in a future version. - -(Enabling all the @option{-fugly-*} options is unlikely -to be feasible, or sensible, in the future, -so users should learn to specify only those -@option{-fugly-*} options they really need for a -particular source file.) - -@item -The @option{-fugly-assumed} option, introduced in -version 0.5.19, has been changed to -better accommodate old and new code. - -@ifset DOC-G77 -@xref{Ugly Assumed-Size Arrays}, for more information. -@end ifset - -@ifclear USERVISONLY -@item -Make a number of fixes to the @command{g77} front end and -the @command{gcc} back end to better support Alpha (AXP) -machines. -This includes providing at least one bug-fix to the -@command{gcc} back end for Alphas. -@end ifclear - -@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 machines, this won't make a 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 @command{g77} front -end, to avoid bugs in @code{complex} support in the -@command{gcc} back end. -New option @option{-fno-emulate-complex} -causes @command{g77} to revert the 0.5.19 behavior. - -@ifclear USERVISONLY -@item -Fix bug whereby @samp{REAL A(1)}, for example, caused -a compiler crash if @option{-fugly-assumed} was in effect -and @var{A} was a local (automatic) array. -That case is no longer affected by the new -handling of @option{-fugly-assumed}. -@end ifclear - -@ifclear USERVISONLY -@item -Fix @command{g77} command driver so that @samp{g77 -o foo.f} -no longer deletes @file{foo.f} before issuing other -diagnostics, and so the @option{-x} option is properly -handled. -@end ifclear - -@ifclear USERVISONLY -@item -Enable inlining of subroutines and functions by the @command{gcc} -back end. -This works as it does for @command{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. -@end ifclear - -@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 @option{-fforce-addr} -also is specified. - -New options @option{-falias-check}, @option{-fargument-alias}, -@option{-fargument-noalias}, -and @option{-fno-argument-noalias-global} control the -way @command{g77} handles potential aliasing. - -@ifset DOC-G77 -@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 @command{g77}. -@end ifset - -@ifclear USERVISONLY -@item -The @code{CONJG()} and @code{DCONJG()} intrinsics now -are compiled in-line. -@end ifclear - -@ifclear USERVISONLY -@item -The bug-fix for 0.5.19.1 has been re-done. -The @command{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 @command{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}.) -@end ifclear - -@item -New option @option{-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, @command{g77} uses a separate memory location -to hold assigned statement labels.) - -@ifset DOC-G77 -@xref{Ugly Assigned Labels}, for more information. -@end ifset - -@item -@code{FORMAT} and @code{ENTRY} statements now are allowed to -precede @code{IMPLICIT NONE} statements. - -@ifclear USERVISONLY -@item -Produce diagnostic for unsupported @code{SELECT CASE} on -@code{CHARACTER} type, instead of crashing, at compile time. -@end ifclear - -@ifclear USERVISONLY -@item -Fix crashes involving diagnosed or invalid code. -@end ifclear - -@ifclear USERVISONLY -@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 @command{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). -@end ifclear - -@ifclear USERVISONLY -@item -Support @command{gcc} version 2.7.2.2 -(modified by @command{g77} into version 2.7.2.2.f.2), -and remove -support for prior versions of @command{gcc}. -@end ifclear - -@ifclear USERVISONLY -@item -Upgrade to @code{libf2c} as of 1997-02-08, and -fix up some of the build procedures. -@end ifclear - -@ifclear USERVISONLY -@item -Improve general build procedures for @command{g77}, -fixing minor bugs (such as deletion of any file -named @file{f771} in the parent directory of @code{gcc/}). -@end ifclear - -@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 @command{f2c} users -may make full use of its features via the @command{g77} -version of @file{f2c.h} and the @code{INTEGER(KIND=2)} -support routines in the @command{g77} version of @code{libf2c}. - -@item -Improve @command{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, @code{gnu}, has been added -to contain the new @code{REALPART}, @code{IMAGPART}, -and @code{COMPLEX} intrinsics. -An old group, @code{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 -@option{-ff90} option specifies Fortran 90 interpretation -or new @option{-fugly-complex} option, in conjunction with -@option{-fnot-f90}, specifies @command{f2c} interpretation. - -@ifclear USERVISONLY -@item -Make improvements to diagnostics. -@end ifclear - -@ifclear USERVISONLY -@item -Speed up compiler a bit. -@end ifclear - -@ifclear USERVISONLY -@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 @code{M} for the node -@code{Diagnostics} in the top-level menu of -the Info documentation.) -@end ifclear -@end itemize - -@ifclear DOC-OLDNEWS -@heading In previous versions: - -Information on previous versions is archived -in @file{@value{path-g77}/news.texi} -following the test of the @code{DOC-OLDNEWS} macro. -@end ifclear - -@ifset DOC-OLDNEWS -@c 1997-02-01: 0.5.19.1 released. -@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: @code{CONJG()}, -@code{DCONJG()}, @code{CCOS()}, @code{CDCOS()}, -@code{CLOG()}, @code{CDLOG()}, @code{CSIN()}, @code{CDSIN()}, -@code{CSQRT()}, @code{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 @code{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 - -@c 1996-12-07: 0.5.19 released. -@heading In 0.5.19: -@itemize @bullet -@item -Fix @code{FORMAT} statement parsing so negative values for -specifiers such as @code{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 @option{-fonetrip} option specifies FORTRAN-66-style -one-trip @code{DO} loops. - -@item -New @option{-fno-silent} option causes names of program units -to be printed as they are compiled, in a fashion similar to -UNIX @command{f77} and @command{f2c}. - -@item -New @option{-fugly-assumed} option specifies that arrays -dimensioned via @samp{DIMENSION X(1)}, for example, are to be -treated as assumed-size. - -@item -New @option{-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 @option{-ff66} option is a ``shorthand'' option that specifies -behaviors considered appropriate for FORTRAN 66 programs. - -@item -New @option{-ff77} option is a ``shorthand'' option that specifies -behaviors considered appropriate for UNIX @command{f77} programs. - -@item -New @option{-fugly-comma} and @option{-fugly-logint} options provided -to perform some of what @option{-fugly} used to do. -@option{-fugly} and @option{-fno-ugly} are now ``shorthand'' options, -in that they do nothing more than enable (or disable) other -@option{-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 @command{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 nonzero -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 @code{whence} arguments. - -@item -Some useless warnings from the @option{-Wunused} option have -been eliminated. - -@item -Fix a problem building the @file{f771} executable -on AIX systems by linking with the @option{-bbigtoc} option. - -@item -Abort configuration if @command{gcc} has not been patched -using the patch file provided in the @file{gcc/f/gbe/} -subdirectory. - -@item -Add options @option{--help} and @option{--version} to the -@command{g77} command, to conform to GNU coding guidelines. -Also add printing of @command{g77} version number when -the @option{--verbose} (@option{-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 - -@c 1996-04-01: 0.5.18 released. -@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, @command{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, @option{-fzeros}, is introduced to -enable the traditional treatment of zeros as any -other value. - -@item -With @option{-ff90} in force, @command{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 @option{-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 @command{gcc} back end (GBE). -These options are @option{-fmove-all-movables}, @option{-freduce-all-givs}, -and @option{-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 @command{gcc} -also is patched to make it easier to manage installations, -especially useful if it turns out a @command{g77} change to the -GBE has a bug. - -The @command{g77}-modified version number is the @command{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 @command{gcc}, @samp{2} for the -second, and so on. - -So, this introduces version 2.7.2.f.1 of @command{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 @option{-Wsurprising}, now produced @emph{only} when both -operators are, indeed, arithmetic (not relational/boolean). - -@item -@option{-Wsurprising} now warns about the remaining cases -of using non-integral variables for implied-@code{DO} -loops, instead of these being rejected unless @option{-fpedantic} -or @option{-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 @command{g77} documentation, which -supersedes @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 @option{-fno-second-underscore} option to specify -that, when @option{-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 @command{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 @command{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 @command{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 - -@c 1995-11-18: 0.5.17 released. -@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 @code{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 @command{ld} command -with @samp{-o /dev/null} that @command{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 @command{mv}. - -@item -Fix omission of @option{-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 @command{g77} (the @command{fini} -utility in particular) is properly built using the host compiler. - -@item -Add new @option{-Wsurprising} option to warn about constructs that are -interpreted by the Fortran standard (and @command{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. @command{f2c}). - -@item -Remove from @option{-fno-pedantic} the diagnostic about @code{DO} -with non-@code{INTEGER} index variable; issue that under -@option{-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 @command{gcc} version 2.7.1. - -@item -Upgrade to @code{libf2c} as of 1995-11-15. -@end itemize - -@c 1995-08-30: 0.5.16 released. -@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 @option{-fno-f2c} by making these -procedures known to @command{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} @code{WANT_LEAD_0} to 1 to make @command{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 @command{f2c} plus @command{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 @command{gcc} back end does not support the necessary -mechanics (and the @command{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 @command{g77} driver. -Provide for easy selection of whether to install copy of @command{g77} -as @command{f77} to replace the broken code. - -@item -Fix @command{gcc} driver (affects @command{g77} thereby) to not -gratuitously invoke the -@code{f771} program (e.g. when @option{-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 @command{gcc}/@command{g77} when -compiling Fortran files. -These options include @option{-p}, @option{-pg}, @option{-aux-info}, @option{-P}, -correct setting of version-number macros for preprocessing, full -recognition of @option{-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 @code{unix} to contain the new intrinsics, -and by default enable this new group. - -@item -Move @code{LOC()} intrinsic out of the @code{vxt} group to the new -@code{unix} group. - -@item -Improve @command{g77} so that @samp{g77 -v} by itself (or with -certain other options, including @option{-B}, @option{-b}, @option{-i}, -@option{-nostdlib}, and @option{-V}) reports lots more useful -version info, and so that long-form options @command{gcc} accepts are -understood by @command{g77} as well (even in truncated, unambiguous forms). - -@item -Add new @command{g77} option @option{--driver=name} to specify driver when -default, @command{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 @command{gcc}, with info such as -@samp{In function `foo':} and @samp{In file included from...:}. - -@item -Support @command{gcc}'s @option{-fident} and @option{-fno-ident} options. - -@item -When @option{-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 (@command{g77} might someday start warning about these)---applies -to @command{gcc} versions 2.7.0 and later, since earlier versions didn't -warn about unused dummy arguments. - -@item -New option @option{-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 -@command{g77} using the native (non-@command{gcc}) compiler on certain machines -(but definitely not all machines nor all non-@command{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 @command{g77} is known to not work well for such cases. - -@item -Lots of new documentation (though work is still needed to put it into -canonical GNU format). - -@item -Build @code{libf2c} with @option{-g0}, not @option{-g2}, in effect -(by default), to produce -smaller library without lots of debugging clutter. -@end itemize - -@c 1995-05-19: 0.5.15 released. -@heading In 0.5.15: -@itemize @bullet -@item -Fix bad code generation involving @samp{X**I} and temporary, internal variables -generated by @command{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 @option{-ff2c} option is in force (which it is by default) so that -@command{f2c} compatibility is indeed provided. - -@item -Disallow @samp{COMMON I(10)} if @samp{I} has previously been specified -with an array declarator. - -@item -New @option{-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 -@option{-ffixed-line-length-none} was in effect. - -@item -No longer generate better code for some kinds of array references, -as @command{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 @command{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 @option{-I} option for @code{INCLUDE} statement, plus @command{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 @command{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 @command{g77}, which expects a working ANSI C -environment (and, for now, a GNU C compiler to compile @command{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 @option{-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 @command{f2c}'s, which supports only -a limited subset of backslash (escape) sequences. - -@item -Make @option{-fugly-args} the default. - -@item -New @option{-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 @option{-fno-ugly-init}. - -@item -New @option{-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 @option{-Wimplicit} option to warn about implicitly typed variables, arrays, -and functions. -(Basically causes all program units to default to @code{IMPLICIT NONE}.) - -@item -@option{-Wall} now implies @option{-Wuninitialized} as with @command{gcc} -(i.e. unless @option{-O} not specified, since @option{-Wuninitialized} -requires @option{-O}), and implies @option{-Wunused} as well. - -@item -@option{-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 @command{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 @command{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 @minus -@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:} @command{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 @command{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 @minus -@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 @command{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 @option{-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 - -@end ifset -@end ifclear diff --git a/contrib/gcc-3.4/gcc/f/news0.texi b/contrib/gcc-3.4/gcc/f/news0.texi deleted file mode 100644 index 21176c39ec..0000000000 --- a/contrib/gcc-3.4/gcc/f/news0.texi +++ /dev/null @@ -1,9 +0,0 @@ -\input texinfo @c -*-texinfo-*- -@c %**start of header -@setfilename NEWS -@c %**end of header - -@c This tells news.texi that it's generating just the NEWS file. -@set DOC-NEWS -@include news.texi -@bye diff --git a/contrib/gcc-3.4/gcc/f/parse.c b/contrib/gcc-3.4/gcc/f/parse.c deleted file mode 100644 index d822773f35..0000000000 --- a/contrib/gcc-3.4/gcc/f/parse.c +++ /dev/null @@ -1,49 +0,0 @@ -/* GNU Fortran - Copyright (C) 1995 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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 "top.h" -#include "com.h" -#include "where.h" -#include "version.h" -#include "flags.h" - -extern FILE *finput; - -void -ffe_parse_file (int set_yydebug ATTRIBUTE_UNUSED) -{ - const char *fname; - ffewhereFile wf; - - if (ffe_is_version ()) - fprintf (stderr, "GNU Fortran Front End version %s\n", version_string); - - if (!ffe_is_pedantic ()) - ffe_set_is_pedantic (pedantic); - - fname = main_input_filename ? main_input_filename : ""; - wf = ffewhere_file_new (fname, strlen (fname)); - ffecom_file (fname); - ffe_file (wf, finput); - - ffecom_finish_compile (); -} diff --git a/contrib/gcc-3.4/gcc/f/proj.h b/contrib/gcc-3.4/gcc/f/proj.h deleted file mode 100644 index 0896bdf32c..0000000000 --- a/contrib/gcc-3.4/gcc/f/proj.h +++ /dev/null @@ -1,52 +0,0 @@ -/* proj.h file for Gnu Fortran - Copyright (C) 1995, 1996, 2000, 2001, 2002 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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 GCC_F_PROJ_H -#define GCC_F_PROJ_H - -#ifdef USE_BCONFIG -#include "bconfig.h" -#else -#include "config.h" -#endif -#include "system.h" -#include "coretypes.h" -#include "tm.h" - -#if (GCC_VERSION < 2000) - #error "You have to use gcc 2.x to build g77." -#endif - -/* Include files everyone gets. is needed for assert(). */ - -#include "assert.h" - -#ifndef UNUSED /* Compile with -DUNUSED= if cc doesn't support this. */ -#define UNUSED ATTRIBUTE_UNUSED -#endif /* !defined (UNUSED) */ - -#ifndef dmpout -#define dmpout stderr -#endif - -#endif /* ! GCC_F_PROJ_H */ diff --git a/contrib/gcc-3.4/gcc/f/root.texi b/contrib/gcc-3.4/gcc/f/root.texi deleted file mode 100644 index 1956abca3c..0000000000 --- a/contrib/gcc-3.4/gcc/f/root.texi +++ /dev/null @@ -1,14 +0,0 @@ -@include gcc-common.texi - -@set email-general gcc@@gcc.gnu.org -@set email-help gcc-help@@gcc.gnu.org -@set email-bugs gcc-bugs@@gcc.gnu.org or bug-gcc@@gnu.org -@set email-patch gcc-patches@@gcc.gnu.org -@set path-g77 gcc/gcc/f -@set path-libf2c gcc/libf2c - -@set which-g77 GCC-@value{version-GCC} -@set which-gcc GCC - -@set email-burley craig@@jcb-sc.com -@set www-burley http://world.std.com/%7Eburley/ diff --git a/contrib/gcc-3.4/gcc/f/src.c b/contrib/gcc-3.4/gcc/f/src.c deleted file mode 100644 index 54fc7773fe..0000000000 --- a/contrib/gcc-3.4/gcc/f/src.c +++ /dev/null @@ -1,427 +0,0 @@ -/* src.c -- Implementation File - Copyright (C) 1995, 2003 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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 "src.h" -#include "top.h" - -/* 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 (void) -{ - 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_bad_symbol_init_[i] = FFEBAD; - ffesrc_bad_symbol_noninit_[i] = FFEBAD; - } - - 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 = TOUPPER (c); /* Upcase source. */ - d = 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 = 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 = 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 = TOUPPER (c); - d = TOUPPER (d); - while ((len > 0) && (c == d)) - { /* Skip past equivalent (case-ins) chars. */ - --len, ++var, ++str_ic; - if (len > 0) - c = TOUPPER (*var); - d = 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 = 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 = TOUPPER (*var); - while ((c != '\0') && (c == *str_uc)) - { /* Skip past equivalent (case-ins) chars. */ - ++var, ++str_uc; - c = 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 = 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 = TOUPPER (*var); - while ((len > 0) && (c == *str_uc)) - { /* Skip past equivalent (case-ins) chars. */ - --len, ++var, ++str_uc; - if (len > 0) - c = 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/contrib/gcc-3.4/gcc/f/src.h b/contrib/gcc-3.4/gcc/f/src.h deleted file mode 100644 index ce5843eaa0..0000000000 --- a/contrib/gcc-3.4/gcc/f/src.h +++ /dev/null @@ -1,140 +0,0 @@ -/* src.h -- Public #include File - Copyright (C) 1995 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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 GCC_F_SRC_H -#define GCC_F_SRC_H - -#include "bad.h" -#include "top.h" - -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() - -/* End of #include file. */ - -#endif /* ! GCC_F_SRC_H */ diff --git a/contrib/gcc-3.4/gcc/f/st.c b/contrib/gcc-3.4/gcc/f/st.c deleted file mode 100644 index cdfdfb596a..0000000000 --- a/contrib/gcc-3.4/gcc/f/st.c +++ /dev/null @@ -1,554 +0,0 @@ -/* st.c -- Implementation File (module.c template V1.0) - Copyright (C) 1995, 2003 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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 (void) -{ - 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 (void) -{ - 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 (void) -{ - 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 (void) -{ - 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 (void) -{ - 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 (void) -{ - 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 (void) -{ - 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 (void) -{ - 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 (void) -{ - 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 (void) -{ - 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 (void) -{ - 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 (void) -{ - 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 (void) -{ - 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 (void) -{ - 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 (void) -{ - 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 (void) -{ - 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/contrib/gcc-3.4/gcc/f/st.h b/contrib/gcc-3.4/gcc/f/st.h deleted file mode 100644 index 65b99f9bbf..0000000000 --- a/contrib/gcc-3.4/gcc/f/st.h +++ /dev/null @@ -1,81 +0,0 @@ -/* st.h -- Public #include File (module.h template V1.0) - Copyright (C) 1995 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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 GCC_F_ST_H -#define GCC_F_ST_H - -/* 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 /* ! GCC_F_ST_H */ diff --git a/contrib/gcc-3.4/gcc/f/sta.c b/contrib/gcc-3.4/gcc/f/sta.c deleted file mode 100644 index ee75fa88f6..0000000000 --- a/contrib/gcc-3.4/gcc/f/sta.c +++ /dev/null @@ -1,1722 +0,0 @@ -/* sta.c -- Implementation File (module.c template V1.0) - Copyright (C) 1995, 1996, 1997, 2003 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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_ (void) -{ - 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_ (void) -{ - 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 - = 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 - = 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_.first) - { - 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_.first) - { - 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) - { - 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: - case FFESTR_firstCASEDEFAULT: - 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; - - 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; - - 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; - - 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: - case FFESTR_secondPROGRAM: - case FFESTR_secondSELECT: - case FFESTR_secondSUBROUTINE: - 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; - - 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; - - case FFESTR_firstENDSUBROUTINE: - ffestb_args.endxyz.len = FFESTR_firstlENDSUBROUTINE; - ffestb_args.endxyz.second = FFESTR_secondSUBROUTINE; - ffesta_add_possible_exec_ ((ffelexHandler) ffestb_endxyz); - break; - - 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; - - /* 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_firstGO: - if ((ffelex_token_type (ffesta_token_0_) == FFELEX_typeNAMES) - || (ffelex_token_type (t) != FFELEX_typeNAME)) - ffesta_add_possible_exec_ ((ffelexHandler) ffestb_goto); - else - switch (ffesta_second_kw) - { - case FFESTR_secondTO: - ffesta_add_possible_exec_ ((ffelexHandler) ffestb_goto); - break; - default: - ffesta_add_possible_exec_ ((ffelexHandler) ffestb_goto); - break; - } - 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; - - 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; - - case FFESTR_firstNAMELIST: - ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R542); - break; - - case FFESTR_firstOPEN: - ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R904); - break; - - 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; - - case FFESTR_firstPRINT: - ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R911); - break; - - case FFESTR_firstPROGRAM: - ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R1102); - break; - - 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; - - 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; - - 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; - - case FFESTR_firstSTOP: - ffestb_args.halt.len = FFESTR_firstlSTOP; - ffesta_add_possible_exec_ ((ffelexHandler) ffestb_halt); - break; - - 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; - - case FFESTR_firstTYPE: - ffesta_add_possible_exec_ ((ffelexHandler) ffestb_V020); - break; - - 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; - - 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; - - case FFELEX_typeEQUALS: - 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 (void) -{ - 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 (void) -{ - 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 (); - } -} - -/* 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 (void) -{ - ffestaPossible_ ptr; - int i; - - ptr = 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 (void) -{ - 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 (void) -{ - 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, const 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, const 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, const 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 (); - } -} - -ffestaPooldisp -ffesta_outpooldisp (void) -{ - return ffesta_outpooldisp_; -} - -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 (void) -{ - 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 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 (); - } - - ffelex_set_names (TRUE); - return (ffelexHandler) ffesta_first; -} diff --git a/contrib/gcc-3.4/gcc/f/sta.h b/contrib/gcc-3.4/gcc/f/sta.h deleted file mode 100644 index cf41777155..0000000000 --- a/contrib/gcc-3.4/gcc/f/sta.h +++ /dev/null @@ -1,117 +0,0 @@ -/* sta.h -- Private #include File (module.h template V1.0) - Copyright (C) 1995 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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 GCC_F_STA_H -#define GCC_F_STA_H - -/* 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, const char *s, ffelexToken names_token, - ffeTokenLength index, ffelexToken next_token); -void ffesta_ffebad_1st (ffebad msg, const char *s, ffelexToken t); -void ffesta_ffebad_1t (ffebad msg, ffelexToken t); -void ffesta_ffebad_2st (ffebad msg, const 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); -ffestaPooldisp ffesta_outpooldisp (void); -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 /* ! GCC_F_STA_H */ diff --git a/contrib/gcc-3.4/gcc/f/stb.c b/contrib/gcc-3.4/gcc/f/stb.c deleted file mode 100644 index 673f96c23c..0000000000 --- a/contrib/gcc-3.4/gcc/f/stb.c +++ /dev/null @@ -1,17812 +0,0 @@ -/* stb.c -- Implementation File (module.c template V1.0) - Copyright (C) 1995, 1996, 2002, 2003 - Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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 "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; - 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; - struct - { - ffebld expr; - } - selectcase; - struct - { - ffesttCaseList cases; - } - case_stmt; - struct - { - bool is_cblock; - } - V014; - 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; - struct - { - bool started; - } - common; - struct - { - bool started; - } - dimension; - struct - { - bool started; - } - dimlist; - struct - { - const 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. */ - const 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); -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); -static ffelexHandler ffestb_varlist5_ (ffelexToken t); -static ffelexHandler ffestb_varlist6_ (ffelexToken t); -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); -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); -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 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); -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); -static ffelexHandler ffestb_V0201_ (ffelexToken ft, ffebld expr, - ffelexToken t); -static ffelexHandler ffestb_V0202_ (ffelexToken ft, ffebld expr, - ffelexToken t); -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); -static ffelexHandler ffestb_R12291_ (ffelexToken t); -static ffelexHandler ffestb_R12292_ (ffelexToken ft, ffebld expr, - ffelexToken t); -static ffelexHandler ffestb_decl_chartype1_ (ffelexToken t); -static ffelexHandler ffestb_decl_attrs_ (ffelexToken t); -static ffelexHandler ffestb_decl_attrs_1_ (ffelexToken t); -static ffelexHandler ffestb_decl_attrs_2_ (ffelexToken t); -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); -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); -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); -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_ (void) -{ - 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_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; - unsigned const 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; - const 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; - unsigned const 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; - const 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); - 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) - { - - 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; - unsigned const 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_; - - 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; - unsigned const 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) - { - 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); - 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) - { - 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; - - case FFESTR_secondBLOCK: - case FFESTR_secondBLOCKDATA: - if (!ffesta_is_inhibited ()) - ffestc_R1112 (ffesta_tokens[1]); - break; - - 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; - - 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; - unsigned const 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_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. */ - unsigned const 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)) - { - 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 ()) - ffestc_let (ffestb_local_.let.dest, expr, ft); - 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_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; - unsigned const 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 (); - goto bad_1; /* :::::::::::::::::::: */ - - case FFELEX_typeCOMMA: - ffesta_confirmed (); /* Error, but clearly intended. */ - goto bad_1; /* :::::::::::::::::::: */ - - case FFELEX_typeCOLONCOLON: - ffesta_confirmed (); - ffesta_confirmed (); /* Error, but clearly intended. */ - goto bad_1; /* :::::::::::::::::::: */ - - default: - goto bad_1; /* :::::::::::::::::::: */ - - case FFELEX_typeOPEN_PAREN: - goto bad_1; /* :::::::::::::::::::: */ - - case FFELEX_typeNAME: - ffesta_confirmed (); - switch (ffesta_first_kw) - { - case FFESTR_firstEXTERNAL: - if (!ffesta_is_inhibited ()) - ffestc_R1207_start (); - break; - - case FFESTR_firstINTRINSIC: - if (!ffesta_is_inhibited ()) - ffestc_R1208_start (); - break; - - 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 (); - if (*p != '\0') - break; - goto bad_1; /* :::::::::::::::::::: */ - - case FFELEX_typeCOMMA: - ffesta_confirmed (); /* Error, but clearly intended. */ - - if (*p != '\0') - break; - goto bad_1; /* :::::::::::::::::::: */ - - case FFELEX_typeCOLONCOLON: - ffesta_confirmed (); - goto bad_1; /* :::::::::::::::::::: */ - - case FFELEX_typeOPEN_PAREN: - goto bad_1; /* :::::::::::::::::::: */ - - case FFELEX_typeNAME: - ffesta_confirmed (); - switch (ffesta_first_kw) - { - case FFESTR_firstEXTERNAL: - if (!ffesta_is_inhibited ()) - ffestc_R1207_start (); - break; - - case FFESTR_firstINTRINSIC: - if (!ffesta_is_inhibited ()) - ffestc_R1208_start (); - break; - - 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; - - 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_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; - - case FFESTR_firstINTRINSIC: - ffestc_R1208_finish (); - break; - - 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; - - case FFESTR_firstINTRINSIC: - ffestc_R1208_item (ffesta_tokens[1]); - break; - - 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; - - case FFESTR_firstINTRINSIC: - ffestc_R1208_item (ffesta_tokens[1]); - ffestc_R1208_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.varlist.badname, t); - break; - } - - if (!ffesta_is_inhibited ()) - { - switch (ffesta_first_kw) - { - case FFESTR_firstEXTERNAL: - ffestc_R1207_finish (); - break; - - case FFESTR_firstINTRINSIC: - ffestc_R1208_finish (); - break; - - default: - assert (FALSE); - } - } - ffelex_token_kill (ffesta_tokens[1]); - return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); -} - -/* 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; - unsigned const 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) -{ - unsigned const 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 = ffeexpr_convert (expr, ft, t, - FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGER1, - 0, - FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - 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: - case FFELEX_typeOPEN_PAREN: - 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) -{ - const 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; - unsigned const 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; - unsigned const 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) -{ - unsigned const 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) -{ - const 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; - unsigned const 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; - unsigned const 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; - unsigned const 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_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_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; - const 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; - unsigned const 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; - const 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 = ffelex_token_length (t) + 1; i > 0; --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 = ffelex_token_length (t) + 1; i > 0; --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 ((unsigned char)*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; - const 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 = ffelex_token_length (t) + 1; i > 0; --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; - const 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 = ffelex_token_length (t) + 1; i > 0; --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 = ffelex_token_length (t) + 1; i > 0; --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 = ffe_is_pedantic() ? required : optional; - 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 ("bad format item" == NULL); - 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_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; - const 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)) - { - /* xgettext:no-c-format */ - 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_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; - unsigned const 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_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_ (void) -{ - 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_ (void) -{ - 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_ (void) -{ - 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_ (void) -{ - 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_ (void) -{ - 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_ (void) -{ - 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_ (void) -{ - 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_ (void) -{ - 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_ (void) -{ - 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_ (void) -{ - 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_ (void) -{ - 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; - - 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; - - 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_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_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; - const 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_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; - unsigned const 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; - unsigned const 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; - unsigned const 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_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; - unsigned const 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; - unsigned const 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; - unsigned const 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_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)) - { - 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_; - - case FFESTR_firstINTRINSIC: - if (!ffesta_is_inhibited ()) - ffestc_decl_attrib (FFESTP_attribINTRINSIC, t, - FFESTR_otherNone, NULL); - return (ffelexHandler) ffestb_decl_attrs_7_; - - 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_; - - case FFESTR_firstSAVE: - if (!ffesta_is_inhibited ()) - ffestc_decl_attrib (FFESTP_attribSAVE, t, - FFESTR_otherNone, NULL); - return (ffelexHandler) ffestb_decl_attrs_7_; - - 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_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])) - { - 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; - unsigned const 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])) - { - 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])) - { - 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_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_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) -{ - unsigned const 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; - unsigned const 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_; - - 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); - - 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_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_; - - 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/contrib/gcc-3.4/gcc/f/stb.h b/contrib/gcc-3.4/gcc/f/stb.h deleted file mode 100644 index 88cb7c5452..0000000000 --- a/contrib/gcc-3.4/gcc/f/stb.h +++ /dev/null @@ -1,177 +0,0 @@ -/* stb.h -- Private #include File (module.h template V1.0) - Copyright (C) 1995, 1996, 2003 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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 GCC_F_STB_H -#define GCC_F_STB_H - -/* 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 - { - const char *badname; - ffeTokenLength len; /* Length of "ENTRY/FUNCTION/SUBROUTINE". */ - bool is_subr; /* TRUE if SUBROUTINE or if ENTRY within - SUBROUTINE. */ - } - dummy; - struct - { - const 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; - struct - { - const char *badname; - ffeTokenLength len; /* Length of - "EXTERNAL/INTENT/INTRINSIC/OPTIONAL/PUBLIC/ - PRIVATE". */ - } - varlist; - struct - { - const 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); -ffelexHandler ffestb_if (ffelexToken t); -ffelexHandler ffestb_let (ffelexToken t); -ffelexHandler ffestb_varlist (ffelexToken t); -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); -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); -ffelexHandler ffestb_R1212 (ffelexToken t); -ffelexHandler ffestb_R1227 (ffelexToken t); -ffelexHandler ffestb_R1229 (ffelexToken t); -ffelexHandler ffestb_S3P4 (ffelexToken t); -ffelexHandler ffestb_V014 (ffelexToken t); -ffelexHandler ffestb_V020 (ffelexToken t); -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 /* ! GCC_F_STB_H */ diff --git a/contrib/gcc-3.4/gcc/f/stc.c b/contrib/gcc-3.4/gcc/f/stc.c deleted file mode 100644 index 5f058135bb..0000000000 --- a/contrib/gcc-3.4/gcc/f/stc.c +++ /dev/null @@ -1,10459 +0,0 @@ -/* stc.c -- Implementation File (module.c template V1.0) - Copyright (C) 1995, 1996, 1997, 2003 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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; - }; /* 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); -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); -static ffestcOrder_ ffestc_order_data_ (void); -static ffestcOrder_ ffestc_order_data77_ (void); -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); -static ffestcOrder_ ffestc_order_parameter_ (void); -static ffestcOrder_ ffestc_order_program_ (void); -static ffestcOrder_ ffestc_order_progspec_ (void); -static ffestcOrder_ ffestc_order_selectcase_ (void); -static ffestcOrder_ ffestc_order_sfunc_ (void); -static ffestcOrder_ ffestc_order_subroutine_ (void); -static ffestcOrder_ ffestc_order_typedecl_ (void); -static ffestcOrder_ ffestc_order_unit_ (void); -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); -static void ffestc_shriek_blockdata_ (bool ok); -static void ffestc_shriek_do_ (bool ok); -static void ffestc_shriek_end_program_ (bool ok); -static void ffestc_shriek_function_ (bool ok); -static void ffestc_shriek_if_ (bool ok); -static void ffestc_shriek_ifthen_ (bool ok); -static void ffestc_shriek_select_ (bool ok); -static void ffestc_shriek_subroutine_ (bool ok); -static int ffestc_subr_binsrch_ (const char *const *list, int size, - ffestpFile *spec, const 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_ (const char *name, ffestpFile *spec); -static int ffestc_subr_speccmp_ (const char *string, ffestpFile *spec, - const 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_() -#define ffestc_shriek_if_lost_ ffestc_shriek_if_ - -/* 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 (void) -{ - 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 (void) -{ - 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_ (void) -{ - 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_ (void) -{ - 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_ (void) -{ - 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_ (void) -{ - 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_ (void) -{ - 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_ (void) -{ - 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_ (void) -{ - 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_ (void) -{ - 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_ (void) -{ - 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_ (void) -{ - 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