From 9e169c4bf36a38689550c059570c57efbf00a6fb Mon Sep 17 00:00:00 2001 From: hjl Date: Thu, 1 Jul 2010 22:22:57 +0000 Subject: Merged trunk at revision 161680 into branch. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/vect256@161681 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ChangeLog | 4831 +++++- gcc/DATESTAMP | 2 +- gcc/Makefile.in | 529 +- gcc/ada/ChangeLog | 3140 ++++ gcc/ada/Makefile.rtl | 8 +- gcc/ada/a-coinve.adb | 2036 ++- gcc/ada/a-comlin.ads | 5 +- gcc/ada/a-convec.adb | 1650 +- gcc/ada/a-envvar.ads | 2 +- gcc/ada/a-excpol-abort.adb | 4 +- gcc/ada/a-ngcoty.adb | 32 +- gcc/ada/a-nudira.adb | 235 +- gcc/ada/a-nudira.ads | 57 +- gcc/ada/a-nuflra.adb | 255 +- gcc/ada/a-nuflra.ads | 45 +- gcc/ada/a-reatim.adb | 10 +- gcc/ada/a-retide.adb | 8 +- gcc/ada/a-strunb-shared.adb | 2086 +++ gcc/ada/a-strunb-shared.ads | 481 + gcc/ada/a-strunb.adb | 21 +- gcc/ada/a-stunau-shared.adb | 62 + gcc/ada/a-stunau.adb | 18 +- gcc/ada/a-stunau.ads | 23 +- gcc/ada/a-stuten.adb | 209 + gcc/ada/a-stuten.ads | 146 + gcc/ada/a-stwiun-shared.adb | 2104 +++ gcc/ada/a-stwiun-shared.ads | 483 + gcc/ada/a-stzunb-shared.adb | 2118 +++ gcc/ada/a-stzunb-shared.ads | 501 + gcc/ada/a-suenco.adb | 390 + gcc/ada/a-suenco.ads | 61 + gcc/ada/a-suewen.adb | 371 + gcc/ada/a-suewen.ads | 67 + gcc/ada/a-suezen.adb | 431 + gcc/ada/a-suezen.ads | 64 + gcc/ada/a-suteio-shared.adb | 132 + gcc/ada/a-swunau-shared.adb | 65 + gcc/ada/a-swunau.adb | 21 +- gcc/ada/a-swunau.ads | 11 +- gcc/ada/a-swuwti-shared.adb | 134 + gcc/ada/a-szunau-shared.adb | 65 + gcc/ada/a-szunau.adb | 29 +- gcc/ada/a-szunau.ads | 11 +- gcc/ada/a-szuzti-shared.adb | 135 + gcc/ada/a-tags.ads | 4 +- gcc/ada/a-tifiio.adb | 14 +- gcc/ada/adaint.c | 220 +- gcc/ada/ali-util.adb | 22 +- gcc/ada/ali-util.ads | 17 +- gcc/ada/ali.adb | 85 +- gcc/ada/ali.ads | 75 +- gcc/ada/alloc.ads | 3 + gcc/ada/atree.adb | 261 +- gcc/ada/atree.ads | 98 +- gcc/ada/back_end.adb | 103 +- gcc/ada/back_end.ads | 2 +- gcc/ada/binde.adb | 271 +- gcc/ada/bindgen.adb | 289 +- gcc/ada/bindgen.ads | 4 +- gcc/ada/bindusg.adb | 17 +- gcc/ada/checks.adb | 271 +- gcc/ada/clean.adb | 7 +- gcc/ada/csets.adb | 16 +- gcc/ada/cstand.adb | 55 +- gcc/ada/cstreams.c | 20 +- gcc/ada/debug.adb | 39 +- gcc/ada/einfo.adb | 610 +- gcc/ada/einfo.ads | 111 +- gcc/ada/env.c | 6 +- gcc/ada/errout.adb | 297 +- gcc/ada/errout.ads | 18 +- gcc/ada/erroutc.ads | 7 +- gcc/ada/exp_aggr.adb | 158 +- gcc/ada/exp_atag.adb | 12 +- gcc/ada/exp_attr.adb | 134 +- gcc/ada/exp_cg.adb | 602 + gcc/ada/exp_cg.ads | 47 + gcc/ada/exp_ch11.adb | 31 +- gcc/ada/exp_ch13.adb | 20 +- gcc/ada/exp_ch3.adb | 142 +- gcc/ada/exp_ch3.ads | 8 +- gcc/ada/exp_ch4.adb | 1074 +- gcc/ada/exp_ch4.ads | 5 +- gcc/ada/exp_ch5.adb | 104 +- gcc/ada/exp_ch6.adb | 209 +- gcc/ada/exp_ch7.adb | 33 +- gcc/ada/exp_ch7.ads | 4 +- gcc/ada/exp_ch9.adb | 275 +- gcc/ada/exp_ch9.ads | 10 +- gcc/ada/exp_dbug.adb | 11 +- gcc/ada/exp_disp.adb | 381 +- gcc/ada/exp_dist.adb | 307 +- gcc/ada/exp_fixd.adb | 18 +- gcc/ada/exp_imgv.adb | 67 +- gcc/ada/exp_intr.adb | 69 +- gcc/ada/exp_pakd.adb | 215 +- gcc/ada/exp_pakd.ads | 7 +- gcc/ada/exp_prag.adb | 21 +- gcc/ada/exp_sel.adb | 40 +- gcc/ada/exp_smem.adb | 7 +- gcc/ada/exp_strm.adb | 4 +- gcc/ada/exp_util.adb | 258 +- gcc/ada/exp_util.ads | 5 + gcc/ada/expander.adb | 6 +- gcc/ada/fmap.adb | 5 +- gcc/ada/freeze.adb | 392 +- gcc/ada/frontend.adb | 7 +- gcc/ada/g-comlin.ads | 135 +- gcc/ada/g-dirope.ads | 6 +- gcc/ada/g-expect-vms.adb | 239 +- gcc/ada/g-expect.adb | 238 +- gcc/ada/g-expect.ads | 118 +- gcc/ada/g-mbdira.adb | 282 + gcc/ada/g-mbdira.ads | 123 + gcc/ada/g-mbflra.adb | 314 + gcc/ada/g-mbflra.ads | 103 + gcc/ada/g-pehage.adb | 242 +- gcc/ada/g-pehage.ads | 25 +- gcc/ada/g-sercom-linux.adb | 11 +- gcc/ada/g-socket.adb | 265 +- gcc/ada/g-socket.ads | 91 +- gcc/ada/g-socthi-mingw.adb | 143 +- gcc/ada/g-socthi-mingw.ads | 10 +- gcc/ada/g-socthi-vms.adb | 8 +- gcc/ada/g-socthi-vms.ads | 10 +- gcc/ada/g-socthi-vxworks.adb | 8 +- gcc/ada/g-socthi-vxworks.ads | 10 +- gcc/ada/g-socthi.adb | 16 +- gcc/ada/g-socthi.ads | 10 +- gcc/ada/g-sothco.ads | 152 +- gcc/ada/g-spipat.adb | 89 +- gcc/ada/g-spitbo.adb | 20 +- gcc/ada/g-sttsne-dummy.ads | 39 - gcc/ada/g-sttsne-locking.adb | 460 - gcc/ada/g-sttsne-locking.ads | 75 - gcc/ada/g-sttsne-vxworks.adb | 204 - gcc/ada/g-sttsne.ads | 83 - gcc/ada/gcc-interface/Make-lang.in | 1394 +- gcc/ada/gcc-interface/Makefile.in | 126 +- gcc/ada/gcc-interface/ada-tree.h | 36 +- gcc/ada/gcc-interface/decl.c | 253 +- gcc/ada/gcc-interface/gigi.h | 4 +- gcc/ada/gcc-interface/lang-specs.h | 5 +- gcc/ada/gcc-interface/misc.c | 8 +- gcc/ada/gcc-interface/trans.c | 331 +- gcc/ada/gcc-interface/utils.c | 162 +- gcc/ada/gcc-interface/utils2.c | 77 +- gcc/ada/get_scos.adb | 172 +- gcc/ada/gnat-style.texi | 2 +- gcc/ada/gnat1drv.adb | 82 +- gcc/ada/gnat_rm.texi | 1281 +- gcc/ada/gnat_ugn.texi | 15078 ++++++------------- gcc/ada/gnatbind.adb | 161 +- gcc/ada/gnatcmd.adb | 192 +- gcc/ada/gnatlink.adb | 11 - gcc/ada/gnatname.adb | 17 +- gcc/ada/gnatsym.adb | 55 +- gcc/ada/gnatvsn.ads | 2 +- gcc/ada/gnatxref.adb | 91 +- gcc/ada/gsocket.h | 45 +- gcc/ada/i-cstrea.ads | 8 +- gcc/ada/i-forbla-darwin.adb | 4 +- gcc/ada/impunit.adb | 34 +- gcc/ada/init.c | 216 +- gcc/ada/initialize.c | 11 +- gcc/ada/inline.adb | 3 +- gcc/ada/inline.ads | 7 +- gcc/ada/itypes.ads | 4 +- gcc/ada/layout.adb | 15 +- gcc/ada/lib-util.adb | 97 +- gcc/ada/lib-util.ads | 13 + gcc/ada/lib-writ.adb | 94 +- gcc/ada/lib-writ.ads | 85 +- gcc/ada/lib-xref.adb | 23 +- gcc/ada/lib-xref.ads | 9 +- gcc/ada/lib.adb | 14 +- gcc/ada/lib.ads | 19 + gcc/ada/make.adb | 99 +- gcc/ada/makeusg.adb | 15 +- gcc/ada/makeutl.adb | 15 +- gcc/ada/makeutl.ads | 7 +- gcc/ada/mlib-prj.adb | 7 +- gcc/ada/mlib-utl.adb | 31 +- gcc/ada/nlists.adb | 71 + gcc/ada/nlists.ads | 8 + gcc/ada/opt.adb | 2 +- gcc/ada/opt.ads | 70 +- gcc/ada/osint-b.adb | 38 +- gcc/ada/osint-b.ads | 20 +- gcc/ada/osint.adb | 33 +- gcc/ada/osint.ads | 18 +- gcc/ada/output.adb | 29 +- gcc/ada/output.ads | 88 +- gcc/ada/par-ch10.adb | 20 +- gcc/ada/par-ch11.adb | 5 +- gcc/ada/par-ch12.adb | 7 +- gcc/ada/par-ch2.adb | 4 +- gcc/ada/par-ch3.adb | 72 +- gcc/ada/par-ch4.adb | 171 +- gcc/ada/par-ch5.adb | 26 +- gcc/ada/par-ch6.adb | 49 +- gcc/ada/par-ch7.adb | 13 +- gcc/ada/par-ch9.adb | 34 +- gcc/ada/par-endh.adb | 2 +- gcc/ada/par-labl.adb | 16 +- gcc/ada/par-prag.adb | 27 +- gcc/ada/par-tchk.adb | 89 +- gcc/ada/par-util.adb | 32 +- gcc/ada/par.adb | 21 +- gcc/ada/par_sco.adb | 593 +- gcc/ada/par_sco.ads | 166 +- gcc/ada/prep.adb | 25 +- gcc/ada/prepcomp.adb | 8 +- gcc/ada/prj-attr.adb | 3 +- gcc/ada/prj-conf.adb | 42 +- gcc/ada/prj-env.adb | 57 +- gcc/ada/prj-env.ads | 4 +- gcc/ada/prj-ext.adb | 3 +- gcc/ada/prj-nmsc.adb | 906 +- gcc/ada/prj-part.adb | 15 +- gcc/ada/prj-proc.adb | 221 +- gcc/ada/prj.adb | 25 +- gcc/ada/prj.ads | 51 +- gcc/ada/projects.texi | 3889 +++++ gcc/ada/put_scos.adb | 139 +- gcc/ada/raise.h | 11 - gcc/ada/repinfo.adb | 3 +- gcc/ada/restrict.adb | 10 +- gcc/ada/rtsfind.adb | 6 +- gcc/ada/s-auxdec-vms-alpha.adb | 809 + gcc/ada/s-auxdec-vms_64.ads | 46 +- gcc/ada/s-crtl.ads | 7 +- gcc/ada/s-fileio.adb | 4 +- gcc/ada/s-filofl.ads | 2 +- gcc/ada/s-finimp.adb | 4 +- gcc/ada/s-interr.adb | 18 +- gcc/ada/s-intman-vxworks.ads | 7 +- gcc/ada/s-os_lib.adb | 14 +- gcc/ada/s-oscons-tmplt.c | 36 +- gcc/ada/s-osinte-hpux-dce.ads | 2 +- gcc/ada/s-osinte-linux.ads | 2 +- gcc/ada/s-osinte-vxworks.ads | 5 +- gcc/ada/s-rannum.adb | 369 +- gcc/ada/s-rannum.ads | 27 +- gcc/ada/s-regpat.adb | 805 +- gcc/ada/s-shasto.adb | 8 +- gcc/ada/s-stchop.adb | 20 +- gcc/ada/s-stoele.adb | 45 +- gcc/ada/s-taprop-vxworks.adb | 52 +- gcc/ada/s-tasdeb.adb | 5 +- gcc/ada/s-tpoben.adb | 10 +- gcc/ada/s-vxwext-kernel.ads | 4 +- gcc/ada/s-vxwext-rtp.ads | 4 +- gcc/ada/s-vxwext.ads | 5 +- gcc/ada/scil_ll.adb | 144 + gcc/ada/scil_ll.ads | 48 + gcc/ada/scng.adb | 58 +- gcc/ada/scng.ads | 8 +- gcc/ada/scos.ads | 129 +- gcc/ada/sem.adb | 417 +- gcc/ada/sem_aggr.adb | 113 +- gcc/ada/sem_attr.adb | 114 +- gcc/ada/sem_aux.adb | 23 +- gcc/ada/sem_aux.ads | 7 +- gcc/ada/sem_case.adb | 2 +- gcc/ada/sem_case.ads | 18 +- gcc/ada/sem_cat.adb | 59 +- gcc/ada/sem_ch10.adb | 86 +- gcc/ada/sem_ch11.adb | 2 +- gcc/ada/sem_ch12.adb | 308 +- gcc/ada/sem_ch13.adb | 1952 ++- gcc/ada/sem_ch13.ads | 14 +- gcc/ada/sem_ch3.adb | 533 +- gcc/ada/sem_ch3.ads | 12 +- gcc/ada/sem_ch4.adb | 375 +- gcc/ada/sem_ch4.ads | 4 +- gcc/ada/sem_ch5.adb | 68 +- gcc/ada/sem_ch6.adb | 354 +- gcc/ada/sem_ch7.adb | 13 +- gcc/ada/sem_ch8.adb | 380 +- gcc/ada/sem_ch9.adb | 118 +- gcc/ada/sem_disp.adb | 67 +- gcc/ada/sem_disp.ads | 9 +- gcc/ada/sem_dist.adb | 10 +- gcc/ada/sem_elab.adb | 41 +- gcc/ada/sem_elim.adb | 122 +- gcc/ada/sem_eval.adb | 869 +- gcc/ada/sem_eval.ads | 3 +- gcc/ada/sem_intr.adb | 35 +- gcc/ada/sem_mech.adb | 5 +- gcc/ada/sem_prag.adb | 356 +- gcc/ada/sem_res.adb | 574 +- gcc/ada/sem_scil.adb | 709 +- gcc/ada/sem_scil.ads | 12 +- gcc/ada/sem_type.adb | 39 +- gcc/ada/sem_util.adb | 561 +- gcc/ada/sem_util.ads | 314 +- gcc/ada/sem_warn.adb | 256 +- gcc/ada/sem_warn.ads | 3 +- gcc/ada/sfn_scan.adb | 13 +- gcc/ada/sinfo.adb | 113 +- gcc/ada/sinfo.ads | 233 +- gcc/ada/sinput-c.adb | 5 +- gcc/ada/snames.ads-tmpl | 15 +- gcc/ada/socket.c | 316 +- gcc/ada/sprint.adb | 64 +- gcc/ada/sprint.ads | 6 +- gcc/ada/style.adb | 16 +- gcc/ada/styleg.adb | 54 +- gcc/ada/switch-b.adb | 89 +- gcc/ada/switch-c.adb | 145 +- gcc/ada/switch-c.ads | 15 +- gcc/ada/switch-m.adb | 172 +- gcc/ada/switch-m.ads | 6 +- gcc/ada/sysdep.c | 28 +- gcc/ada/system-vms-ia64.ads | 7 +- gcc/ada/system-vms-zcx.ads | 232 - gcc/ada/system-vms.ads | 237 - gcc/ada/system-vms_64.ads | 7 +- gcc/ada/tbuild.adb | 9 +- gcc/ada/tbuild.ads | 22 +- gcc/ada/tempdir.ads | 4 +- gcc/ada/tree_io.ads | 9 +- gcc/ada/treepr.adb | 19 +- gcc/ada/types.ads | 98 +- gcc/ada/ug_words | 1 + gcc/ada/uintp.adb | 86 +- gcc/ada/uintp.ads | 13 +- gcc/ada/usage.adb | 71 +- gcc/ada/vms_conv.adb | 12 +- gcc/ada/vms_data.ads | 277 +- gcc/ada/xr_tabls.adb | 13 +- gcc/ada/xref_lib.adb | 34 +- gcc/alias.c | 50 +- gcc/alloc-pool.c | 18 +- gcc/auto-inc-dec.c | 7 + gcc/basic-block.h | 14 +- gcc/bitmap.c | 90 +- gcc/bitmap.h | 41 +- gcc/bt-load.c | 3 +- gcc/builtins.c | 237 +- gcc/c-ada-spec.c | 3230 ---- gcc/c-ada-spec.h | 41 - gcc/c-common.c | 9465 ------------ gcc/c-common.def | 53 - gcc/c-common.h | 1191 -- gcc/c-config-lang.in | 2 +- gcc/c-convert.c | 2 +- gcc/c-cppbuiltin.c | 1107 -- gcc/c-decl.c | 37 +- gcc/c-dump.c | 61 - gcc/c-family/ChangeLog | 162 + gcc/c-family/c-ada-spec.c | 3292 ++++ gcc/c-family/c-ada-spec.h | 41 + gcc/c-family/c-common.c | 9280 ++++++++++++ gcc/c-family/c-common.def | 53 + gcc/c-family/c-common.h | 1009 ++ gcc/c-family/c-cppbuiltin.c | 1179 ++ gcc/c-family/c-dump.c | 61 + gcc/c-family/c-format.c | 2870 ++++ gcc/c-family/c-format.h | 326 + gcc/c-family/c-gimplify.c | 189 + gcc/c-family/c-lex.c | 1058 ++ gcc/c-family/c-omp.c | 531 + gcc/c-family/c-opts.c | 1660 ++ gcc/c-family/c-pch.c | 517 + gcc/c-family/c-ppoutput.c | 625 + gcc/c-family/c-pragma.c | 1340 ++ gcc/c-family/c-pragma.h | 133 + gcc/c-family/c-pretty-print.c | 2282 +++ gcc/c-family/c-pretty-print.h | 213 + gcc/c-family/c-semantics.c | 146 + gcc/c-family/c.opt | 1061 ++ gcc/c-family/stub-objc.c | 327 + gcc/c-format.c | 2872 ---- gcc/c-format.h | 326 - gcc/c-gimplify.c | 190 - gcc/c-lang.c | 4 +- gcc/c-lang.h | 2 +- gcc/c-lex.c | 1058 -- gcc/c-objc-common.c | 29 +- gcc/c-omp.c | 531 - gcc/c-opts.c | 1815 --- gcc/c-parser.c | 89 +- gcc/c-pch.c | 517 - gcc/c-ppoutput.c | 625 - gcc/c-pragma.c | 1336 -- gcc/c-pragma.h | 133 - gcc/c-pretty-print.c | 2261 --- gcc/c-pretty-print.h | 212 - gcc/c-semantics.c | 146 - gcc/c-tree.h | 7 +- gcc/c-typeck.c | 159 +- gcc/c.opt | 1060 -- gcc/caller-save.c | 4 +- gcc/calls.c | 74 +- gcc/cfg.c | 10 +- gcc/cfganal.c | 13 +- gcc/cfgexpand.c | 33 +- gcc/cfgloop.c | 14 +- gcc/cfgrtl.c | 5 +- gcc/cgraph.c | 16 +- gcc/cgraph.h | 11 +- gcc/cgraphbuild.c | 4 +- gcc/cgraphunit.c | 44 +- gcc/collect2.c | 11 +- gcc/combine-stack-adj.c | 2 +- gcc/combine.c | 30 +- gcc/common.opt | 30 +- gcc/config.gcc | 4 +- gcc/config.in | 6 + gcc/config/alpha/alpha.c | 36 +- gcc/config/alpha/alpha.h | 9 - gcc/config/arc/arc.h | 8 - gcc/config/arm/arm-c.c | 2 +- gcc/config/arm/arm-cores.def | 1 + gcc/config/arm/arm-protos.h | 2 - gcc/config/arm/arm-tune.md | 2 +- gcc/config/arm/arm.c | 435 +- gcc/config/arm/arm.h | 147 - gcc/config/arm/arm.md | 48 +- gcc/config/arm/constraints.md | 12 +- gcc/config/arm/thumb2.md | 164 +- gcc/config/avr/avr-c.c | 2 +- gcc/config/avr/avr.c | 3 +- gcc/config/avr/avr.h | 2 - gcc/config/bfin/bfin.c | 11 +- gcc/config/bfin/bfin.h | 2 - gcc/config/cris/cris-protos.h | 2 - gcc/config/cris/cris.c | 29 +- gcc/config/cris/cris.h | 12 - gcc/config/crx/crx.h | 2 - gcc/config/darwin-c.c | 4 +- gcc/config/darwin-driver.c | 5 +- gcc/config/darwin-protos.h | 2 + gcc/config/darwin.c | 20 +- gcc/config/darwin.h | 10 +- gcc/config/fr30/fr30.h | 35 - gcc/config/frv/frv-protos.h | 2 - gcc/config/frv/frv.c | 58 +- gcc/config/frv/frv.h | 81 - gcc/config/h8300/h8300.c | 2 +- gcc/config/h8300/h8300.h | 11 - gcc/config/i386/atom.md | 7 +- gcc/config/i386/cygming.h | 2 +- gcc/config/i386/i386-c.c | 4 +- gcc/config/i386/i386-protos.h | 11 +- gcc/config/i386/i386.c | 431 +- gcc/config/i386/i386.h | 133 +- gcc/config/i386/i386.md | 4033 +++-- gcc/config/i386/msformat-c.c | 4 +- gcc/config/i386/ppro.md | 8 +- gcc/config/i386/predicates.md | 43 +- gcc/config/i386/sol2.h | 2 +- gcc/config/i386/sse.md | 421 +- gcc/config/i386/winnt.c | 4 +- gcc/config/ia64/ia64-c.c | 4 +- gcc/config/ia64/ia64-protos.h | 6 +- gcc/config/ia64/ia64.c | 85 +- gcc/config/ia64/ia64.h | 36 - gcc/config/ia64/sysv4.h | 9 +- gcc/config/ia64/t-ia64 | 2 +- gcc/config/ia64/vms.h | 16 +- gcc/config/iq2000/iq2000-protos.h | 2 - gcc/config/iq2000/iq2000.c | 39 +- gcc/config/iq2000/iq2000.h | 12 - gcc/config/lm32/lm32.h | 2 - gcc/config/m32c/m32c-pragma.c | 41 +- gcc/config/m32c/m32c-protos.h | 3 + gcc/config/m32c/m32c.c | 119 +- gcc/config/m32c/m32c.h | 8 +- gcc/config/m32c/predicates.md | 10 +- gcc/config/m32r/m32r-protos.h | 2 - gcc/config/m32r/m32r.c | 24 +- gcc/config/m32r/m32r.h | 26 - gcc/config/m68hc11/m68hc11-protos.h | 5 +- gcc/config/m68hc11/m68hc11.c | 17 +- gcc/config/m68hc11/m68hc11.h | 22 +- gcc/config/m68k/m68k.c | 52 +- gcc/config/m68k/m68k.h | 15 - gcc/config/mcore/mcore-protos.h | 2 - gcc/config/mcore/mcore.c | 21 +- gcc/config/mcore/mcore.h | 21 - gcc/config/mep/mep-pragma.c | 2 +- gcc/config/mep/mep.c | 12 +- gcc/config/mep/mep.h | 2 - gcc/config/mep/t-mep | 2 +- gcc/config/mips/crtfastmath.c | 53 + gcc/config/mips/linux.h | 6 + gcc/config/mips/linux64.h | 4 +- gcc/config/mips/loongson.md | 25 + gcc/config/mips/loongson2ef.md | 7 + gcc/config/mips/mips-dsp.md | 72 + gcc/config/mips/mips-dspr2.md | 52 + gcc/config/mips/mips-protos.h | 2 - gcc/config/mips/mips-ps-3d.md | 24 + gcc/config/mips/mips.c | 47 +- gcc/config/mips/mips.h | 64 +- gcc/config/mips/mips.md | 405 +- gcc/config/mips/sync.md | 12 + gcc/config/mmix/mmix.c | 2 +- gcc/config/mmix/mmix.h | 2 - gcc/config/mn10300/mn10300.h | 9 - gcc/config/moxie/moxie-protos.h | 5 +- gcc/config/moxie/moxie.c | 29 +- gcc/config/moxie/moxie.h | 18 - gcc/config/pa/pa.c | 38 +- gcc/config/pa/pa.h | 19 +- gcc/config/pdp11/pdp11.c | 46 +- gcc/config/pdp11/pdp11.h | 35 +- gcc/config/picochip/picochip-protos.h | 4 +- gcc/config/picochip/picochip.c | 22 +- gcc/config/picochip/picochip.h | 3 - gcc/config/rs6000/altivec.h | 2 + gcc/config/rs6000/altivec.md | 84 +- gcc/config/rs6000/constraints.md | 2 +- gcc/config/rs6000/e500.h | 9 +- gcc/config/rs6000/linux64.h | 32 + gcc/config/rs6000/linux64.opt | 4 + gcc/config/rs6000/predicates.md | 2 +- gcc/config/rs6000/rs6000-builtin.def | 11 +- gcc/config/rs6000/rs6000-c.c | 26 +- gcc/config/rs6000/rs6000-protos.h | 9 +- gcc/config/rs6000/rs6000.c | 1489 +- gcc/config/rs6000/rs6000.h | 64 +- gcc/config/rs6000/rs6000.md | 354 +- gcc/config/rs6000/rs6000.opt | 12 +- gcc/config/rs6000/t-rs6000 | 2 +- gcc/config/rs6000/titan.md | 171 + gcc/config/rs6000/vector.md | 14 + gcc/config/rs6000/vsx.md | 20 +- gcc/config/rx/constraints.md | 7 + gcc/config/rx/predicates.md | 4 +- gcc/config/rx/rx-modes.def | 26 + gcc/config/rx/rx-protos.h | 3 +- gcc/config/rx/rx.c | 366 +- gcc/config/rx/rx.h | 34 +- gcc/config/rx/rx.md | 609 +- gcc/config/s390/s390.c | 8 +- gcc/config/s390/s390.h | 3 - gcc/config/s390/s390.md | 4 +- gcc/config/score/score.h | 2 - gcc/config/score/score3.c | 2 +- gcc/config/score/score7.c | 2 +- gcc/config/sh/sh-protos.h | 8 +- gcc/config/sh/sh.c | 61 +- gcc/config/sh/sh.h | 25 - gcc/config/sol2-c.c | 6 +- gcc/config/sol2.h | 3 +- gcc/config/sparc/sparc-protos.h | 2 - gcc/config/sparc/sparc.c | 14 +- gcc/config/sparc/sparc.h | 9 - gcc/config/spu/spu-c.c | 4 +- gcc/config/spu/spu-protos.h | 2 +- gcc/config/spu/spu.c | 70 +- gcc/config/spu/spu.h | 53 - gcc/config/stormy16/stormy16.h | 2 - gcc/config/t-darwin | 2 +- gcc/config/t-sol2 | 4 +- gcc/config/v850/t-v850 | 2 +- gcc/config/v850/t-v850e | 2 +- gcc/config/v850/v850-c.c | 2 +- gcc/config/v850/v850-protos.h | 2 - gcc/config/v850/v850.c | 42 +- gcc/config/v850/v850.h | 22 - gcc/config/vax/vax.c | 18 + gcc/config/vax/vax.h | 12 - gcc/config/xtensa/xtensa-protos.h | 6 +- gcc/config/xtensa/xtensa.c | 8 +- gcc/config/xtensa/xtensa.h | 3 - gcc/configure | 45 +- gcc/configure.ac | 38 +- gcc/convert.c | 3 +- gcc/coretypes.h | 17 +- gcc/cp/ChangeLog | 563 + gcc/cp/Make-lang.in | 30 +- gcc/cp/call.c | 203 +- gcc/cp/class.c | 513 +- gcc/cp/config-lang.in | 2 +- gcc/cp/cp-gimplify.c | 6 +- gcc/cp/cp-lang.c | 3 +- gcc/cp/cp-objcp-common.c | 4 +- gcc/cp/cp-objcp-common.h | 3 + gcc/cp/cp-tree.def | 1 + gcc/cp/cp-tree.h | 163 +- gcc/cp/cvt.c | 8 +- gcc/cp/cxx-pretty-print.c | 20 +- gcc/cp/cxx-pretty-print.h | 2 +- gcc/cp/decl.c | 330 +- gcc/cp/decl2.c | 28 +- gcc/cp/error.c | 28 +- gcc/cp/except.c | 206 +- gcc/cp/expr.c | 4 +- gcc/cp/g++spec.c | 2 +- gcc/cp/init.c | 21 +- gcc/cp/lang-specs.h | 8 +- gcc/cp/lex.c | 13 +- gcc/cp/method.c | 779 +- gcc/cp/name-lookup.c | 50 +- gcc/cp/name-lookup.h | 2 +- gcc/cp/parser.c | 153 +- gcc/cp/pt.c | 187 +- gcc/cp/ptree.c | 6 +- gcc/cp/repo.c | 12 +- gcc/cp/rtti.c | 18 +- gcc/cp/search.c | 30 +- gcc/cp/semantics.c | 126 +- gcc/cp/tree.c | 81 +- gcc/cp/typeck.c | 225 +- gcc/cp/typeck2.c | 44 +- gcc/cppspec.c | 2 +- gcc/cse.c | 24 +- gcc/cselib.c | 15 +- gcc/cselib.h | 2 +- gcc/dbgcnt.def | 2 + gcc/dbxout.c | 6 +- gcc/dce.c | 43 +- gcc/ddg.c | 6 +- gcc/debug.c | 3 +- gcc/debug.h | 7 +- gcc/defaults.h | 225 +- gcc/df-core.c | 257 +- gcc/df-problems.c | 1046 +- gcc/df-scan.c | 290 +- gcc/df.h | 103 +- gcc/diagnostic-core.h | 5 +- gcc/diagnostic.c | 91 +- gcc/diagnostic.h | 29 +- gcc/doc/cpp.texi | 2 +- gcc/doc/extend.texi | 70 +- gcc/doc/gcc.texi | 8 +- gcc/doc/gccint.texi | 2 +- gcc/doc/gcov.texi | 10 +- gcc/doc/generic.texi | 8 + gcc/doc/gimple.texi | 42 +- gcc/doc/gty.texi | 37 +- gcc/doc/include/fdl.texi | 85 +- gcc/doc/install.texi | 13 +- gcc/doc/invoke.texi | 167 +- gcc/doc/md.texi | 177 +- gcc/doc/plugins.texi | 6 +- gcc/doc/sourcebuild.texi | 3 + gcc/doc/tm.texi | 218 +- gcc/doc/tm.texi.in | 11168 ++++++++++++++ gcc/double-int.c | 202 +- gcc/double-int.h | 64 +- gcc/dse.c | 8 +- gcc/dse.h | 2 - gcc/dwarf2asm.c | 33 +- gcc/dwarf2asm.h | 7 +- gcc/dwarf2out.c | 628 +- gcc/dwarf2out.h | 7 +- gcc/emit-rtl.c | 52 +- gcc/emit-rtl.h | 4 +- gcc/except.c | 48 +- gcc/except.h | 63 +- gcc/expmed.c | 86 +- gcc/expr.c | 364 +- gcc/expr.h | 136 - gcc/final.c | 31 +- gcc/flags.h | 23 - gcc/fold-const.c | 530 +- gcc/fortran/ChangeLog | 479 + gcc/fortran/Make-lang.in | 2 +- gcc/fortran/array.c | 2 +- gcc/fortran/check.c | 166 +- gcc/fortran/cpp.c | 124 +- gcc/fortran/cpp.h | 6 + gcc/fortran/decl.c | 360 +- gcc/fortran/dependency.c | 1 - gcc/fortran/dependency.h | 1 + gcc/fortran/dump-parse-tree.c | 32 +- gcc/fortran/error.c | 2 +- gcc/fortran/expr.c | 102 + gcc/fortran/f95-lang.c | 10 +- gcc/fortran/gfc-internals.texi | 4 +- gcc/fortran/gfortran.h | 57 +- gcc/fortran/gfortran.texi | 37 +- gcc/fortran/gfortranspec.c | 33 +- gcc/fortran/interface.c | 88 +- gcc/fortran/intrinsic.c | 124 +- gcc/fortran/intrinsic.h | 8 +- gcc/fortran/intrinsic.texi | 88 +- gcc/fortran/invoke.texi | 8 +- gcc/fortran/io.c | 2 +- gcc/fortran/lang-specs.h | 2 +- gcc/fortran/lang.opt | 38 +- gcc/fortran/libgfortran.h | 19 +- gcc/fortran/match.c | 150 +- gcc/fortran/match.h | 2 + gcc/fortran/mathbuiltins.def | 17 + gcc/fortran/module.c | 14 +- gcc/fortran/openmp.c | 38 +- gcc/fortran/options.c | 19 +- gcc/fortran/parse.c | 120 +- gcc/fortran/parse.h | 2 +- gcc/fortran/primary.c | 6 + gcc/fortran/resolve.c | 406 +- gcc/fortran/scanner.c | 39 +- gcc/fortran/simplify.c | 46 +- gcc/fortran/st.c | 15 +- gcc/fortran/symbol.c | 29 +- gcc/fortran/trans-array.c | 67 +- gcc/fortran/trans-decl.c | 24 +- gcc/fortran/trans-expr.c | 98 +- gcc/fortran/trans-intrinsic.c | 512 +- gcc/fortran/trans-openmp.c | 52 +- gcc/fortran/trans-stmt.c | 51 +- gcc/fortran/trans-types.c | 35 +- gcc/fortran/trans.h | 15 +- gcc/function.c | 56 +- gcc/function.h | 6 +- gcc/fwprop.c | 4 +- gcc/gcc-plugin.h | 27 +- gcc/gcc.c | 722 +- gcc/genattr.c | 147 +- gcc/genattrtab.c | 696 +- gcc/genautomata.c | 219 +- gcc/gencodes.c | 2 +- gcc/genconditions.c | 5 +- gcc/genconfig.c | 2 +- gcc/genconstants.c | 46 +- gcc/genemit.c | 15 +- gcc/genenums.c | 66 + gcc/genextract.c | 3 +- gcc/genflags.c | 3 +- gcc/gengtype.c | 257 +- gcc/genhooks.c | 343 + gcc/genmddeps.c | 8 +- gcc/genopinit.c | 2 +- gcc/genoutput.c | 118 +- gcc/genpeep.c | 2 +- gcc/genpreds.c | 101 +- gcc/genrecog.c | 92 +- gcc/gensupport.c | 404 +- gcc/gensupport.h | 15 +- gcc/ggc-common.c | 38 +- gcc/ggc-internal.h | 121 + gcc/ggc-none.c | 15 +- gcc/ggc-page.c | 38 +- gcc/ggc-zone.c | 69 +- gcc/ggc.h | 292 +- gcc/gimple-fold.c | 1661 +- gcc/gimple-iterator.c | 8 +- gcc/gimple-pretty-print.c | 30 + gcc/gimple.c | 126 +- gcc/gimple.h | 252 +- gcc/gimplify.c | 170 +- gcc/graphite-clast-to-gimple.c | 63 +- gcc/graphite-poly.h | 1 + gcc/graphite-sese-to-poly.c | 53 +- gcc/haifa-sched.c | 28 +- gcc/implicit-zee.c | 2 +- gcc/integrate.c | 4 +- gcc/ipa-cp.c | 37 +- gcc/ipa-inline.c | 21 +- gcc/ipa-prop.c | 391 +- gcc/ipa-prop.h | 21 +- gcc/ipa-pure-const.c | 502 +- gcc/ipa-ref.c | 8 + gcc/ipa-ref.h | 1 + gcc/ipa-reference.c | 330 +- gcc/ipa-split.c | 1112 ++ gcc/ipa-struct-reorg.c | 29 +- gcc/ipa.c | 20 +- gcc/ira-build.c | 256 +- gcc/ira-color.c | 16 +- gcc/ira-conflicts.c | 74 +- gcc/ira-costs.c | 35 +- gcc/ira-emit.c | 2 +- gcc/ira-int.h | 102 +- gcc/ira-lives.c | 373 +- gcc/ira.c | 53 +- gcc/ira.h | 3 +- gcc/java/ChangeLog | 72 + gcc/java/Make-lang.in | 4 +- gcc/java/boehm.c | 49 +- gcc/java/class.c | 50 +- gcc/java/constants.c | 9 +- gcc/java/decl.c | 16 +- gcc/java/except.c | 34 +- gcc/java/expr.c | 2 +- gcc/java/gcj.texi | 4 +- gcc/java/java-tree.h | 24 +- gcc/java/jcf-parse.c | 9 +- gcc/java/jcf-reader.c | 4 +- gcc/java/jcf.h | 2 +- gcc/java/jvspec.c | 8 +- gcc/java/lang.c | 1 - gcc/lambda-code.c | 4 +- gcc/lambda.h | 2 +- gcc/langhooks-def.h | 4 + gcc/langhooks.h | 12 + gcc/loop-init.c | 2 +- gcc/loop-iv.c | 2 +- gcc/loop-unswitch.c | 2 + gcc/lto-cgraph.c | 208 +- gcc/lto-section-in.c | 6 +- gcc/lto-streamer-in.c | 128 +- gcc/lto-streamer-out.c | 95 +- gcc/lto-streamer.c | 148 +- gcc/lto-streamer.h | 112 +- gcc/lto-symtab.c | 39 +- gcc/lto-wrapper.c | 2 +- gcc/lto/ChangeLog | 27 + gcc/lto/lto-coff.c | 14 +- gcc/lto/lto-lang.c | 12 +- gcc/lto/lto.c | 18 +- gcc/matrix-reorg.c | 80 +- gcc/mkconfig.sh | 22 +- gcc/objc/ChangeLog | 23 + gcc/objc/config-lang.in | 2 +- gcc/objc/objc-act.c | 23 +- gcc/objc/objc-act.h | 3 +- gcc/objc/objc-lang.c | 2 +- gcc/objcp/ChangeLog | 19 + gcc/objcp/Make-lang.in | 2 +- gcc/objcp/config-lang.in | 2 +- gcc/objcp/lang-specs.h | 10 +- gcc/objcp/objcp-decl.h | 4 +- gcc/objcp/objcp-lang.c | 3 +- gcc/omp-low.c | 79 +- gcc/optabs.c | 29 +- gcc/opth-gen.awk | 5 +- gcc/opts-common.c | 229 +- gcc/opts.c | 275 +- gcc/opts.h | 48 +- gcc/output.h | 10 +- gcc/params.def | 10 +- gcc/passes.c | 31 +- gcc/po/ChangeLog | 5 + gcc/po/EXCLUDES | 1 + gcc/po/exgettext | 2 +- gcc/postreload.c | 6 +- gcc/predict.c | 30 +- gcc/predict.h | 1 + gcc/pretty-print.c | 3 - gcc/print-rtl.c | 15 + gcc/read-md.c | 1139 ++ gcc/read-md.h | 140 + gcc/read-rtl.c | 1022 +- gcc/recog.c | 555 +- gcc/recog.h | 7 +- gcc/reg-stack.c | 3 +- gcc/reginfo.c | 42 +- gcc/regrename.c | 3 +- gcc/reload.c | 16 +- gcc/reload.h | 15 +- gcc/reload1.c | 688 +- gcc/rtl-error.c | 3 +- gcc/rtl-error.h | 24 + gcc/rtl.c | 9 +- gcc/rtl.def | 9 +- gcc/rtl.h | 30 +- gcc/rtlanal.c | 2 +- gcc/sched-deps.c | 5 +- gcc/sdbout.c | 4 +- gcc/sel-sched-dump.c | 24 +- gcc/sel-sched-dump.h | 23 +- gcc/sel-sched.c | 24 +- gcc/sese.c | 2 +- gcc/simplify-rtx.c | 137 +- gcc/stmt.c | 4 +- gcc/stor-layout.c | 27 +- gcc/stringpool.c | 19 +- gcc/stub-objc.c | 327 - gcc/system.h | 30 +- gcc/target-def.h | 968 +- gcc/target.def | 2358 +++ gcc/target.h | 1173 +- gcc/targhooks.c | 174 +- gcc/targhooks.h | 27 +- gcc/testsuite/ChangeLog | 1074 ++ gcc/testsuite/c-c++-common/Wunused-var-10.c | 68 + gcc/testsuite/c-c++-common/Wunused-var-11.c | 12 + gcc/testsuite/c-c++-common/Wunused-var-9.c | 80 + gcc/testsuite/c-c++-common/pr20000.c | 32 + gcc/testsuite/c-c++-common/torture/pr42834.c | 23 + gcc/testsuite/c-c++-common/uninit-17.c | 25 + gcc/testsuite/c-c++-common/warn-ommitted-condop.c | 29 + gcc/testsuite/g++.dg/cpp0x/decltype4.C | 1 + gcc/testsuite/g++.dg/cpp0x/defaulted10.C | 4 +- gcc/testsuite/g++.dg/cpp0x/defaulted13.C | 8 +- gcc/testsuite/g++.dg/cpp0x/defaulted17.C | 12 + gcc/testsuite/g++.dg/cpp0x/defaulted18.C | 9 + gcc/testsuite/g++.dg/cpp0x/defaulted19.C | 21 + gcc/testsuite/g++.dg/cpp0x/defaulted2.C | 4 +- gcc/testsuite/g++.dg/cpp0x/defaulted3.C | 4 +- gcc/testsuite/g++.dg/cpp0x/explicit5.C | 25 + gcc/testsuite/g++.dg/cpp0x/implicit-copy.C | 8 +- gcc/testsuite/g++.dg/cpp0x/implicit1.C | 26 + gcc/testsuite/g++.dg/cpp0x/implicit2.C | 33 + gcc/testsuite/g++.dg/cpp0x/implicit3.C | 56 + gcc/testsuite/g++.dg/cpp0x/implicit4.C | 20 + gcc/testsuite/g++.dg/cpp0x/implicit5.C | 19 + gcc/testsuite/g++.dg/cpp0x/initlist15.C | 3 + gcc/testsuite/g++.dg/cpp0x/initlist19.C | 4 +- gcc/testsuite/g++.dg/cpp0x/initlist39.C | 15 + gcc/testsuite/g++.dg/cpp0x/initlist40.C | 12 + gcc/testsuite/g++.dg/cpp0x/initlist9.C | 4 +- .../g++.dg/cpp0x/lambda/lambda-ctor-neg.C | 4 +- gcc/testsuite/g++.dg/cpp0x/lambda/lambda-errloc.C | 2 +- gcc/testsuite/g++.dg/cpp0x/lambda/lambda-errloc2.C | 4 +- gcc/testsuite/g++.dg/cpp0x/noexcept01.C | 83 + gcc/testsuite/g++.dg/cpp0x/noexcept02.C | 52 + gcc/testsuite/g++.dg/cpp0x/noexcept03.C | 68 + gcc/testsuite/g++.dg/cpp0x/noexcept04.C | 31 + gcc/testsuite/g++.dg/cpp0x/noexcept05.C | 19 + gcc/testsuite/g++.dg/cpp0x/noexcept06.C | 30 + gcc/testsuite/g++.dg/cpp0x/noexcept07.C | 25 + gcc/testsuite/g++.dg/cpp0x/noexcept08.C | 56 + gcc/testsuite/g++.dg/cpp0x/not_special.C | 16 +- gcc/testsuite/g++.dg/cpp0x/nullptr01.C | 2 + gcc/testsuite/g++.dg/cpp0x/nullptr02.C | 6 + gcc/testsuite/g++.dg/cpp0x/nullptr03.C | 5 +- gcc/testsuite/g++.dg/cpp0x/nullptr04.C | 14 +- gcc/testsuite/g++.dg/cpp0x/nullptr05.C | 2 + gcc/testsuite/g++.dg/cpp0x/nullptr06.C | 2 + gcc/testsuite/g++.dg/cpp0x/nullptr07.C | 3 + gcc/testsuite/g++.dg/cpp0x/nullptr08.C | 2 + gcc/testsuite/g++.dg/cpp0x/nullptr09.C | 2 + gcc/testsuite/g++.dg/cpp0x/nullptr10.C | 4 + gcc/testsuite/g++.dg/cpp0x/nullptr11.C | 23 + gcc/testsuite/g++.dg/cpp0x/nullptr12.C | 2 + gcc/testsuite/g++.dg/cpp0x/nullptr13.C | 5 + gcc/testsuite/g++.dg/cpp0x/nullptr14.C | 2 + gcc/testsuite/g++.dg/cpp0x/nullptr15.C | 3 + gcc/testsuite/g++.dg/cpp0x/nullptr16.C | 3 + gcc/testsuite/g++.dg/cpp0x/nullptr17.C | 2 + gcc/testsuite/g++.dg/cpp0x/nullptr18.C | 2 + gcc/testsuite/g++.dg/cpp0x/nullptr20.C | 5 +- gcc/testsuite/g++.dg/cpp0x/nullptr21.C | 17 + gcc/testsuite/g++.dg/cpp0x/nullptr22.C | 4 + gcc/testsuite/g++.dg/cpp0x/rv-trivial-bug.C | 9 +- gcc/testsuite/g++.dg/cpp0x/rv1n.C | 34 +- gcc/testsuite/g++.dg/cpp0x/rv1p.C | 32 +- gcc/testsuite/g++.dg/cpp0x/rv2n.C | 110 +- gcc/testsuite/g++.dg/cpp0x/rv2p.C | 112 +- gcc/testsuite/g++.dg/cpp0x/rv3n.C | 202 +- gcc/testsuite/g++.dg/cpp0x/rv3p.C | 224 +- gcc/testsuite/g++.dg/cpp0x/rv4n.C | 230 +- gcc/testsuite/g++.dg/cpp0x/rv4p.C | 280 +- gcc/testsuite/g++.dg/cpp0x/rv5n.C | 170 +- gcc/testsuite/g++.dg/cpp0x/rv5p.C | 224 +- gcc/testsuite/g++.dg/cpp0x/rv6n.C | 74 +- gcc/testsuite/g++.dg/cpp0x/rv6p.C | 112 +- gcc/testsuite/g++.dg/cpp0x/rv7n.C | 18 +- gcc/testsuite/g++.dg/cpp0x/rv7p.C | 32 +- gcc/testsuite/g++.dg/cpp0x/rv8p.C | 4 +- gcc/testsuite/g++.dg/debug/dwarf2/accessibility1.C | 24 + gcc/testsuite/g++.dg/debug/dwarf2/dwarf4-typedef.C | 34 + gcc/testsuite/g++.dg/debug/dwarf2/typedef3.C | 19 + gcc/testsuite/g++.dg/diagnostic/method1.C | 20 + gcc/testsuite/g++.dg/diagnostic/parm1.C | 11 + gcc/testsuite/g++.dg/eh/new1.C | 2 +- gcc/testsuite/g++.dg/eh/spec8.C | 4 +- gcc/testsuite/g++.dg/expr/cond8.C | 4 +- gcc/testsuite/g++.dg/expr/string-1.C | 4 +- gcc/testsuite/g++.dg/ext/attr-alias-1.C | 37 + gcc/testsuite/g++.dg/ext/attr-alias-2.C | 37 + gcc/testsuite/g++.dg/ext/has_virtual_destructor.C | 6 +- gcc/testsuite/g++.dg/ext/label13.C | 2 +- gcc/testsuite/g++.dg/ext/unary_trait_incomplete.C | 24 +- gcc/testsuite/g++.dg/gomp/pr26690-1.C | 2 +- gcc/testsuite/g++.dg/inherit/virtual5.C | 29 + gcc/testsuite/g++.dg/init/ctor4.C | 4 +- gcc/testsuite/g++.dg/init/new5.C | 4 +- gcc/testsuite/g++.dg/init/pr44086.C | 15 + gcc/testsuite/g++.dg/init/synth2.C | 4 +- gcc/testsuite/g++.dg/ipa/iinline-2.C | 61 + gcc/testsuite/g++.dg/ipa/iinline-3.C | 64 + gcc/testsuite/g++.dg/lto/20081118_1.C | 1 + gcc/testsuite/g++.dg/lto/20100603-1_0.C | 14 + gcc/testsuite/g++.dg/lto/20100603-1_1.c | 2 + gcc/testsuite/g++.dg/other/arm-neon-1.C | 18 + gcc/testsuite/g++.dg/other/error13.C | 4 +- gcc/testsuite/g++.dg/other/error20.C | 2 +- gcc/testsuite/g++.dg/other/error31.C | 2 +- gcc/testsuite/g++.dg/other/pr25632.C | 6 +- gcc/testsuite/g++.dg/other/typedef4.C | 7 + gcc/testsuite/g++.dg/other/unused1.C | 2 +- gcc/testsuite/g++.dg/overload/arg3.C | 3 +- gcc/testsuite/g++.dg/overload/copy1.C | 3 +- gcc/testsuite/g++.dg/parse/error19.C | 2 +- gcc/testsuite/g++.dg/plugin/attribute_plugin.c | 2 + gcc/testsuite/g++.dg/plugin/dumb_plugin.c | 3 +- gcc/testsuite/g++.dg/plugin/header_plugin.c | 4 +- gcc/testsuite/g++.dg/plugin/pragma_plugin.c | 3 +- gcc/testsuite/g++.dg/plugin/selfassign.c | 35 +- gcc/testsuite/g++.dg/pr44486.C | 10 + gcc/testsuite/g++.dg/tc1/dr147.C | 10 + gcc/testsuite/g++.dg/tc1/dr152.C | 6 +- gcc/testsuite/g++.dg/template/crash100.C | 24 + gcc/testsuite/g++.dg/template/error23.C | 4 +- gcc/testsuite/g++.dg/template/incomplete4.C | 4 +- gcc/testsuite/g++.dg/template/incomplete5.C | 4 +- gcc/testsuite/g++.dg/template/qualified-id2.C | 27 + gcc/testsuite/g++.dg/template/qualified-id3.C | 14 + gcc/testsuite/g++.dg/template/qualttp5.C | 2 +- gcc/testsuite/g++.dg/torture/pr43801.C | 22 + gcc/testsuite/g++.dg/torture/pr43905.C | 13 + gcc/testsuite/g++.dg/torture/pr44357.C | 228 + gcc/testsuite/g++.dg/torture/pr44492.C | 31 + gcc/testsuite/g++.dg/torture/pr44535.C | 34 + gcc/testsuite/g++.dg/tree-ssa/copyprop-1.C | 4 +- gcc/testsuite/g++.dg/tree-ssa/pr31146.C | 2 +- gcc/testsuite/g++.dg/tree-ssa/pr33604.C | 12 +- gcc/testsuite/g++.dg/warn/Wunused-var-10.C | 42 + gcc/testsuite/g++.dg/warn/Wunused-var-11.C | 33 + gcc/testsuite/g++.dg/warn/Wunused-var-12.C | 36 + gcc/testsuite/g++.dg/warn/Wunused-var-13.C | 22 + gcc/testsuite/g++.dg/warn/Wunused-var-14.C | 17 + gcc/testsuite/g++.dg/warn/incomplete2.C | 4 +- gcc/testsuite/g++.old-deja/g++.bob/inherit2.C | 7 +- gcc/testsuite/g++.old-deja/g++.bugs/900205_04.C | 4 +- gcc/testsuite/g++.old-deja/g++.bugs/900514_03.C | 4 +- gcc/testsuite/g++.old-deja/g++.jason/new.C | 6 +- gcc/testsuite/g++.old-deja/g++.jason/opeq3.C | 4 +- gcc/testsuite/g++.old-deja/g++.law/ctors17.C | 4 +- gcc/testsuite/g++.old-deja/g++.law/ctors5.C | 2 +- gcc/testsuite/g++.old-deja/g++.law/operators27.C | 2 +- gcc/testsuite/g++.old-deja/g++.mike/p755.C | 2 +- gcc/testsuite/g++.old-deja/g++.oliva/delete1.C | 3 +- gcc/testsuite/g++.old-deja/g++.oliva/dwarf2.C | 1 - gcc/testsuite/g++.old-deja/g++.oliva/dwarf3.C | 1 - gcc/testsuite/g++.old-deja/g++.other/delete3.C | 2 +- gcc/testsuite/g++.old-deja/g++.other/init19.C | 2 +- gcc/testsuite/g++.old-deja/g++.other/new.C | 4 +- gcc/testsuite/g++.old-deja/g++.pt/assign1.C | 4 +- gcc/testsuite/g++.old-deja/g++.pt/auto_ptr.C | 3 +- gcc/testsuite/g++.old-deja/g++.pt/crash20.C | 5 +- gcc/testsuite/g++.old-deja/g++.pt/crash9.C | 4 +- gcc/testsuite/gcc.c-torture/compile/20100609-1.c | 8 + gcc/testsuite/gcc.c-torture/compile/pc44485.c | 46 + gcc/testsuite/gcc.c-torture/compile/pr44686.c | 7 + gcc/testsuite/gcc.c-torture/compile/pr44687.c | 32 + gcc/testsuite/gcc.c-torture/execute/20100316-1.c | 24 + gcc/testsuite/gcc.c-torture/execute/960321-1.x | 15 + .../gcc.c-torture/execute/frame-address.c | 3 +- gcc/testsuite/gcc.c-torture/execute/pr44468.c | 60 + gcc/testsuite/gcc.c-torture/execute/pr44555.c | 16 + gcc/testsuite/gcc.c-torture/execute/pr44575.c | 49 + gcc/testsuite/gcc.c-torture/execute/pr44683.c | 18 + gcc/testsuite/gcc.dg/assign-warn-1.c | 20 +- gcc/testsuite/gcc.dg/assign-warn-2.c | 20 +- gcc/testsuite/gcc.dg/c90-const-expr-10.c | 2 +- gcc/testsuite/gcc.dg/c99-array-lval-8.c | 6 +- gcc/testsuite/gcc.dg/c99-arraydecl-3.c | 4 +- gcc/testsuite/gcc.dg/c99-const-expr-10.c | 2 +- gcc/testsuite/gcc.dg/c99-restrict-4.c | 17 + gcc/testsuite/gcc.dg/cast-qual-2.c | 8 +- gcc/testsuite/gcc.dg/compound-literal-1.c | 2 +- gcc/testsuite/gcc.dg/cpp/line3.c | 8 +- gcc/testsuite/gcc.dg/format/gcc_diag-1.c | 24 +- gcc/testsuite/gcc.dg/funroll-loops-all.c | 2 +- gcc/testsuite/gcc.dg/graphite/pr44391.c | 7 + gcc/testsuite/gcc.dg/init-bad-7.c | 11 + gcc/testsuite/gcc.dg/ipa/ipa-sra-6.c | 32 + gcc/testsuite/gcc.dg/ipa/modif-1.c | 41 - gcc/testsuite/gcc.dg/ipa/pure-const-1.c | 80 + gcc/testsuite/gcc.dg/ipa/pure-const-2.c | 28 + gcc/testsuite/gcc.dg/lto/20091216-1_0.c | 6 +- gcc/testsuite/gcc.dg/lto/20100603-1_0.c | 4 + gcc/testsuite/gcc.dg/lto/20100603-2_0.c | 5 + gcc/testsuite/gcc.dg/lto/20100603-3_0.c | 4 + gcc/testsuite/gcc.dg/noncompile/990416-1.c | 8 +- gcc/testsuite/gcc.dg/noncompile/pr44517.c | 18 + gcc/testsuite/gcc.dg/noreturn-4.c | 2 +- gcc/testsuite/gcc.dg/noreturn-7.c | 6 +- gcc/testsuite/gcc.dg/opts-1.c | 9 + gcc/testsuite/gcc.dg/opts-2.c | 8 + gcc/testsuite/gcc.dg/opts-3.c | 7 + gcc/testsuite/gcc.dg/plugin/finish_unit_plugin.c | 1 + gcc/testsuite/gcc.dg/plugin/one_time_plugin.c | 2 +- gcc/testsuite/gcc.dg/plugin/selfassign.c | 35 +- gcc/testsuite/gcc.dg/pr32370.c | 8 +- gcc/testsuite/gcc.dg/pr36902.c | 2 +- gcc/testsuite/gcc.dg/pr37561.c | 2 +- gcc/testsuite/gcc.dg/pr39874.c | 29 + gcc/testsuite/gcc.dg/pr41340.c | 4 +- gcc/testsuite/gcc.dg/pr41551.c | 4 +- gcc/testsuite/gcc.dg/pr42461.c | 14 + gcc/testsuite/gcc.dg/pr44393.c | 15 + gcc/testsuite/gcc.dg/pr44404.c | 35 + gcc/testsuite/gcc.dg/pr44509.c | 9 + gcc/testsuite/gcc.dg/pr44539.c | 29 + gcc/testsuite/gcc.dg/pr44674.c | 10 + gcc/testsuite/gcc.dg/pr44699.c | 157 + gcc/testsuite/gcc.dg/pragma-diag-1.c | 21 + gcc/testsuite/gcc.dg/struct/w_prof_global_array.c | 2 +- gcc/testsuite/gcc.dg/struct/w_prof_global_var.c | 2 +- gcc/testsuite/gcc.dg/struct/w_prof_local_array.c | 2 +- gcc/testsuite/gcc.dg/struct/w_prof_local_var.c | 2 +- .../gcc.dg/struct/w_prof_single_str_global.c | 2 +- gcc/testsuite/gcc.dg/struct/w_prof_two_strs.c | 2 +- gcc/testsuite/gcc.dg/struct/w_ratio_cold_str.c | 2 +- gcc/testsuite/gcc.dg/struct/wo_prof_array_field.c | 2 +- .../gcc.dg/struct/wo_prof_array_through_pointer.c | 2 +- .../gcc.dg/struct/wo_prof_double_malloc.c | 2 +- gcc/testsuite/gcc.dg/struct/wo_prof_empty_str.c | 2 +- .../gcc.dg/struct/wo_prof_escape_arg_to_local.c | 2 +- .../gcc.dg/struct/wo_prof_escape_return.c | 2 +- .../gcc.dg/struct/wo_prof_escape_str_init.c | 2 +- .../gcc.dg/struct/wo_prof_escape_substr_array.c | 2 +- .../gcc.dg/struct/wo_prof_escape_substr_pointer.c | 2 +- .../gcc.dg/struct/wo_prof_escape_substr_value.c | 2 +- gcc/testsuite/gcc.dg/struct/wo_prof_global_array.c | 2 +- gcc/testsuite/gcc.dg/struct/wo_prof_global_var.c | 2 +- gcc/testsuite/gcc.dg/struct/wo_prof_local_array.c | 2 +- gcc/testsuite/gcc.dg/struct/wo_prof_local_var.c | 2 +- .../gcc.dg/struct/wo_prof_malloc_size_var.c | 2 +- .../gcc.dg/struct/wo_prof_single_str_global.c | 2 +- .../gcc.dg/struct/wo_prof_single_str_local.c | 2 +- gcc/testsuite/gcc.dg/struct/wo_prof_two_strs.c | 2 +- gcc/testsuite/gcc.dg/torture/pr43781.c | 45 + gcc/testsuite/gcc.dg/tree-prof/stringop-1.c | 4 +- gcc/testsuite/gcc.dg/tree-ssa/20030807-7.c | 2 +- gcc/testsuite/gcc.dg/tree-ssa/foldaddr-2.c | 13 - gcc/testsuite/gcc.dg/tree-ssa/foldaddr-3.c | 28 - gcc/testsuite/gcc.dg/tree-ssa/forwprop-1.c | 2 +- gcc/testsuite/gcc.dg/tree-ssa/forwprop-10.c | 11 +- gcc/testsuite/gcc.dg/tree-ssa/forwprop-2.c | 2 +- gcc/testsuite/gcc.dg/tree-ssa/forwprop-5.c | 11 +- gcc/testsuite/gcc.dg/tree-ssa/forwprop-8.c | 2 +- gcc/testsuite/gcc.dg/tree-ssa/ipa-split-1.c | 29 + gcc/testsuite/gcc.dg/tree-ssa/ipa-split-2.c | 41 + gcc/testsuite/gcc.dg/tree-ssa/ipa-split-3.c | 21 + gcc/testsuite/gcc.dg/tree-ssa/ipa-split-4.c | 29 + gcc/testsuite/gcc.dg/tree-ssa/loadpre6.c | 8 +- gcc/testsuite/gcc.dg/tree-ssa/ltrans-1.c | 1 + gcc/testsuite/gcc.dg/tree-ssa/ltrans-3.c | 1 + gcc/testsuite/gcc.dg/tree-ssa/ltrans-4.c | 1 + gcc/testsuite/gcc.dg/tree-ssa/ltrans-5.c | 1 + gcc/testsuite/gcc.dg/tree-ssa/ltrans-6.c | 1 + gcc/testsuite/gcc.dg/tree-ssa/ltrans-8.c | 1 + gcc/testsuite/gcc.dg/tree-ssa/pr17141-1.c | 6 +- gcc/testsuite/gcc.dg/tree-ssa/pr21086.c | 9 +- gcc/testsuite/gcc.dg/tree-ssa/pr44258.c | 43 + gcc/testsuite/gcc.dg/tree-ssa/pr44423.c | 47 + gcc/testsuite/gcc.dg/tree-ssa/pr44483.c | 20 + gcc/testsuite/gcc.dg/tree-ssa/prefetch-7.c | 22 +- gcc/testsuite/gcc.dg/tree-ssa/prefetch-8.c | 28 + gcc/testsuite/gcc.dg/tree-ssa/prefetch-9.c | 32 + gcc/testsuite/gcc.dg/tree-ssa/pta-ptrarith-1.c | 6 +- gcc/testsuite/gcc.dg/tree-ssa/pta-ptrarith-2.c | 6 +- gcc/testsuite/gcc.dg/tree-ssa/ssa-ccp-21.c | 6 +- gcc/testsuite/gcc.dg/tree-ssa/ssa-ccp-23.c | 2 +- gcc/testsuite/gcc.dg/tree-ssa/ssa-ccp-25.c | 2 +- gcc/testsuite/gcc.dg/tree-ssa/ssa-ccp-26.c | 2 +- gcc/testsuite/gcc.dg/tree-ssa/ssa-fre-1.c | 3 +- gcc/testsuite/gcc.dg/tree-ssa/ssa-fre-13.c | 3 +- gcc/testsuite/gcc.dg/tree-ssa/ssa-fre-14.c | 3 +- gcc/testsuite/gcc.dg/tree-ssa/ssa-pre-26.c | 6 +- gcc/testsuite/gcc.dg/tree-ssa/ssa-pre-7.c | 4 +- gcc/testsuite/gcc.dg/tree-ssa/ssa-sccvn-4.c | 2 +- gcc/testsuite/gcc.dg/tree-ssa/struct-aliasing-1.c | 4 +- gcc/testsuite/gcc.dg/tree-ssa/struct-aliasing-2.c | 5 +- gcc/testsuite/gcc.dg/tree-ssa/vrp47.c | 1 + gcc/testsuite/gcc.dg/vect/bb-slp-10.c | 3 + gcc/testsuite/gcc.dg/vect/bb-slp-11.c | 3 + gcc/testsuite/gcc.dg/vect/bb-slp-13.c | 3 + gcc/testsuite/gcc.dg/vect/bb-slp-14.c | 3 + gcc/testsuite/gcc.dg/vect/bb-slp-15.c | 3 + gcc/testsuite/gcc.dg/vect/bb-slp-17.c | 3 + gcc/testsuite/gcc.dg/vect/bb-slp-18.c | 3 + gcc/testsuite/gcc.dg/vect/bb-slp-19.c | 5 +- gcc/testsuite/gcc.dg/vect/bb-slp-20.c | 3 + gcc/testsuite/gcc.dg/vect/bb-slp-21.c | 3 + gcc/testsuite/gcc.dg/vect/bb-slp-22.c | 3 + gcc/testsuite/gcc.dg/vect/bb-slp-23.c | 3 + gcc/testsuite/gcc.dg/vect/bb-slp-3.c | 5 +- gcc/testsuite/gcc.dg/vect/bb-slp-4.c | 5 +- gcc/testsuite/gcc.dg/vect/pr44507.c | 55 + gcc/testsuite/gcc.dg/vect/slp-perm-5.c | 3 +- gcc/testsuite/gcc.dg/vect/slp-perm-6.c | 3 +- gcc/testsuite/gcc.dg/volatile2.c | 7 +- gcc/testsuite/gcc.target/arm/eliminate.c | 19 + gcc/testsuite/gcc.target/arm/pr40900.c | 12 + gcc/testsuite/gcc.target/arm/thumb2-cmpneg2add-1.c | 12 + gcc/testsuite/gcc.target/arm/thumb2-cmpneg2add-2.c | 12 + gcc/testsuite/gcc.target/arm/wmul-1.c | 2 +- gcc/testsuite/gcc.target/arm/wmul-3.c | 18 + gcc/testsuite/gcc.target/arm/wmul-4.c | 18 + gcc/testsuite/gcc.target/i386/abi-2.c | 1 + gcc/testsuite/gcc.target/i386/aes-avx-check.h | 9 +- gcc/testsuite/gcc.target/i386/aes-check.h | 9 +- gcc/testsuite/gcc.target/i386/amd64-abi-3.c | 2 +- gcc/testsuite/gcc.target/i386/avx-check.h | 9 +- .../gcc.target/i386/avx-vextractf128-256-3.c | 7 + .../gcc.target/i386/avx-vextractf128-256-4.c | 7 + gcc/testsuite/gcc.target/i386/extract-1.c | 10 + gcc/testsuite/gcc.target/i386/extract-2.c | 11 + gcc/testsuite/gcc.target/i386/extract-3.c | 21 + gcc/testsuite/gcc.target/i386/extract-4.c | 22 + gcc/testsuite/gcc.target/i386/extract-5.c | 21 + gcc/testsuite/gcc.target/i386/extract-6.c | 23 + gcc/testsuite/gcc.target/i386/fma4-check.h | 9 +- gcc/testsuite/gcc.target/i386/mmx-3dnow-check.h | 9 +- gcc/testsuite/gcc.target/i386/mmx-check.h | 9 +- gcc/testsuite/gcc.target/i386/mod-1.c | 29 + gcc/testsuite/gcc.target/i386/pclmul-avx-check.h | 9 +- gcc/testsuite/gcc.target/i386/pclmul-check.h | 9 +- gcc/testsuite/gcc.target/i386/pr27971.c | 8 +- gcc/testsuite/gcc.target/i386/pr39139.c | 16 +- gcc/testsuite/gcc.target/i386/pr39315-check.c | 4 +- gcc/testsuite/gcc.target/i386/pr44481.c | 14 + gcc/testsuite/gcc.target/i386/pr44546.c | 22 + gcc/testsuite/gcc.target/i386/sse-check.h | 9 +- gcc/testsuite/gcc.target/i386/sse2-check.h | 9 +- gcc/testsuite/gcc.target/i386/sse2-vec-2a.c | 5 + gcc/testsuite/gcc.target/i386/sse3-check.h | 9 +- gcc/testsuite/gcc.target/i386/sse4_1-check.h | 9 +- gcc/testsuite/gcc.target/i386/sse4_2-check.h | 9 +- gcc/testsuite/gcc.target/i386/sse4a-check.h | 9 +- gcc/testsuite/gcc.target/i386/ssse3-check.h | 9 +- gcc/testsuite/gcc.target/i386/umod-1.c | 11 + gcc/testsuite/gcc.target/i386/umod-2.c | 14 + gcc/testsuite/gcc.target/i386/umod-3.c | 21 + gcc/testsuite/gcc.target/i386/vararg-1.c | 1 + gcc/testsuite/gcc.target/i386/vararg-2.c | 1 + .../gcc.target/i386/volatile-bitfields-1.c | 17 + .../gcc.target/i386/volatile-bitfields-2.c | 17 + gcc/testsuite/gcc.target/i386/xop-check.h | 9 +- gcc/testsuite/gcc.target/mips/madd-9.c | 16 + gcc/testsuite/gcc.target/powerpc/recip-1.c | 18 + gcc/testsuite/gcc.target/powerpc/recip-2.c | 21 + gcc/testsuite/gcc.target/powerpc/recip-3.c | 22 + gcc/testsuite/gcc.target/powerpc/recip-4.c | 36 + gcc/testsuite/gcc.target/powerpc/recip-5.c | 94 + gcc/testsuite/gcc.target/powerpc/recip-6.c | 16 + gcc/testsuite/gcc.target/powerpc/recip-7.c | 16 + gcc/testsuite/gcc.target/powerpc/recip-test.h | 149 + gcc/testsuite/gcc.target/powerpc/recip-test2.h | 432 + .../gcc.target/x86_64/abi/callabi/leaf-1.c | 11 + .../gcc.target/x86_64/abi/callabi/leaf-2.c | 25 + gcc/testsuite/gfortran.dg/abstract_type_8.f03 | 29 + gcc/testsuite/gfortran.dg/actual_rank_check_1.f90 | 23 + .../gfortran.dg/aliasing_array_result_1.f90 | 164 + gcc/testsuite/gfortran.dg/alloc_comp_class_1.f90 | 33 + .../gfortran.dg/allocate_alloc_opt_10.f90 | 46 + .../gfortran.dg/allocate_alloc_opt_11.f90 | 26 + gcc/testsuite/gfortran.dg/allocate_alloc_opt_7.f90 | 18 + gcc/testsuite/gfortran.dg/allocate_alloc_opt_8.f90 | 16 + gcc/testsuite/gfortran.dg/allocate_alloc_opt_9.f90 | 23 + gcc/testsuite/gfortran.dg/array_constructor_23.f | 4 +- gcc/testsuite/gfortran.dg/array_memcpy_3.f90 | 2 +- gcc/testsuite/gfortran.dg/array_memcpy_4.f90 | 2 +- gcc/testsuite/gfortran.dg/associate_1.f03 | 49 + gcc/testsuite/gfortran.dg/associate_2.f95 | 12 + gcc/testsuite/gfortran.dg/associate_3.f03 | 41 + gcc/testsuite/gfortran.dg/associate_4.f08 | 12 + gcc/testsuite/gfortran.dg/associated_target_4.f90 | 23 + gcc/testsuite/gfortran.dg/asynchronous_3.f03 | 15 + gcc/testsuite/gfortran.dg/atan2_1.f90 | 1 + gcc/testsuite/gfortran.dg/btest_1.f90 | 7 + gcc/testsuite/gfortran.dg/class_23.f03 | 24 + gcc/testsuite/gfortran.dg/class_allocate_2.f03 | 4 +- gcc/testsuite/gfortran.dg/contiguous_1.f90 | 177 + gcc/testsuite/gfortran.dg/contiguous_2.f90 | 12 + gcc/testsuite/gfortran.dg/contiguous_3.f90 | 65 + .../gfortran.dg/data_namelist_conflict.f90 | 26 + gcc/testsuite/gfortran.dg/end_subroutine_1.f90 | 16 + gcc/testsuite/gfortran.dg/end_subroutine_2.f90 | 24 + gcc/testsuite/gfortran.dg/endfile_2.f90 | 2 +- gcc/testsuite/gfortran.dg/endfile_3.f90 | 9 + gcc/testsuite/gfortran.dg/endfile_4.f90 | 8 + gcc/testsuite/gfortran.dg/entry_19.f90 | 9 + gcc/testsuite/gfortran.dg/eof_3.f90 | 1 + gcc/testsuite/gfortran.dg/generic_23.f03 | 67 + gcc/testsuite/gfortran.dg/gomp/pr44536.f90 | 10 + gcc/testsuite/gfortran.dg/gomp/sharing-3.f90 | 2 +- gcc/testsuite/gfortran.dg/ibclr_1.f90 | 7 + gcc/testsuite/gfortran.dg/ibits_1.f90 | 13 + gcc/testsuite/gfortran.dg/ibset_1.f90 | 7 + gcc/testsuite/gfortran.dg/import8.f90 | 18 + gcc/testsuite/gfortran.dg/interface_proc_end.f90 | 5 +- gcc/testsuite/gfortran.dg/ltrans-7.f90 | 1 + gcc/testsuite/gfortran.dg/mvbits_9.f90 | 19 + gcc/testsuite/gfortran.dg/nan_6.f90 | 99 + gcc/testsuite/gfortran.dg/pr43688.f90 | 11 + gcc/testsuite/gfortran.dg/pr43866.f90 | 44 + gcc/testsuite/gfortran.dg/pr44592.f90 | 20 + gcc/testsuite/gfortran.dg/proc_ptr_27.f90 | 20 + gcc/testsuite/gfortran.dg/proc_ptr_28.f90 | 39 + gcc/testsuite/gfortran.dg/read_infnan_1.f90 | 31 + gcc/testsuite/gfortran.dg/selected_char_kind_4.f90 | 24 + gcc/testsuite/gfortran.dg/selected_real_kind_1.f90 | 10 + gcc/testsuite/gfortran.dg/selected_real_kind_2.f90 | 32 + gcc/testsuite/gfortran.dg/selected_real_kind_3.f90 | 6 + gcc/testsuite/gfortran.dg/semicolon_fixed.f | 8 +- gcc/testsuite/gfortran.dg/semicolon_fixed_2.f | 12 + gcc/testsuite/gfortran.dg/semicolon_free.f90 | 1 + gcc/testsuite/gfortran.dg/semicolon_free_2.f90 | 10 + gcc/testsuite/gfortran.dg/type_decl_1.f90 | 30 + gcc/testsuite/gfortran.dg/type_decl_2.f90 | 12 + gcc/testsuite/gfortran.dg/typebound_call_14.f03 | 29 + gcc/testsuite/gfortran.dg/typebound_call_15.f03 | 25 + gcc/testsuite/gfortran.dg/typebound_proc_14.f03 | 33 + gcc/testsuite/gfortran.dg/typebound_proc_15.f03 | 34 + gcc/testsuite/gfortran.dg/typebound_proc_16.f03 | 58 + gcc/testsuite/gfortran.dg/typebound_proc_4.f03 | 6 +- gcc/testsuite/gfortran.dg/unpack_bounds_1.f90 | 0 gcc/testsuite/gfortran.dg/unpack_bounds_2.f90 | 0 gcc/testsuite/gfortran.dg/unpack_bounds_3.f90 | 0 gcc/testsuite/gfortran.dg/warn_conversion.f90 | 1 - gcc/testsuite/gfortran.dg/warn_conversion_2.f90 | 7 +- gcc/testsuite/gfortran.dg/whole_file_18.f90 | 2 +- gcc/testsuite/gfortran.dg/whole_file_20.f03 | 33 + .../gfortran.fortran-torture/compile/pr40421.f90 | 15 + gcc/testsuite/gnat.dg/class_wide2.adb | 2 +- gcc/testsuite/gnat.dg/noreturn3.adb | 27 + gcc/testsuite/gnat.dg/noreturn3.ads | 12 + gcc/testsuite/gnat.dg/not_null.adb | 2 - gcc/testsuite/lib/lto.exp | 11 +- gcc/testsuite/lib/target-supports.exp | 50 + gcc/timevar.def | 1 + gcc/toplev.c | 116 +- gcc/toplev.h | 36 +- gcc/tree-affine.c | 28 + gcc/tree-browser.c | 12 +- gcc/tree-cfg.c | 256 +- gcc/tree-cfgcleanup.c | 27 +- gcc/tree-chrec.c | 6 +- gcc/tree-complex.c | 2 +- gcc/tree-data-ref.c | 46 +- gcc/tree-dfa.c | 136 +- gcc/tree-eh.c | 22 +- gcc/tree-flow-inline.h | 57 +- gcc/tree-flow.h | 36 +- gcc/tree-if-conv.c | 274 +- gcc/tree-inline.c | 234 +- gcc/tree-into-ssa.c | 25 +- gcc/tree-iterator.c | 6 +- gcc/tree-loop-distribution.c | 36 +- gcc/tree-mudflap.c | 15 +- gcc/tree-nested.c | 44 +- gcc/tree-object-size.c | 51 +- gcc/tree-parloops.c | 13 +- gcc/tree-pass.h | 1 + gcc/tree-phinodes.c | 2 +- gcc/tree-predcom.c | 10 +- gcc/tree-pretty-print.c | 98 +- gcc/tree-profile.c | 4 + gcc/tree-scalar-evolution.c | 45 +- gcc/tree-sra.c | 190 +- gcc/tree-ssa-alias.c | 287 +- gcc/tree-ssa-ccp.c | 216 +- gcc/tree-ssa-copy.c | 2 +- gcc/tree-ssa-dce.c | 66 +- gcc/tree-ssa-dom.c | 118 +- gcc/tree-ssa-forwprop.c | 327 +- gcc/tree-ssa-ifcombine.c | 40 +- gcc/tree-ssa-live.h | 22 +- gcc/tree-ssa-loop-im.c | 14 +- gcc/tree-ssa-loop-ivopts.c | 36 +- gcc/tree-ssa-loop-manip.c | 4 +- gcc/tree-ssa-loop-niter.c | 15 +- gcc/tree-ssa-loop-prefetch.c | 49 +- gcc/tree-ssa-loop-unswitch.c | 130 +- gcc/tree-ssa-loop.c | 2 +- gcc/tree-ssa-math-opts.c | 275 +- gcc/tree-ssa-operands.c | 52 +- gcc/tree-ssa-operands.h | 2 +- gcc/tree-ssa-phiopt.c | 21 +- gcc/tree-ssa-phiprop.c | 7 +- gcc/tree-ssa-pre.c | 212 +- gcc/tree-ssa-propagate.c | 13 +- gcc/tree-ssa-propagate.h | 4 +- gcc/tree-ssa-reassoc.c | 30 +- gcc/tree-ssa-sccvn.c | 334 +- gcc/tree-ssa-sccvn.h | 4 +- gcc/tree-ssa-sink.c | 5 +- gcc/tree-ssa-structalias.c | 25 +- gcc/tree-ssa-ter.c | 18 + gcc/tree-ssa-threadedge.c | 15 +- gcc/tree-ssa.c | 208 +- gcc/tree-ssanames.c | 2 +- gcc/tree-stdarg.c | 3 +- gcc/tree-vect-data-refs.c | 31 +- gcc/tree-vect-loop.c | 54 +- gcc/tree-vect-patterns.c | 2 + gcc/tree-vect-slp.c | 9 +- gcc/tree-vect-stmts.c | 56 +- gcc/tree-vectorizer.h | 73 +- gcc/tree-vrp.c | 81 +- gcc/tree.c | 185 +- gcc/tree.def | 22 + gcc/tree.h | 50 +- gcc/var-tracking.c | 88 +- gcc/varasm.c | 100 +- gcc/varpool.c | 4 +- gcc/vec.h | 3 +- gcc/vmsdbg.h | 5 +- gcc/vmsdbgout.c | 269 +- 1394 files changed, 130179 insertions(+), 75459 deletions(-) create mode 100644 gcc/ada/a-strunb-shared.adb create mode 100644 gcc/ada/a-strunb-shared.ads create mode 100644 gcc/ada/a-stunau-shared.adb create mode 100644 gcc/ada/a-stuten.adb create mode 100644 gcc/ada/a-stuten.ads create mode 100644 gcc/ada/a-stwiun-shared.adb create mode 100644 gcc/ada/a-stwiun-shared.ads create mode 100644 gcc/ada/a-stzunb-shared.adb create mode 100644 gcc/ada/a-stzunb-shared.ads create mode 100755 gcc/ada/a-suenco.adb create mode 100755 gcc/ada/a-suenco.ads create mode 100755 gcc/ada/a-suewen.adb create mode 100755 gcc/ada/a-suewen.ads create mode 100755 gcc/ada/a-suezen.adb create mode 100755 gcc/ada/a-suezen.ads create mode 100644 gcc/ada/a-suteio-shared.adb create mode 100644 gcc/ada/a-swunau-shared.adb create mode 100644 gcc/ada/a-swuwti-shared.adb create mode 100644 gcc/ada/a-szunau-shared.adb create mode 100644 gcc/ada/a-szuzti-shared.adb create mode 100644 gcc/ada/exp_cg.adb create mode 100644 gcc/ada/exp_cg.ads create mode 100644 gcc/ada/g-mbdira.adb create mode 100644 gcc/ada/g-mbdira.ads create mode 100644 gcc/ada/g-mbflra.adb create mode 100644 gcc/ada/g-mbflra.ads delete mode 100644 gcc/ada/g-sttsne-dummy.ads delete mode 100644 gcc/ada/g-sttsne-locking.adb delete mode 100644 gcc/ada/g-sttsne-locking.ads delete mode 100644 gcc/ada/g-sttsne-vxworks.adb delete mode 100644 gcc/ada/g-sttsne.ads create mode 100644 gcc/ada/projects.texi create mode 100644 gcc/ada/s-auxdec-vms-alpha.adb create mode 100644 gcc/ada/scil_ll.adb create mode 100644 gcc/ada/scil_ll.ads delete mode 100644 gcc/ada/system-vms-zcx.ads delete mode 100644 gcc/ada/system-vms.ads delete mode 100644 gcc/c-ada-spec.c delete mode 100644 gcc/c-ada-spec.h delete mode 100644 gcc/c-common.c delete mode 100644 gcc/c-common.def delete mode 100644 gcc/c-common.h delete mode 100644 gcc/c-cppbuiltin.c delete mode 100644 gcc/c-dump.c create mode 100644 gcc/c-family/ChangeLog create mode 100644 gcc/c-family/c-ada-spec.c create mode 100644 gcc/c-family/c-ada-spec.h create mode 100644 gcc/c-family/c-common.c create mode 100644 gcc/c-family/c-common.def create mode 100644 gcc/c-family/c-common.h create mode 100644 gcc/c-family/c-cppbuiltin.c create mode 100644 gcc/c-family/c-dump.c create mode 100644 gcc/c-family/c-format.c create mode 100644 gcc/c-family/c-format.h create mode 100644 gcc/c-family/c-gimplify.c create mode 100644 gcc/c-family/c-lex.c create mode 100644 gcc/c-family/c-omp.c create mode 100644 gcc/c-family/c-opts.c create mode 100644 gcc/c-family/c-pch.c create mode 100644 gcc/c-family/c-ppoutput.c create mode 100644 gcc/c-family/c-pragma.c create mode 100644 gcc/c-family/c-pragma.h create mode 100644 gcc/c-family/c-pretty-print.c create mode 100644 gcc/c-family/c-pretty-print.h create mode 100644 gcc/c-family/c-semantics.c create mode 100644 gcc/c-family/c.opt create mode 100644 gcc/c-family/stub-objc.c delete mode 100644 gcc/c-format.c delete mode 100644 gcc/c-format.h delete mode 100644 gcc/c-gimplify.c delete mode 100644 gcc/c-lex.c delete mode 100644 gcc/c-omp.c delete mode 100644 gcc/c-opts.c delete mode 100644 gcc/c-pch.c delete mode 100644 gcc/c-ppoutput.c delete mode 100644 gcc/c-pragma.c delete mode 100644 gcc/c-pragma.h delete mode 100644 gcc/c-pretty-print.c delete mode 100644 gcc/c-pretty-print.h delete mode 100644 gcc/c-semantics.c delete mode 100644 gcc/c.opt create mode 100644 gcc/config/mips/crtfastmath.c create mode 100644 gcc/config/rs6000/titan.md create mode 100644 gcc/config/rx/rx-modes.def create mode 100644 gcc/doc/tm.texi.in create mode 100644 gcc/genenums.c create mode 100644 gcc/genhooks.c create mode 100644 gcc/ggc-internal.h create mode 100644 gcc/ipa-split.c create mode 100644 gcc/read-md.c create mode 100644 gcc/read-md.h create mode 100644 gcc/rtl-error.h delete mode 100644 gcc/stub-objc.c create mode 100644 gcc/target.def create mode 100644 gcc/testsuite/c-c++-common/Wunused-var-10.c create mode 100644 gcc/testsuite/c-c++-common/Wunused-var-11.c create mode 100644 gcc/testsuite/c-c++-common/Wunused-var-9.c create mode 100644 gcc/testsuite/c-c++-common/pr20000.c create mode 100644 gcc/testsuite/c-c++-common/torture/pr42834.c create mode 100644 gcc/testsuite/c-c++-common/uninit-17.c create mode 100644 gcc/testsuite/c-c++-common/warn-ommitted-condop.c create mode 100644 gcc/testsuite/g++.dg/cpp0x/defaulted17.C create mode 100644 gcc/testsuite/g++.dg/cpp0x/defaulted18.C create mode 100644 gcc/testsuite/g++.dg/cpp0x/defaulted19.C create mode 100644 gcc/testsuite/g++.dg/cpp0x/explicit5.C create mode 100644 gcc/testsuite/g++.dg/cpp0x/implicit1.C create mode 100644 gcc/testsuite/g++.dg/cpp0x/implicit2.C create mode 100644 gcc/testsuite/g++.dg/cpp0x/implicit3.C create mode 100644 gcc/testsuite/g++.dg/cpp0x/implicit4.C create mode 100644 gcc/testsuite/g++.dg/cpp0x/implicit5.C create mode 100644 gcc/testsuite/g++.dg/cpp0x/initlist39.C create mode 100644 gcc/testsuite/g++.dg/cpp0x/initlist40.C create mode 100644 gcc/testsuite/g++.dg/cpp0x/noexcept01.C create mode 100644 gcc/testsuite/g++.dg/cpp0x/noexcept02.C create mode 100644 gcc/testsuite/g++.dg/cpp0x/noexcept03.C create mode 100644 gcc/testsuite/g++.dg/cpp0x/noexcept04.C create mode 100644 gcc/testsuite/g++.dg/cpp0x/noexcept05.C create mode 100644 gcc/testsuite/g++.dg/cpp0x/noexcept06.C create mode 100644 gcc/testsuite/g++.dg/cpp0x/noexcept07.C create mode 100644 gcc/testsuite/g++.dg/cpp0x/noexcept08.C create mode 100644 gcc/testsuite/g++.dg/debug/dwarf2/accessibility1.C create mode 100644 gcc/testsuite/g++.dg/debug/dwarf2/dwarf4-typedef.C create mode 100644 gcc/testsuite/g++.dg/debug/dwarf2/typedef3.C create mode 100644 gcc/testsuite/g++.dg/diagnostic/method1.C create mode 100644 gcc/testsuite/g++.dg/diagnostic/parm1.C create mode 100644 gcc/testsuite/g++.dg/ext/attr-alias-1.C create mode 100644 gcc/testsuite/g++.dg/ext/attr-alias-2.C create mode 100644 gcc/testsuite/g++.dg/inherit/virtual5.C create mode 100644 gcc/testsuite/g++.dg/init/pr44086.C create mode 100644 gcc/testsuite/g++.dg/ipa/iinline-2.C create mode 100644 gcc/testsuite/g++.dg/ipa/iinline-3.C create mode 100644 gcc/testsuite/g++.dg/lto/20100603-1_0.C create mode 100644 gcc/testsuite/g++.dg/lto/20100603-1_1.c create mode 100644 gcc/testsuite/g++.dg/other/arm-neon-1.C create mode 100644 gcc/testsuite/g++.dg/other/typedef4.C create mode 100644 gcc/testsuite/g++.dg/pr44486.C create mode 100644 gcc/testsuite/g++.dg/template/crash100.C create mode 100644 gcc/testsuite/g++.dg/template/qualified-id2.C create mode 100644 gcc/testsuite/g++.dg/template/qualified-id3.C create mode 100644 gcc/testsuite/g++.dg/torture/pr43801.C create mode 100644 gcc/testsuite/g++.dg/torture/pr43905.C create mode 100644 gcc/testsuite/g++.dg/torture/pr44357.C create mode 100644 gcc/testsuite/g++.dg/torture/pr44492.C create mode 100644 gcc/testsuite/g++.dg/torture/pr44535.C create mode 100644 gcc/testsuite/g++.dg/warn/Wunused-var-10.C create mode 100644 gcc/testsuite/g++.dg/warn/Wunused-var-11.C create mode 100644 gcc/testsuite/g++.dg/warn/Wunused-var-12.C create mode 100644 gcc/testsuite/g++.dg/warn/Wunused-var-13.C create mode 100644 gcc/testsuite/g++.dg/warn/Wunused-var-14.C create mode 100644 gcc/testsuite/gcc.c-torture/compile/20100609-1.c create mode 100644 gcc/testsuite/gcc.c-torture/compile/pc44485.c create mode 100644 gcc/testsuite/gcc.c-torture/compile/pr44686.c create mode 100644 gcc/testsuite/gcc.c-torture/compile/pr44687.c create mode 100644 gcc/testsuite/gcc.c-torture/execute/20100316-1.c create mode 100644 gcc/testsuite/gcc.c-torture/execute/960321-1.x create mode 100644 gcc/testsuite/gcc.c-torture/execute/pr44468.c create mode 100644 gcc/testsuite/gcc.c-torture/execute/pr44555.c create mode 100644 gcc/testsuite/gcc.c-torture/execute/pr44575.c create mode 100644 gcc/testsuite/gcc.c-torture/execute/pr44683.c create mode 100644 gcc/testsuite/gcc.dg/c99-restrict-4.c create mode 100644 gcc/testsuite/gcc.dg/graphite/pr44391.c create mode 100644 gcc/testsuite/gcc.dg/init-bad-7.c create mode 100644 gcc/testsuite/gcc.dg/ipa/ipa-sra-6.c delete mode 100644 gcc/testsuite/gcc.dg/ipa/modif-1.c create mode 100644 gcc/testsuite/gcc.dg/ipa/pure-const-1.c create mode 100644 gcc/testsuite/gcc.dg/ipa/pure-const-2.c create mode 100644 gcc/testsuite/gcc.dg/lto/20100603-1_0.c create mode 100644 gcc/testsuite/gcc.dg/lto/20100603-2_0.c create mode 100644 gcc/testsuite/gcc.dg/lto/20100603-3_0.c create mode 100644 gcc/testsuite/gcc.dg/noncompile/pr44517.c create mode 100644 gcc/testsuite/gcc.dg/opts-1.c create mode 100644 gcc/testsuite/gcc.dg/opts-2.c create mode 100644 gcc/testsuite/gcc.dg/opts-3.c create mode 100644 gcc/testsuite/gcc.dg/pr39874.c create mode 100644 gcc/testsuite/gcc.dg/pr42461.c create mode 100644 gcc/testsuite/gcc.dg/pr44393.c create mode 100644 gcc/testsuite/gcc.dg/pr44404.c create mode 100644 gcc/testsuite/gcc.dg/pr44509.c create mode 100644 gcc/testsuite/gcc.dg/pr44539.c create mode 100644 gcc/testsuite/gcc.dg/pr44674.c create mode 100644 gcc/testsuite/gcc.dg/pr44699.c create mode 100644 gcc/testsuite/gcc.dg/pragma-diag-1.c create mode 100644 gcc/testsuite/gcc.dg/torture/pr43781.c delete mode 100644 gcc/testsuite/gcc.dg/tree-ssa/foldaddr-2.c delete mode 100644 gcc/testsuite/gcc.dg/tree-ssa/foldaddr-3.c create mode 100644 gcc/testsuite/gcc.dg/tree-ssa/ipa-split-1.c create mode 100644 gcc/testsuite/gcc.dg/tree-ssa/ipa-split-2.c create mode 100644 gcc/testsuite/gcc.dg/tree-ssa/ipa-split-3.c create mode 100644 gcc/testsuite/gcc.dg/tree-ssa/ipa-split-4.c create mode 100644 gcc/testsuite/gcc.dg/tree-ssa/pr44258.c create mode 100644 gcc/testsuite/gcc.dg/tree-ssa/pr44423.c create mode 100644 gcc/testsuite/gcc.dg/tree-ssa/pr44483.c create mode 100644 gcc/testsuite/gcc.dg/tree-ssa/prefetch-8.c create mode 100644 gcc/testsuite/gcc.dg/tree-ssa/prefetch-9.c create mode 100644 gcc/testsuite/gcc.dg/vect/pr44507.c create mode 100644 gcc/testsuite/gcc.target/arm/eliminate.c create mode 100644 gcc/testsuite/gcc.target/arm/pr40900.c create mode 100644 gcc/testsuite/gcc.target/arm/thumb2-cmpneg2add-1.c create mode 100644 gcc/testsuite/gcc.target/arm/thumb2-cmpneg2add-2.c create mode 100644 gcc/testsuite/gcc.target/arm/wmul-3.c create mode 100644 gcc/testsuite/gcc.target/arm/wmul-4.c create mode 100644 gcc/testsuite/gcc.target/i386/avx-vextractf128-256-3.c create mode 100644 gcc/testsuite/gcc.target/i386/avx-vextractf128-256-4.c create mode 100644 gcc/testsuite/gcc.target/i386/extract-1.c create mode 100644 gcc/testsuite/gcc.target/i386/extract-2.c create mode 100644 gcc/testsuite/gcc.target/i386/extract-3.c create mode 100644 gcc/testsuite/gcc.target/i386/extract-4.c create mode 100644 gcc/testsuite/gcc.target/i386/extract-5.c create mode 100644 gcc/testsuite/gcc.target/i386/extract-6.c create mode 100644 gcc/testsuite/gcc.target/i386/mod-1.c create mode 100644 gcc/testsuite/gcc.target/i386/pr44481.c create mode 100644 gcc/testsuite/gcc.target/i386/pr44546.c create mode 100644 gcc/testsuite/gcc.target/i386/sse2-vec-2a.c create mode 100644 gcc/testsuite/gcc.target/i386/umod-1.c create mode 100644 gcc/testsuite/gcc.target/i386/umod-2.c create mode 100644 gcc/testsuite/gcc.target/i386/umod-3.c create mode 100644 gcc/testsuite/gcc.target/i386/volatile-bitfields-1.c create mode 100644 gcc/testsuite/gcc.target/i386/volatile-bitfields-2.c create mode 100644 gcc/testsuite/gcc.target/mips/madd-9.c create mode 100644 gcc/testsuite/gcc.target/powerpc/recip-1.c create mode 100644 gcc/testsuite/gcc.target/powerpc/recip-2.c create mode 100644 gcc/testsuite/gcc.target/powerpc/recip-3.c create mode 100644 gcc/testsuite/gcc.target/powerpc/recip-4.c create mode 100644 gcc/testsuite/gcc.target/powerpc/recip-5.c create mode 100644 gcc/testsuite/gcc.target/powerpc/recip-6.c create mode 100644 gcc/testsuite/gcc.target/powerpc/recip-7.c create mode 100644 gcc/testsuite/gcc.target/powerpc/recip-test.h create mode 100644 gcc/testsuite/gcc.target/powerpc/recip-test2.h create mode 100644 gcc/testsuite/gcc.target/x86_64/abi/callabi/leaf-1.c create mode 100644 gcc/testsuite/gcc.target/x86_64/abi/callabi/leaf-2.c create mode 100644 gcc/testsuite/gfortran.dg/abstract_type_8.f03 create mode 100644 gcc/testsuite/gfortran.dg/actual_rank_check_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/aliasing_array_result_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/alloc_comp_class_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/allocate_alloc_opt_10.f90 create mode 100644 gcc/testsuite/gfortran.dg/allocate_alloc_opt_11.f90 create mode 100644 gcc/testsuite/gfortran.dg/allocate_alloc_opt_7.f90 create mode 100644 gcc/testsuite/gfortran.dg/allocate_alloc_opt_8.f90 create mode 100644 gcc/testsuite/gfortran.dg/allocate_alloc_opt_9.f90 create mode 100644 gcc/testsuite/gfortran.dg/associate_1.f03 create mode 100644 gcc/testsuite/gfortran.dg/associate_2.f95 create mode 100644 gcc/testsuite/gfortran.dg/associate_3.f03 create mode 100644 gcc/testsuite/gfortran.dg/associate_4.f08 create mode 100644 gcc/testsuite/gfortran.dg/associated_target_4.f90 create mode 100644 gcc/testsuite/gfortran.dg/asynchronous_3.f03 create mode 100644 gcc/testsuite/gfortran.dg/btest_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/class_23.f03 create mode 100644 gcc/testsuite/gfortran.dg/contiguous_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/contiguous_2.f90 create mode 100644 gcc/testsuite/gfortran.dg/contiguous_3.f90 create mode 100644 gcc/testsuite/gfortran.dg/data_namelist_conflict.f90 create mode 100644 gcc/testsuite/gfortran.dg/end_subroutine_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/end_subroutine_2.f90 create mode 100644 gcc/testsuite/gfortran.dg/endfile_3.f90 create mode 100644 gcc/testsuite/gfortran.dg/endfile_4.f90 create mode 100644 gcc/testsuite/gfortran.dg/entry_19.f90 create mode 100644 gcc/testsuite/gfortran.dg/generic_23.f03 create mode 100644 gcc/testsuite/gfortran.dg/gomp/pr44536.f90 create mode 100644 gcc/testsuite/gfortran.dg/ibclr_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/ibits_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/ibset_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/import8.f90 create mode 100644 gcc/testsuite/gfortran.dg/mvbits_9.f90 create mode 100644 gcc/testsuite/gfortran.dg/nan_6.f90 create mode 100644 gcc/testsuite/gfortran.dg/pr43688.f90 create mode 100644 gcc/testsuite/gfortran.dg/pr43866.f90 create mode 100644 gcc/testsuite/gfortran.dg/pr44592.f90 create mode 100644 gcc/testsuite/gfortran.dg/proc_ptr_27.f90 create mode 100644 gcc/testsuite/gfortran.dg/proc_ptr_28.f90 create mode 100644 gcc/testsuite/gfortran.dg/read_infnan_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/selected_char_kind_4.f90 create mode 100644 gcc/testsuite/gfortran.dg/selected_real_kind_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/selected_real_kind_2.f90 create mode 100644 gcc/testsuite/gfortran.dg/selected_real_kind_3.f90 create mode 100644 gcc/testsuite/gfortran.dg/semicolon_fixed_2.f create mode 100644 gcc/testsuite/gfortran.dg/semicolon_free_2.f90 create mode 100644 gcc/testsuite/gfortran.dg/type_decl_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/type_decl_2.f90 create mode 100644 gcc/testsuite/gfortran.dg/typebound_call_14.f03 create mode 100644 gcc/testsuite/gfortran.dg/typebound_call_15.f03 create mode 100644 gcc/testsuite/gfortran.dg/typebound_proc_14.f03 create mode 100644 gcc/testsuite/gfortran.dg/typebound_proc_15.f03 create mode 100644 gcc/testsuite/gfortran.dg/typebound_proc_16.f03 mode change 100755 => 100644 gcc/testsuite/gfortran.dg/unpack_bounds_1.f90 mode change 100755 => 100644 gcc/testsuite/gfortran.dg/unpack_bounds_2.f90 mode change 100755 => 100644 gcc/testsuite/gfortran.dg/unpack_bounds_3.f90 create mode 100644 gcc/testsuite/gfortran.dg/whole_file_20.f03 create mode 100644 gcc/testsuite/gfortran.fortran-torture/compile/pr40421.f90 create mode 100644 gcc/testsuite/gnat.dg/noreturn3.adb create mode 100644 gcc/testsuite/gnat.dg/noreturn3.ads (limited to 'gcc') diff --git a/gcc/ChangeLog b/gcc/ChangeLog index 261b202b35e..40522695b58 100644 --- a/gcc/ChangeLog +++ b/gcc/ChangeLog @@ -1,3 +1,4735 @@ +2010-07-01 López-Ibáñez + + * reload.c: Include toplev.h. + * recog.c: Likewise. + * Makefile.in: Adjust dependencies. + +2010-07-01 Jakub Jelinek + + PR debug/44694 + * dwarf2out.c (reg_loc_descriptor): For eliminated arg_pointer_rtx + or frame_pointer_rtx use DW_OP_fbreg offset DW_OP_stack_value. + +2010-07-01 Richard Guenther + + * emit-rtl.c (set_mem_attributes_minus_bitpos): Use unsigned + types for offsets. + +2010-07-01 Joern Rennecke + + PR target/44732 + * config/ia64/ia64.c (ia64_register_move_cost): Remove stray '{'. + + * config/ia64/ia64.c (ia64_register_move_cost): Fix argument types. + +2010-07-01 Bernd Schmidt + + PR target/44727 + * config/i386/i386.md (peephole2 for arithmetic ops with memory): + Make sure operand 0 dies. + +2010-07-01 Richard Guenther + + PR middle-end/42834 + PR middle-end/44468 + * doc/gimple.texi (is_gimple_mem_ref_addr): Document. + * doc/generic.texi (References to storage): Document MEM_REF. + * tree-pretty-print.c (dump_generic_node): Handle MEM_REF. + (print_call_name): Likewise. + * tree.c (recompute_tree_invariant_for_addr_expr): Handle MEM_REF. + (build_simple_mem_ref_loc): New function. + (mem_ref_offset): Likewise. + * tree.h (build_simple_mem_ref_loc): Declare. + (build_simple_mem_ref): Define. + (mem_ref_offset): Declare. + * fold-const.c: Include tree-flow.h. + (operand_equal_p): Handle MEM_REF. + (build_fold_addr_expr_with_type_loc): Likewise. + (fold_comparison): Likewise. + (fold_unary_loc): Fold + VIEW_CONVERT_EXPR > to MEM_REF . + (fold_binary_loc): Fold MEM[&MEM[p, CST1], CST2] to MEM[p, CST1 + CST2], + fold MEM[&a.b, CST2] to MEM[&a, offsetof (a, b) + CST2]. + * tree-ssa-alias.c (ptr_deref_may_alias_decl_p): Handle MEM_REF. + (ptr_deref_may_alias_ref_p_1): Likewise. + (ao_ref_base_alias_set): Properly differentiate base object for + offset and TBAA. + (ao_ref_init_from_ptr_and_size): Use MEM_REF. + (indirect_ref_may_alias_decl_p): Handle MEM_REFs properly. + (indirect_refs_may_alias_p): Likewise. + (refs_may_alias_p_1): Likewise. Remove pointer SSA name def + chasing code. + (ref_maybe_used_by_call_p_1): Handle MEM_REF. + (call_may_clobber_ref_p_1): Likewise. + * dwarf2out.c (loc_list_from_tree): Handle MEM_REF. + * expr.c (expand_assignment): Handle MEM_REF. + (store_expr): Handle MEM_REFs from STRING_CSTs. + (store_field): If expanding a MEM_REF of a non-addressable + decl use bitfield operations. + (get_inner_reference): Handle MEM_REF. + (expand_expr_addr_expr_1): Likewise. + (expand_expr_real_1): Likewise. + * tree-eh.c (tree_could_trap_p): Handle MEM_REF. + * alias.c (ao_ref_from_mem): Handle MEM_REF. + (get_alias_set): Likewise. Properly handle VIEW_CONVERT_EXPRs. + * tree-data-ref.c (dr_analyze_innermost): Handle MEM_REF. + (dr_analyze_indices): Likewise. + (dr_analyze_alias): Likewise. + (object_address_invariant_in_loop_p): Likewise. + * gimplify.c (mark_addressable): Handle MEM_REF. + (gimplify_cond_expr): Build MEM_REFs. + (gimplify_modify_expr_to_memcpy): Likewise. + (gimplify_init_ctor_preeval_1): Handle MEM_REF. + (gimple_fold_indirect_ref): Adjust. + (gimplify_expr): Handle MEM_REF. Gimplify INDIRECT_REF to MEM_REF. + * tree.def (MEM_REF): New tree code. + * tree-dfa.c: Include toplev.h. + (get_ref_base_and_extent): Handle MEM_REF. + (get_addr_base_and_unit_offset): New function. + * emit-rtl.c (set_mem_attributes_minus_bitpos): Handle MEM_REF. + * gimple-fold.c (may_propagate_address_into_dereference): Handle + MEM_REF. + (maybe_fold_offset_to_array_ref): Allow possibly out-of bounds + accesses if the array has just one dimension. Remove always true + parameter. Do not require type compatibility here. + (maybe_fold_offset_to_component_ref): Remove. + (maybe_fold_stmt_indirect): Remove. + (maybe_fold_reference): Remove INDIRECT_REF handling. + Fold back to non-MEM_REF. + (maybe_fold_offset_to_address): Simplify. Deal with type + mismatches here. + (maybe_fold_reference): Likewise. + (maybe_fold_stmt_addition): Likewise. Also handle + &ARRAY + I in addition to &ARRAY[0] + I. + (fold_gimple_assign): Handle ADDR_EXPR of MEM_REFs. + (gimple_get_relevant_ref_binfo): Handle MEM_REF. + * cfgexpand.c (expand_debug_expr): Handle MEM_REF. + * tree-ssa.c (useless_type_conversion_p): Make most pointer + conversions useless. + (warn_uninitialized_var): Handle MEM_REF. + (maybe_rewrite_mem_ref_base): New function. + (execute_update_addresses_taken): Implement re-writing of MEM_REFs + to SSA form. + * tree-inline.c (remap_gimple_op_r): Handle MEM_REF, remove + INDIRECT_REF handling. + (copy_tree_body_r): Handle MEM_REF. + * gimple.c (is_gimple_addressable): Adjust. + (is_gimple_address): Likewise. + (is_gimple_invariant_address): ADDR_EXPRs of MEM_REFs with + invariant base are invariant. + (is_gimple_min_lval): Adjust. + (is_gimple_mem_ref_addr): New function. + (get_base_address): Handle MEM_REF. + (count_ptr_derefs): Likewise. + (get_base_loadstore): Likewise. + * gimple.h (is_gimple_mem_ref_addr): Declare. + (gimple_call_fndecl): Handle invariant MEM_REF addresses. + * tree-cfg.c (verify_address): New function, split out from ... + (verify_expr): ... here. Use for verifying ADDR_EXPRs and + the address operand of MEM_REFs. Verify MEM_REFs. Reject + INDIRECT_REFs. + (verify_types_in_gimple_min_lval): Handle MEM_REF. Disallow + INDIRECT_REF. Allow conversions. + (verify_types_in_gimple_reference): Verify VIEW_CONVERT_EXPR of + a register does not change its size. + (verify_types_in_gimple_reference): Verify MEM_REF. + (verify_gimple_assign_single): Disallow INDIRECT_REF. + Handle MEM_REF. + * tree-ssa-operands.c (opf_non_addressable, opf_not_non_addressable): + New. + (mark_address_taken): Handle MEM_REF. + (get_indirect_ref_operands): Pass through opf_not_non_addressable. + (get_asm_expr_operands): Pass opf_not_non_addressable. + (get_expr_operands): Handle opf_[not_]non_addressable. + Handle MEM_REF. Remove INDIRECT_REF handling. + * tree-vrp.c: (check_array_ref): Handle MEM_REF. + (search_for_addr_array): Likewise. + (check_array_bounds): Likewise. + (vrp_stmt_computes_nonzero): Adjust for MEM_REF. + * tree-ssa-loop-im.c (for_each_index): Handle MEM_REF. + (ref_always_accessed_p): Likewise. + (gen_lsm_tmp_name): Likewise. Handle ADDR_EXPR. + * tree-complex.c (extract_component): Do not handle INDIRECT_REF. + Handle MEM_REF. + * cgraphbuild.c (mark_load): Properly check for NULL result + from get_base_address. + (mark_store): Likewise. + * tree-ssa-loop-niter.c (array_at_struct_end_p): Handle MEM_REF. + * tree-loop-distribution.c (generate_builtin): Exchange INDIRECT_REF + handling for MEM_REF. + * tree-scalar-evolution.c (follow_ssa_edge_expr): Handle + &MEM[ptr + CST] similar to POINTER_PLUS_EXPR. + * builtins.c (stabilize_va_list_loc): Use the function ABI + valist type if we couldn't canonicalize the argument type. + Always dereference with the canonical va-list type. + (maybe_emit_free_warning): Handle MEM_REF. + (fold_builtin_memory_op): Simplify and handle MEM_REFs in folding + memmove to memcpy. + * builtins.c (fold_builtin_memory_op): Use ref-all types + for all memcpy foldings. + * omp-low.c (build_receiver_ref): Adjust for MEM_REF. + (build_outer_var_ref): Likewise. + (scan_omp_1_op): Likewise. + (lower_rec_input_clauses): Likewise. + (lower_lastprivate_clauses): Likewise. + (lower_reduction_clauses): Likewise. + (lower_copyprivate_clauses): Likewise. + (expand_omp_atomic_pipeline): Likewise. + (expand_omp_atomic_mutex): Likewise. + (create_task_copyfn): Likewise. + * tree-ssa-sccvn.c (copy_reference_ops_from_ref): Handle MEM_REF. + Remove old union trick. Initialize constant offsets. + (ao_ref_init_from_vn_reference): Likewise. Do not handle + INDIRECT_REF. Init base_alias_set properly. + (vn_reference_lookup_3): Replace INDIRECT_REF handling with + MEM_REF. + (vn_reference_fold_indirect): Adjust for MEM_REFs. + (valueize_refs): Fold MEM_REFs. Re-evaluate constant offset + for ARRAY_REFs. + (may_insert): Remove. + (visit_reference_op_load): Do not test may_insert. + (run_scc_vn): Remove parameter, do not fiddle with may_insert. + * tree-ssa-sccvn.h (struct vn_reference_op_struct): Add + a field to store the constant offset this op applies. + (run_scc_vn): Adjust prototype. + * cgraphunit.c (thunk_adjust): Adjust for MEM_REF. + * tree-ssa-ccp.c (ccp_fold): Replace INDIRECT_REF folding with + MEM_REF. Propagate &foo + CST as &MEM[&foo, CST]. Do not + bother about volatile qualifiers on pointers. + (fold_const_aggregate_ref): Handle MEM_REF, do not handle INDIRECT_REF. + * tree-ssa-loop-ivopts.c + * tree-ssa-loop-ivopts.c (determine_base_object): Adjust + for MEM_REF. + (strip_offset_1): Likewise. + (find_interesting_uses_address): Replace INDIRECT_REF handling with + MEM_REF handling. + (get_computation_cost_at): Likewise. + * ipa-pure-const.c (check_op): Handle MEM_REF. + * tree-stdarg.c (check_all_va_list_escapes): Adjust for MEM_REF. + * tree-ssa-sink.c (is_hidden_global_store): Handle MEM_REF + and constants. + * ipa-inline.c (likely_eliminated_by_inlining_p): Handle MEM_REF. + * tree-parloops.c (take_address_of): Adjust for MEM_REF. + (eliminate_local_variables_1): Likewise. + (create_call_for_reduction_1): Likewise. + (create_loads_for_reductions): Likewise. + (create_loads_and_stores_for_name): Likewise. + * matrix-reorg.c (may_flatten_matrices_1): Sanitize. + (ssa_accessed_in_tree): Handle MEM_REF. + (ssa_accessed_in_assign_rhs): Likewise. + (update_type_size): Likewise. + (analyze_accesses_for_call_stmt): Likewise. + (analyze_accesses_for_assign_stmt): Likewise. + (transform_access_sites): Likewise. + (transform_allocation_sites): Likewise. + * tree-affine.c (tree_to_aff_combination): Handle MEM_REF. + * tree-vect-data-refs.c (vect_create_addr_base_for_vector_ref): Do + not handle INDIRECT_REF. + * tree-ssa-phiopt.c (add_or_mark_expr): Handle MEM_REF. + (cond_store_replacement): Likewise. + * tree-ssa-pre.c (create_component_ref_by_pieces_1): Handle + MEM_REF, no not handle INDIRECT_REFs. + (insert_into_preds_of_block): Properly initialize avail. + (phi_translate_1): Fold MEM_REFs. Re-evaluate constant offset + for ARRAY_REFs. Properly handle reference lookups that + require a bit re-interpretation. + (can_PRE_operation): Do not handle INDIRECT_REF. Handle MEM_REF. + * tree-sra.c + * tree-sra.c (build_access_from_expr_1): Handle MEM_REF. + (build_ref_for_offset_1): Remove. + (build_ref_for_offset): Build MEM_REFs. + (gate_intra_sra): Disable for now. + (sra_ipa_modify_expr): Handle MEM_REF. + (ipa_early_sra_gate): Disable for now. + * tree-sra.c (create_access): Swap INDIRECT_REF handling for + MEM_REF handling. + (disqualify_base_of_expr): Likewise. + (ptr_parm_has_direct_uses): Swap INDIRECT_REF handling for + MEM_REF handling. + (sra_ipa_modify_expr): Remove INDIRECT_REF handling. + Use mem_ref_offset. Remove bogus folding. + (build_access_from_expr_1): Properly handle MEM_REF for + non IPA-SRA. + (make_fancy_name_1): Add support for MEM_REF. + * tree-predcom.c (ref_at_iteration): Handle MEM_REFs. + * tree-mudflap.c (mf_xform_derefs_1): Adjust for MEM_REF. + * ipa-prop.c (compute_complex_assign_jump_func): Handle MEM_REF. + (compute_complex_ancestor_jump_func): Likewise. + (ipa_analyze_virtual_call_uses): Likewise. + * tree-ssa-forwprop.c (forward_propagate_addr_expr_1): Replace + INDIRECT_REF folding with more generalized MEM_REF folding. + (tree_ssa_forward_propagate_single_use_vars): Adjust accordingly. + (forward_propagate_addr_into_variable_array_index): Also handle + &ARRAY + I in addition to &ARRAY[0] + I. + * tree-ssa-dce.c (ref_may_be_aliased): Handle MEM_REF. + * tree-ssa-ter.c (find_replaceable_in_bb): Avoid TER if that + creates assignments with overlap. + * tree-nested.c (get_static_chain): Adjust for MEM_REF. + (get_frame_field): Likewise. + (get_nonlocal_debug_decl): Likewise. + (convert_nonlocal_reference_op): Likewise. + (struct nesting_info): Add mem_refs pointer-set. + (create_nesting_tree): Allocate it. + (convert_local_reference_op): Insert to be folded mem-refs. + (fold_mem_refs): New function. + (finalize_nesting_tree_1): Perform defered folding of mem-refs + (free_nesting_tree): Free the pointer-set. + * tree-vect-stmts.c (vectorizable_store): Adjust for MEM_REF. + (vectorizable_load): Likewise. + * tree-ssa-phiprop.c (phiprop_insert_phi): Adjust for MEM_REF. + (propagate_with_phi): Likewise. + * tree-object-size.c (addr_object_size): Handle MEM_REFs + instead of INDIRECT_REFs. + (compute_object_offset): Handle MEM_REF. + (plus_stmt_object_size): Handle MEM_REF. + (collect_object_sizes_for): Dispatch to plus_stmt_object_size + for &MEM_REF. + * tree-flow.h (get_addr_base_and_unit_offset): Declare. + (symbol_marked_for_renaming): Likewise. + * Makefile.in (tree-dfa.o): Add $(TOPLEV_H). + (fold-const.o): Add $(TREE_FLOW_H). + * tree-ssa-structalias.c (get_constraint_for_1): Handle MEM_REF. + (find_func_clobbers): Likewise. + * ipa-struct-reorg.c (decompose_indirect_ref_acc): Handle MEM_REF. + (decompose_access): Likewise. + (replace_field_acc): Likewise. + (replace_field_access_stmt): Likewise. + (insert_new_var_in_stmt): Likewise. + (get_stmt_accesses): Likewise. + (reorg_structs_drive): Disable. + * config/i386/i386.c (ix86_va_start): Adjust for MEM_REF. + (ix86_canonical_va_list_type): Likewise. + +2010-06-30 Joern Rennecke + + PR other/44566 + * coretypes.h [!USED_FOR_TARGET] (reg_class_t): Define. + * target.def (struct gcc_target): Replace enum reg_class with + reg_class_t in hook argument / return types. + * doc/tm.texi.in (TARGET_SECONDARY_RELOAD): Likewise. + (TARGET_IRA_COVER_CLASSES, TARGET_MEMORY_MOVE_COST): Likewise. + (TARGET_BRANCH_TARGET_REGISTER_CLASS): Likewise. + * targhooks.h (default_branch_target_register_class): Likewise. + (default_ira_cover_classes, default_secondary_reload): Likewise. + (default_memory_move_cost, default_register_move_cost): Likewise. + * targhooks.c (default_branch_target_register_class): Likewise. + (default_ira_cover_classes, default_secondary_reload): Likewise. + (default_memory_move_cost, default_register_move_cost): Likewise. + * reload.c (push_secondary_reload, secondary_reload_class): Likewise. + * bt-load.c (branch_target_load_optimize): Likewise. + * ira.c (setup_cover_and_important_classes): Likewise. + * ira-costs.c (copy_cost): Likewise. + * reload1.c (emit_input_reload_insns): Likewise. + * config/alpha/alpha.c (alpha_secondary_reload): Likewise. + * config/frv/frv.c (frv_secondary_reload): Likewise. + * config/s390/s390.c (s390_secondary_reload): Likewise. + * config/i386/i386.c (i386_ira_cover_classes): Likewise. + (ix86_secondary_reload, ix86_memory_move_cost): Likewise. + (ix86_register_move_cost): Likewise. + * config/sh/sh-protos.h (sh_secondary_reload): Likewise. + * config/sh/sh.c (sh_target_reg_class, sh_secondary_reload): Likewise. + * config/xtensa/xtensa.c (xtensa_secondary_reload): Likewise. + * config/xtensa/xtensa-protos.h (xtensa_secondary_reload): Likewise. + * config/rs6000/rs6000.c (rs6000_secondary_reload): Likewise. + (rs6000_ira_cover_classes): Likewise. + * config/picochip/picochip.c (picochip_secondary_reload): Likewise. + * config/picochip/picochip-protos.h (picochip_secondary_reload): + Likewise. + * config/pa/pa.c (pa_secondary_reload): Likewise. + * config/mips/mips.c (mips_ira_cover_classes): Likewise. + * config/bfin/bfin.c (bfin_secondary_reload): Likewise. + * config/ia64/ia64.c (ia64_register_move_cost): Likewise. + * doc/tm.texi: Regenerate. + +2010-06-30 Sebastian Pop + + PR bootstrrap/44726 + * graphite-sese-to-poly.c (build_poly_dr): Avoid uninitialized + use. + (build_alias_set_optimal_p): Likewise. + (build_base_obj_set_for_drs): Likewise. + +2010-06-30 Joern Rennecke + + * target.def: Remove comment about licensing problems of function + declarations. + + * target.def (declare_constant_name): Change exp to expr. Use DEFHOOK. + * doc/tm.texi.in (TARGET_ASM_DECLARE_CONSTANT_NAME): Use @hook. + * doc/tm.texi: Regenerate. + + * target.def (builtin_reciprocal): Change tm_fn to md_fn. Use DEFHOOK. + * doc/tm.texi.in (TARGET_BUILTIN_RECIPROCAL): Use @hook. + + * target.def (enum_va_list_p): Use DEFHOOK. + * doc/tm.texi.in (TARGET_ENUM_VA_LIST_P): Use @hook. + Rename ptype to ptree. + * doc/tm.texi: Regenerate. + + * target.def (fold_builtin): Rename nargs to n_args. Use DEFHOOK. + * doc/tm.texi.in (TARGET_FOLD_BUILTIN): Use @hook. + * doc/tm.texi: Regenerate. + + * target.def (memory_move_cost): Use DEFHOOK. + * doc/tm.texi.in (TARGET_MEMORY_MOVE_COST): Use @hook. + Rename regclass AKA class to rclass. + * doc/tm.texi: Regenerate. + + * target.def (pragma_parse): Use DEFHOOK. + * doc/tm.texi.in (TARGET_OPTION_PRAGMA_PARSE): Use @hook. + s/TARGET_VALID_OPTION_ATTRIBUTE_P/TARGET_OPTION_VALID_ATRIBUTE_P/ . + * doc/tm.texi: Regenerate. + + * target.def (pass_by_reference): Use DEFHOOK. + * doc/tm.texi.in (TARGET_PASS_BY_REFERENCE): Use @hook. + * doc/tm.texi: Regenerate. + + * target.def (resolve_overloaded_builtin): Rename params to arglist. + Use DEFHOOK. + * doc/tm.texi.in (TARGET_RESOLVE_OVERLOADED_BUILTIN): Use @hook. + * doc/tm.texi: Regenerate. + + * target.def (return_pops_args): Use DEFHOOK. + * doc/tm.texi.in (TARGET_RETURN_POPS_ARGS): Use @hook. + Rename stack-size to size. + * doc/tm.texi: Regenerate. + + * target.def (dfa_new_cycle): Use DEFHOOK. Rename dump_file to dump, + last-sched_cycle to last_clock, cur_cycle to clock. + * doc/tm.texi.in: Use @hook. + * doc/tm.texi: Regenerate. + + * target.def (print_operand, print_operand_address): Update comment. + (print_operand_punct_valid_p): Likewise. + +2010-06-30 Manuel López-Ibáñez + + * toplev.h (_fatal_insn_not_found, _fatal_insn): Move declarations + to rtl.h. + (error_for_asm, warning_for_asm): Move declarations to rtl-error.h. + * rtl.h (_fatal_insn_not_found, _fatal_insn): Move declarations + here. + * rtl-error.h: New. + * regrename.c: Do not include toplev.h. Include rtl-error.h. + * rtl-error.c: Likewise. + * reload.c: Likewise. + * recog.c: Likewise. + * sel-sched.c: Likewise. + * function.c: Likewise. + * reg-stack.c: Likewise. + * cfgrtl.c: Likewise. + * reload1.c: Likewise. + * final.c: Include rtl-error. + * Makefile.in: Adjust dependencies. + +2010-06-30 Jan Hubicka + + PR middle-end/PR44706 + * ipa-split (split_function): Refine conditions when to use DECL_RESULT + to return the value. + +2010-06-30 Michael Matz + + PR bootstrap/44699 + * tree-vrp.c (vrp_finalize): Deal with changing num_ssa_names. + * gimple-fold.c (gimplify_and_update_call_from_tree): If LHS is + a gimple reg, attach the original VDEF to the last store in the + sequence. + +2010-06-30 Iain Sandoe + + PR other/44034 + * config/darwin.c (darwin_override_options): Use renamed + targetm.asm_out.emit_unwind_label. + +2010-06-30 Bernd Schmidt + + PR tree-optimization/39799 + * tree-inline.c (remap_ssa_name): Initialize variable only if + SSA_NAME_OCCURS_IN_ABNORMAL_PHI. + +2010-06-30 Nathan Froyd + + * c-parser.c (c_parser_omp_for_loop): Use a VEC for for_block. + +2010-06-30 Richard Guenther + + PR target/44722 + * config/i386/i386.md (peephole2 for fix:SSEMODEI24): Guard + against oscillation with reverse peephole2. + +2010-06-30 H.J. Lu + + PR target/44721 + * config/i386/i386.md (peephole2 for arithmetic ops with memory): + Fix last commit. + +2010-06-30 Nick Clifton + + * config/rx/rx-modes.def: New file. + * config/rx/rx.h (FIRST_PSEUDO_REGISTER): Increase to 17. + (CC_REGNUM): Define. + (FIXED_REGISTERS, CALL_USED_REGISTERS, REGISTER_NAMES): Add cc + register. + (CC_NO_CARRY, NOTICE_UPDATE_CC): Delete. + (SELECT_CC_MODE): Define. + * config/rx/rx.md (CC_REG): Define. Update all patterns to use + (reg:CC CC_REG) instead of (cc0). + (attr "cc"): Delete. + (cbranchsi4): Do not split compare and branch here. Instead move + it to... + (cbranchsi4_): ... here. New patterns. + (cmpsi): Call rx-compare_redundant to find out if it is necessary + to emit the compare instruction. + * config/rx/rx.c (rx_gen-cond_branch_template): Remove tests of + cc_status flags. + (rx_get_stack_layout): Iterate up to before CC_REGNUM not + FIRST_PSEUDO_REGNUM. + (rx_expand_prologue, rx_expand_epilogue): Likewise. + (rx_notice_update_cc): Delete. + (rx_cc_modes_compatible): New function. + (flags_needed_for_conditional): New function. + (flags_from_mode): New function. + (rx_compare_redundant): New function - scans backwards through + insn list to find out if condition flags are already set + correctly. + (TARGET_CC_MODES_COMPATIBLE): Define. + * config/rx/rx-protos.h (rx_compare_redundant): Prototype. + + * config/rx/rx.h (BRANCH_COST): Define. + (REGISTER_MOVE_COST): Define. + * config/rx/predicates (rx_source_operand): Allow all constant + types. + * config/rx/rx.md (addsi3): Add alternative for swapped operands. + (tstsi4): New pattern. + * config/rx/rx.c (rx_memory_move_cost): Define. + (TARGET_MEMORY_MOVE_COST): Define. + +2010-06-30 Manuel López-Ibáñez + + * tree.h (block_may_fallthru): Declare here. + * tree-flow.h (block_may_fallthru): Do not declare here. + * c-typeck.c: Do not include tree-flow.h. Include gimple.h and + bitmap.h + * Makefile.in (c-typeck.o): Update dependencies. + +2010-06-30 Jakub Jelinek + + PR debug/44694 + * cselib.h (cselib_preserve_cfa_base_value): Add regno argument. + * cselib.c (cfa_base_preserved_regno): New static variable. + (cselib_reset_table): Don't reset cfa_base_preserved_regno instead + of REGNO (cfa_base_preserved_val->locs->loc). + (cselib_preserve_cfa_base_value): Add regno argument, set + cfa_base_preserved_regno to it. + (cselib_invalidate_regno): Allow removal of registers other than + cfa_base_preserved_regno from cfa_base_preserved_val. + (cselib_finish): Set cfa_base_preserved_regno to INVALID_REGNUM. + * var-tracking.c (adjust_mems): Replace sp or hfp even outside + of MEM addresses, if not on LHS. + (reverse_op): Don't add reverse ops for cfa_base_rtx. + (vt_init_cfa_base): Adjust cselib_preserve_cfa_base_value caller. + +2010-06-30 Bernd Schmidt + + * recog.c (peep2_do_rebuild_jump_labels, peep2_do_cleanup_cfg): New + static variables. + (peep2_buf_position): New static function. + (peep2_regno_dead_p, peep2_reg_dead_p, peep2_find_free_register, + peephole2_optimize): Use it. + (peep2_attempt, peep2_update_life): New static functions, broken out + of peephole2_optimize. + (peep2_fill_buffer): New static function. + (peephole2_optimize): Change the main loop to try to fill the buffer + with the maximum number of insns before matching them against + peepholes. Use a forward scan. Remove special case for targets with + conditional execution. + * genrecog.c (change_state): Delete dead code. + * config/i386/i386.md (peephole2 for arithmetic ops with memory): + Rewrite so as not to expect the second insn to have had a peephole + applied yet. + +2010-06-29 Nathan Froyd + + * genhooks.c (emit_findices): Cast field precision to int. + (emit_documentation): Likewise. + +2010-06-29 Jakub Jelinek + + PR tree-optimization/43801 + * cgraph.c (cgraph_create_virtual_clone): Clear DECL_SECTION_NAME + if old_decl was DECL_ONE_ONLY. + + PR debug/44668 + * dwarf2out.c (add_accessibility_attribute): New function. + (gen_subprogram_die, gen_variable_die, gen_field_die): Use it + instead of adding DW_AT_accessibility manually. + (gen_enumeration_type_die, gen_struct_or_union_type_die, + gen_typedef_die): Use it. + +2010-06-29 Douglas B Rupp + + * vmsdbgout.c (full_name): Just output the file name if not native. + +2010-06-29 Douglas B Rupp + + * vmsdbgout.c (func_table): Replace with VEC func{nam,num}_tables. + (funcnam_table): New static table. + (funcnum_table): New static table. + (write_rtnbeg): Write value saved in funcnum_table. + (write_rtnend): Write value saved in funcnum_table. + (vmsdbgout_begin_function): Save current function info in + (vmsdbgout_init): Initialize func{nam,num}_tables. Minor reformatting. + (vmsdbgout_finish): Iterate over funcnum_table. + +2010-06-29 Douglas B Rupp + + * vmsdbgout.c (vmsdbgout_begin_epilogue): Declare + (vmsdbgout_type_decl): Declare + (vmsdbg_debug_hooks): Add entry for type_decl and begin_epilogue. + (FUNC_EPILOGUE_LABEL): New macro + (vmsdbgout_begin_epilogue): New function. + (vmsdbgout_type_decl): New function. + +2010-06-29 Douglas B Rupp + + * vmsdbg.h: Update copyright. + +2010-06-29 Douglas B Rupp + + * vmsdbg.h (DST_K_TBG): New DST constant. + * vmsdbgout.c (addr_const_to_string): Removed, not referenced. + (write_modbeg): Cast module_language to avoid warning. + (write_rtnbeg): Use DST_K_TBG vice magic mystery number. + +2010-06-29 Joern Rennecke + + PR other/44034 + * target.def, doc/tm.texi.in, genhooks.c: New files. + * target.h: Instead of defining individual hook members, + define DEFHOOKPOD / DEFHOOK / DEFHOOK_UNDOC / HOOKSTRUCT and + include target.def. + * target-def.h: Instead of defining individual hook initializers, + include target-hooks-def.h. + * df-scan.c, haifa-sched.c, sel-sched.c: Rename targetm members: + targetm.live_on_entry -> targetm.extra_live_on_entry + targetm.sched.md_finish ->targetm.sched.finish + targetm.sched.md_init -> targetm.sched.init + targetm.sched.md_init_global -> targetm.sched.init_global + targetm.asm_out.unwind_label -> targetm.asm_out.emit_unwind_label + targetm.asm_out.except_table_label -> + targetm.asm_out.emit_except_table_label + targetm.asm_out.visibility -> targetm.asm_out.assemble_visibility + targetm.target_help -> targetm.help + targetm.vectorize.builtin_support_vector_misalignment -> + targetm.vectorize.support_vector_misalignment + targetm.file_start_app_off -> targetm.asm_file_start_app_off + targetm.file_start_file_directive -> + targetm.asm_file_start_file_directive + * dwarf2out.c, opts.c, tree-vect-data-refs.c, except.c: Likewise. + * varasm.c, config/alpha/alpha.c, config/cris/cris.c: Likewise. + * gcc/config/spu/spu.c, config/ia64/ia64.c: Rename target macros: + TARGET_VECTOR_ALIGNMENT_REACHABLE -> + TARGET_VECTORIZE_VECTOR_ALIGNMENT_REACHABLE + TARGET_SUPPORT_VECTOR_MISALIGNMENT -> + TARGET_VECTORIZE_SUPPORT_VECTOR_MISALIGNMENT + TARGET_UNWIND_EMIT -> TARGET_ASM_UNWIND_EMIT + * config/rs6000/rs6000.c, config/arm/arm.c: Likewise. + * Makefile.in (TARGET_H): Depend on target.def. + (TARGET_DEF_H): Depend on target-hooks-def.h. + (target-hooks-def.h, tm.texi, s-target-hooks-def-h): New rules. + (s-tm-texi, build/genhooks.o, build/genhooks): Likewise. + * doc/tm.texi: Regenerate. + + * Makefile.in (s-tm-texi): Remove stray tab / rule. + + * config/m68k/m68k.c (targetm.sched.init_global): Update comment. + (targetm.sched.init): Likewise. + +2010-06-29 Nathan Froyd + + PR bootstrap/44713 + * config/i386/i386.c (type_natural_mode): Const-ify CUM parameter. + (function_arg_advance_32): Const-ify TYPE parameter. + (function_arg_advance_64): Likewise. Change type of NAMED to bool. + (ix86_function_arg_advance): Change type of NAMED to bool. + (function_arg_32): Const-ify CUM and TYPE parameters. + (function_arg_64): Likewise. Change type of NAMED to bool. + (function_arg_ms_64): Const-ify CUM parameter. Change type of NAMED + to bool. + (ix86_function_arg): Change type of NAMED to bool. + (ix86_setup_incoming_varargs): Call ix86_function_arg_advance. Pass + last argument as a bool. + +2010-06-29 Joern Rennecke + + * doc/tm.texi (TARGET_OPTION_OVERRIDE): Document. + (OVERRIDE_OPTIONS): Add note of obsolescence. + Replace references with references to TARGET_OPTION_OVERRIDE. + (Except for C_COMMON_OVERRIDE_OPTIONS, which remains similar to + the macro). + * targhooks.c (default_target_option_override): New function. + * targhooks.h (default_target_option_override): Declare. + * target.h (struct gcc_target): Add override member to + target_option member. + * toplev.c (process_options): Replace OVERRIDE_OPTIONS use with + targetm.target_option.override call. + * target-def.h (TARGET_OPTION_OVERRIDE): Define. + (TARGET_OPTION_HOOKS): Add TARGET_OPTION_OVERRIDE. + +2010-06-29 Jan Hubicka + + * tree-inline.c: Replace incomming by incomin and clonning by cloning. + +2010-06-29 Jan Hubicka + + * predict.c (propagate_freq): Clear EXIT_BLOCK_PTR frequency if it is + unreachable. + (rebuild_frequencies): New function. + * predict.h (rebuild_frequencies): Declare. + * tree-inline.c (copy_cfg_body): Compute properly count & frequency of + entry block and edge reaching new_entry. + (tree_function_versioning): When doing partial cloning, rebuild frequencies + when done. + * passes.c (execute_function_todo): Use rebild_frequencies. + +2010-06-29 Richard Guenther + + * tree-dfa.c (dump_variable): Remove noalias_state dumping. + * tree-flow.h (enum noalias_state): Remove. + (struct var_ann_d): Remove noalias_state member. + +2010-06-29 Bernd Schmidt + + PR target/43902 + * config/arm/arm.md (maddsidi4, umaddsidi4): New expanders. + (maddhisi4): Renamed from mulhisi3addsi. Operands renumbered. + (maddhidi4): Likewise. + + Revert parts of the change for PR25130. + * cse.c (exp_equiv_p): For MEMs, if for_gcse, only compare + MEM_ALIAS_SET. + +2010-06-29 Nathan Froyd + + * calls.c, dse.c, expr.c, function.c: Call targetm.calls.function_arg, + targetm.calls.function_incoming_arg, and + targetm.calls.function_arg_advance instead of FUNCTION_ARG, + FUNCTION_INCOMING_ARG, and FUNCTION_ARG_ADVANCE, respectively. + * target.h (struct gcc_target): Add function_arg_advance, + function_arg, and function_incoming_arg fields. + * target-def.h (TARGET_FUNCTION_ARG_ADVANCE, TARGET_FUNCTION_ARG): + (TARGET_FUNCTION_INCOMING_ARG): Define. + (TARGET_CALLS): Add TARGET_FUNCTION_ARG_ADVANCE, TARGET_FUNCTION_ARG, + and TARGET_FUNCTION_INCOMING_ARG. + * targhooks.h (default_function_arg_advance): Declare. + (default_function_arg, default_function_incoming_arg): Declare. + * targhooks.c (default_function_arg_advance): New function. + (default_function_arg, default_function_incoming_arg): New function. + * config/i386/i386.c (function_arg_advance): Rename to... + (ix86_function_arg_advance): ...this. Make static. + (function_arg): Rename to... + (ix86_function_arg): ...this. Make static. + (TARGET_FUNCTION_ARG_ADVANCE): Define. + (TARGET_FUNCTION_ARG): Define. + * config/i386/i386.h (FUNCTION_ARG_ADVANCE): Delete. + (FUNCTION_ARG): Delete. + * config/i386/i386-protos.h (function_arg_advance): Delete prototype. + (function_arg): Delete prototype. + +2010-06-29 Nathan Froyd + + * reginfo.c (init_reg_sets_1): Adjust comments. + * combine-stack-adj.c (rest_of_handle_stack_adjustments): Likewise. + * calls.c (prepare_call_address): Likewise. + (emit_call_1): Use targetm.calls.return_pops_args. + (expand_call): Likewise. + * function.c (assign_parms): Likewise. + * system.h (RETURN_POPS_ARGS): Add to #pragma poison list. + * target.h (struct gcc_target) [struct calls]: Add + return_pops_args field. + * targhooks.h (default_return_pops_args): Declare. + * targhooks.c (default_return_pops_args): Define. + * target-def.h (TARGET_RETURN_POPS_ARGS): Define. + (TARGET_CALLS): Add TARGET_RETURN_POPS_ARGS. + * doc/tm.texi (RETURN_POPS_ARGS): Rename to... + (TARGET_RETURN_POPS_ARGS): ...this. Use deftypefn. Adjust + documentation. + * config/alpha/alpha.h (RETURN_POPS_ARGS): Delete. + * config/arc/arc.h (RETURN_POPS_ARGS): Likewise. + * config/arm/arm.h (RETURN_POPS_ARGS): Likewise. + * config/avr/avr.h (RETURN_POPS_ARGS): Likewise. + * config/bfin/bfin.h (RETURN_POPS_ARGS): Likewise. + * config/cris/cris.h (RETURN_POPS_ARGS): Likewise. + * config/crx/crx.h (RETURN_POPS_ARGS): Likewise. + * config/fr30/fr30.h (RETURN_POPS_ARGS): Likewise. + * config/frv/frv.h (RETURN_POPS_ARGS): Likewise. + * config/h8300/h8300.h (RETURN_POPS_ARGS): Likewise. + * config/ia64/ia64.h (RETURN_POPS_ARGS): Likewise. + * config/iq2000/iq2000.h (RETURN_POPS_ARGS): Likewise. + * config/lm32/lm32.h (RETURN_POPS_ARGS): Likewise. + * config/m32c/m32c.h (RETURN_POPS_ARGS): Likewise. + * config/m32r/m32r.h (RETURN_POPS_ARGS): Likewise. + * config/m68hc11/m68hc11.h (RETURN_POPS_ARGS): Likewise. + * config/mcore/mcore.h (RETURN_POPS_ARGS): Likewise. + * config/mep/mep.h (RETURN_POPS_ARGS): Likewise. + * config/mips/mips.h (RETURN_POPS_ARGS): Likewise. + * config/mmix/mmix.h (RETURN_POPS_ARGS): Likewise. + * config/mn10300/mn10300.h (RETURN_POPS_ARGS): Likewise. + * config/moxie/moxie.h (RETURN_POPS_ARGS): Likewise. + * config/pa/pa.h (RETURN_POPS_ARGS): Likewise. + * config/pdp11/pdp11.h (RETURN_POPS_ARGS): Likewise. + * config/picochip/picochip.h (RETURN_POPS_ARGS): Likewise. + * config/rs6000/rs6000.h (RETURN_POPS_ARGS): Likewise. + * config/rx/rx.h (RETURN_POPS_ARGS): Likewise. + * config/s390/s390.h (RETURN_POPS_ARGS): Likewise. + * config/score/score.h (RETURN_POPS_ARGS): Likewise. + * config/sh/sh.h (RETURN_POPS_ARGS): Likewise. + * config/sparc/sparc.h (RETURN_POPS_ARGS): Likewise. + * config/spu/spu.h (RETURN_POPS_ARGS): Likewise. + * config/stormy16/stormy16.h (RETURN_POPS_ARGS): Likewise. + * config/v850/v850.h (RETURN_POPS_ARGS): Likewise. + * config/xtensa/xtensa.h (RETURN_POPS_ARGS): Likewise. + * config/i386/i386-protos.h (ix86_return_pops_args): Delete. + * config/i386/i386.h (RETURN_POPS_ARGS): Delete. + * config/i386/i386.c (ix86_return_pops_args): Make static. + Constify arguments. + (TARGET_RETURN_POPS_ARGS): Define. + * config/m68k/m68k.h (RETURN_POPS_ARGS): Move to... + * config/m68k/m68k.c (m68k_return_pops_args): ...here. New function. + (TARGET_RETURN_POPS_ARGS): Define. + * config/vax/vax.h (RETURN_POPS_ARGS): Move to... + * config/vax/vax.c (vax_return_pops_args): ...here. New function. + (TARGET_RETURN_POPS_ARGS): Define. + +2010-06-29 Richard Guenther + + PR middle-end/44667 + * tree-inline.c (initialize_inlined_parameters): Make sure + to remap the inlined parameter variable substitutions types. + +2010-06-29 Eric Botcazou + + PR rtl-optimization/44659 + * combine.c (make_compound_operation) : Do not return the + result of force_to_mode if it partially re-expanded the compound. + +2010-06-28 Jan Hubicka + + PR middle-end/44671 + * ipa-split.c (test_nonssa_use, mark_nonssa_use): Check also uses of + RESULT_DECL. + +2010-06-28 Anatoly Sokolov + + * double-int.h (force_fit_type_double): Remove declaration. + * double-int.c (force_fit_type_double): Move to tree.c. + * tree.h (force_fit_type_double): Declare. + * tree.h (force_fit_type_double): Moved from double-int.c. Use + double_int type for 'cst' argument. Use double_int_fits_to_tree_p and + double_int_to_tree instead of fit_double_type and build_int_cst_wide. + * convert.c (convert_to_pointer): Adjust call to + force_fit_type_double. + * tree-vrp.c (extract_range_from_assert, + extract_range_from_unary_expr): Adjust call to force_fit_type_double. + * fold-const.c: Update comment. + (int_const_binop, fold_convert_const_int_from_int, + fold_convert_const_int_from_real, fold_convert_const_int_from_fixed, + extract_muldiv_1, fold_div_compare, fold_sign_changed_comparison, + fold_unary_loc, fold_negate_const, fold_abs_const, fold_not_const, + round_up_loc): Adjust call to force_fit_type_double. + +2010-06-28 Philipp Tomsich + + * config/rs6000/rs6000.h (PROCESSOR_TITAN): Declare. + +2010-06-28 Martin Jambor + + * tree-sra.c (convert_callers): New parameter, change fndecls of + recursive calls. + (modify_function): Pass the old decl to convert_callers. + +2010-06-28 Martin Jambor + + * ipa-cp.c (ipcp_init_cloned_node): Replace calls to + ipa_check_create_node_params and ipa_initialize_node_params with + checking asserts they are not necessary. + +2010-06-28 Jan Hubicka + + PR tree-optimization/44687 + * ipa-split.c (split_function): Use DECL_RESULT to store return value. + +2010-06-28 Martin Jambor + + PR c++/44535 + * gimple-fold.c (get_first_base_binfo_with_virtuals): New function. + (gimple_get_relevant_ref_binfo): Use get_first_base_binfo_with_virtuals + instead of BINFO_BASE_BINFO. + +2010-06-28 Michael Matz + + PR middle-end/44592 + * gimple-fold.c (gimplify_and_update_call_from_tree): Maintain + proper VDEF chain for intermediate stores in the sequence. + +2010-06-28 Jan Hubicka + + PR tree-optimization/44357 + * ipa-inline.c (add_new_edges_to_heap): Do not add edges to uninlinable + functions. + +2010-06-28 Philipp Tomsich + + * config.gcc (powerpc*-*-*): Handle titan. + * config/rs6000/rs6000.c (titan_cost): New costs. + (rs6000_override_options): Add "titan" to processor_target_table. + Add Titan to branch alignment logic. + Correctly set rs6000_cost for titan. + * config/rs6000/rs6000.md (cpu): Add titan. Include "titan.md". + * config/rs6000/titan.md: New file. + * doc/invoke.texi (RS/6000 and PowerPC Options): Document -mcpu=titan. + +2010-06-28 Nathan Froyd + + * tree-browser.c (TB_history_stack): Convert to a VEC. + (TB_SET_HEAD): Adjust for new type of TB_history_stack. + (TB_history_prev): Likewise. + +2010-06-28 Nathan Froyd + + * vec.h (vec_heap_free): Add parentheses around free. + +2010-06-28 Steven Bosscher + + * system.h: Poison GCC_EXCEPT_H for front-end files. + + * langhooks.h (struct lang_hooks): Add eh_protect_cleanup_actions + langhook. + * langhooks-def.h (LANG_HOOKS_EH_PROTECT_CLEANUP_ACTIONS) New. + Define to NULL by default. + * except.h: Define GCC_EXCEPT_H. + (doing_eh): Remove prototype. + (init_eh, init_eh_for_function): Move prototypes to toplev.h. + (lang_protect_cleanup_actions): Remove. + * except.c (lang_protect_cleanup_actions): Remove. + (doing_eh): Remove. + (gen_eh_region): Don't check doing_eh here. + * toplev.h (init_eh, init_eh_for_function_): Moved from except.h. + * tree-eh.c (honor_protect_cleanup_actions): Use new langhook + instead of lang_protect_cleanup_actions. + * omp-low.c (maybe_catch_exception): Likewise. + * Makefile.in: Update dependencies. + +2010-06-28 Bingfeng Mei + + * cgraph.h (struct varpool_node): new used_from_object_file flag. + (struct cgraph_local_info): new used_from_object_file flag. + * cgraph.c (dump_cgraph_node): dump used_from_object_file flag. + (cgraph_clone_node): initialize used_from_object_file. + (cgraph_create_virtual_clone): initialize used_from_object_file. + * lto-symbtab.c (lto_symtab_merge_decls_1): Set + used_from_object_file flags for symbols of LDPR_PREVAILING_DEF + when compiling with -fwhole-program. + (lto_symtab_resolve_symbols) Use LDPR_PREVAILING_DEF_IRONLY for + internal resolver. + * ipa.c (function_and_variable_visibility): Set externally_visible + flag of varpool_node if used_from_object_file flag is set. + (cgraph_externally_visible_p): check used_from_object_file flag. + * doc/invoke.texi (-fwhole-program option): Change description of + externally_visible attribute accordingly. + * doc/extend.texi (externally_visible): Ditto. + +2010-06-27 Jan Hubicka + + * params.def (max-inline-insns-auto): Default to 40. + * doc/invoke.texi (max-inline-insns-auto): Document the change. + +2010-06-27 Jan Hubicka + + PR middle-end/44671 + PR middle-end/44686 + * tree.c (build_function_decl_skip_args): Clear DECL_BUILT_IN on + signature change. + * ipa-split.c (split_function): Always clear DECL_BUILT_IN. + * ipa-prop.c (ipa_modify_formal_parameters): Likewise. + +2010-06-27 Anatoly Sokolov + + * target.h (struct gcc_target): Add register_move_cost field. + * target-def.h (TARGET_REGISTER_MOVE_COST): New. + (TARGET_INITIALIZER): Use TARGET_REGISTER_MOVE_COST. + * targhooks.c (default_register_move_cost): New function. + * targhooks.h (default_register_move_cost): Declare function. + * defaults.h (REGISTER_MOVE_COST): Delete. + * ira-int.h (ira_register_move_cost): Update comment. + * ira.c: (ira_register_move_cost): Update comment. + * reload.h (register_move_cost): Declare. + * reginfo.c (register_move_cost): New function. + (move_cost): Update comment. + (init_move_cost, memory_move_secondary_cost): Replace + REGISTER_MOVE_COST with register_move_cost. + * postreload.c (reload_cse_simplify_set): (Ditto.). + * reload.c (find_valid_class, find_reloads): (Ditto.). + * reload1.c (choose_reload_regs): (Ditto.). + * doc/tm.texi (TARGET_REGISTER_MOVE_COST): New. + (REGISTER_MOVE_COST, TARGET_MEMORY_MOVE_COST): Update documentation. + * doc/md.texi (can_create_pseudo_p): Update documentation. + + * config/i386/i386.h (MEMORY_MOVE_COST): Remove macro. + * config/i386/i386-protos.h (int ix86_memory_move_cost): Remove. + * config/i386/i386.h (ix86_memory_move_cost): Make static. + (TARGET_MEMORY_MOVE_COST): Define. + + * config/ia64/ia64.h (MEMORY_MOVE_COST): Remove macro. + * config/ia64/ia64-protos.h (int ia64_memory_move_cost): Remove. + * config/ia64/ia64.h (ia64_memory_move_cost): Make static. + (TARGET_MEMORY_MOVE_COST): Define. + +2010-06-27 Richard Guenther + + PR tree-optimization/44683 + * tree-ssa-dom.c (record_edge_info): Record equivalences for the + false edge from the inverted condition. + +2010-06-27 Richard Guenther + + PR middle-end/44684 + * tree-ssa-alias.c (refs_may_alias_p_1): Allow SSA name refs. + (stmt_may_clobber_ref_p_1): Do not bother to call the oracle + for register LHS. Or non-store assignments. + +2010-06-26 Eric Botcazou + + * config/sparc/sparc.c (sparc_emit_set_const32): Make static. + (sparc_emit_set_const64): Likewise. Remove disabled code. + * config/sparc/sparc-protos.h (sparc_emit_set_const32): Delete. + (sparc_emit_set_const64): Likewise. + +2010-06-26 Catherine Moore + + * config/mips/mips.md (alu_type): New attribute. + (type): Infer type from alu_type. + (*add3, *add3_mips16, *addsi3_extended, + *baddu_si_eb, *baddu_si_el, *baddu_di, sub3, + *subsi3_extended, negsi2, negdi2, *low, + *low_mips16, *ior3, *ior3_mips16, + xor3, *nor3, + *zero_extend_trunc, + *zero_extendhi_truncqi): Set alu_type instead of type. + +2010-06-26 Douglas B Rupp + + * config/alpha/alpha.c (alpha_need_linkage): Adjust + splay_tree_new_ggc call. + (alpha_use_linkage): Likewise. + +2010-06-26 Joseph Myers + + * collect2.c (main): Remove SWITCHES_NEED_SPACES conditional. + * doc/tm.texi (SWITCHES_NEED_SPACES): Don't document. + * gcc.c (SWITCHES_NEED_SPACES, switches_need_spaces): Remove. + (static_specs): Remove switches_need_spaces. + (process_command, do_self_spec): Hardcode handling "-o" instead of + checking switches_need_spaces. + * system.h (SWITCHES_NEED_SPACES): Poison. + +2010-06-26 Richard Guenther + + PR tree-optimization/44393 + * tree-loop-distribution.c (generate_loops_for_partition): Fix + stmt removal and VOP renaming. + (generate_memset_zero): Remove redundant stmt updating. + * tree-flow.h (mark_virtual_ops_in_bb): Remove. + * tree-cfg.c (mark_virtual_ops_in_bb): Likewise. + +2010-06-26 Jan Hubicka + + * ipa-split.c (consider_split): PHI in entry block is OK as long as all + edges comming from header are equivalent. + (visit_bb): Handle PHIs correctly. + * tree-inline.c (copy_phis_for_bb): Be able to copy + PHI from entry edge. + (copy_cfg_body): Produce edge from entry BB before copying + PHIs. + +2010-06-26 Richard Guenther + + PR middle-end/44674 + * tree-ssa-alias.c (refs_may_alias_p_1): Allow all kind of + decls. Handle LABEL_DECLs like FUNCTION_DECLs. + +2010-06-26 Joseph Myers + + * gcc.c (n_switches_alloc, n_infiles_alloc, alloc_infile, + add_infile, alloc_switch): New. + (process_command): Remove variable lang_n_infiles. Process + options in a single pass. Use new functions for allocating + infiles and switches arrays. Properly skip operands of + -Xpreprocessor and -Xassembler. + +2010-06-26 Jan Hubicka + + PR middle-end/44671 + * cgraphunit.c (cgraph_function_versioning): Remove wrong + cgraph_make_decl_local call; fix typo copying RTL data. + +2010-06-25 DJ Delorie + + * config/m32c/m32c-protos.h (m32c_note_pragma_address): Declare. + (m32c_output_aligned_common): Likewise. + * config/m32c/m32c.h (ASM_OUTPUT_ALIGNED_DECL_COMMON): New. + (ASM_OUTPUT_ALIGNED_DECL_LOCAL): New. + * config/m32c/m32c-pragma.c (m32c_pragma_address): New. + (m32c_register_pragmas): Register it. + * config/m32c/m32c.c (m32c_get_pragma_address): New. + (m32c_insert_attributes): Set #pragma address decls volatile. + (pragma_entry_eq): New. + (pragma_entry_hash): New. + (m32c_note_pragma_address): New. + (m32c_get_pragma_address): New. + (m32c_output_aligned_common): New. + * doc/extend.texi: Document the new pragma. + + * config/m32c/m32c.c (m32c_illegal_subreg_p): Reject illegal MEMs + also. + * config/m32c/predicates.md (m32c_any_operand): Check the code + instead of memory_operand so as to allow matching volatile MEMs. + (m32c_nonimmediate_operand): Likewise. + (mra_operand): Allow volatiles. + +2010-06-25 Alexandre Oliva + + PR debug/44610 + * simplify-rtx.c (delegitimize_mem_from_attrs): Don't use a base + address if the offset is unknown. + +2010-06-25 Douglas B Rupp + + * dwarf2out.c (dwarf2out_vms_debug_main_pointer): New function. + * dwarf2out.h (dwarf2out_vms_debug_main_pointer): Declare new function. + * config/ia64/ia64-protos.h (ia64_start_function): Declare. + * config/ia64/sysv4.h (ASM_DECLARE_FUNCTION_NAME): Move contents + to ia64_start_function. Invoke it. + * config/ia64/ia64.c (ia64_start_function): Call new function + dwarf2out_vms_debug_main_pointer. + +2010-06-25 Sebastian Pop + + * tree-if-conv.c (insert_gimplified_predicates): Do not insert + statements computing the true predicate. + +2010-06-25 Sebastian Pop + + * tree-if-conv.c (init_bb_predicate): Initialize the predicate + to boolean_true_node. + (reset_bb_predicate): New. + (predicate_bbs): Call reset_bb_predicate. + +2010-06-25 Sebastian Pop + + * tree-if-conv.c (combine_blocks): Remove FIXME comment. + (tree_if_conversion): Returns true when something has been changed. + (main_tree_if_conversion): Return TODO_cleanup_cfg when if-conversion + changed something. + +2010-06-25 Sebastian Pop + + * Makefile.in (tree-if-conv.o): Depends on DBGCNT_H. + * dbgcnt.def (if_conversion_tree): New DEBUG_COUNTER. + * tree-if-conv.c: Include dbgcnt.h. + (tree_if_conversion): Use if_conversion_tree to count the number of + if-convertible loops. + +2010-06-25 Changpeng Fang + + * common.opt (fprefetch-loop-arrays): Re-define + -fprefetch-loop-arrays as a tri-state option with the initial + value of -1. + * tree-ssa-loop.c (gate_tree_ssa_loop_prefetch): Invoke prefetch + pass only when flag_prefetch_loop_arrays > 0. + * toplev.c (process_options): Note that, with tri-states, + flag_prefetch_loop_arrays>0 means prefetching is enabled. + * config/i386/i386.c (override_options): Enable prefetching at -O3 + for a set of CPUs that sw prefetching is helpful. + (software_prefetching_beneficial_p): New. Return TRUE if software + prefetching is beneficial for the given CPU. + +2010-06-25 H.J. Lu + + PR rtl-optimization/44326 + * implicit-zee.c (find_removable_zero_extends): Replace + INSN_P with NONDEBUG_INSN_P. + +2010-06-25 Martin Jambor + + * ipa-prop.h (struct ipa_param_descriptor): Removed the modified flag. + (struct ipa_node_params): Removed the modification_analysis_done flag. + (ipa_is_param_modified): Removed. + (ipa_analyze_node): Declare. + (ipa_compute_jump_functions): Remove declaration. + (ipa_count_arguments): Likewise. + (ipa_detect_param_modifications): Likewise. + (ipa_analyze_params_uses): Likewise. + * ipa-prop.c (struct param_analysis_info): New type. + (visit_store_addr_for_mod_analysis): Removed. + (visit_load_for_mod_analysis): Renamed to visit_ref_for_mod_analysis, + moved down in the file. + (ipa_detect_param_modifications): Merged into ipa_analyze_params_uses. + (ipa_count_arguments): Made static. + (mark_modified): New function. + (is_parm_modified_before_call): New function. + (compute_pass_through_member_ptrs): New parameter parms_info, call + is_parm_modified_before_call instead of ipa_is_param_modified. + (ipa_compute_jump_functions_for_edge): New parameter parms_info, pass + it to compute_pass_through_member_ptrs. + (ipa_compute_jump_functions): New parameter parms_info, pass it to + ipa_compute_jump_functions_for_edge. Call ipa_initialize_node_params + on the callee if it is analyzed. Made static. + (ipa_analyze_indirect_call_uses): New parameter parms_info, call + is_parm_modified_before_call instead of ipa_is_param_modified. + (ipa_analyze_call_uses): New parameter parms_info, pass it to + ipa_analyze_indirect_call_uses. + (ipa_analyze_stmt_uses): New parameter parms_info, pass it to + ipa_analyze_call_uses. + (ipa_analyze_params_uses): New parameter parms_info, pass it to + ipa_analyze_stmt_uses. Also perform the used analysis. Made static. + (ipa_analyze_node): New function. + (ipa_print_node_params): Do not dump the modified flag. + (ipa_write_node_info): Assert uses_analysis_done rather than streaming + it. Do not stream the modified parameter flag. + (ipa_read_node_info): Set uses_analysis_done to 1 instead of streaming + it. Do not stream the modified parameter flag. + * ipa-cp.c (ipcp_analyze_node): Removed. + (ipcp_init_stage): Iterate only once over the nodes, analyze each one + with only a call to ipa_analyze_node. + * ipa-inline.c (inline_indirect_intraprocedural_analysis): Analyze the + node with only a call to ipa_analyze_node. + +2010-06-25 Manuel López-Ibáñez + + * doc/invoke.texi (-Wsuggest-attribute): Add item for noreturn. + +2010-06-25 Jan Hubicka + + * tree-pass.h (pass_split_functions): Declare. + * opts.c (decode_options): Enable function splitting at -O2 + * timevar.def (TV_IPA_FNSPLIT): New macro. + * ipa-split.c: New file. + * common.opt (-fpartial-inlining): New flag. + * Makefile.in (ipa-split.o): New object file. + * passes.c (init_optimization_passes): Add ipa-split. + * params.def (partial-inlining-entry-probability): New parameters. + * doc/invoke.texi (-fpartial-inlining): New. + +2010-06-25 Manuel López-Ibáñez + + PR 44665 + * tree-inline.c (gimple_expand_calls_inline): Fix typo in comment. + * gimplify.c (is_gimple_reg_rhs_or_call): Likewise. + (gimplify_expr): Likewise. + +2010-06-25 Martin Jambor + + * ipa-prop.c (determine_cst_member_ptr): Ignore non-clobbering + statements instead of bailing out on them. + (ipa_analyze_indirect_call_uses): Do not require that loads from the + parameter are in the same BB as the condition. Update comments. + +2010-06-25 Jakub Jelinek + + PR middle-end/43866 + * tree-ssa-loop-unswitch.c (tree_may_unswitch_on): If stmt is always + true or always false, return NULL_TREE. + (tree_unswitch_single_loop): Optimize conditions even when reaching + max-unswitch-level parameter. If num > 0, optimize first all conditions + using entry checks, then do still reachable block discovery and consider + only conditions in still reachable basic blocks in the loop. + + PR tree-optimization/44539 + * tree-cfgcleanup.c (fixup_noreturn_call): Call update_stmt even when + the call doesn't have LHS, but has VDEF. + +2010-06-25 Joseph Myers + + * config/pa/pa.h (MODIFY_TARGET_NAME): Remove. + * doc/tm.texi (MODIFY_TARGET_NAME): Don't document. + * gcc.c (enum add_del, struct modify_target, modify_target): + Remove. + (process_command): Remove code conditional on MODIFY_TARGET_NAME. + * system.h (MODIFY_TARGET_NAME): Poison. + +2010-06-25 Alan Modra + + * doc/invoke.texi: Delete mcmodel=medium from powerpc options. + * config/rs6000/rs6000.h (enum rs6000_cmodel): Delete CMODEL_MEDIUM. + * config/rs6000/linux64.h (SUBSUBTARGET_OVERRIDE_OPTIONS): Set + CMODEL_LARGE as default. + * config/rs6000/rs6000.c (rs6000_handle_option): Remove mcmodel=medium. + (offsettable_ok_by_alignment): Delete. + (rs6000_emit_move): Remove mcmodel=medium optimization. + +2010-06-25 Bernd Schmidt + + With large parts from Jim Wilson: + PR target/43902 + * tree-pretty-print.c (dump_generic_node, op_code_prio): Add + WIDEN_MULT_PLUS_EXPR and WIDEN_MULT_MINUS_EXPR. + * optabs.c (optab_for_tree_code): Likewise. + (expand_widen_pattern_expr): Likewise. + * tree-ssa-math-opts.c (convert_mult_to_widen): New function, broken + out of execute_optimize_widening_mul. + (convert_plusminus_to_widen): New function. + (execute_optimize_widening_mul): Use the two new functions. + * expr.c (expand_expr_real_2): Add support for GIMPLE_TERNARY_RHS. + Remove code to generate widening multiply-accumulate. Add support + for WIDEN_MULT_PLUS_EXPR and WIDEN_MULT_MINUS_EXPR. + * gimple-pretty-print.c (dump_ternary_rhs): New function. + (dump_gimple_assign): Call it when appropriate. + * tree.def (WIDEN_MULT_PLUS_EXPR, WIDEN_MULT_MINUS_EXPR): New codes. + * cfgexpand.c (gimple_assign_rhs_to_tree): Likewise. + (expand_gimple_stmt_1): Likewise. + (expand_debug_expr): Support WIDEN_MULT_PLUS_EXPR and + WIDEN_MULT_MINUS_EXPR. + * tree-ssa-operands.c (get_expr_operands): Likewise. + * tree-inline.c (estimate_operator_cost): Likewise. + * gimple.c (extract_ops_from_tree_1): Renamed from + extract_ops_from_tree. Add new arg for a third operand; fill it. + (gimple_build_assign_stat): Support operations with three operands. + (gimple_build_assign_with_ops_stat): Likewise. + (gimple_assign_set_rhs_from_tree): Likewise. + (gimple_assign_set_rhs_with_ops_1): Renamed from + gimple_assign_set_rhs_with_ops. Add new arg for a third operand. + (get_gimple_rhs_num_ops): Support GIMPLE_TERNARY_RHS. + (get_gimple_rhs_num_ops): Handle WIDEN_MULT_PLUS_EXPR and + WIDEN_MULT_MINUS_EXPR. + * gimple.h (enum gimple_rhs_class): Add GIMPLE_TERNARY_RHS. + (extract_ops_from_tree_1): Adjust declaration. + (gimple_assign_set_rhs_with_ops_1): Likewise. + (gimple_build_assign_with_ops): Pass NULL for last operand. + (gimple_build_assign_with_ops3): New macro. + (gimple_assign_rhs3, gimple_assign_rhs3_ptr, gimple_assign_set_rhs3, + gimple_assign_set_rhs_with_ops, extract_ops_from_tree): New inline + functions. + * tree-cfg.c (verify_gimple_assign_ternary): New static function. + (verify_gimple_assign): Call it. + * doc/gimple.texi (Manipulating operands): Document GIMPLE_TERNARY_RHS. + (Tuple specific accessors, subsection GIMPLE_ASSIGN): Document new + functions for dealing with three-operand statements. + * tree.c (commutative_ternary_tree_code): New function. + * tree.h (commutative_ternary_tree_code): Declare it. + * tree-vrp.c (gimple_assign_nonnegative_warnv_p): Return false for + ternary statements. + (gimple_assign_nonzero_warnv_p): Likewise. + * tree-ssa-sccvn.c (stmt_has_constants): Handle GIMPLE_TERNARY_RHS. + * tree-ssa-ccp.c (get_rhs_assign_op_for_ccp): New static function. + (ccp_fold): Use it. Handle GIMPLE_TERNARY_RHS. + * tree-ssa-dom.c (enum expr_kind): Add EXPR_TERNARY. + (struct hashtable_expr): New member ternary in the union. + (initialize_hash_element): Handle GIMPLE_TERNARY_RHS. + (hashable_expr_equal_p): Fix indentation. Handle EXPR_TERNARY. + (iterative_hash_hashable_expr): Likewise. + (print_expr_hash_elt): Handle EXPR_TERNARY. + * gimple-fold.c (fold_gimple_assign): Handle GIMPLE_TERNARY_RHS. + * tree-ssa-threadedge.c (fold_assignment_stmt): Remove useless break + statements. Handle GIMPLE_TERNARY_RHS. + +2010-06-25 Jan Hubicka + + * doc/invoke.texi (-Wsuggest-attribute): Add noreturn. + +2010-06-25 Shujing Zhao + + PR c/44517 + * c-parser.c (c_parser_parms_list_declarator): Return NULL if one of + parameters are not good. + (c_parser_parameter_declaration): Error unknown type name if the type + name can't start declaration specifiers. + +2010-06-25 Joseph Myers + + * gcc.c (translate_options): Don't mention +e in comment. + (process_command): Don't handle +e specially. + +2010-06-25 Bernd Schmidt + + * ira.c (allocno_pool, copy_pool, allocno_live_range_pool): Delete. + + * ira-build.c (merge_hard_reg_conflicts): New function. + (create_cap_allocno, copy_info_to_removed_store_destinations, + propagate_some_info_from_allocno, propagate_allocno_info): Use it. + (move_allocno_live_ranges, copy_allocno_live_ranges): New functions. + (remove_unnecessary_allocnos, remove_low_level_allocnos) + copy_nifo_to_removed_store_destination): Use them. + * ira-lives.c (make_hard_regno_born): New function, split out of + make_regno_born. + (make_allocno_born): Likewise. + (make_hard_regno_dead): New function, split out of make_regno_dead. + (make_allocno_dead): Likewise. + (inc_register_pressure): New function, split out of set_allocno_live. + (dec_register_pressure): New function, split out of clear_allocno_live. + (mark_pseudo_regno_live): New function, split out of mark_reg_live. + (mark_hard_reg_live): Likewise. Use inc_register_pressure. + (mark_pseudo_regno_dead): New function, split out of mark_reg_dead. + (mark_hard_reg_dead): Likewise. Use dec_register_pressure. + (make_pseudo_conflict): Use mark_pseudo_regno_dead and + mark_pseudo_regno_live. + (process_bb_node_lives): Use mark_pseudo_regno_live, + make_hard_regno_born and make_allocno_dead. + (make_regno_born, make_regno_dead, mark_reg_live, mark_reg_dead, + set_allocno_live, clear_allocno_live): Delete functions. + + * ira-int.h (ira_parent_allocno, ira_parent_or_cap_allocno): Declare. + * ira-build.c (ira_parent_allocno, ira_parent_or_cap_allocno): New + functions. + (ira_flattening): Use ira_parent_allocno. + * ira-conflicts.c (process_regs_for_copy, propagate_copies) + build_allocno_conflicts): Use ira_parent_or_cap_allocno. + + * ira-color.c (assign_hard_reg): Improve formatting of multi-line for + statement. + + * ira-int.h (SET_MINMAX_SET_BIT, CLEAR_MINMAX_SET_BIT, + TEST_MINMAX_SET_BIT, minmax_set_iterator, minmax_set_iter_init, + minmax_set_iter_cond, minmax_set_iter_next, + FOR_EACH_BIT_IN_MINMAX_SET): Renamed from SET_ALLOCNO_SET_BIT, + CLEAR_ALLOCNO_SET_BIT, TEST_ALLOCNO_SET_BIT, ira_allocno_set_iterator, + ira_allocno_set_iter_init, ira_allocno_set_iter_cond, + ira_allocno_set_iter_Next and FOR_EACH_ALLOCNO_IN_ALLOCNO_SET. All + uses changed. + + * ira-int.h (struct live_range, live_range_t): Renamed from struct + ira_allocno_live_range and allocno_live_range_t; all uses changed. + * ira-build.c (live_range_pool): Renamed from allocno_live_range_pool. + All uses changed. + +2010-06-24 Richard Earnshaw + + * thumb2.md (thumb2_tlobits_cbranch): Delete. + (peephole2 to convert zero_extract/compare of single bit to + lshift/compare): New. + +2010-06-24 Anatoly Sokolov + + * fold-const.c (const_binop): Remove 'notrunc' argement. Adjust + recursive call and call to 'int_const_binop'. + (build_range_check, fold_cond_expr_with_comparison, unextend, + fold_truthop, extract_muldiv_1, fold_comparison, fold_binary_loc, + multiple_of_p): Adjust call to const_binop. + +2010-06-24 Uros Bizjak + + * config/i386/i386.md (XFmode push splitter): Use GET_MODE_SIZE to + determine size of XFmode operand. + (XFmode extended DFmode push splitter): Ditto. + (XFmode extended SFmode push splitter): Ditto. + +2010-06-24 H.J. Lu + + PR target/44588 + * config/i386/i386.md (extract_code): New. + (divmodqi4): Likewise. + (divmodhiqi3): Likewise. + (udivmodhiqi3): Likewise. + (divqi3): Remvoved. + +2010-06-24 Jakub Jelinek + + PR middle-end/44492 + * recog.h (struct recog_data): Add is_asm field. + * recog.c (asm_operand_ok, constrain_operands): If neither < nor > is + present in constraints of inline-asm operand and memory operand + contains {PRE,POST}_{INC,DEC,MODIFY}, return 0. + (extract_insn): Initialize recog_data.is_asm. + * doc/md.texi (Constraints): Document operand side-effect rules. + +2010-06-24 Andi Kleen + + * c-parser.c (c_parser_conditional_expression): Call + warn_for_omitted_condop. + * doc/invoke.texi: Document omitted condop warning. + +2010-06-24 Nick Clifton + + * loop-unswitch.c (compare_and_jump_seq): Assert that the last + insn in the sequence is a jump insn before setting its label. + +2010-06-24 Alan Modra + + * collect2.c (main): Match exactly --version and --help. + +2010-06-24 DJ Delorie + + * config/m32c/m32c-pragma.c: Don't include rtl.h. + +2010-06-23 Uros Bizjak + + * config/i386/i386.md (mov): Macroize expander from mov{sf,df,xf} + using X87MODEF mode iterator. + (pushsf splitter): Macroize splitter using P mode iterator. + (*swap): Macroize insn from *swap{sf,df} using MODEF + mode iterator. + + (*movxf_internal): Rename from *movxf_integer. + (*movxf_internal_nointeger): Rename from *movxf_nointeger. + (*movdf_internal_rex64): Rename from *movdf_integer_rex64. + (*movdf_internal): Rename from *movdf_integer. + (*movdf_internal_nointeger): Rename from *movdf_nointeger. + (*movsf_internal): Rename from *movdf_1. + +2010-06-23 Basile Starynkevitch + + * coretypes.h: (gimple_seq_node_d, gimple_seq_node) + (const_gimple_seq_node): Removed typedefs. + + * gimple.h: (gimple_seq_node_d, gimple_seq_node) + (const_gimple_seq_node): Added typedefs moved from coretypes.h. + +2010-06-23 H.J. Lu + + * config/i386/i386.c (bdesc_args): Replace CODE_FOR_avx_si_si256, + CODE_FOR_avx_ps_ps256 and CODE_FOR_avx_pd_pd256 with + CODE_FOR_vec_extract_lo_v8si, CODE_FOR_vec_extract_lo_v8sf + and CODE_FOR_vec_extract_lo_v4df. + + * config/i386/sse.md (vec_extract_lo_): + Changed to define_insn_and_split. + (vec_extract_lo_): Likewise. + (vec_extract_lo_v16hi): Likewise. + (vec_extract_lo_v32qi): Likewise. + (avx__): Likewise. + (avx__): Removed. + +2010-06-23 Joern Rennecke + + PR target/44640 + * config/spu/spu-protos.h (spu_expand_epilogue) Use bool. + * config/spu/spu.c (spu_scalar_mode_supported_p): Declare with bool. + (spu_vector_mode_supported_p, spu_handle_fndecl_attribute): Likewise. + (spu_handle_vector_attribute, spu_pass_by_reference): Likewise. + (spu_rtx_costs, spu_function_ok_for_sibcall): Likewise. + + PR target/44640 + * config/spu/spu.c (ea_load_store_inline): Use add_reg_note. + + PR other/44644 + * df-core.c (struct df): Rename to df_d. + * df.h (struct df): Likewise. + * dse.h (struct df): Remove forward declaration. + * recog.h (struct insn_data): Rename to: + (struct_insn_data_d). Adjusted all users. + +2010-06-23 Arnaud Charlet + + * config/m68k/m68k.c (m68k_output_addr_const_extra): Add cast to + enum type. + (m68k_sched_attr_opx_type): Remove unreachable return. + (m68k_sched_attr_opy_type): Likewise. + (m68k_sched_attr_size): Likewise. + (sched_get_opxy_mem_type): Likewise. + (m68k_sched_attr_op_mem): Likewise. + +2010-06-22 Eric Botcazou + + * cgraphunit.c (cgraph_redirect_edge_call_stmt_to_callee): Chain the + new statement and adjust VDEF only if necessary. Remove superfluous + call to maybe_clean_or_replace_eh_stmt. + * gimple.c (gimple_call_copy_skip_args): Use gimple_call_copy_flags to + copy the flags. + * gimple-iterator.c (gsi_replace): Clear BB of old statement here... + * tree-inline.c (copy_bb): ...and not there. + +2010-06-22 Cary Coutant + + * dwarf2out.c (is_nested_in_subprogram): New function. + (should_move_die_to_comdat): Use it. + (copy_ancestor_tree): Don't mark DIEs here. + (copy_decls_walk): Start walk from root of newly-added tree; + mark DIEs here instead. + +2010-06-22 H.J. Lu + + * config/i386/i386.md (unit): Also check sseishft1. + +2010-06-22 Jan Hubicka + + * gimple.h (gimple_expr_code): Do checking on when gimple checking is + enabled. + +2010-06-22 Jan Hubicka + + * df-problems.c (df_rd_confluence_n, df_lr_confluence_n, + df_live_confluence_n, df_byte_lr_confluence_n, df_md_confluence_n): + Return true if something changed. + * df.h (df_confluence_function_n): Return bool. + * df-core.c (df_worklist_propagate_forward, + df_worklist_propagate_backward): Track changes and ages. + (df_worklist_dataflow_doublequeue): Use bitmap iterator for main walk; + track ages. + * dse.c (dse_confluence_n): Return always true. + +2010-06-22 Jan Hubicka + + * bitmap.c (bitmap_clear_bit): Micro optimize. + +2010-06-22 Uros Bizjak + + * config/i386/i386.md (SWI1248x): New mode iterator. + (SWI48x): Ditto. + (SWI12): Ditto. + (SWI24): Ditto. + + (mov): Macroize expander from mov{qi,hi,si,di} using + SWI1248x mode iterator. + (*push2_rex64): Macroize insn from *push{qi,hi,si}_rex64 + using SWI124 mode iterator. + (*push2): Macroize insn from *push{qi,hi} using SWI12 + mode iterator. + (*push2_prologue): Macroize insn from *pushsi2_prologue and + *pushdi2_prologue_rex64 using P mode iterator. + (*mov_xor): Macroize insn from *movsi_xor and *movdi_xor_rex64 + using SWI48 mode iterator. + (*mov_or): Ditto from *movsi_or and *movdi_or_rex64. + (*movabs_1): Macroize insn from *movabs{qi,hi,si,di}_1_rex64 + using SWI1248x mode iterator. + (*movabs_2): Ditto from *movabs{qi,hi,si,di}_1_rex64. + (*swap): Macroize insn from *swapsi and *swapdi_rex64 using + SWI48 mode iterator. + (*swap_1): Macroize insn from *swap{qi,hi}_1 using SWI12 mode + iterator. + (*swap_2): Ditto from *swap{qi,hi}_2. + (movstrict): Macroize expander from movstrict{qi,hi} using + SWI12 mode iterator. + (*movstrict_1): Macroize insn from *movstrict{qi,hi}_1 using + SWI12 mode iterator. + (*movstrict_xor): Ditto from *movstrict{qi,hi}_xor. + (*mov_extv_1): Macroize insn from *mov{hi,si}_extv_1 using + SWI24 mode iterator. + (*mov_extzv_1): Macroize insn from *mov{si,di}_extzv_1 using + SWI48 mode iterator. + (mov_insn_1): New expander. + (*mov_insv_1_rex64): Macroize insn from *mov{si,di}_insv_1_rex64 + using SWI48x mode iterator. + + (*movoi_internal_avx): Rename from *movoi_internal. + (*movti_internal_rex64): Rename from *movti_rex64. + (*movti_internal_sse): Rename from *movti_sse. + (*movdi_internal_rex64): Rename from *movdi_1_rex64. + (*movdi_internal): Rename from *movdi_2. + (*movsi_internal): Rename from *movsi_1. + (*movhi_internal): Rename from *movhi_1. + (*movqi_internal): Rename from *movqi_1. + + (insv): Update the call to gen_movsi_insv_1 for rename. + * config/i386/i386.c (promote_duplicated_reg): Ditto. + +2010-06-22 Jan Hubicka + + * passes.c (execute_function_todo): Move call of statistics_fini_pass + to ... + (execute_todo) ... this one. + +2010-06-22 Alan Modra + + PR target/44364 + * config/rs6000/e500.h (HARD_REGNO_CALLER_SAVE_MODE): Define. + * caller-save.c (insert_restore, insert_save): Use non-validate + form of adjust_address. + +2010-06-21 John David Anglin + + PR target/39690 + * config/pa/pa.c (override_options): Disable + -freorder-blocks-and-partition. + +2010-06-21 H.J. Lu + + PR target/44615 + * config/i386/atom.md (atom_sseishft_2): Also check sseishft1. + + * config/i386/i386.md (type): Add sseishft1 + + * config/i386/ppro_insn (ppro_insn): Also check sseishft1. + (ppro_insn_load): Likewise. + (ppro_insn_store): Likewise. + (ppro_insn_both): Likewise. + + * config/i386/sse.md (sse2_lshrv1ti3): Add atom_unit. + (*vec_extractv2di_1_rex64_avx): Replace sseishft with sseishft1 + for type. + (*vec_extractv2di_1_avx): Likewise. + (*vec_extractv2di_1_rex64): Replace sseishft with sseishft1 for + type. Remove atom_unit. + (*vec_extractv2di_1_sse2): Likewise. + +2010-06-21 DJ Delorie + + * diagnostic.h (diagnostic_classification_change_t): New. + (diagnostic_context): Add history and push/pop list. + (diagnostic_push_diagnostics): Declare. + (diagnostic_pop_diagnostics): Declare. + * diagnostic.c (diagnostic_classify_diagnostic): Store changes + from pragmas in a history chain instead of the global table. + (diagnostic_push_diagnostics): New. + (diagnostic_pop_diagnostics): New. + (diagnostic_report_diagnostic): Scan history chain to find state + of diagnostics as of the diagnostic location. + * opts.c (set_option): Pass UNKNOWN_LOCATION to + diagnostic_classify_diagnostic. + (enable_warning_as_error): Likewise. + * diagnostic-core.h (DK_POP): Add after "real" diagnostics, for + use in the history chain. + * c-family/c-pragma.c (handle_pragma_diagnostic): Add push/pop, + allow these pragmas anywhere. + * doc/extend.texi: Document pragma GCC diagnostic changes. + +2010-06-21 Jakub Jelinek + + * dwarf2out.c (add_linkage_name): New function. Don't add + anything to DW_TAG_member DIEs. + (add_name_and_src_coords_attributes): Use it. + (gen_variable_die): Call it for C++ static data members if + specification is DW_TAG_member. + + * dwarf2out.c (base_type_die): Use DW_ATE_UTF for + C++ char16_t and char32_t. + + * Makefile.in (build/genattrtab.o): Depend on vecprim.h. + * genattrtab.c: Include vecprim.h. + (cached_attrs, cached_attr_count, attrs_seen_once, + attrs_seen_more_than_once, attrs_to_cache, attrs_cached_inside, + attrs_cached_after): New variables. + (find_attrs_to_cache): New function. + (FLG_BITWISE, FLG_AFTER, FLG_INSIDE, FLG_OUTSIDE_AND): Define. + (write_test_expr): Add attrs_cached argument, return it too, + attempt to cache non-const attributes used more than once in + a single case handling. + (write_attr_get): Use find_attrs_to_cache, for caching candidates + emit cached_* variables. Adjust write_attr_set callers. + (write_attr_set): Add attrs_cached attribute, use find_attrs_to_cache + to find attributes that should be cached in this block. Adjust + write_test_expr callers. + (write_attr_case): Clear attrs_to_cache. Adjust write_attr_set + callers. + (make_automaton_attrs): Adjust write_test_expr caller. + + * Makefile.in (cfgexpand.o): Depend on $(INSN_ATTR_H). + * genattrtab.c (check_tune_attr, find_tune_attr): New functions. + (make_automaton_attrs): If find_tune_attr returns non-NULL, + write separate internal_dfa_insn_code_* and insn_default_latency_* + functions for each attribute's value and emit init_sched_attrs + function and function pointers. + * genattr.c (const_attrs, reservations): New variables. + (gen_attr): Add const attributes to const_attrs vector. + (check_tune_attr, find_tune_attr): New functions. + (main): Add reservations to reservations vector. If find_tune_attr + returns true, add prototype for init_sched_attrs and make + internal_dfa_insn_code and insn_default_latency function pointers, + otherwise define init_sched_attrs as dummy macro. + * cfgexpand.c: Include insn-attr.h. + (gimple_expand_cfg): Call init_sched_attrs. + + * stmt.c (resolve_asm_operand_names): Fix handling of %%. + + PR target/44575 + * config/i386/i386.c (ix86_gimplify_va_arg): When copying + va_arg from a set of register save slots into a temporary, + if the container is bigger than type size, do the copying + using smaller mode or using memcpy. + + PR bootstrap/44426 + * sel-sched-dump.h (sel_prepare_string_for_dot_label): Remove + prototype. + (sel_print_to_dot): Remove macro. + (sel_print): Likewise. New prototype. + * sel-sched-dump.c (sel_prepare_string_for_dot_label): Make static. + (sel_print): New function. + +2010-06-21 Rainer Orth + + * config/sol2.h (TARGET_OS_CPP_BUILTINS): Define + __STDC_VERSION__=199901L, _XOPEN_SOURCE=600 for C++. + +2010-06-21 Nick Clifton + + * config/rx/rx.h (PTRDIFF_TYPE): Define. + (SMALL_REGISTER_CLASS): Define (to zero). + (PRINT_OPERAND): Delete. + (PRINT_OPERAND_ADDRESS): Delete. + * config/rx/rx-protos.h (rx_print_operand): Delete prototype. + (rx_print_operand_address): Delete prototype. + * config/rx/rx.c (rx_print_operand): Make static. + Allow %H and %L to handle CONST_DOUBLEs. + (rx_print_operand_address): Make static. + (rx_gen_move_template): Rename local variable 'template' to + out_template. + (rx_function_arg): Do not pass unknown sized objects in registers. + (TARGET_PRINT_OPERAND): Define. + (TARGET_PRINT_OPERAND_ADDRESS): Define. + +2010-06-21 Jan Kratochvil + + * Makefile.in (POD2MAN): Provide --date from $(DATESTAMP). + +2010-06-21 Kai Tietz + + * config/i386/i386.c (ix86_compute_frame_layout): Avoid + stack-alignment for simple leaf-functions. + +2010-06-20 Alexandre Oliva + + * doc/install.texi: Document bootstrap-lto. + +2010-06-20 Alexandre Oliva + + PR debug/44248 + * lto-streamer-in.c (input_bb): Leave debug stmts alone. + (input_function): Drop them here, if VTA is disabled. + +2010-06-20 Uros Bizjak + + PR target/44546 + * config/i386/predicates.md (ix86_swapped_fp_comparsion_operator): + New predicate. + * config/i386/i386.md (*fp_jcc_8_387 and splitters): Use + ix86_swapped_fp_comparsion_operator instead of + ix86_fp_comparison_operator. + + (*fp_jcc_1_387): Rename from *fp_jcc_3_387. + (*fp_jcc_1r_387): Rename from *fp_jcc_4_387. + (*fp_jcc_2_387): Rename from *fp_jcc_5_387. + (*fp_jcc_2r_387): Rename from *fp_jcc_6_387. + (*fp_jcc_3_387): Rename from *fp_jcc_7_387. + (*fp_jcc_4__387): Rename from *fp_jcc_8_387. + +2010-06-20 Joseph Myers + + PR other/32998 + * opth-gen.awk: Generate definitions of OPT_SPECIAL_unknown, + OPT_SPECIAL_program_name and OPT_SPECIAL_input_file. + * opts-common.c (find_opt): Return OPT_SPECIAL_unknown on failure. + (decode_cmdline_option): Update for this return value. Set + orig_option_with_args_text field. Set arg field for unknown + options. Make static. + (decode_cmdline_options_to_array): New. + (prune_options): Update handling of find_opt return value. + * opts.c (read_cmdline_option): Take decoded option. Return void. + (read_cmdline_options): Take decoded options. + (decode_options): Add parameters for decoded options. Use + decode_cmdline_options_to_array. Use decoded options for -O + scan. Use integral_argument for -O parameters. Update call to + read_cmdline_options. + (enable_warning_as_error): Update handling of find_opt return value. + * opts.h: Update comment on unknown options. + (struct cl_decoded_option): Update comments on opt_index and arg. + Add orig_option_with_args_text. + (decode_cmdline_option): Remove. + (decode_cmdline_options_to_array): Declare. + (decode_options): Update prototype. + * toplev.c (save_argv): Remove. + (save_decoded_options, save_decoded_options_count): New. + (read_integral_parameter): Remove. + (print_switch_values): Use decoded options. + (toplev_main): Don't set save_argv. Update call to decode_options. + * toplev.h (read_integral_parameter): Remove. + * varasm.c (elf_record_gcc_switches): Don't handle holding back names. + +2010-06-19 Richard Earnshaw + + PR target/44072 + * arm.md (cmpsi2_addneg): Prefer emitting adds to subs with a negative + immediate. + * constraints.md (Pw, Px): New constraints. + * thumb2.md (cmpsi2_addneg peephole2): New peepholes. + +2010-06-19 H.J. Lu + + * config/i386/sse.md (fma4modesuffixf4): Removed. + (ssemodesuffixf2s): Likewise. + (ssemodesuffixf4): Likewise. + (ssemodesuffixf2c): Likewise. + (ssescalarmodesuffix2s): Likewise. + (avxmodesuffixf2c): Likewise. + (ssemodesuffix): New. + (ssescalarmodesuffix): Likewise. + Update patterns with ssemodesuffix and ssescalarmodesuffix. + +2010-06-19 Philip Herron + + * c-decl.c (c_write_global_declarations): Don't check flag_syntax_only. + +2010-06-18 H.J. Lu + + * stor-layout.c (debug_rli): Remove unused local variables. + +2010-06-18 Eric Botcazou + + PR rtl-optimization/40900 + * expr.c (expand_expr_real_1) : Fix long line. Save the + original expression for later reuse. + : Use promote_function_mode to compute the signedness + of the promoted RTL for a SSA_NAME on the LHS of a call statement. + +2010-06-18 Anatoly Sokolov + + * double-int.h (double_int_to_shwi, double_int_to_uhwi, + double_int_fits_in_uhwi_p): Implement as static inline. + (double_int_xor): New inline function. + (double_int_lrotate, double_int_rrotate, double_int_max, + double_int_umax, double_int_smax, double_int_min, double_int_umin, + double_int_smin): Declare. + (lrotate_double, rrotate_double): Remove declaration. + * double-int.c (double_int_fits_in_uhwi_p, double_int_to_shwi, + double_int_to_uhwi, lrotate_double, rrotate_double): Remove function. + (double_int_lrotate, double_int_rrotate, double_int_max, + double_int_umax, double_int_smax, double_int_min, double_int_umin, + double_int_smin): New function. + * fold-const.c (int_const_binop): Clean up, use double_int_* + functions. + * simplify-rtx.c (simplify_const_binary_operation): Clean up, use + double_int_* and immed_double_int_const functions. + +2010-06-18 Nathan Froyd + + * function.h (types_used_by_cur_var_decl): Change type to a VEC. + * function.c (types_used_by_cur_var_decl): Likewise. + (used_types_insert): Adjust for new type of types_used_by_cur_var_decl. + +2010-06-18 Nathan Froyd + + * tree.h (record_layout_info): Change type of pending_statics field + to a VEC. + * stor-layout.c (start_record_layout): Store NULL into + pending_statics. + (debug_rli): Call debug_vec_tree instead of debug_tree. + (place_field): Likewise. + (finish_record_layout): Likewise. + +2010-06-18 Alan Modra + + * config/rs6000/linux64.h (SET_CMODEL): Don't expand to empty. + +2010-06-17 John David Anglin + + PR target/43740 + * config/pa/pa.c (emit_move_sequence): Don't infer REG_POINTER flag + for SET source operand from SET destination operand. + +2010-06-17 Bernd Schmidt + + PR rtl-optimization/39871 + * reload1.c (init_eliminable_invariants): For flag_pic, disable + equivalences only for constants that aren't LEGITIMATE_PIC_OPERAND_P. + (function_invariant_p): Rule out a plus of frame or arg pointer with + a SYMBOL_REF. + * ira.c (find_reg_equiv_invariant_const): Likewise. + +2010-06-17 Gunther Nikl + + * config/rs6000/rs6000.c (print_operand) <'K'>: Also use + print_operand_address and puts to output the operand for CONST. + +2010-06-17 Jakub Jelinek + + PR debug/44572 + * dwarf2out.c (dwarf2out_debug_hooks): Add entry for begin_epilogue + hook. + +2010-06-17 Nathan Froyd + + * v850-protos.h (print_operand): Delete. + (print_operand_address): Delete. + * v850.h (PRINT_OPERAND): Delete. + (PRINT_OPERAND_PUNCT_VALID_P): Delete. + (PRINT_OPERAND_ADDRESS): Delete. + * v850.c (print_operand_address): Rename to... + (v850_print_operand_address): ...this. Make static. Call + v850_print_operand. + (print_operand): Rename to... + (v850_print_operand): ...this. Make static. Call + v850_print_operand_address. + (v850_print_operand_punct_valid_p): New function. + (TARGET_PRINT_OPERAND, TARGET_PRINT_OPERAND_ADDRESS): Define. + (TARGET_PRINT_OPERAND_PUNCT_VALID_P): Define. + +2010-06-17 Nathan Froyd + + * config/sh/sh-protos.h (print_operand): Delete. + (print_operand_address): Delete. + * config/sh/sh.h (PRINT_OPERAND): Delete. + (PRINT_OPERAND_PUNCT_VALID_P): Delete. + (PRINT_OPERAND_ADDRESS): Delete. + * config/sh/sh.c (sh_print_operand_address): Make static. + (sh_print_operand): Make static. Call sh_print_operand_address + and sh_print_operand. + (sh_print_operand_punct_valid_p): New function. + (TARGET_PRINT_OPERAND, TARGET_PRINT_OPERAND_ADDRESS): Define. + (TARGET_PRINT_OPERAND_PUNCT_VALID_P): Define. + +2010-06-17 Nathan Froyd + + * config/mcore/mcore-protos.h (mcore_print_operand): Delete. + (mcore_print_operand_address): Delete. + * config/mcore/mcore.h (PRINT_OPERAND): Delete. + (PRINT_OPERAND_PUNCT_VALID_P): Delete. + (PRINT_OPERAND_ADDRESS): Delete. + * config/mcore/mcore.c (mcore_print_operand_address): Make static. + (mcore_print_operand): Make static. + (mcore_print_operand_punct_valid_p): New function. + (TARGET_PRINT_OPERAND, TARGET_PRINT_OPERAND_ADDRESS): Define + (TARGET_PRINT_OPERAND_PUNCT_VALID_P): Define. + +2010-06-17 Nathan Froyd + + * config/m68hc11/m68hc11-protos.h (print_operand): Delete. + (print_operand_address): Delete. + * config/m68hc11/m68hc11.h (PRINT_OPERAND): Delete. + (PRINT_OPERAND_ADDRESS): Delete. + * config/m68hc11/m68hc11.c (m68hc11_print_operand_address): Make + static. + (m68hc11_print_operand): Make static. + (TARGET_PRINT_OPERAND, TARGET_PRINT_OPERAND_ADDRESS): Define. + +2010-06-17 Nathan Froyd + + * config/m32r/m32r-protos.h (m32r_print_operand): Delete. + (m32r_print_operand_address): Delete. + * config/m32r/m32r.h (m32r_punct_chars): Delete. + (PRINT_OPERAND): Delete. + (PRINT_OPERAND_PUNCT_VALID_P): Delete. + (PRINT_OPERAND_ADDRESS): Delete. + * config/m32r/m32r.c (m32r_punct_chars): Make static. + (m32r_print_operand_address): Make static. + (m32r_print_operand): Make static. + (m32r_print_operand_punct_valid_p): New function. + (TARGET_PRINT_OPERAND, TARGET_PRINT_OPERAND_ADDRESS): + (TARGET_PRINT_OPERAND_ADDRESS): Define. + +2010-06-17 Nathan Froyd + + * config/iq2000/iq2000-protos.h (print_operand): Delete. + (print_operand_address): Delete. + * config/iq2000/iq2000.h (PRINT_OPERAND): Delete. + (PRINT_OPERAND_PUNCT_VALID_P): Delete. + (PRINT_OPERAND_ADDRESS): Delete. + (iq2000_print_operand_punct): Delete. + * config/iq2000/iq2000.c (iq2000_print_operand_punct): Make static. + (iq2000_print_operand_address): Make static. + (iq2000_print_operand): Make static. + (iq2000_print_operand_punct_valid_p): New function. + (TARGET_PRINT_OPERAND, TARGET_PRINT_OPERAND_ADDRESS): + (TARGET_PRINT_OPERAND_ADDRESS): Define. + +2010-06-17 Nathan Froyd + + * config/frv/frv-protos.h (frv_print_operand): Delete. + (frv_print_operand_address): Delete. + * config/frv/frv.h (PRINT_OPERAND): Delete. + (PRINT_OPERAND_PUNCT_VALID_P): Delete. + (PRINT_OPERAND_ADDRESS): Delete. + * config/frv/frv.c (frv_print_operand_address): Make static. + (frv_print_operand): Make static. + (frv_print_operand_punct_valid_p): New function. + (TARGET_PRINT_OPERAND, TARGET_PRINT_OPERAND_ADDRESS): + (TARGET_PRINT_OPERAND_ADDRESS): Define. + +2010-06-17 Nathan Froyd + + * tree.h (vec_member): Declare. + * tree.c (vec_member): Define. + +2010-06-17 Richard Guenther + + * tree-flow-inline.h (array_ref_contains_indirect_ref): Remove. + * tree-flow.h (array_ref_contains_indirect_ref): Likewise. + +2010-06-17 Richard Guenther + + * tree-inline.c (declare_return_variable): Remove bogus code. + +2010-06-17 Richard Guenther + + * gimplify.c (gimplify_bind_expr): Always promote complex + and vector variables to registers if possible. + +2010-06-17 Richard Guenther + + * expr.c (get_inner_reference): Use double_int for bit_offset + calculation. + +2010-06-16 DJ Delorie + + * common.opt (-fstrict-volatile-bitfields): new. + * doc/invoke.texi: Document it. + * fold-const.c (optimize_bit_field_compare): For volatile + bitfields, use the field's type to determine the mode, not the + field's size. + * expr.c (expand_assignment): Likewise. + (get_inner_reference): Likewise. + (expand_expr_real_1): Likewise. + * expmed.c (store_fixed_bit_field): Likewise. + (extract_bit_field_1): Likewise. + (extract_fixed_bit_field): Likewise. + +2010-06-16 Richard Guenther + + * tree-inline.c (remap_gimple_op_r): Recurse using remap_gimple_op_r. + +2010-06-16 Douglas B Rupp + + * config/ia64/vms.h (ASM_OUTPUT_DWARF_DELTA_UNITS): Remove. + (ASM_OUTPUT_DWARF_VMS_DELTA: Define new macro. + * dbxout.c (gcc_debug_hooks): New entry begin_epilogue. + * debug.c: Likewise. + * sdbout.c: Likewise. + * vmsdbgout.c: Likewise. + * debug.h: Likewise. (dwarf2out_vms_{begin,end}_prologue): Declare. + * doc/tm.texi (ASM_OUTPUT_DWARF_VMS_DELTA): Document. + * dwarf2asm.c (dw2_asm_output_vms_delta): New function. + (ASM_OUTPUT_DWARF_VMS_DELTA): Call it. + * dwarf2asm.h (dw2_asm_output_vms_delta): Declare. + * dwarf2out.c (dw_fde_struct): New fields + dw_fde_vms_{end,begin}_prologue. + (PROLOGUE_END_LABEL, EPILOGUE_BEGIN_LABEL): New macros. + (dwarf2out_begin_prologue): Set dw_fde_struct defaults for above. + (dwarf2out_vms_end_prologue): New function. + (dwarf2out_vms_begin_epilogue): New function. + (dw_val_struct): New value dw_val_class_vms_delta. + (gcc_debug_hooks): New entry begin_epilogue. Set end_prologue, + begin_epilogue for VMS. + (AT_vms_delta1, AT_vms_delta2, add_AT_vms_delta): Declare + new static functions. + (dwarf_attr_name): New cases DW_AT_HP_{prologue,epilogue}. + (AT_vms_delta1, AT_vms_delta2, add_AT_vms_delta): New + static functions. + (print_die): New case dw_val_class_vms_delta. + (attr_checksum): Likewise. + (same_dw_val_p: Likewise. + (size_of_die): Likewise. + (value_format): Likewise. + (output_die): Likewise. + (gen_subprogram_die): Call add_AT_vms_delta on VMS. + (dwarf2out_begin_epilogue): Rename to dwarf2out_cfi_begin_epilogue + * dwarf2out.h (dwarf2out_begin_epilogue): Rename to + dwarf2out_cfi_begin_epilogue + * final.c (final_scan_insn): Likewise. Call begin_epilogue. + +2010-06-16 Nathan Froyd + + * config/cris/cris-protos.h (cris_print_operand): Delete. + (cris_print_operand_address): Delete. + * config/cris/cris.h (PRINT_OPERAND): Delete. + (PRINT_OPERAND_PUNCT_VALID_P): Delete. + (PRINT_OPERAND_ADDRESS): Delete. + * config/cris/cris.c (cris_print_operand_address): Make static. + (cris_print_operand): Make static. + (cris_print_operand_punct_valid_p): New function. + (TARGET_PRINT_OPERAND, TARGET_PRINT_OPERAND_ADDRESS): + (TARGET_PRINT_OPERAND_ADDRESS): Define. + +2010-06-16 Nathan Froyd + + * config/arm/arm-protos.h (arm_print_operand): Delete. + (arm_print_operand_address): Delete. + * config/arm/arm.h (PRINT_OPERAND): Delete. + (PRINT_OPERAND_PUNCT_VALID_P): Delete. + (PRINT_OPERAND_ADDRESS, ARM_PRINT_OPERAND_ADDRESS): + (THUMB_PRINT_OPERAND_ADDRESS): Delete and move code to... + * config/arm/arm.c (arm_print_operand_address): ...here. New function. + (arm_print_operand): Make static. + (arm_print_operand_punct_valid_p): New function. + (TARGET_PRINT_OPERAND, TARGET_PRINT_OPERAND_ADDRESS): + (TARGET_PRINT_OPERAND_ADDRESS): Define. + +2010-06-16 Nick Clifton + + * config/rx/constraints.md (NEGint4): New constraint. + * config/rx/rx.md (attr cc): Add set_zsc. + (cbranchsf4): Only test for -fnon-call-exceptions if cfun has been + initialised. + (cmpsf): Likewise. + (call_internal): Clobber the cc0 register. + (call_value_internal): Likewise. + (cstoresi4): Likewise. + (movsieq): Likewise. + (movsine): Likewise. + (addsi3): Add alternative to handle small negative constants. + (sunsi3): Likewise. + (addsi3): Do not set the O bit in the cc0 register. + (adddi3): Likewise. + (subsi3): Likewise. + (subdi3): Likewise. + (andsi3): Reorder alternatives to prefer shorter forms. + (mulsi3): Likewise. + (iorsi3): Likewise. + (negsi2): Note that the cc0 flags are set. + (rotlsi3): Note that only the Z and S bits are set in cc0. + (lshrsi3): Likewise. + (ashlsi3): Likewise. + (subsf3): Use %Q for the MEM operand. + (fix_truncsfsi2): Likewise. + (floatsisf2): Likewise. + (bitset): Remove early clobber from destination. + (bitset_in_memory): Likewise. + (lrintsf2): Clobber the cc0 register. + * config/rx/rx.c (rx_notice_update_cc): Handle CC_SET_ZSC. + (rx_print_operand): Handle %N. + +2010-06-16 Jan Hubicka + + * df-core.c (df_compact_blocks): Free problem_temps vector. + +2010-06-16 Martin Jambor + + PR tree-optimization/43905 + * tree-sra.c: Include tree-inline.h. + (create_abstract_origin): Removed. + (modify_function): Version the call graph node instead of creating + abstract origins and dealing with same_body aliases. + * tree-sra.c (ipa_sra_preliminary_function_checks): Check whether the + function is versionable. + * Makefile.in (tree-sra.o): Add TREE_INLINE_H to dependencies. + +2010-06-16 Maxim Kuvyrkov + + * config/mips/linux64.h (BIONIC_DYNAMIC_LINKERN32): Define. + (CHOOSE_DYNAMIC_LINKER): Update. + +2010-06-15 Uros Bizjak + + * config/i386/i386.c (*prefetch_sse_): Macroize insn from + *prefetch_sse and *prefetch_sse_rex using P mode iterator. + (*prefetch_3dnow_): Ditto from *prefetch_3dnow and + *prefetch_3dnow_rex. + +2010-06-15 Anatoly Sokolov + + * target.h (struct asm_out):Add declare_constant_name field. + * target-def.h (TARGET_ASM_DECLARE_CONSTANT_NAME): Define. + (TARGET_INITIALIZER): Use TARGET_ASM_DECLARE_CONSTANT_NAME. + * output.h (default_asm_declare_constant_name): Declare. + (assemble_label): Update prototype. + * varasm.c (assemble_constant_contents): Use + targetm.asm_out.declare_constant_name target hook. + (assemble_label): Add 'file' argument. + (default_asm_declare_constant_name): New function. + * system.h (ASM_DECLARE_CONSTANT_NAME): Poison. + * doc/tm.texi (ASM_DECLARE_CONSTANT_NAME): Remove. + (TARGET_ASM_DECLARE_CONSTANT_NAME): Document it. + + * config/darwin-protos.h (darwin_asm_declare_constant_name): Declare. + * config/darwin.c (darwin_asm_declare_constant_name): New function. + (machopic_output_indirection): Update assemble_label argument list. + * config/darwin.h (ASM_DECLARE_CONSTANT_NAME): Remove. + (TARGET_ASM_DECLARE_CONSTANT_NAME): Define. + +2010-06-15 Sebastian Pop + + PR middle-end/44391 + * graphite-clast-to-gimple.c (graphite_create_new_loop_guard): Use + size_one_node for pointer types. Do not call gmp_cst_to_tree. + +2010-06-15 Richard Guenther + + * tree-ssa-pre.c (eliminate): Handle PHI elimination to constants. + +2010-06-15 Paul Brook + + * config/arm/arm.c (use_vfp_abi): Add sorry() for Thumb-1 + hard-float ABI. + +2010-06-15 Alexandre Oliva + + * tree-vect-patterns.c (vect_pattern_recog_1): Bail out if we + don't get a vector type for output. + +2010-06-15 Jakub Jelinek + + PR fortran/44536 + * langhooks.h (struct lang_hooks_for_decls): Add omp_report_decl. + * langhooks-def.h (LANG_HOOKS_OMP_REPORT_DECL): Define. + (LANG_HOOKS_DECLS): Add it. + * gimplify.c (omp_notice_variable): Call + lang_hooks.decls.omp_report_decl. + +2010-06-15 Martin Jambor + + PR lto/44464 + * tree-sra.c (replace_removed_params_ssa_names): Call release_ssa_name + on the newly dead SSA name. + +2010-06-15 Alan Modra + + * doc/invoke.texi: Add mcmodel to powerpc options. + * configure.ac: Add HAVE_LD_LARGE_TOC test. + * configure: Regenerate. + * config.in: Regenerate. + * config/rs6000/linux64.opt (mcmodel): New. + * config/rs6000/linux64.h (TARGET_USES_LINUX64_OPT): Define. + (TARGET_CMODEL, SET_CMODEL): Define. + (SUBSUBTARGET_OVERRIDE_OPTIONS): Check user -mcmodel choice, + select CMODEL_MEDIUM default. + * config/rs6000/rs6000.h (enum rs6000_cmodel): New. + (TARGET_CMODEL): Define default. + * config/rs6000/rs6000.c (cmodel): New variable. + (rs6000_explicit_options): Add cmodel field. + (rs6000_handle_option): Handle -mcmodel. + (create_TOC_reference): Add largetoc_reg param. Generate high, + lo_sum rtl for CMODEL_MEDIUM and CMODEL_LARGE. Update all callers. + (rs6000_delegitimize_address): Recognise new toc reference rtl + and minimal-toc rtl. + (rs6000_legitimize_reload_address): Handle new toc references. + (print_operand_address): Handle legitimate_constant_pool_address_p + match before lo_sum. + (rs6000_eliminate_indexed_memrefs): Tidy. + (rs6000_emit_move): Tweak threshold for inlining constants. + Keep rs6000_emit_allocate_stack large stack frame offsets + loaded into r0 inline. + (rs6000_generate_compare ): One more clobber. + (tocrel_base, tocrel_offset): New variables. + (toc_relative_expr_p): Set them here. + (print_operand_address): Skip over any offset on constant pool address. + (rs6000_output_addr_const_extra): Print tocrel_offset before @toc. + (rs6000_mode_dependent_address ): False for new toc refs. + (offsettable_ok_by_alignment): New function. + (rs6000_emit_move): Address suitably aligned local symbol_refs + relative to the toc pointer for -mcmodel=medium. + (legitimate_constant_pool_address_p): Make param const_rtx. Add + strict param. Allow lo_sum version of addressing. Verify reg + used for -mminimal-toc and -mcmodel != small. Update all callers. + * config/rs6000/constraints.md: Update for above change. + * config/rs6000/predicates.md: Likewise. + * config/rs6000/rs6000.md (tls_gd_aix): Generate -mcmodel=medium/large + code. + (tls_gd): Split for -mcmodel=medium/large. + (tls_gd_high, tls_gd_low): New. + (tls_ld_aix, tls_ld, tls_ld_high, tls_ld_low): Similarly. + (tls_got_dtprel, tls_got_dtprel_high, tls_got_dtprel_low): Similarly. + (tls_got_tprel, tls_got_tprel_high, tls_got_tprel_low): Similarly. + (largetoc_high, largetoc_low): New. + (cmptf_internal2): Add clobber. + * config/rs6000/rs6000-protos.h: Update. + +2010-06-14 Changpeng Fang + + * tree-ssa-loop-prefetch.c (nothing_to_prefetch_p): New. Return + true if no prefetch is going to be generated for a given group. + (estimate_prefetch_count): Use prefetch_mod and unroll_factor to + estimate the prefetch_count. + (loop_prefetch_arrays): Call nothing_to_prefetch_p; estimate the + prefetch count by considering the unroll_factor and prefetch_mod + for is_loop_prefetching_profitable. + +2010-06-14 Andreas Schwab + + * config/m68k/m68k.c (m68k_delegitimize_address): Don't do + anything if the argument is not a MEM. + +2010-06-14 Alexandre Oliva + + PR debug/43650 + PR debug/44181 + PR debug/44247 + * tree-ssa-loop-manip.c (tree_transform_and_unroll_loop): Skip + debug stmts. + (canonicalize_loop_ivs): Likewise. + +2010-06-14 Alexandre Oliva + + PR debug/43656 + * haifa-sched.c (setup_insn_reg_pressure_info, + update_register_pressure): Reject debug insns. + (ready_sort): Don't setup reg pressure for debug insns. + (schedule_insn): Don't update reg pressure for debug insns. + +2010-06-14 Richard Guenther + + * lto-streamer.c (cached_bp): Remove. + (bitpack_delete): Likewise. + (bitpack_create): Likewise. + (bp_get_next_word): Likewise. + (bp_pack_value, bp_unpack_value): Move ... + * lto-streamer.h (bp_pack_value, bp_unpack_value): ... here. + Re-implement. + (struct bitpack_d): Likewise. + (bitpack_create, lto_output_bitpack, lto_input_bitpack): + New inline functions. + * lto-streamer-out.c (lto_output_bitpack): Remove. + (pack_ts_base_value_fields): Adjust. Avoid conditional bitpacking. + (pack_value_fields): Adjust. + (lto_write_tree): Likewise. + (output_gimple_stmt): Likewise. + (output_function): Likewise. + * lto-streamer-in.c (input_gimple_stmt): Adjust. + (input_function): Likewise. + (unpack_ts_base_value_fields): Adjust. Avoid conditional bitpacking. + (lto_input_bitpack): Remove. + (lto_materialize_tree): Adjust. + * Makefile.in (ipa-prop.o): Add $(LTO_STREAMER_H) dependency. + * lto-cgraph.c (lto_output_edge): Adjust. + (lto_output_node): Likewise. + (lto_output_varpool_node): Likewise. + (lto_output_ref): Likewise. + (input_node): Likewise. + (input_varpool_node): Likewise. + (input_ref): Likewise. + (input_edge): Likewise. + (output_node_opt_summary): Likewise. + (input_node_opt_summary): Likewise. + * ipa-pure-const.c (pure_const_write_summary): Likewise. + (pure_const_read_summary): Likewise. + * ipa-prop.c (ipa_write_indirect_edge_info): Likewise. + (ipa_read_indirect_edge_info): Likewise. + (ipa_write_node_info): Likewise. + (ipa_read_node_info): Likewise. + +2010-06-14 H.J. Lu + + PR target/44534 + * config/i386/sse.md (vec_extract_lo_): Replace 0x1 with 0x0. + (vec_extract_lo_v16hi): Likewise. + (vec_extract_lo_v32qi): Likewise. + +2010-06-14 Jakub Jelinek + + PR bootstrap/44426 + * tree.h (build_call_expr): Don't define as vararg macro, instead + add a prototype. + * builtins.c (build_call_nofold): Remove. + (expand_builtin_int_roundingfn, expand_builtin_pow, + expand_builtin_mempcpy_args, expand_builtin_stpcpy, + expand_builtin_memset_args, expand_builtin_strcmp, + expand_builtin_strncmp, expand_builtin_memory_chk): Use + build_call_nofold_loc instead of build_call_nofold. + (build_call_expr): New function. + + PR tree-optimization/44508 + * tree-ssa-propagate.h (substitute_and_fold): Add DO_DCE argument. + * tree-ssa-propagate.c (substitute_and_fold): If !DO_DCE, + don't eliminate trivially dead stmts. + * tree-vrp.c (vrp_finalize): Pass false as last argument + to substitute_and_fold. + * tree-ssa-copy.c (fini_copy_prop): Pass true as last argument + to substitute_and_fold. + * tree-ssa-ccp.c (ccp_finalize): Likewise. + + PR bootstrap/44509 + * c-config-lang.in (gtfiles): Add c-family/c-cppbuiltin.c. + * c-family/c-cppbuiltin.c: Include gt-c-family-c-cppbuiltin.h. + (lazy_hex_fp_values, lazy_hex_fp_value_count): Add GTY(()) markers. + (lazy_hex_fp_value, builtin_define_with_hex_fp_value): Use + ggc_strdup instead of xstrdup. + +2010-06-14 Ira Rosen + + PR tree-optimization/44507 + * tree-vect-loop.c (get_initial_def_for_reduction): Use -1 + to build initial vector for BIT_AND_EXPR. + * tree-vect-slp.c (vect_get_constant_vectors): Likewise. + +2010-06-14 Jakub Jelinek + + * config/s390/s390.md (*mov_64 DD_DF, mov): Properly + adjust z10prop set_attr. + +2010-06-13 Jan Hubicka + + * bitmap.c (bitmap_and, bitmap_and_into, bitmap_and_compl, + bitmap_and_compl_into, bitmap_compl_and_into, bitmap_ior, + bitmap_ior_into, bitmap_xor, bitmap_xor_into, + bitmap_ior_and_compl, bitmap_ior_and_compl): Turn internal + datastructure checks into checking asserts. + * rtlanal.c (find_reg_note): Use gcc_checking_assert. + * tree-ssa-sccvn.c (VN_INFO): Likewise. + * df-scan.c (df_reorganize_refs_by_reg_by_reg, df_install_ref, + df_ref_create_structure): Likewise. + * alloc-pool.c (create_alloc_pool, empty_alloc_pool, pool_alloc, + pool_free): Use gcc_checking_assert. + * alias.c (get_alias_set): Likewise. + * var-tracking.c (variable_htab_free, shared_hash_copy, + canonicalize_values_mark, variable_merge_over_cur): Likewise. + * lto-streamer.c (bp_unpack_value): Likewise. + +2010-06-13 Richard Guenther + + * lto-streamer-in.c (lto_input_ts_type_tree_pointers): + Do not stream but initialize TYPE_CANONICAL to NULL. + (lto_output_ts_type_tree_pointers): Do not stream TYPE_CANONICAL. + * gimple.c (gimple_types_compatible_p): Disregard + TYPE_STRUCTURAL_EQUALITY_P. + (gimple_register_type): Use TYPE_CANONICAL as cache. + * lto-streamer.c (lto_record_common_node): Zero TYPE_CANONICAL + before registering common types. + * config/i386/i386.c (ix86_function_arg_boundary): Do not + use TYPE_CANONICAL, instead use TYPE_MAIN_VARIANT. + * tree.h (TYPE_CANONICAL): Clarify documentation. + +2010-06-13 Anatoly Sokolov + + * config/ia64/ia64.h (FUNCTION_VALUE_REGNO_P, FUNCTION_VALUE, + LIBCALL_VALUE): Remove macros. + * config/ia64/ia64-protos.h (ia64_function_value): Remove. + * config/ia64/ia64.c (TARGET_FUNCTION_VALUE, TARGET_LIBCALL_VALUE, + TARGET_FUNCTION_VALUE_REGNO_P): Define. + (ia64_libcall_value, ia64_function_value_regno_p): New functions. + (ia64_function_value): Make static. Handle receiving the function + type in 'fn_decl_or_type' argunent. Add 'outgoing' argument. + +2010-06-12 Jan Hubicka + + * cse.c (cse_extended_basic_block): Move optimize_bb_for_speed_p + at correct place. + +2010-06-12 Bernd Schmidt + + * config/arm/arm.c (thumb2_reorg): Fix errors in previous change. + +2010-06-12 Jan Hubicka + + * df-core.c (df_clear_bb_info): New function. + (df_set_blocks): bb_info is always allocated. + (df_get_bb_info): Use block_info_elt_size. + (df_set_bb_info): Likewise. + (df_compact_blocks): Update for new block_info. + (grow_bb_info): New function. + * df-problems.c (df_grow_bb_info): Move to df-core.c + (df_rd_set_bb_info): Remove. + (df_rd_free_bb_info): Do not free block pool. + (df_rd_alloc): Do not create pool, use check for + obstack presence instead of NULL pointer for new blocks. + (df_rd_free): DO not free alloc pool; clear block_info. + (problem_RD): Add size of block info structure. + (df_lr_set_bb_info): Remove. + (df_lr_free_bb_info): Do not free block pool. + (df_lr_alloc): Do not create pool, use check for + obstack presence instead of NULL pointer for new blocks. + (df_lr_free): DO not free alloc pool; clear block_info. + (problem_LR): Add size of block info structure. + (df_live_set_bb_info): Remove. + (df_live_free_bb_info): Do not free block pool. + (df_live_alloc): Do not create pool, use check for + obstack presence instead of NULL pointer for new blocks. + (df_live_free): DO not free alloc pool; clear block_info. + (problem_LIVE): Add size of block info structure. + (problem_CHAIN): Add size of block info structure. + (df_byte_lr_set_bb_info): Remove. + (df_byte_lr_free_bb_info): Do not free block pool. + (df_byte_lr_alloc): Do not create pool, use check for + obstack presence instead of NULL pointer for new blocks. + (df_byte_lr_free): DO not free alloc pool; clear block_info. + (problem_BYTE_LR): Add size of block info structure. + (problem_NOTE): Add size of block info structure. + (df_byte_MD_set_bb_info): Remove. + (df_byte_MD_free_bb_info): Do not free block pool. + (df_byte_MD_alloc): Do not create pool, use check for + obstack presence instead of NULL pointer for new blocks. + (df_byte_MD_free): DO not free alloc pool; clear block_info. + (problem_BD): Add size of block info structure. + * df-scan.c (df_scan_free_internal): Free block pool. + (df_scan_set_bb_info): Remove. + (df_scan_free_bb_info): Check for artificial_defs instead + of bb_info being non-NULL. + (df_scan_alloc): DO not create df_scan_block pool. + (problem_SCAN): Set size of block info. + (df_bb_refs_record): Do not allocate bb_info. + * df.h (df_problem): Add block_info_elt_size. + (struct dataflow): Change block_info to void *. + (df_scan_get_bb_info, df_rd_get_bb_info, df_lr_get_bb_info, + df_md_get_bb_info, df_live_get_bb_info, df_byte_lr_get_bb_info): Return + in-line structures. + +2010-06-12 Jan Hubicka + + PR tree-optimize/44485 + * tree-cfgcleanup.c (fixup_noreturn_call): Remove basic blocks + containing use of return value of noreturn function. + +2010-06-12 Anatoly Sokolov + + * targhooks.c (default_function_value): Don't use + FUNCTION_OUTGOING_VALUE. + * system.h (FUNCTION_OUTGOING_VALUE): Poison. + * doc/tm.texi (FUNCTION_OUTGOING_VALUE): Removed. + +2010-06-12 Kazu Hirata + + * config.gcc (mips64*-*-linux*, mipsisa64*-*-linux*, mips*-*-linux*): + Add crtfastmath.o to extra_parts. + * config/mips/crtfastmath.c: New. + * config/mips/linux.h (ENDFILE_SPEC): New. + +2010-06-12 Sebastian Pop + + * graphite-clast-to-gimple.c (gcc_type_for_interval): Do not pass + old_type in parameter. + (gcc_type_for_value): Update call to gcc_type_for_interval. + (compute_type_for_level_1): Renamed compute_type_for_level. + Update call to gcc_type_for_interval. + +2010-06-11 Joseph Myers + + * common.opt (Wstrict-aliasing=, Wstrict-overflow=, fabi-version=, + flto-compression-level=, ftree-parallelize-loops=): Add RejectNegative. + +2010-06-11 Joseph Myers + + * opts-common.c: Include options.h. + (integral_argument): Move from opts.c. + (decode_cmdline_option): New. Based on read_cmdline_option. + * opts.c (integral_argument): Move to opts-common.c. + (read_cmdline_option): Move most contents to + decode_cmdline_option. Use %qs in diagnostics. + * opts.h (CL_ERR_DISABLED, CL_ERR_MISSING_ARG, CL_ERR_WRONG_LANG, + CL_ERR_UINT_ARG, struct cl_decoded_option, integral_argument, + decode_cmdline_option): New. + +2010-06-11 Uros Bizjak + + PR target/44481 + * config/i386/i386.md (UNSPEC_PARITY): New unspec. + (paritydi2_cmp): Use UNSPEC_PARITY unspec instead of parity RTX. + (partiysi2_cmp): Ditto. + (*partiyhi2_cmp): Ditto. + (*parityqi2_cmp): Remove. + +2010-06-11 Jan Hubicka + + * bitmap.h (bmp_iter_next_bit): New. + (bmp_iter_set, bmp_iter_and, bmp_iter_and_compl): Use it. + +2010-06-11 Sandra Loosemore + Eric Botcazou + + * tree-ssa-loop-ivopts.c (get_computation_cost_at): Return again the + computed cost. + +2010-06-11 Uros Bizjak + + * config/i386/i386.md (unspec): New define_c_enum. + (unspecv): Ditto. + +2010-06-10 Jakub Jelinek + + * c-family/c-cppbuiltin.c: Include cpp-id-data.h. + (lazy_hex_fp_values, lazy_hex_fp_value_count): New variables. + (lazy_hex_fp_value): New function. + (builtin_define_with_hex_fp_value): Provide definitions lazily. + * Makefile.in (c-family/c-cppbuiltin.o): Depend on $(CPP_ID_DATA_H). + +2010-06-11 Sebastian Pop + + PR middle-end/44483 + * tree-if-conv.c (bb_predicate_s): New struct. + (bb_predicate_p): New. + (bb_has_predicate): New. + (bb_predicate): New. + (set_bb_predicate): New. + (bb_predicate_gimplified_stmts): New. + (set_bb_predicate_gimplified_stmts): New. + (add_bb_predicate_gimplified_stmts): New. + (init_bb_predicate): New. + (free_bb_predicate): New. + (is_predicated): Use bb_predicate. + (add_to_predicate_list): Use bb_predicate and set_bb_predicate. + (predicate_bbs): Same. Gimplify the condition of the basic blocks + before processing their successors. + (clean_predicate_lists): Removed. + (find_phi_replacement_condition): Use bb_predicate. + (process_phi_nodes): Renamed ifconvert_phi_nodes. Avoid useless + computations. + (insert_gimplified_predicates): New. + (combine_blocks): Call insert_gimplified_predicates. + (tree_if_conversion): Call free_bb_predicate instead of + clean_predicate_lists. + +2010-10-11 Paul Brook + + * doc/invoke.texi: Document ARM -mcpu=cortex-m4. + * config/arm/arm.c (all_architectures): Change v7e-m default to + cortexm4. + * config/arm/arm-cores.def: Add cortex-m4. + * config/arm/arm-tune.md: Regenerate. + +2010-06-11 Jan Hubicka + + * ipa-pure-const.c (special_builtlin_state): New function. + (check_call): Use it instead of special casign BUILT_IN_RETURN. + (propagate_pure_const): Use it. + +2010-06-11 Jan Hubicka + + * df-problems.c (df_live_scratch): Convert to bitmap_head. + (df_live_alloc): Initialize df_live_scratch when initializing + problem_data. + (df_live_transfer_function): Update uses of df_live_scratch. + (df_live_free): Free problem_data; clear df_live_scratch before + releasing the obstack. + (df_md_free): Free problem data. + +2010-06-11 Jan Hubicka + + * doc/invoke.texi (Wsuggest-attribute): Document. + (Wmissing-noreturn): Remove. + * ipa-pure-const.c (warn_function_noreturn): New function. + * opts.c (decode_options): Set warn_suggest_attribute_noreturn on + warn_missing_noreturn. + * common.opt (Wsuggest-attribute=noreturn): New. + * tree-flow.h (warn_function_noreturn): Declare. + * tree-cfg.c (execute_warn_function_noreturn): Use + warn_function_noreturn. + (gate_warn_function_noreturn): New. + (pass_warn_function_noreturn): Update. + +2010-06-11 Manuel López-Ibáñez + + * c-typeck.c (handle_warn_cast_qual): Add loc + parameter. Improve warning message. + (build_c_cast): Pass location to handle_warn_cast_qual. + +2010-06-11 Uros Bizjak + + * config/i386/i386.md (pro_epilogue_adjust_stack_1) : Assert + that operand 0 == operand 1. Use x86_maybe_negate_const_int to output + insn mnemonic. + (pro_epilogue_adjust_stack_rex64) : Ditto. + +2010-06-10 Dodji Seketeli + + Fix bootstap on mips + * dwarf2out.c (is_naming_typedef_dec): Built-in TYPE_DECLs cannot + be naming typedefs. + +2010-06-11 Kai Tietz + + * system.h (helper_const_non_const_cast): New inline for + gcc version <= 4.0. + (CONST_CAST2): For gcc version <= 4.0 use + new helper to do const/non-const casting. + +2010-06-10 Richard Sandiford + + * doc/md.texi: Document the "unspec" and "unspecv" enum names. + * Makefile.in (OBJS-common): Include insn-enums.o. + (insn-enums.o): New rule. + (simple_generated_c): Add insn-enums.c. + (build/genenums.o): New rule. + (genprogmd): Add "enums". + * genconstants.c (print_enum_type): Declare a C string array + for each enum. + * genenums.c: New file. + * print-rtl.c (print_rtx): If defined, use the "unspecv" enum + for UNSPEC_VOLATILE. If defined, use the "unspec" enum for both + UNSPEC and (as a fallback) for UNSPEC_VOLATILE. + +2010-06-10 Richard Sandiford + + * doc/md.texi (define_enum_attr): Document. + * rtl.def (DEFINE_ENUM_ATTR): New rtx. + * read-md.h (lookup_enum_type): Declare. + * read-md.c (lookup_enum_type): New function. + * genattr.c (gen_attr, main): Handle DEFINE_ENUM_ATTR. + * genattrtab.c (attr_desc): Add an enum_name field. + (evaluate_eq_attr): Take the associated attribute as argument. + Get the enum prefix from the enum_name field, if defined. + Use ACONCAT rather than a fixed-length buffer. Update recursive calls. + (simplify_test_exp): Pass attr to evaluate_eq_attr. + (add_attr_value): New function, split out from... + (gen_attr): ...here. Handle DEFINE_ENUM_ATTR. + (write_test_expr): Pass attr to evaluate_eq_attr. + (write_attr_get): Use the enum_name as the enum tag, if defined. + (write_attr_valueq): Use the enum_name as a prefix, if defined. + (find_attr): Initialize enum_name. + (main): Handle DEFINE_ENUM_ATTR. + * gensupport.c (process_rtx): Likewise. + * config/mips/mips.h (mips_tune_attr): Delete. + * config/mips/mips.md (cpu): Use define_attr_enum. + +2010-06-10 Richard Sandiford + + * doc/md.texi (define_c_enum, define_enum): Document. + * read-md.h (md_constant): Add a parent_enum field. + (enum_value, enum_type): New structures. + (upcase_string, traverse_enum_types): Declare. + * read-md.c (enum_types): New variable. + (upcase_string, add_constant): New functions. + (handle_constants): Don't create the hash table here. + Use add_constant. + (traverse_md_constants): Don't check for a null md_constants. + (decimal_string, handle_enum, traverse_enum_types): New functions. + (read_md_files): Initialize md_constants and md_enums. + * genconstants.c (print_md_constant): Ignore info argument. + Only print constants that belong to no enum. + (print_enum_type): New function. + (main): Don't pass stdout to print_md_constant. Call print_enum_type + for each defined enum type. + * config/mips/mips.md (processor): New define_enum. + (unspec): New define_c_enum. + (UNSPEC_COMPARE_AND_SWAP, UNSPEC_COMPARE_AND_SWAP_12) + (UNSPEC_SYNC_OLD_OP, UNSPEC_SYNC_NEW_OP, UNSPEC_SYNC_NEW_OP_12) + (UNSPEC_SYNC_OLD_OP_12, UNSPEC_SYNC_EXCHANGE, UNSPEC_SYNC_EXCHANGE_12) + (UNSPEC_MEMORY_BARRIER): Moved to sync.md. + (UNSPEC_ADDQ, UNSPEC_ADDQ_S, UNSPEC_SUBQ, UNSPEC_SUBQ_S, UNSPEC_ADDSC) + (UNSPEC_ADDWC, UNSPEC_MODSUB, UNSPEC_RADDU_W_QB, UNSPEC_ABSQ_S) + (UNSPEC_PRECRQ_QB_PH, UNSPEC_PRECRQ_PH_W, UNSPEC_PRECRQ_RS_PH_W) + (UNSPEC_PRECRQU_S_QB_PH, UNSPEC_PRECEQ_W_PHL, UNSPEC_PRECEQ_W_PHR) + (UNSPEC_PRECEQU_PH_QBL, UNSPEC_PRECEQU_PH_QBR, UNSPEC_PRECEQU_PH_QBLA) + (UNSPEC_PRECEQU_PH_QBRA, UNSPEC_PRECEU_PH_QBL, UNSPEC_PRECEU_PH_QBR) + (UNSPEC_PRECEU_PH_QBLA, UNSPEC_PRECEU_PH_QBRA, UNSPEC_SHLL) + (UNSPEC_SHLL_S, UNSPEC_SHRL_QB, UNSPEC_SHRA_PH, UNSPEC_SHRA_R) + (UNSPEC_MULEU_S_PH_QBL, UNSPEC_MULEU_S_PH_QBR, UNSPEC_MULQ_RS_PH) + (UNSPEC_MULEQ_S_W_PHL, UNSPEC_MULEQ_S_W_PHR, UNSPEC_DPAU_H_QBL) + (UNSPEC_DPAU_H_QBR, UNSPEC_DPSU_H_QBL, UNSPEC_DPSU_H_QBR) + (UNSPEC_DPAQ_S_W_PH, UNSPEC_DPSQ_S_W_PH, UNSPEC_MULSAQ_S_W_PH) + (UNSPEC_DPAQ_SA_L_W, UNSPEC_DPSQ_SA_L_W, UNSPEC_MAQ_S_W_PHL) + (UNSPEC_MAQ_S_W_PHR, UNSPEC_MAQ_SA_W_PHL, UNSPEC_MAQ_SA_W_PHR) + (UNSPEC_BITREV, UNSPEC_INSV, UNSPEC_REPL_QB, UNSPEC_REPL_PH) + (UNSPEC_CMP_EQ, UNSPEC_CMP_LT, UNSPEC_CMP_LE, UNSPEC_CMPGU_EQ_QB) + (UNSPEC_CMPGU_LT_QB, UNSPEC_CMPGU_LE_QB, UNSPEC_PICK, UNSPEC_PACKRL_PH) + (UNSPEC_EXTR_W, UNSPEC_EXTR_R_W, UNSPEC_EXTR_RS_W, UNSPEC_EXTR_S_H) + (UNSPEC_EXTP, UNSPEC_EXTPDP, UNSPEC_SHILO, UNSPEC_MTHLIP, UNSPEC_WRDSP) + (UNSPEC_RDDSP): Move to mips-dsp.md. + (UNSPEC_ABSQ_S_QB, UNSPEC_ADDU_PH, UNSPEC_ADDU_S_PH, UNSPEC_ADDUH_QB) + (UNSPEC_ADDUH_R_QB, UNSPEC_APPEND, UNSPEC_BALIGN, UNSPEC_CMPGDU_EQ_QB) + (UNSPEC_CMPGDU_LT_QB, UNSPEC_CMPGDU_LE_QB, UNSPEC_DPA_W_PH) + (UNSPEC_DPS_W_PH, UNSPEC_MADD, UNSPEC_MADDU, UNSPEC_MSUB, UNSPEC_MSUBU) + (UNSPEC_MUL_PH, UNSPEC_MUL_S_PH, UNSPEC_MULQ_RS_W, UNSPEC_MULQ_S_PH) + (UNSPEC_MULQ_S_W, UNSPEC_MULSA_W_PH, UNSPEC_MULT, UNSPEC_MULTU) + (UNSPEC_PRECR_QB_PH, UNSPEC_PRECR_SRA_PH_W, UNSPEC_PRECR_SRA_R_PH_W) + (UNSPEC_PREPEND, UNSPEC_SHRA_QB, UNSPEC_SHRA_R_QB, UNSPEC_SHRL_PH) + (UNSPEC_SUBU_PH, UNSPEC_SUBU_S_PH, UNSPEC_SUBUH_QB, UNSPEC_SUBUH_R_QB) + (UNSPEC_ADDQH_PH, UNSPEC_ADDQH_R_PH, UNSPEC_ADDQH_W, UNSPEC_ADDQH_R_W) + (UNSPEC_SUBQH_PH, UNSPEC_SUBQH_R_PH, UNSPEC_SUBQH_W, UNSPEC_SUBQH_R_W) + (UNSPEC_DPAX_W_PH, UNSPEC_DPSX_W_PH, UNSPEC_DPAQX_S_W_PH) + (UNSPEC_DPAQX_SA_W_PH, UNSPEC_DPSQX_S_W_PH, UNSPEC_DPSQX_SA_W_PH): + Moved to mips-dspr2.md. + (UNSPEC_MOVE_TF_PS, UNSPEC_C, UNSPEC_ALNV_PS, UNSPEC_CABS) + (UNSPEC_ADDR_PS, UNSPEC_CVT_PW_PS, UNSPEC_CVT_PS_PW, UNSPEC_MULR_PS) + (UNSPEC_ABS_PS, UNSPEC_RSQRT1, UNSPEC_RSQRT2, UNSPEC_RECIP1) + (UNSPEC_RECIP2, UNSPEC_SINGLE_CC, UNSPEC_SCC): Move from mips-ps-3d.md. + (UNSPEC_LOONGSON_PAVG, UNSPEC_LOONGSON_PCMPEQ, UNSPEC_LOONGSON_PCMPGT) + (UNSPEC_LOONGSON_PEXTR, UNSPEC_LOONGSON_PINSR_0) + (UNSPEC_LOONGSON_PINSR_1, UNSPEC_LOONGSON_PINSR_2) + (UNSPEC_LOONGSON_PINSR_3, UNSPEC_LOONGSON_PMADD) + (UNSPEC_LOONGSON_PMOVMSK, UNSPEC_LOONGSON_PMULHU) + (UNSPEC_LOONGSON_PMULH, UNSPEC_LOONGSON_PMULL, UNSPEC_LOONGSON_PMULU) + (UNSPEC_LOONGSON_PASUBUB, UNSPEC_LOONGSON_BIADD, + UNSPEC_LOONGSON_PSADBH) + (UNSPEC_LOONGSON_PSHUFH, UNSPEC_LOONGSON_PUNPCKH) + (UNSPEC_LOONGSON_PUNPCKL, UNSPEC_LOONGSON_PADDD) + (UNSPEC_LOONGSON_PSUBD): Move to mips-loongson.md. + (UNSPEC_LOONGSON_ALU1_TURN_ENABLED_INSN) + (UNSPEC_LOONGSON_ALU2_TURN_ENABLED_INSN) + (UNSPEC_LOONGSON_FALU1_TURN_ENABLED_INSN) + (UNSPEC_LOONGSON_FALU2_TURN_ENABLED_INSN): Move to mips-loongson2ef.md. + (cpu): Update comment. + * config/mips/sync.md (UNSPEC_COMPARE_AND_SWAP) + (UNSPEC_COMPARE_AND_SWAP_12, UNSPEC_SYNC_OLD_OP, UNSPEC_SYNC_NEW_OP) + (UNSPEC_SYNC_NEW_OP_12, UNSPEC_SYNC_OLD_OP_12, UNSPEC_SYNC_EXCHANGE) + (UNSPEC_SYNC_EXCHANGE_12, UNSPEC_MEMORY_BARRIER): Moved from mips.md. + * config/mips/loongson.md (UNSPEC_LOONGSON_PAVG, + UNSPEC_LOONGSON_PCMPEQ) + (UNSPEC_LOONGSON_PCMPGT, UNSPEC_LOONGSON_PEXTR, + UNSPEC_LOONGSON_PINSR_0) + (UNSPEC_LOONGSON_PINSR_1, UNSPEC_LOONGSON_PINSR_2) + (UNSPEC_LOONGSON_PINSR_3, UNSPEC_LOONGSON_PMADD) + (UNSPEC_LOONGSON_PMOVMSK, UNSPEC_LOONGSON_PMULHU) + (UNSPEC_LOONGSON_PMULH, UNSPEC_LOONGSON_PMULL, UNSPEC_LOONGSON_PMULU) + (UNSPEC_LOONGSON_PASUBUB, UNSPEC_LOONGSON_BIADD, + UNSPEC_LOONGSON_PSADBH) + (UNSPEC_LOONGSON_PSHUFH, UNSPEC_LOONGSON_PUNPCKH) + (UNSPEC_LOONGSON_PUNPCKL, UNSPEC_LOONGSON_PADDD) + (UNSPEC_LOONGSON_PSUBD): Moved from mips.md + * config/mips/loongson2ef.md (UNSPEC_LOONGSON_ALU1_TURN_ENABLED_INSN) + (UNSPEC_LOONGSON_ALU2_TURN_ENABLED_INSN) + (UNSPEC_LOONGSON_FALU1_TURN_ENABLED_INSN) + (UNSPEC_LOONGSON_FALU2_TURN_ENABLED_INSN): Moved from mips.md + * config/mips/mips-dsp.md (UNSPEC_ADDQ, UNSPEC_ADDQ_S, UNSPEC_SUBQ) + (UNSPEC_SUBQ_S, UNSPEC_ADDSC, UNSPEC_ADDWC, UNSPEC_MODSUB) + (UNSPEC_RADDU_W_QB, UNSPEC_ABSQ_S, UNSPEC_PRECRQ_QB_PH) + (UNSPEC_PRECRQ_PH_W, UNSPEC_PRECRQ_RS_PH_W, UNSPEC_PRECRQU_S_QB_PH) + (UNSPEC_PRECEQ_W_PHL, UNSPEC_PRECEQ_W_PHR, UNSPEC_PRECEQU_PH_QBL) + (UNSPEC_PRECEQU_PH_QBR, UNSPEC_PRECEQU_PH_QBLA, UNSPEC_PRECEQU_PH_QBRA) + (UNSPEC_PRECEU_PH_QBL, UNSPEC_PRECEU_PH_QBR, UNSPEC_PRECEU_PH_QBLA) + (UNSPEC_PRECEU_PH_QBRA, UNSPEC_SHLL, UNSPEC_SHLL_S, UNSPEC_SHRL_QB) + (UNSPEC_SHRA_PH, UNSPEC_SHRA_R, UNSPEC_MULEU_S_PH_QBL) + (UNSPEC_MULEU_S_PH_QBR, UNSPEC_MULQ_RS_PH, UNSPEC_MULEQ_S_W_PHL) + (UNSPEC_MULEQ_S_W_PHR, UNSPEC_DPAU_H_QBL, UNSPEC_DPAU_H_QBR) + (UNSPEC_DPSU_H_QBL, UNSPEC_DPSU_H_QBR, UNSPEC_DPAQ_S_W_PH) + (UNSPEC_DPSQ_S_W_PH, UNSPEC_MULSAQ_S_W_PH, UNSPEC_DPAQ_SA_L_W) + (UNSPEC_DPSQ_SA_L_W, UNSPEC_MAQ_S_W_PHL, UNSPEC_MAQ_S_W_PHR) + (UNSPEC_MAQ_SA_W_PHL, UNSPEC_MAQ_SA_W_PHR, UNSPEC_BITREV, UNSPEC_INSV) + (UNSPEC_REPL_QB, UNSPEC_REPL_PH, UNSPEC_CMP_EQ, UNSPEC_CMP_LT) + (UNSPEC_CMP_LE, UNSPEC_CMPGU_EQ_QB, UNSPEC_CMPGU_LT_QB) + (UNSPEC_CMPGU_LE_QB, UNSPEC_PICK, UNSPEC_PACKRL_PH, UNSPEC_EXTR_W) + (UNSPEC_EXTR_R_W, UNSPEC_EXTR_RS_W, UNSPEC_EXTR_S_H, UNSPEC_EXTP) + (UNSPEC_EXTPDP, UNSPEC_SHILO, UNSPEC_MTHLIP, UNSPEC_WRDSP) + (UNSPEC_RDDSP): Moved from mips.md. + * config/mips/mips-dspr2.md (UNSPEC_ABSQ_S_QB, UNSPEC_ADDU_PH) + (UNSPEC_ADDU_S_PH, UNSPEC_ADDUH_QB, UNSPEC_ADDUH_R_QB, UNSPEC_APPEND) + (UNSPEC_BALIGN, UNSPEC_CMPGDU_EQ_QB, UNSPEC_CMPGDU_LT_QB) + (UNSPEC_CMPGDU_LE_QB, UNSPEC_DPA_W_PH, UNSPEC_DPS_W_PH, UNSPEC_MADD) + (UNSPEC_MADDU, UNSPEC_MSUB, UNSPEC_MSUBU, UNSPEC_MUL_PH) + (UNSPEC_MUL_S_PH, UNSPEC_MULQ_RS_W, UNSPEC_MULQ_S_PH, UNSPEC_MULQ_S_W) + (UNSPEC_MULSA_W_PH, UNSPEC_MULT, UNSPEC_MULTU, UNSPEC_PRECR_QB_PH) + (UNSPEC_PRECR_SRA_PH_W, UNSPEC_PRECR_SRA_R_PH_W, UNSPEC_PREPEND) + (UNSPEC_SHRA_QB, UNSPEC_SHRA_R_QB, UNSPEC_SHRL_PH, UNSPEC_SUBU_PH) + (UNSPEC_SUBU_S_PH, UNSPEC_SUBUH_QB, UNSPEC_SUBUH_R_QB, UNSPEC_ADDQH_PH) + (UNSPEC_ADDQH_R_PH, UNSPEC_ADDQH_W, UNSPEC_ADDQH_R_W, UNSPEC_SUBQH_PH) + (UNSPEC_SUBQH_R_PH, UNSPEC_SUBQH_W, UNSPEC_SUBQH_R_W, UNSPEC_DPAX_W_PH) + (UNSPEC_DPSX_W_PH, UNSPEC_DPAQX_S_W_PH, UNSPEC_DPAQX_SA_W_PH) + (UNSPEC_DPSQX_S_W_PH, UNSPEC_DPSQX_SA_W_PH): Moved from mips.md. + * config/mips/mips-ps-3d.md (UNSPEC_MOVE_TF_PS, UNSPEC_C) + (UNSPEC_ALNV_PS, UNSPEC_CABS, UNSPEC_ADDR_PS, UNSPEC_CVT_PW_PS) + (UNSPEC_CVT_PS_PW, UNSPEC_MULR_PS, UNSPEC_ABS_PS, UNSPEC_RSQRT1) + (UNSPEC_RSQRT2, UNSPEC_RECIP1, UNSPEC_RECIP2, UNSPEC_SINGLE_CC) + (UNSPEC_SCC): Moved from mips.md. + * config/mips/mips.c (mips_arch, mips_tune): Change enum from + "processor_type" to "processor". + (mips_rtx_cost_data): Replace PROCESSOR_MAX with NUM_PROCESSOR_VALUES. + * config/mips/mips.h (processor_type): Delete. + (mips_cpu_info.cpu, mips_arch, mips_tune): Change enum from + "processor_type" to "processor". + +2010-06-10 Richard Sandiford + + * configure.ac (tm_include_list): Add insn-constants.h. + * configure: Regenerate. + * Makefile.in (GTM_H): Move insn-constants.h here from... + (TM_H): ...here. + * mkconfig.sh: Remove special handling for insn-constants.h. + +2010-06-10 Richard Sandiford + + * Makefile.in (BUILD_RTL): Move build/read-md.o to... + (BUILD_MD): ...this new variable. + (simple_generated_rtl_h, simple_generated_rtl_c): New variables + that include the old contents of simple_generated_h and + simple_generated_c. + (simple_generated_h, simple_generated_c): Include them. Add + insn-constants.h. + (s-%): Make simple_generated_{h,c} stamps depend on $(MD_DEPS) + and simple_generated_rtl_{h,c} stamps depend on insn-conditions.md. + Remove these dependencies from the main rule and include + insn-conditions.md in the command line only if it appears + in the dependency list. + (insn-constants.h, s-constants): Delete. + (build/genconstants.o): Don't depend on $(RTL_BASE_H), $(GTM_H) + or gensupport.h. + (build/genmddeps.o): Likewise. + (genprogrtl): New variable that contains everything from genprogmd + except mddeps and constants. + (genprogmd): Redefine in terms of genprogrtl. Make these programs + depend on $(BUILD_MD) + (genprog): New variable. Make these programs depend on + $(BUILD_ERRORS). + * genmddeps.c: Don't include tm.h, rtl.h or gensupport.h. + (main): Use read_md_files instead of init_rtx_reader_args. + * genconstants.c: As for genmddeps.c. + * read-md.h (read_skip_construct): Declare. + * read-md.c (read_skip_construct): New function. + (handle_file): Allow a null handle_directive, skipping the + construct if so. + (parse_include): Update the comment accordingly. + +2010-06-10 Richard Sandiford + + * Makefile.in (build/genmddeps.o): Depend on $(READ_MD_H). + * genmddeps.c: Include read-md.h. + (main): Call init_rtx_reader_args instead of init_md_reader_args. + * genattr.c (main): Likewise. + * genattrtab.c (main): Likewise. + * genautomata.c (main): Likewise. + * gencodes.c (main): Likewise. + * genconditions.c (main): Likewise. + * genconfig.c (main): Likewise. + * genconstants.c (main): Likewise. + * genemit.c (main): Likewise. + * genextract.c (main): Likewise. + * genflags.c (main): Likewise. + * genopinit.c (main): Likewise. + * genoutput.c (main): Likewise. + * genpeep.c (main): Likewise. + * genrecog.c (main): Likewise. + * genpreds.c (main): Likewise. + * gensupport.h (in_fname): Move to read-md.h. + (init_md_reader_args_cb): Rename to... + (init_rtx_reader_args_cb): ...this and return a bool. + (init_md_reader_args): Rename to... + (init_rtx_reader_args): ...this and return a bool. + (include_callback): Move to read-md.h. + * gensupport.c (in_fname, include_callback, base_dir, max_include_len) + (file_name_list, first_dir_md_include): Move to read-md.c + (first_bracket_include): Delete unused variable. + (last_dir_md_include): Move to read-md.c. + (process_include): Delete, moving code to read-md.c:handle_include. + (process_rtx): Don't handle INCLUDE. + (save_string): Delete. + (rtx_handle_directive): New function. + (init_md_reader_args_cb): Rename to... + (init_rtx_reader_args_cb): ...this and return a boolean success value. + Use read_md_args. + (init_md_reader_args): Rename to... + (init_rtx_reader_args): ...this and return a boolean success value. + * rtl.def (INCLUDE): Delete. + * rtl.h (read_rtx): Remove "int *" argument. Add "const char *" + argument. + * read-rtl.c (read_conditions): Don't gobble ')' here. + (read_mapping): Likewise. + (read_rtx): Remove LINENO argument. Add RTX_NAME argument. + Handle top-level non-rtx constructs here rather than in read_rtx_1. + Store the whole queue in *X. Remove call to init_md_reader. + (read_rtx_1): Rename to... + (read_rtx_code): ...this. Call read_nested_rtx to read subrtxes. + Don't handle top-level non-rtx constructs here. Don't handle (nil) + here. + (read_nested_rtx): New function. Handle (nil) here rather than + in read_rtx_code. + (read_rtx_variadic): Call read_nested_rtx to read subrtxes. Don't + gobble ')' here. + * read-md.h (directive_handler_t): New type. + (in_fname, include_callback): Moved from read-md.h. + (read_constants, init_md_reader): Delete. + (read_md_files): Declare. + * read-md.c (file_name_list, in_fname, base_dir, first_dir_md_include) + (last_dir_md_include_ptr, include_callback, max_include_len): Moved + from gensupport.c. + (read_constants): Rename to... + (handle_constants): ...this. Don't gobble ')' here. + (handle_include, handle_file, handle_toplevel_file) + (parse_include): New functions, mostly taken from gensupport.c. + (init_md_reader): Subsume into... + (read_md_files): ...this new function. + +2010-06-10 Richard Sandiford + + * read-md.h (read_char): Increment read_md_lineno after reading '\n'. + (unread_char): Decrement read_md_lineno after putting back '\n'. + * read-md.c (fatal_with_file_and_line): Push back any characters + that we decide not to add to the context. + (read_skip_spaces): Don't increment read_md_lineno here. Avoid using + fatal_expected_char in cases where '/' ends a line (for example). + (read_name): Don't increment read_md_lineno here. + (read_escape): Likewise. + (read_quoted_string): Likewise. + (read_braced_string): Likewise. + +2010-06-10 Richard Sandiford + + * Makefile.in (READ_MD_H): Add $(HASHTAB_H). + (build/genconstants.o): Depend on $(READ_MD_H) gensupport.h. + * genconstants.c: Include read-md.h. + * read-rtl.c (md_constants): Move to read-md.c. + (md_name): Move to read-md.h. + (initialize_iterators): Use leading_string_hash instead of def_hash + and leading_string_eq_p instead of def_name_eq_p. + (read_name): Move to read-md.c. + (def_hash, def_name_eq_p): Delete. + (read_constants, traverse_md_constants): Move to read-md.c. + * rtl.h (md_constant, traverse_md_constants): Move to read-md.h. + * read-md.h: Include hashtab.h. + (md_name): Moved from read-rtl.c. + (md_constant): Moved from read-md.h. + (leading_string_hash, leading_string_eq_p, read_name) + (read_constants, traverse_md_constants): Declare. + * read-md.c (md_constants): Moved from read-rtl.c. + (leading_string_hash, leading_string_eq_p): New functions. + (read_name, read_constants, traverse_md_constants): Moved from + read-rtl.c. + +2010-06-10 Richard Sandiford + + * read-rtl.c (md_name): New structure. + (read_name): Take an md_name instead of a buffer pointer. + Use the "string" field instead of strcpy when expanding constants. + (read_constants): Remove the tmp_char argument. Update the calls + to read_name, using two local name buffers instead of the tmp_char + argument. Merge the constant-creation code. + (read_conditions): Remove the tmp_char argument. Update the calls + to read_name, using a local name buffer instead of the tmp_char + argument. + (read_mapping): Replace tmp_char variable with a local name buffer. + Update the calls to read_name. + (read_rtx_1): Likewise. Update the calls to read_constants and + read_conditions. + +2010-06-10 Richard Sandiford + + * Makefile.in (build/read-md.o): Depend on errors.h. + * read-md.h (error_with_line): Declare. + * read-md.c: Include errors.h. + (message_with_line_1): New function, extracted from... + (message_with_line): ...here. + (error_with_line): New function. + * genattrtab.c: If a call to message_with_line is followed by + "have_error = 1;", replace both statements with a call to + error_with_line. + * genoutput.c: Likewise. + * genpreds.c: Likewise. + * genrecog.c: If a call to message_with_line is followed by + "error_count++;", replace both statements with a call to + error_with_line. + (errorcount): Delete. + (main): Don't check it. + * gensupport.c: If a call to message_with_line is followed by + "errors = 1;", replace both statements with a call to error_with_line. + (errors): Delete. + (process_define_cond_exec): Check have_error instead of errors. + (init_md_reader_args_cb): Likewise. Don't set errors. + +2010-06-10 Richard Sandiford + + * read-md.h (read_md_file): Declare. + (read_char, unread_char): New functions. + (fatal_with_file_and_line, fatal_expected_char, read_skip_spaces) + (read_quoted_string, read_string): Remove FILE * argument. + * read-md.c (read_md_file): New variable. + (read_md_filename, read_md_lineno): Update comments and remove + unnecessary initialization. + (fatal_with_file_and_line, fatal_expected_char, read_skip_spaces) + (read_escape, read_quoted_string, read_braced_string, read_string): + Remove FILE * argument. Update calls accordingly, using read_char + and unread_char instead of getc and ungetc. + * rtl.h (read_rtx): Remove FILE * argument. + * read-rtl.c (iterator_group): Remove FILE * argument from + "find_builtin". + (iterator_traverse_data): Remove "infile" field. + (find_mode, find_code, apply_mode_maps, apply_iterator_to_rtx) + (add_mapping, read_name, read_constants, read_conditions) + (validate_const_int, find_iterator, read_mapping, check_code_iterator) + (read_rtx, read_rtx_1, read_rtx_variadic): Remove FILE * argument. + Remove file arguments from all calls, using read_char and unread_char + instead of getc and ungetc. + * gensupport.c (process_include): Preserve read_md_file around + the include. Set read_md_file to the handle of the included file. + Update call to read_rtx. + (init_md_reader_args_cb): Set read_md_file to the handle of the file + and remove local FILE *. Update calls to read_rtx. + +2010-06-10 Richard Sandiford + + * read-md.h (read_rtx_lineno): Rename to... + (read_md_lineno): ...this. + (read_rtx_filename): Rename to... + (read_md_filename): ...this. + (copy_rtx_ptr_loc): Rename to... + (copy_md_ptr_loc): ...this. + (print_rtx_ptr_loc): Rename to... + (print_md_ptr_loc): ...this. + * read-md.c: Likewise. Update references after renaming. + (string_obstack): Replace RTL with MD in comment. + (set_rtx_ptr_loc): Rename to... + (set_md_ptr_loc): ...this. + (get_rtx_ptr_loc): Rename to... + (get_md_ptr_loc): ...this. + * genconditions.c: Update references after renaming. + * genemit.c: Likewise. + * genoutput.c: Likewise. + * genpreds.c: Likewise. + * gensupport.c: Likewise. + * read-rtl.c: Likewise. + +2010-06-10 Richard Sandiford + + * Makefile.in (READ_MD_H): New variable. + (BUILD_RTL): Add build/read-md.o. + (lto-wrapper.o): Depend on coretypes.h instead of defaults.h. + (build/gensupport.o, build/read-rtl.o, build/genattr.o) + (build/genattrtab.o, build/genconditions.o build/genemit.o) + (build/genextract.o, build/genflags.o, build/genoutput.o) + (build/genpreds.o, build/genrecog.o): Depend on $(READ_MD_H). + (build/read-md.o): New rule. + * defaults.h (obstack_chunk_alloc, obstack_chunk_free) + (OBSTACK_CHUNK_SIZE, gcc_obstack_init): Move to... + * coretypes.h: ...here. + * lto-wrapper.c: Include coretypes.h instead of defaults.h. + * pretty-print.c (obstack_chunk_alloc, obstack_chunk_free): Delete. + * genattr.c: Include read-md.h. + * genattrtab.c: Likewise. + * genconditions.c: Likewise. + * genemit.c: Likewise. + * genextract.c: Likewise. + * genflags.c: Likewise. + * genoutput.c: Likewise. + * genpreds.c: Likewise. + * genrecog.c: Likewise. + * rtl.h (read_skip_spaces, copy_rtx_ptr_loc, print_rtx_ptr_loc) + (join_c_conditions, print_c_condition, read_rtx_filename) + (read_rtx_lineno): Move to read-md.h. + * read-rtl.c: Include read-md.h. + (ptr_loc, string_obstack, ptr_locs, ptr_loc_obstack) + (joined_conditions, joined_conditions_obstack, read_rtx_lineno) + (read_rtx_filename, fatal_with_file_and_line, fatal_expected_char) + (leading_ptr_hash, leading_ptr_eq_p, set_rtx_ptr_loc, get_rtx_ptr_loc) + (copy_rtx_ptr_loc, print_rtx_ptr_loc, join_c_conditions) + (print_c_condition, read_skip_spaces, read_escape, read_quoted_string) + (read_braced_string, read_string): Move to read-md.c. + (read_rtx): Move some initialization to init_md_reader and call + init_md_reader here. + * gensupport.h (message_with_line, n_comma_elts, scan_comma_elt): + Move to read-md.h. + * gensupport.c: Include read-md.h. + (message_with_line, n_comma_elts, scan_comma_elt): Move to read-md.c. + * read-md.h, read-md.c: New files. + +2010-06-10 Anatoly Sokolov + + * config/moxie/moxie.h (FUNCTION_VALUE, FUNCTION_OUTGOING_VALUE, + LIBCALL_VALUE, FUNCTION_VALUE_REGNO_P): Remove macros. + * config/moxie/moxie-protos.h (moxie_function_value): Remove. + * config/moxie/moxie.c (moxie_function_value): Make static. + (moxie_libcall_value, moxie_function_value_regno_p): New functions. + (TARGET_LIBCALL_VALUE, TARGET_FUNCTION_VALUE_REGNO_P): Define. + +2010-06-10 Martin Jambor + + * Makefile.in (tree-sra.o): Add DBGCNT_H to dependencies. + * dbgcnt.def (tree_sra): New counter. + * tree-sra.c: Include dbgcnt.h. + (gate_intra_sra): Check tree_sra debug counter. + +2010-06-10 Martin Jambor + + PR tree-optimization/44258 + * tree-sra.c (build_access_subtree): Return false iff there is a + partial overlap. + (build_access_trees): Likewise. + (analyze_all_variable_accesses): Disqualify candidates if + build_access_trees returns true for them. + +2010-06-10 Alexandre Oliva + + PR debug/41371 + * var-tracking.c (find_loc_in_1pdv): Remove recursion, only + tail-recurse into canonical node. Fast-forward over + non-canonical VALUEs. + +2010-06-10 H.J. Lu + + PR boostrap/44470 + * config/i386/i386.md (*add_1): Revert revision 160394. + (*addsi_1_zext) : Likewise. + (add lea splitter): Likewise. + (add_zext lea splitter): Likewise. + +2010-06-10 Joseph Myers + + * common.opt (fshow-column): Don't mark as C ObjC C++ ObjC++. + +2010-06-10 Jan Hubicka + + * df-problems.c (df_live_problem_data): Add live_bitmaps. + (df_live_alloc): Initialize problem data and live_osbtacks. + (df_live_finalize): Remove obstack, problem data; do not + clear all bitmaps. + (df_live_top_dump, df_live_bottom_dump): Do not dump old + data when not allocated. + (df_live_verify_solution_start): Do not allocate problem data. + (df_live_verify_solution_end): Check if out is allocated. + (struct df_md_problem_data): New structure. + (df_md_alloc): Allocate problem data. + (df_md_free): Free problem data; do not clear bitmaps. + +2010-06-10 Jan Beulich + + PR bootstrap/37304 + * configure.ac: Replace $() with ${} when intending to expand + variables rather than invoking commands. + * configure: Re-generate. + +2010-06-10 Jan Hubicka + + PR rtl-optimization/44460 + * emit-rtl.c (set_mem_attributes_minus_bitpos): Remove + TYPE_NEEDS_CONSTRUCTING sanity check. + +2010-06-10 Gerald Pfeifer + + * doc/include/fdl.texi: Move to GFDL version 1.3. + + * doc/cpp.texi: Move to GFDL version 1.3. + * doc/gcc.texi: Move to GFDL version 1.3. Fix copyright years. + * doc/gccint.texi: Move to GFDL version 1.3. + * doc/gcov.texi: Move to GFDL version 1.3. Update copyright years. + * doc/install.texi: Move to GFDL version 1.3. Fix copyright years. + * doc/invoke.texi: Move to GFDL version 1.3. + +2010-06-09 Jan Hubicka + + * ipa-pure-const.c (propagate_pure_const, propagate_noreturn): + Break out from ... + (propagate) ... here; swap the order. + +2010-06-09 Jan Hubicka + + * bitmap.c (bitmap_elt_insert_after, bitmap_first_set_bit, + bitmap_first_set_bit, bitmap_last_set_bit, bitmap_last_set_bit, + bitmap_and_into, bitmap_and_compl_into, bitmap_set_range, + bitmap_compl_and_into, bitmap_elt_ior): Use checking asserts. + +2010-06-09 Changpeng Fang + + * tree-ssa-loop-prefetch.c (gather_memory_references_ref): + Do not the gather memory reference in the outer loop if the step + is not a constant. + +2010-06-09 Changpeng Fang + + * tree-ssa-loop-prefetch.c (PREFETCH_MOD_TO_UNROLL_FACTOR_RATIO) : + Change the PREFETCH_MOD_TO_UNROLL_FACTOR_RATIO threshold value from + 8 to 4. Minor change of the related comments. + +2010-06-09 Sebastian Pop + + * tree-scalar-evolution.c (instantiate_scev_name): Do not fail + the scev analysis when the variable is not used outside the loop + in a close phi node: call compute_overall_effect_of_inner_loop. + +2010-06-09 Sebastian Pop + + * graphite-sese-to-poly.c (single_pred_cond): Renamed + single_pred_cond_non_loop_exit. Return NULL for loop exit edges. + (build_sese_conditions_before): Renamed call to single_pred_cond. + (build_sese_conditions_after): Same. + +2010-06-09 Sebastian Pop + + * graphite-poly.h: Fix comments and indentation. + * graphite-sese-to-poly.c: Same. + (build_sese_conditions_before): Compute stmt and gbb only when needed. + * tree-chrec.c: Fix comments and indentation. + (tree-ssa-loop-niter.c): Same. + +2010-06-09 Eric Botcazou + + PR rtl-optimization/42461 + * dce.c (deletable_insn_p): Return true for const or pure calls again. + * except.c (insn_could_throw_p): Return false if !flag_exceptions. + +2010-06-09 Jan Hubicka + + * bitmap.c (bitmap_and): Walk array forward. + (bitmap_and_compl_into): Likewise. + (bitmap_xor): Likewise. + (bitmap_xor_into): Likewise. + (bitmap_equal_p): Likewise. + (bitmap_intersect_p): Likewise. + (bitmap_intersect_compl_p): Likewise. + (bitmap_ior_and_into): Likewise. + (bitmap_elt_copy): Likewise. + (bitmap_and_compl): Likewise. + (bitmap_elt_ior): Likewise. + +2010-06-09 Dave Korn + + * opts-common.c (prune_options): Ensure replacement argv array + is correctly terminated by a NULL entry. + +2010-06-09 Jan Hubicka + + * cgraph.h (varpool_first_static_initializer, + varpool_next_static_initializer): Make checking only when + checking enabled. + * tree-vectorizer.h (vinfo_for_stmt): Remove check. + (set_vinfo_for_stmt, get_earlier_stmt, is_loop_header_bb_p): Change + gcc_assert to gcc_checking_assert. + * tree-flow-inline.h (gimple_vop, get_var_ann, relink_imm_use, + phi_nodes, set_phi_nodes, phi_arg_index_from_use, op_iter_next_use, + op_iter_next_def, op_iter_next_tree, op_iter_init, op_iter_init_use, + op_iter_init_phiuse, op_iter_init_phidef, + array_ref_contains_indirect_ref, ref_contains_array_ref): Use + gcc_checking_assert. + * emit-rtl.h (set_first_insn, set_last_insn): Likewise. + * tree-ssa-live.h (var_to_partition, var_to_partition_to_var, + partition_is_global, live_on_entry, live_on_exit, + live_merge_and_clear): Likewise. + * system.h (gcc_checking_assert): New macro. + * gimple.h (set_bb_seq): Use gcc_checking_assert. + +2010-06-09 Jason Merrill + + * Makefile.in (TAGS): Collect tags info from c-family. + +2010-06-09 Jan Hubicka + + * gimple.h (gcc_gimple_checking_assert): New macro. + (gimple_set_def_ops, gimple_set_use_ops, + gimple_set_vuse, gimple_set_vdef, + gimple_omp_subcode, gimple_omp_set_subcode, gimple_ops, gimple_op, + gimple_op_ptr, gimple_op_ptr, gimple_set_op, gimple_bind_set_block, + gimple_asm_input_op, gimple_asm_input_op_ptr, gimple_asm_set_input_op, + gimple_asm_output_op, gimple_asm_output_op_ptr, + gimple_asm_set_output_op, gimple_asm_clobber_op, + gimple_asm_set_clobber_op, gimple_asm_label_op, + gimple_asm_set_label_op, gimple_try_set_kind, + gimple_try_catch_is_cleanup, gimple_try_set_catch_is_cleanup, + gimple_phi_arg, gimple_switch_num_labels, gimple_switch_set_index, + gimple_switch_label, gimple_switch_set_label, gimple_omp_for_index, + gimple_omp_for_index_ptr, gimple_omp_for_set_index, + gimple_omp_for_initial, gimple_omp_for_initial_ptr, + gimple_omp_for_set_initial, gimple_omp_for_final, + gimple_omp_for_final_ptr, gimple_omp_for_set_final, + gimple_omp_for_incr, gimple_omp_for_incr_ptr, gimple_omp_for_set_incr, + gimple_omp_for_set_cond, gimple_omp_for_cond): Make checking + conditional with ENABLE_GIMPLE_CHECKING. + (gimple_phi_set_arg): Likewise; replace memcpy by assignment. + +2010-06-09 Sandra Loosemore + + * tree-ssa-loop-ivopts.c (adjust_setup_cost): New function. + (get_computation_cost_at): Use it. + (determine_use_iv_cost_condition): Likewise. + (determine_iv_cost): Likewise. + +2010-06-09 Richard Guenther + + * tree-ssa-loop-niter.c (simplify_replace_tree): Do not + replace constants. + +2010-06-09 Kai Tietz + + * c-objc-common.c (c_tree_printer): Pre-intialize t by NULL_TREE. + +2010-06-09 Martin Jambor + + PR tree-optimization/44423 + * tree-sra.c (dump_access): Dump also grp_assignment_read. + (analyze_access_subtree): Pass negative allow_replacements to children + if the current type is scalar. + +2010-06-09 Joern Rennecke + + PR testsuite/42843 + * gcc-plugin.h (int plugin_is_GPL_compatible): Declare as extern "C". + * doc/plugins.texi (Plugin license check): Update information + on type of plugin_is_GPL_compatible. + * Makefile.in (PLUGINCC): Define as $(COMPILER). + (PLUGINCFLAGS): Define as $(COMPILER_FLAGS). + +2010-06-09 Bernd Schmidt + + * config/arm/arm.c (thumb2_reorg): New function. + (arm_reorg): Call it. + * config/arm/thumb2.md (define_peephole2 for flag clobbering + arithmetic operations): Delete. + +2010-06-09 Edmar Wienskoski + + PR target/44067 + * config/rs6000/rs6000.md (DIFD): Do not split dpfp values for + e500v2 target. + +2010-06-09 Joern Rennecke + + PR plugins/44459 + * gcc-plugin.h: Encapsulate all declarations in extern "C". + +2010-06-08 Jan Hubicka + + * basic-block.h (single_succ_edge, single_pred_edge, ei_container, + ei_next, ei_prev): Do sanity checking with ENABLE_CHECKING only. + +2010-06-08 Sandra Loosemore + + PR tree-optimization/39874 + PR middle-end/28685 + * gimple.h (maybe_fold_and_comparisons, maybe_fold_or_comparisons): + Declare. + * gimple-fold.c (canonicalize_bool, same_bool_comparison_p, + same_bool_result_p): New. + (and_var_with_comparison, and_var_with_comparison_1, + and_comparisons_1, and_comparisons, maybe_fold_and_comparisons): New. + (or_var_with_comparison, or_var_with_comparison_1, + or_comparisons_1, or_comparisons, maybe_fold_or_comparisons): New. + * tree-ssa-reassoc.c (eliminate_redundant_comparison): Use + maybe_fold_and_comparisons or maybe_fold_or_comparisons instead + of combine_comparisons. + * tree-ssa-ifcombine.c (ifcombine_ifandif, ifcombine_iforif): Likewise. + +2010-06-08 Anatoly Sokolov + + * config/pdp11/pdp11.h (FUNCTION_VALUE, FUNCTION_OUTGOING_VALUE, + LIBCALL_VALUE, FUNCTION_VALUE_REGNO_P): Remove macros. + * config/pdp11/pdp11.c (pdp11_function_value, pdp11_libcall_value, + pdp11_function_value_regno_p): New functions. + (TARGET_FUNCTION_VALUE, TARGET_LIBCALL_VALUE, + TARGET_FUNCTION_VALUE_REGNO_P): Define. + +2010-06-08 Kazu Hirata + + * config/arm/arm.c (arm_rtx_costs_1): Don't special case for + Thumb-2 in the MINUS case. + +2010-06-08 Laurynas Biveinis + + * doc/tm.texi (Per-Function Data): Do not reference ggc_alloc. + + * doc/gty.texi (GTY Options): Document typed GC allocation and + variable_size GTY option. + + * ggc-internal.h: New. + + * ggc.h: Update copyright year. + (digit_string): Move to stringpool.c. + (ggc_mark_stringpool, ggc_purge_stringpool, ggc_mark_roots) + (gt_pch_save_stringpool, gt_pch_fixup_stringpool) + (gt_pach_restore_stringpool, gt_pch_p_S, gt_pch_note_object) + (init_ggc_pch, ggc_pch_count_object, ggc_pch_total_size) + (ggc_pch_this_base, ggc_pch_alloc_object, ggc_pch_prepare_write) + (ggc_pch_write_object, ggc_pch_finish, ggc_pch_read) + (ggc_force_collect, ggc_get_size, ggc_statistics) + (ggc_print_common_statistics): Move to ggc-internal.h. + (digit_vector, new_ggc_zone, destroy_ggc_zone, ggc_alloc_stat) + (ggc_alloc, ggc_alloc_cleared, ggc_realloc, ggc_calloc, GGC_NEW) + (GGC_CNEW, GGC_NEWVEC, GGC_CNEWVEC, GGC_NEWVAR, ggc_alloc_rtvec) + (ggc_alloc_tree, gt_pch_save, ggc_min_expand_heuristic) + (ggc_min_heapsize_heuristic, ggc_alloc_zone) + (ggc_alloc_zone_pass_stat): Remove. + (ggc_internal_alloc_stat, ggc_internal_alloc) + (ggc_internal_cleared_alloc_stat): New. + (GGC_RESIZEVEC, GGC_RESIZEVAR): Redefine. + (ggc_internal_vec_alloc_stat) + (ggc_internal_cleared_vec_alloc_stat) + (ggc_internal_vec_alloc_stat, ggc_internal_cleared_vec_alloc) + (ggc_alloc_atomic_stat, ggc_alloc_atomic) + (ggc_alloc_cleared_atomic, ggc_cleared_alloc_htab_ignore_args) + (ggc_cleared_alloc_ptr_array_two_args): New. + (htab_create_ggc, splay_tree_new_ggc): Redefine. + (ggc_splay_alloc): Change the type of the first argument to + enum gt_types_enum. + (ggc_alloc_string): Make macro. + (ggc_alloc_string_stat): New. + (ggc_strdup): Redefine. + (rtl_zone, tree_zone, tree_id_zone): Declare unconditionally. + (ggc_alloc_rtvec_sized): New. + (ggc_alloc_zone_stat): Rename to ggc_internal_alloc_zone_stat. + (ggc_internal_alloc_zone_pass_stat, ggc_internal_alloc_zone_stat) + (ggc_internal_cleared_alloc_zone_stat) + (ggc_internal_zone_alloc_stat) + (ggc_internal_zone_cleared_alloc_stat) + (ggc_internal_zone_vec_alloc_stat) + (ggc_alloc_zone_rtx_def_stat) + (ggc_alloc_zone_tree_node_stat) + (ggc_alloc_zone_cleared_tree_node_stat) + (ggc_alloc_cleared_gimple_statement_d_stat): New. + + * ggc-common.c: Include ggc-internal.h. + (ggc_internal_cleared_alloc_stat): Rename from + ggc_alloc_cleared_stat. + (ggc_realloc_stat): Use ggc_internal_alloc_stat. + (ggc_calloc): Remove. + (ggc_cleared_alloc_htab_ignore_args): New. + (ggc_cleared_alloc_ptr_array_two_args): New. + (ggc_splay_alloc): Add obj_type parameter. + (init_ggc_heuristics): Formatting fixes. + + * ggc-none.c: Update copyright year. + (ggc_alloc_stat): Rename to ggc_alloc_stat. + (ggc_alloc_cleared_stat): Rename to + ggc_internal_cleared_alloc_stat. + (struct alloc_zone, rtl_zone, tree_zone, tree_id_zone): New. + + * ggc-page.c: Update copyright year. Include ggc-internal.h. + Remove references to ggc_alloc in comments. + (ggc_alloc_typed_stat): Call ggc_internal_alloc_stat. + (ggc_alloc_stat): Rename to ggc_internal_alloc_stat. + (new_ggc_zone, destroy_ggc_zone): Remove. + (struct alloc_zone, rtl_zone, tree_zone, tree_id_zone): New. + + * ggc-zone.c: Include ggc-internal.h. Remove references to + ggc_alloc in comments. + (ggc_alloc_zone_stat): ggc_internal_alloc_zone_stat. + (ggc_internal_alloc_zone_pass_stat): New. + (ggc_internal_cleared_alloc_zone_stat): New. + (ggc_alloc_typed_stat): Use ggc_internal_alloc_zone_pass_stat. + (ggc_alloc_stat): Rename ggc_internal_alloc_stat. + (new_ggc_zone, destroy_ggc_zone): Remove. + + * stringpool.c: Update copyright year. Include ggc-internal.h + (digit_vector): Make static. + (digit_string): Moved from ggc.h. + (stringpool_ggc_alloc): Use ggc_alloc_atomic. + (ggc_alloc_string): Rename to ggc_alloc_string_stat. + + * Makefile.in (GGC_INTERNAL_H): New. + (ggc_common.o, ggc-page.o, ggc-zone.o, stringpool.o): Add + $(GGC_INTERNAL_H) to dependencies. + + * gentype.c: Update copyright year. + (walk_type): Accept variable_size GTY option. + (USED_BY_TYPED_GC_P): New macro. + (write_enum_defn): Use USED_BY_TYPED_GC_P. Do not output + whitespace at the end of strings. + (get_type_specifier, variable_size_p): New functions. + (alloc_quantity, alloc_zone): New enums. + (write_typed_alloc_def): New function. + (write_typed_struct_alloc_def): Likewise. + (write_typed_typed_typedef_alloc_def): Likewise. + (write_typed_alloc_defns): Likewise. + (output_typename, write_splay_tree_allocator_def): Likewise. + (write_splay_tree_allocators): Likewise. + (main): Call write_typed_alloc_defns and + write_splay_tree_allocators. + + * lto-streamer.h (lto_file_decl_data_ptr): New. + + * passes.c (order): Define using cgraph_node_ptr. + + * strinpool.c (struct string_pool_data): Declare nested_ptr using + ht_identifier_ptr. + + * gimple.h (union gimple_statement_d): Likewise. + + * rtl.h (struct rtx_def): Likewise. + (struct rtvec_def): Likewise. + + * tree.h (union tree_node): Likewise. + + * tree-ssa-operands.h (struct ssa_operand_memory_d): Likewise. + + * cfgloop.c (record_loop_exits): Use htab_create_ggc. + + * tree-scalar-evolution.c (scev_initialize): Likewise. + + * alias.c (record_alias_subset): Update splay_tree_new_ggc call. + + * dwarf2asm.c (dw2_force_const_mem): Likewise. + + * omp-low.c (lower_omp_critical): Likewise. + + * bitmap.h (struct bitmap_head_def): Update comment to not + reference ggc_alloc. + + * config/pa/pa.c (get_deferred_label): Use GGC_RESIZEVEC. + + * ira.c (fix_reg_equiv_init): Use GGC_RESIZEVEC. + + * ipa-prop.c (duplicate_ggc_array): Rename to + duplicate_ipa_jump_func_array. Use typed GC allocation. + (ipa_edge_duplication_hook): Call duplicate_ipa_jump_func_array. + + * gimple.c (gimple_alloc_stat): Use + ggc_alloc_cleared_gimple_statement_d_stat. + + * varasm.c (create_block_symbol): Use ggc_alloc_zone_rtx_def. + + * tree.c (make_node_stat): Use + ggc_alloc_zone_cleared_tree_node_stat. + (make_tree_vec_stat): Likewise. + (build_vl_exp_stat): Likewise. + (copy_node_stat): Use ggc_alloc_zone_tree_node_stat. + (make_tree_binfo_stat): Likewise. + (tree_cons_stat): Likewise. + + * rtl.c (rtx_alloc_stat): Use ggc_alloc_zone_rtx_def_stat. + (shallow_copy_rtx_stat): Likewise. + (make_node_stat): Likewise. + + * lto-symtab.c: Fix comment. + + * tree-cfg.c (create_bb): Update comment to not reference + ggc_alloc_cleared. + * tree-ssa-structalias.c (struct heapvar_for_stmt): Fix param_is value. + + * varpool.c (varpool_node): Use typed GC allocation. + (varpool_extra_name_alias): Likewise. + + * varasm.c (emutls_decl): Likewise. + (get_unnamed_section): Likewise. + (get_noswitch_section): Likewise. + (get_section): Likewise. + (get_block_for_section): Likewise. + (build_constant_desc): Likewise. + (create_constant_pool): Likewise. + (force_const_mem): Likewise. + + * tree.c (build_vl_exp_stat): Likewise. + (build_real): Likewise. + (build_string): Likewise. + (decl_debug_expr_insert): Likewise. + (decl_value_expr_insert): Likewise. + (type_hash_add): Likewise. + (build_omp_clause): Likewise. + + * tree-ssanames.c (duplicate_ssa_name_ptr_info): Likewise. + + * tree-ssa.c (init_tree_ssa): Likewise. + + * tree-ssa-structalias.c (heapvar_insert): Likewise. + + * tree-ssa-operands.c (ssa_operand_alloc): Likewise. + + * tree-ssa-loop-niter.c (record_estimate): Likewise. + + * tree-ssa-alias.c (get_ptr_info): Likewise. + + * tree-scalar-evolution.c (new_scev_info_str): Likewise. + + * tree-phinodes.c (allocate_phi_node): Likewise. + + * tree-iterator.c (tsi_link_before): Likewise. + (tsi_link_after): Likewise. + + * tree-eh.c (add_stmt_to_eh_lp_fn): Likewise. + + * tree-dfa.c (create_var_ann): Likewise. + + * tree-cfg.c (create_bb): Likewise. + + * toplev.c (alloc_for_identifier_to_locale): Likewise. + (general_init): Likewise. + + * stringpool.c (stringpool_ggc_alloc): Likewise. + (gt_pch_save_stringpool): Likewise. + + * sese.c (if_region_set_false_region): Likewise. + + * passes.c (do_per_function_toporder): Likewise. + + * optabs.c (set_optab_libfunc): Likewise. + (set_conv_libfunc): Likewise. + + * lto-symtab.c (lto_symtab_register_decl): Likewise. + + * lto-streamer-in.c (lto_input_eh_catch_list): Likewise. + (input_eh_region): Likewise. + (input_eh_lp): Likewise. + (make_new_block): Likewise. + (unpack_ts_real_cst_value_fields): Likewise. + + * lto-section-in.c (lto_new_in_decl_state): Likewise. + + * lto-cgraph.c (input_node_opt_summary): Likewise. + + * loop-init.c (loop_optimizer_init): Likewise. + + * lambda.h (lambda_vector_new): Likewise. + + * lambda-code.c (replace_uses_equiv_to_x_with_y): Likewise. + + * ira.c (update_equiv_regs): Likewise. + + * ipa.c (cgraph_node_set_new): Likewise. + (cgraph_node_set_add): Likewise. + (varpool_node_set_new): Likewise. + (varpool_node_set_add): Likewise. + + * ipa-prop.c (ipa_compute_jump_functions_for_edge): Likewise. + (duplicate_ipa_jump_func_array): Likewise. + (ipa_read_node_info): Likewise. + + * ipa-cp.c (ipcp_create_replace_map): Likewise. + + * integrate.c (get_hard_reg_initial_val): Likewise. + + * gimple.c (gimple_alloc_stat): Likewise. + (gimple_build_omp_for): Likewise. + (gimple_seq_alloc): Likewise. + (gimple_copy): Likewise. + + * gimple-iterator.c (gsi_insert_before_without_update): Likewise. + (gsi_insert_after_without_update): Likewise. + + * function.c (add_frame_space): Likewise. + (insert_temp_slot_address): Likewise. + (assign_stack_temp_for_type): Likewise. + (allocate_struct_function): Likewise. + (types_used_by_var_decl_insert): Likewise. + + * except.c (init_eh_for_function): Likewise. + (gen_eh_region): Likewise. + (gen_eh_region_catch): Likewise. + (gen_eh_landing_pad): Likewise. + (add_call_site): Likewise. + + * emit-rtl.c (get_mem_attrs): Likewise. + (get_reg_attrs): Likewise. + (start_sequence): Likewise. + (init_emit): Likewise. + + * dwarf2out.c (new_cfi): Likewise. + (queue_reg_save): Likewise. + (dwarf2out_frame_init): Likewise. + (new_loc_descr): Likewise. + (find_AT_string): Likewise. + (new_die): Likewise. + (add_var_loc_to_decl): Likewise. + (clone_die): Likewise. + (clone_as_declaration): Likewise. + (break_out_comdat_types): Likewise. + (new_loc_list): Likewise. + (loc_descriptor): Likewise. + (add_loc_descr_to_each): Likewise. + (add_const_value_attribute): Likewise. + (tree_add_const_value_attribute): Likewise. + (add_comp_dir_attribute): Likewise. + (add_name_and_src_coords_attributes): Likewise. + (lookup_filename): Likewise. + (store_vcall_insn): Likewise. + (dwarf2out_init): Likewise. + + * dbxout.c (dbxout_init): Likewise. + + * config/xtensa/xtensa.c (xtensa_init_machine_status): Likewise. + + * config/sparc/sparc.c (sparc_init_machine_status): Likewise. + + * config/score/score7.c (score7_output_external): Likewise. + + * config/score/score3.c (score3_output_external): Likewise. + + * config/s390/s390.c (s390_init_machine_status): Likewise. + + * config/rs6000/rs6000.c (builtin_function_type): Likewise. + (rs6000_init_machine_status): Likewise. + (output_toc): Likewise. + + * config/pa/pa.c (pa_init_machine_status): Likewise. + (get_deferred_plabel): Likewise. + + * config/moxie/moxie.c (moxie_init_machine_status): Likewise. + + * config/mmix/mmix.c (mmix_init_machine_status): Likewise. + + * config/mips/mips.c (mflip_mips16_use_mips16_p): Likewise. + + * config/mep/mep.c (mep_init_machine_status): Likewise. + (mep_note_pragma_flag): Likewise. + + * config/m32c/m32c.c (m32c_init_machine_status): Likewise. + + * config/iq2000/iq2000.c (iq2000_init_machine_status): Likewise. + + * config/ia64/ia64.c (ia64_init_machine_status): Likewise. + + * config/i386/winnt.c (i386_pe_record_external_function): Likewise. + (i386_pe_maybe_record_exported_symbol): Likewise. + + * config/i386/i386.c (get_dllimport_decl): Likewise. + (ix86_init_machine_status): Likewise. + (assign_386_stack_local): Likewise. + + * config/frv/frv.c (frv_init_machine_status): Likewise. + + * config/darwin.c (machopic_indirection_name): Likewise. + + * config/cris/cris.c (cris_init_machine_status): Likewise. + + * config/bfin/bfin.c (bfin_init_machine_status): Likewise. + + * config/avr/avr.c (avr_init_machine_status): Likewise. + + * config/arm/arm.c (arm_init_machine_status): Likewise. + + * config/alpha/alpha.c (alpha_init_machine_status): Likewise. + (alpha_need_linkage): Likewise. + (alpha_use_linkage): Likewise. + + * cgraph.c (cgraph_allocate_node): Likewise. + (cgraph_create_edge_1): Likewise. + (cgraph_create_indirect_edge): Likewise. + (cgraph_add_asm_node): Likewise. + + * cfgrtl.c (init_rtl_bb_info): Likewise. + + * cfgloop.c (alloc_loop): Likewise. + (rescan_loop_exit): Likewise. + + * cfg.c (init_flow): Likewise. + (alloc_block): Likewise. + (unchecked_make_edge): Likewise. + + * c-parser.c (c_parse_init): Likewise. + (c_parse_file): Likewise. + + * c-decl.c (bind): Likewise. + (record_inline_static): Likewise. + (push_scope): Likewise. + (make_label): Likewise. + (lookup_label_for_goto): Likewise. + (finish_struct): Likewise. + (finish_enum): Likewise. + (c_push_function_context): Likewise. + + * bitmap.c (bitmap_element_allocate): Likewise. + (bitmap_gc_alloc_stat): Likewise. + + * alias.c (record_alias_subset): Likewise. + (init_alias_analysis): Likewise. + +2010-06-08 Shujing Zhao + + * fold-const.c (fold_comparison): Remove redundant parenthesis. + * tree-inline.c (expand_call_inline): Pass translated return value of + cgraph_inline_failed_string to diagnostic function. + +2010-06-08 Andrew Pinski + Shujing Zhao + + PR c/37724 + * c-typeck.c (convert_for_assignment): Call pedwarn_init if the + implicit bad conversions is initialization. + (error_init): Use gmsgid instead of msgid for argument name and change + the call for error. + (pedwarn_init): Use gmsgid instead of msgid for argument name and + change the call for pedwarn. + (warning_init): Use gmsgid instead of msgid for argument name and + change the call for warning. + +2010-06-07 Nathan Froyd + + * config/mips/mips-protos.h (mips_print_operand): Delete. + (mips_print_operand_address): Delete. + * config/mips/mips.h (mips_print_operand_punct): Delete. + (PRINT_OPERAND): Delete. + (PRINT_OPERAND_PUNCT_VALID_P): Delete. + (PRINT_OPERAND_ADDRESS): Delete. + * config/mips/mips.c (mips_print_operand_punct): Make static. + (mips_print_operand_address): Make static. + (mips_print_operand): Make static. Call + mips_print_operand_punct_valid_p. + (mips_print_operand_punct_valid_p): New function. + (TARGET_PRINT_OPERAND, TARGET_PRINT_OPERAND_ADDRESS): Define. + (TARGET_PRINT_OPERAND_PUNCT_VALID_P): Define. + +2010-06-07 Jan Hubicka + + PR middle-end/44454 + (df_lr_top_dump, df_lr_bottom_dump): Check that in/out bitmaps + are allocated. + +2010-06-07 Kaz Kojima + + * config/sh/sh.c (sh_build_builtin_va_list): Set tree type + name of RECORD. + +2010-06-07 Rainer Orth + + * doc/sourcebuild.texi (Effective-Target Keywords, Other + attributes): Document gas. + +2010-06-07 Uros Bizjak + + * config/i386/i386.md (*add_1): Remove alternative 2. + : Split instruction. + : Remove alternative 2 handling. + (*addsi_1_zext) : Split instruction. + (add lea splitter): Generate SImode lea for mode sizes <= SImode. + (add_zext lea splitter): Use ix86_lea_for_add_ok in insn predicate. + + (*movsi_1) : Use %a modifier to output operand 1. + (ashift_zext lea splitter): Use DImode for multiplication. + + * config/i386/i386.c (ix86_expand_epilogue): Do not use ix86_gen_add + to generate addition. + +2010-06-07 Joseph Myers + + * common.opt (fira-verbose): Use Var. + (fpcc-struct-return): Use Init instead of VarExists. + * defaults.h (DEFAULT_PCC_STRUCT_RETURN): Move definition from + toplev.c. + * flags.h (flag_signed_char, flag_short_enums, + flag_pcc_struct_return, flag_ira_verbose, + flag_detailed_statistics, flag_remove_unreachable_functions): Remove. + * toplev.c (flag_detailed_statistics, flag_signed_char, + flag_short_enums, flag_pcc_struct_return, flag_ira_verbose): Remove. + (DEFAULT_PCC_STRUCT_RETURN): Move definition to defaults.h. + * toplev.h (flag_crossjumping, flag_if_conversion, + flag_if_conversion2, flag_keep_static_consts, flag_peel_loops, + flag_rerun_cse_after_loop, flag_thread_jumps, flag_tracer, + flag_unroll_loops, flag_unroll_all_loops, flag_unswitch_loops, + flag_cprop_registers, time_report, flag_ira_loop_pressure, + flag_ira_coalesce, flag_ira_move_spills, + flag_ira_share_save_slots, flag_ira_share_spill_slots): Remove. + +2010-06-07 Jan Hubicka + + * df-core.c (df_analyze_problem): Do verification after allocation. + + * df-problems.c (df_lr_problem_data): Add lr_bitmaps. + (df_lr_alloc): Initialize problem data; move bitmaps to + lr_bitmaps obstack. + (df_lr_finalize): Free problem data; do not bother to free bitmaps. + (df_lr_verify_solution_start): Do not initialize problem data; + allocate bitmaps in lr_bitmaps. + (df_lr_verify_solution_end): Do not free problem data. + +2010-06-07 Jan Hubicka + + * cgraph.c (cgraph_edge_cannot_lead_to_return): Also check + if caller is noreturn. + * ipa-reference.c (analyze_function): Use ipa_ref_cannot_lead_to_return + * ipa-ref.h (ipa_ref_cannot_lead_to_return): New function. + * ipa-ref.c (ipa_ref_cannot_lead_to_return): New function. + * ipa-pure-const.c (check_decl): Add IPA parameter. + (state_from_flags): New function. + (better_state, worse_state): New functions. + (check_call): When in IPA mode, do not care about callees. + (check_load, check_store): Update. + (check_ipa_load, check_ipa_store): New. + (check_stmt): When in IPA mode, use IPA checkers. + (analyze_function): Use state_from_flags. + (propagate): Check indirect edges and references. + +2010-06-07 Kazu Hirata + + PR rtl-optimization/44404 + * auto-inc-dec.c (find_inc): Use reg_overlap_mentioned_p instead + of count_occurrences to see if it's safe to modify mem_insn. + +2010-06-07 Richard Guenther + + * gimplify.c (gimplify_cleanup_point_expr): For empty body + and EH-only cleanup drop the cleanup instead of inserting it + unconditionally. + +2010-06-07 Ira Rosen + + * doc/tm.texi (TARGET_VECTORIZE_BUILTIN_VECTORIZATION_COST): Update + documentation. + * targhooks.c (default_builtin_vectorization_cost): New function. + * targhooks.h (default_builtin_vectorization_cost): Declare. + * target.h (enum vect_cost_for_stmt): Define. + (builtin_vectorization_cost): Change argument and comment. + * tree-vectorizer.h: Remove cost model macros. + * tree-vect-loop.c: Include target.h. + (vect_get_cost): New function. + (vect_estimate_min_profitable_iters): Replace cost model macros with + calls to vect_get_cost. + (vect_model_reduction_cost, vect_model_induction_cost): Likewise. + * target-def.h (TARGET_VECTORIZE_BUILTIN_VECTORIZATION_COST): Add + default implementation. + * tree-vect-stmts.c (cost_for_stmt): Replace cost model macros with + calls to target hook builtin_vectorization_cost. + (vect_model_simple_cost, vect_model_store_cost, vect_model_load_cost): + Likewise. + * Makefile.in (tree-vect-loop.o): Add dependency on TARGET_H. + * config/spu/spu.c (spu_builtin_vectorization_cost): Replace with new + implementation to return costs. + * config/i386/i386.c (ix86_builtin_vectorization_cost): Likewise. + * config/spu/spu.h: Remove vectorizer cost model macros. + * config/i386/i386.h: Likewise. + * tree-vect-slp.c (vect_build_slp_tree): Replace cost model macro with + a call to target hook builtin_vectorization_cost. + +2010-06-06 Sriraman Tallam + + PR target/44319 + * config/i386/i386.c (override_options): Turn zee pass on for level 2 + and above and defer till target is known. + (optimization_options): Turn on zee pass if TARGET_64BIT is set and + turn off otherwise. + +2010-05-25 Jan Hubicka + + * df-core.c (df_set_blocks): Use bitmap_head instead of bitmap. + (df_compact_blocks): Likewise. + * df.h (struct df): Turn hardware_regs_used, + regular_block_artificial_uses, eh_block_artificial_uses, + insns_to_delete, insns_to_rescan, insns_to_notes_rescan into + bitmap_head. + * df-problems.c (df_lr_local_compute, df_lr_confluence_0, + df_byte_lr_alloc, df_simulate_fixup_sets): Update. + * df-scan.c (df_scan_free_internal, df_scan_alloc, df_scan_start_dump, + df_scan_blocks, df_insn_delete, df_insn_rescan, + df_insn_rescan_debug_internal, df_insn_rescan_all, + df_process_deferred_rescans, df_process_deferred_rescans, + df_notes_rescan, df_get_call_refs, df_get_call_refs, + regs_invalidated_by_call_regset, df_get_call_refs, df_bb_refs_collect, + df_record_entry_block_defs, df_record_exit_block_uses, + df_update_exit_block_uses, df_bb_verify, df_entry_block_bitmap_verify, + df_scan_verify): Update. + +2010-05-25 Dodji Seketeli + + PR c++/44188 + * c-common.c (is_typedef_decl): Move this definition ... + * tree.c (is_typedef_decl): ... here. + (typdef_variant_p): Move definition here from gcc/cp/tree.c. + * c-common.h (is_typedef_decl): Move this declaration ... + * tree.h (is_typedef_decl): ... here. + (typedef_variant_p): Move declaration here from gcc/cp/cp-tree.h + * dwarf2out.c (is_naming_typedef_decl): New function. + (gen_tagged_type_die): Split out of ... + (gen_type_die_with_usage): ... this function. When an anonymous + tagged type is named by a typedef, make sure a DW_TAG_typedef DIE + is emitted for the typedef. + (gen_typedef_die): Emit DW_TAG_typedef also for typedefs naming + anonymous tagged types. + +2010-06-06 Manuel López-Ibáñez + + PR c/20000 + * c-decl.c (grokdeclarator): Delete warning. + +2010-06-06 Eric Botcazou + + * stor-layout.c (self_referential_size): Set UNKNOWN_LOCATION on the + newly built CALL_EXPR. + * tree-profile.c (tree_profiling): Don't profile functions produced + for built-in stuff. + +2010-06-06 Segher Boessenkool + + PR bootstrap/44427 + PR bootstrap/44428 + * genautomata.c (SET_BIT, CLEAR_BIT, TEST_BIT): Make these macros + endianness-independent. + +2010-06-05 Steven Bosscher + + * c-common.c: Move to c-family/. + * c-common.def: Likewise. + * c-common.h: Likewise. + * c-cppbuiltin.c: Likewise. + * c-dump.c: Likewise. + * c-format.c: Likewise. + * c-format.h : Likewise. + * c-gimplify.c: Likewise. + * c-lex.c: Likewise. + * c-omp.c: Likewise. + * c.opt: Likewise. + * c-opts.c: Likewise. + * c-pch.c: Likewise. + * c-ppoutput.c: Likewise. + * c-pragma.c: Likewise. + * c-pragma.h: Likewise. + * c-pretty-print.c: Likewise. + * c-pretty-print.h: Likewise. + * c-semantics.c: Likewise. + * stub-objc.c: Likewise. + + * gengtype.c (get_file_langdir): Special-case files in c-family/. + (get_output_file_with_visibility): Fix name for c-common.h. + * c-config-lang.in: Update paths in gtfiles for files in c-family/. + + * c-tree.h: Update include path for moved files. + * c-lang.c: Likewise. + * c-lang.h: Likewise. + * c-parser.c: Likewise. + * c-convert.c: Likewise. + * c-decl.c: Likewise. + * c-objc-common.c: Likewise. + * configure.ac: Make sure c-family/ exists in the build directory. + * configure: Regenerate. + * Makefile.in: Update paths for moved files. Regroup files per + location and update dependencies. Move generated_files down after + ALL_GTFILES_H. + + * config/spu/spu-c.c: Update paths for moved files. + * config/mep/mep-pragma.c: Likewise. + * config/darwin-c.c: Likewise. + * config/i386/msformat-c.c: Likewise. + * config/i386/i386-c.c: Likewise. + * config/avr/avr-c.c: Likewise. + * config/sol2-c.c: Likewise. + * config/ia64/ia64-c.c: Likewise. + * config/rs6000/rs6000-c.c: Likewise. + * config/arm/arm.c: Likewise. + * config/arm/arm-c.c: Likewise. + * config/h8300/h8300.c: Likewise. + * config/v850/v850-c.c: Likewise. + + * config/t-darwin: Fix dependencies for moved files. + * config/t-sol2: Fix dependencies for moved files. + * config/mep/t-mep: Fix dependencies for moved files. + * config/ia64/t-ia64: Fix dependencies for moved files. + * config/rs6000/t-rs6000: Fix dependencies for moved files. + * config/v850/t-v850: Fix dependencies for moved files. + * config/v850/t-v850e: Fix dependencies for moved files. + + * config/m32c/m32c-pragma.c + + * po/exgettext: Look in c-family/ also. + +2010-06-05 Eric Botcazou + + * tree-ssa-dce.c (mark_last_stmt_necessary): New function. + (mark_control_dependent_edges_necessary): Call it instead of marking + the last statement manually. + (propagate_necessity): Likewise. + +2010-06-05 Jan Hubicka + + * basic-block.h (compute_dominance_frontiers): Updated. + (compute_idf): Likewise. + + * tree-into-ssa.c (insert_phi_nodes): Use bitmap heads + for dominance frontiers. + (rewrite_into_ssa): Update for bitmap heads in dominance frontiers. + (insert_updated_phi_nodes_for): Likewise. + (update_ssa): Likewise. + * cfganal.c (compute_dominance_frontiers_1): Likewise. + (compute_dominance_frontiers): Likewise. + (compute_idf): Likewise. + * df-problems.c (df_md_local_compute): Likewise. + +2010-06-05 Anatoly Sokolov + + * target.h (struct gcc_target): Add memory_move_cost field. + * target-def.h (TARGET_MEMORY_MOVE_COST): New. + (TARGET_INITIALIZER): Use TARGET_MEMORY_MOVE_COST. + * targhooks.c (default_memory_move_cost): New function. + * targhooks.h (default_memory_move_cost): Declare function. + * reload.h (memory_move_cost): Declare. + (memory_move_secondary_cost): Change type of 'in' argument to bool. + * reginfo.c (memory_move_cost): New function. + (memory_move_secondary_cost): Change type of 'in' argument to bool. + * ira.h (ira_memory_move_cost): Update comment. + * ira.c: (ira_memory_move_cost): Update comment. + (setup_class_subset_and_memory_move_costs): Replace MEMORY_MOVE_COST + with memory_move_cost. + * postreload.c (reload_cse_simplify_set): (Ditto.). + * reload1.c (choose_reload_regs): (Ditto.). + * doc/tm.texi (TARGET_MEMORY_MOVE_COST): New. + (MEMORY_MOVE_COST): Revise documentation. + + * config/i386/i386.h (MEMORY_MOVE_COST): Remove macro. + * config/i386/i386-protos.h (int ix86_memory_move_cost): Remove. + * config/i386/i386.h (ix86_memory_move_cost): Make static. Change + type of 'in' argument to bool. + (TARGET_MEMORY_MOVE_COST): Define. + +2010-06-05 Jan Hubicka + + * ipa-pure-const.c (propagate): Fix typo in handling of functions + that cannot return. Be more careful when merging the results with + previously known ones. + +2010-06-05 Matthias Klose + + * gcc.c (cc1_options, cpp_unique_options): Use find-plugindir spec + function to add the -iplugindir option. + (find_plugindir_spec_function): Add new declaration and function. + (static_spec_func): Use it for "find-plugindir". + +2010-06-05 Jakub Jelinek + + PR c++/44361 + * c-typeck.c (mark_exp_read): Handle C_MAYBE_CONST_EXPR. + * c-parser.c (c_parser_postfix_expression): Call mark_exp_read on + statement expression. + +2010-06-05 Jan Hubicka + + * df-problems.c (seen_in_block, seen_in_insn): Convert to bitmap_head. + (df_rd_problem_data): Convert sparse_invalidated_by_call, + dense_invalidated_by_call to bitmap head. + (df_rd_alloc, df_rd_bb_local_compute_process_def, + df_rd_bb_local_compute, df_rd_confluence_n, df_rd_transfer_function, + df_rd_start_dump, df_lr_verify_transfer_functions, + df_live_verify_transfer_functions, df_chain_create_bb, + df_chain_add_problem, df_byte_lr_check_regs, df_byte_lr_alloc, + df_byte_lr_confluence_0, df_byte_lr_confluence_n, df_note_compute, + df_simulate_one_insn_forwards, df_md_alloc, + df_md_bb_local_compute_process_def, + df_md_bb_local_compute_process_def, df_md_local_compute, + df_md_transfer_function df_md_free): Update. + +2010-06-05 Joseph Myers + + PR c/44322 + * c-typeck.c (build_unary_op): Merge qualifiers into pointer + target type for ADDR_EXPR; require no changes to qualifiers except + for function types. + * c-tree.h (c_build_type_variant): Remove. + +2010-06-05 Segher Boessenkool + + * genautomata.c (get_excl_set): Do work per element, not per char. + (check_presence_pattern_sets): Similar. + (check_absence_pattern_sets): Similar. + +2010-06-05 Segher Boessenkool + + * genautomata.c (curr_state_pass_num): Delete. + (min_issue_delay_pass_states): Delete. + (min_issue_delay): Delete. + (initiate_min_issue_delay_pass_states): Delete. + (output_min_issue_delay_table): Compute min_issue_delay_vect + using a breadth-first search variant. + (output_tables): Don't call initiate_min_issue_delay_pass_states. + +2010-06-04 H.J. Lu + + PR boostrap/44421 + * df-problems.c (df_lr_bb_local_compute): Updated for embedded bitmaps. + (df_byte_lr_bb_local_compute): Likewise. + +2010-06-03 Jason Merrill + + Implement noexcept operator (5.3.7) + * c-common.c (c_common_reswords): Add noexcept. + * c-common.h (enum rid): Add RID_NOEXCEPT. + +2010-06-04 Joseph Myers + + * config/darwin-driver.c (darwin_default_min_version): Use + GCC-specific formats in diagnostics. + * cppspec.c (lang_specific_driver): Use GCC-specific formats in + diagnostics. + * gcc.c (translate_options, read_specs, add_sysrooted_prefix, + execute, process_command, end_going_arg, do_self_spec, do_spec_1, + eval_spec_function, handle_braces, process_brace_body, main, + perror_with_name, used_arg, set_multilib_dir, print_multilib_info, + getenv_spec_function, compare_version_strings, + version_compare_spec_function): Use GCC-specific formats in + diagnostics. + +2010-06-04 Uros Bizjak + + * config/i386/i386.md (*addhi_1_lea) : Assert + that operand 0 and operand 1 are equal. + (*addqi_1_lea) : Ditto. + (*add_2) : Remove assert that operand 0 + and operand 1 are equal. + : Ditto. Remove ??? comment. + (*add_3) : Remove assert that operand 0 + and operand 1 are equal. + : Ditto. Remove ??? comment. + (*adddi_4) : Remove assert that operand 0 and operand 1 + are equal. + (*add_4) : Ditto. + (*add_5) : Ditto. + +2010-06-04 Nathan Froyd + + * config/i386/i386-protos.h (ix86_print_operand): Declare. + * config/i386/i386.c (ix86_print_operand): Make non-static. + * config/i386/sol2.h (ASM_OUTPUT_CALL): Call ix86_print_operand. + * output.h (output_operand): Declare. + * final.c (output_operand): Make non-static. + +2010-06-04 Alexandre Oliva + + PR rtl-optimization/44013 + * sched-deps.c (add_dependence_list_and_free): Don't free lists + when processing debug insns. + + PR debug/41371 + * var-tracking.c (find_loc_in_1pdv): Mark initial value before + recursing. Check that recursion is bounded. Rename inner var + to avoid hiding incoming argument. + +2010-06-04 Uros Bizjak + + * config/i386/i386.md (*addqi_2) : Do not assert that + operands[2] == 255. + (*addqi_3): Ditto. + (*addqi_4): Ditto. + (*addqi_5): Ditto. + (*addqi_ext_1_rex64): Ditto. + (*addqi_ext_1): Ditto. + + (*addqi_4): Check for incdec_operand in QImode. + + (*add_2): Macroize insn from *add_2 and *add{qi,hi}_2 + using SWI mode iterator. + (*add_3): Ditto from *add_3 and *add{qi,hi}_3. + (*add_4): Macroize insn from *add{qi,hi,si}_4 using SWI124 + mode iterator. + (*add_5): Macroize insn from *add_5 and *add{qi,hi}_5 + using SWI mode iterator. + +2010-06-04 Manuel López-Ibáñez + + PR c/25880 + * c-objc-common.c (c_tree_printer): Handle %V, %v and %#v. + * c-format.c (gcc_diag_flag_specs): Add hash. + (gcc_cxxdiag_flag_specs): Use gcc_diag_flag_specs directly. + (gcc_tdiag_char_table,gcc_cdiag_char_table): Handle %V and %v. + * c-pretty-print.c (pp_c_cv_qualifier): Rename as + pp_c_cv_qualifiers. Handle qualifiers spelling here. + (pp_c_type_qualifier_list): Call the function above. + * c-pretty-print.h (pp_c_cv_qualifiers): Declare. + * c-typeck.c (handle_warn_cast_qual): Print qualifiers. + (WARN_FOR_QUALIFIERS): New macro. + (convert_for_assignment): Use it. + +2010-06-04 Kai Tietz + + * config/i386/cygming.h (ASM_GENERATE_INTERNAL_LABEL): Prefix by '*'. + +2010-06-04 Jan Hubicka + + * df.h (df_rd_bb_info, df_md_bb_info, df_lr_bb_info, df_live_bb_info, + df_byte_lr_bb_info): Embedd bitmap_head into the structure. + (DF_LIVE_IN, DF_LIVE_OUT, DF_LR_IN, DF_LR_OUT, DF_BYTE_LR_IN, + DF_BYTE_LR_OUT): Update for embedded bitmaps. + * fwprop.c (single_def_use_enter_block): Likewise. + * ddg.c (create_ddg_dep_from_intra_loop_link, + add_cross_iteration_register_deps, build_inter_loop_deps): Likewise. + * loop-iv.c (latch_dominating_def): Likewise. + * df-problems.c (df_rd_free_bb_info, df_rd_alloc, + df_rd_bb_local_compute_process_def, df_rd_bb_local_compute_process_def, + df_rd_init_solution, df_rd_init_solution, df_rd_transfer_function, + df_rd_transfer_function, df_rd_top_dump, + df_rd_bottom_dump): Update. + (df_lr_free_bb_info, df_lr_alloc, df_lr_reset, df_lr_bb_local_compute, + df_lr_bb_local_compute, df_lr_bb_local_compute, df_lr_bb_local_compute, + df_lr_bb_local_compute, df_lr_local_compute, df_lr_init, df_lr_init, + df_lr_confluence_0, df_lr_free, df_lr_top_dump, df_lr_bottom_dump, + df_lr_verify_solution_start, df_lr_verify_solution_end, + df_lr_verify_transfer_functions, df_lr_verify_transfer_functions, + df_live_free_bb_info, df_live_alloc, df_live_reset, + df_live_bb_local_compute, df_live_init, df_live_transfer_function, + df_live_finalize, df_live_free, df_live_top_dump, df_live_bottom_dump, + df_live_verify_solution_start, df_live_verify_solution_end, + df_live_verify_transfer_functions, df_chain_create_bb, + df_byte_lr_free_bb_info, df_byte_lr_alloc, df_byte_lr_reset, + df_byte_lr_bb_local_compute, df_byte_lr_bb_local_compute, + df_byte_lr_bb_local_compute, df_byte_lr_bb_local_compute, + df_byte_lr_bb_local_compute, df_byte_lr_local_compute, df_byte_lr_init, + df_byte_lr_confluence_0, df_byte_lr_confluence_n, + df_byte_lr_transfer_function, df_byte_lr_top_dump, + df_byte_lr_bottom_dump, df_create_unused_note, + df_note_bb_compute, df_md_free_bb_info, df_md_alloc, + df_md_bb_local_compute_process_def, df_md_local_compute, df_md_reset, + df_md_transfer_function, df_md_init, df_md_confluence_0, + df_md_confluence_n, + df_md_top_dump, df_md_bottom_dump): Update. + (struct df_lr_problem_data): Embedd bitmap headers. + +2010-06-04 Jan Hubicka + + * dce.c (dce_process_block): Do not re-scan already marked + instructions. + +2010-06-04 Bernd Schmidt + + PR rtl-optimization/39871 + PR rtl-optimization/40615 + PR rtl-optimization/42500 + PR rtl-optimization/42502 + * ira.c (init_reg_equiv_memory_loc: New function. + (ira): Call it twice. + * reload.h (calculate_elim_costs_all_insns): Declare. + * ira-costs.c: Include "reload.h". + (regno_equiv_gains): New static variable. + (init_costs): Allocate it. + (finish_costs): Free it. + (ira_costs): Call calculate_elim_costs_all_insns. + (find_costs_and_classes): Take estimated elimination costs + into account. + (ira_adjust_equiv_reg_cost): New function. + * ira.h (ira_adjust_equiv_reg_cost): Declare it. + * reload1.c (init_eliminable_invariants, free_reg_equiv, + elimination_costs_in_insn, note_reg_elim_costly): New static functions. + (elim_bb): New static variable. + (reload): Move code out of here into init_eliminable_invariants and + free_reg_equiv. Call them. + (calculate_elim_costs_all_insns): New function. + (eliminate_regs_1): Declare. Add extra arg FOR_COSTS; + all callers changed. If FOR_COSTS is true, don't call alter_reg, + but call note_reg_elim_costly if we turned a valid memory address + into an invalid one. + * Makefile.in (ira-costs.o): Depend on reload.h. + +2010-06-04 Julian Brown + + * config/arm/thumb2.md (*thumb2_movdf_soft_insn): Fix alternatives + for pool ranges. + +2010-06-04 Richard Guenther + + PR lto/41584 + * cgraph.h (struct varpool_node): Add lto_file_data field. + * lto-cgraph.c (input_varpool_node): Initialize it. + +2010-06-04 Uros Bizjak + + * config/i386/predicates.md (pic_symbolic_operand): Remove predicate. + * config/i386/i386.md (*add_1): Do not use pic_symbolic_operand + predicate in "type" attribute calculation. + (*addsi_1_zext): Ditto. + (*add_2): Do not use pic_symbolic_operand in insn predicate. + (*addsi_2_zext): Ditto. + (*add_3): Ditto. + (*addsi_3_zext): Ditto. + (*add_5): Ditto. + +2010-06-03 Jan Hubicka + + * tree-into-ssa.c (mark_block_for_update): Avoid redundant call + of bitmap_bit_p. + * cfganal.c (compute_dominance_frontiers_1): Likewise. + +2010-06-03 Jan Hubicka + + * df-problems.c (df_create_unused_note, df_note_bb_compute): + micro-optimize the checks when to add new note. + +2010-06-03 Nathan Froyd + + * final.c (output_asm_insn): Call + targetm.asm_out.print_operand_punct_valid_p. Update comments. + (output_operand): Call targetm.asm_out.print_operand. Update comments. + (output_address): Call targetm.asm_out.print_operand_address. + Update comments. + * target.h (struct gcc_target): Add print_operand, + print_operand_address, and print_operand_punct_valid_p fields. + * targhooks.h (default_print_operand): Declare. + (default_print_operand_address): Declare. + (default_print_operand_punct_valid_p): Declare. + * targhooks.c (default_print_operand): Define. + (default_print_operand_address): Define. + (default_print_operand_punct_valid_p): Define. + * target-def.h (TARGET_PRINT_OPERAND): Define if not defined. + (TARGET_PRINT_OPERAND_ADDRESS): Likewise. + (TARGET_PRINT_OPERAND_PUNCT_VALID_P): Likewise. + (TARGET_ASM_OUT): Add TARGET_PRINT_OPERAND, + TARGET_PRINT_OPERAND_ADDRESS, and TARGET_PRINT_OPERAND_PUNCT_VALID_P. + * vmsdbgout.c (addr_const_to_string): Update comment. + * config/i386/i386.c (print_operand): Rename to... + (ix86_print_operand): ...this. Make static. + (print_operand_address): Rename to... + (ix86_print_operand_address): ...this. Make static. Call + ix86_print_operand instead of PRINT_OPERAND. + (ix86_print_operand_punct_valid_p): New function. + (TARGET_PRINT_OPERAND): Define. + (TARGET_PRINT_OPERAND_ADDRESS): Define. + (TARGET_PRINT_OPERAND_PUNCT_VALID_P): Define. + * config/i386/i386.h (HI_REGISTER_NAMES): Update comment. + (PRINT_OPERAND_PUNCT_VALID_P): Delete. + (PRINT_OPERAND): Delete. + (PRINT_OPERAND_ADDRESS): Delete. + * config/i386/i386-protos.h (print_operand): Delete prototype. + (print_operand_address): Delete prototype. + +2010-06-03 Richard Guenther + + PR tree-optimization/44403 + * tree-vect-data-refs.c (vect_create_addr_base_for_vector_ref): + Preserve pointer qualifiers. + (vect_create_data_ref_ptr): Likewise. + +2010-06-03 H.J. Lu + + PR c++/44294 + * defaults.h (MAX_FIXED_MODE_SIZE): New. + + * stor-layout.c (MAX_FIXED_MODE_SIZE): Removed. + +2010-06-03 Jakub Jelinek + + PR debug/44375 + * tree-cfg.c (gimple_can_merge_blocks_p): For -O0 + return false if merging the bbs would lead to goto_locus + location being lost from the IL. + +2010-06-03 Jan Hubicka + Jakub Jelinek + + * var-tracking.c (dataflow_set_equiv_regs): Shortcut the loop if + set->regs[i] is NULL or has just one entry. + +2010-06-03 Jan Hubicka + + * lto-cgraph.c (lto_varpool_encoder_size): Remove. + * lto-streamer.h (lto_varpool_encoder_size): New inline function. + +2010-06-03 Paul Brook + + * config/arm/arm.c (FL_TUNE): Define. + (arm_default_cpu, arm_cpu_select): Remove. + (all_cores): Populate core field. + (arm_selected_arch, arm_selected_cpu, arm_selected_tune): New. + (arm_find_cpu): New function. + (arm_handle_option): Lookup cpu/architecture names. + (arm_override_options): Cleanup mcpu/march/mtune handling. + (arm_file_start): Ditto. + +2010-06-03 Alan Modra + + PR target/44169 + * config/rs6000/rs6000.md (load_toc_v4_PIC_1b): Add label operand. + * config/rs6000/rs6000.c (rs6000_legitimize_tls_address): Pass label + rtx to gen_load_toc_v4_PIC_1b. Tidy. + (rs6000_emit_load_toc_table): Likewise. + +2010-06-02 Jan Hubicka + + * passes.c (init_optimization_passes): Put ipa reference + after ipa pure-const. + +2010-06-02 Jan Hubicka + + * ipa-reference.c (ipa_reference_local_vars_info_d): Remove + calls_read_all and calls_write_all. + (get_reference_optimization_summary): Fix formatting. + (is_proper_for_analysis): Check that decl is not readonly. + (propagate_bits): Check CONST/PURE/noreturn flags. + (ipa_init): Move all_module_statics to optimization_summary_obstack. + (analyze_function): Ignore indirect edges. + (copy_global_bitmap): For all module statics, do nothing. + (generate_summary): Do not print calls_read_all/calls_write_all. + (read_write_all_from_decl): Take node as argument; check + cgraph_node_cannot_return. + (propagate): Reorganize read_all/write_all computation; + check indirect edges; check ecf flags; use all_module_statics + in the results; do not free all_module_statics. + (stream_out_bitmap): Handle all_module_statics. + (ipa_reference_write_optimization_summary): Likewise; use + varpool/cgraph encoders to get boundaries. + (ipa_reference_read_optimization_summary): Read in all_module_statics; + use it when possible. + +2010-06-02 Michael Meissner + + PR target/44218 + * doc/invoke.texi (RS/6000 and PowerPC Options): Delete obsolete + -mswdiv option. Add -mrecip, -mrecip=, -mrecip-precision options. + + * doc/extend.texi (powerpc builtins): Document vec_recip, + vec_rsqrt, vec_rsqrte altivec/vsx builtins. + + * config/rs6000/rs60000-protos.h (rs6000_emit_swdiv): New function. + (rs6000_emit_swrsqrt): Ditto. + (rs6000_emit_swdivsf): Delete. + (rs6000_emit_swdivdf): Ditto. + (rs6000_emit_swrsqrtsf): Ditto. + + * config/rs6000/rs6000.c (rs6000_recip_bits): New global to + describe the reciprocal estimate support for each type. + (recip_options): Map -mrecip= into option bits. + (gen_2arg_fn_t): New typedef for binary rtx gen function. + (rs6000_debug_reg_global): If -mdebug=reg, print the state of the + reciprocal estimate instructions. + (rs6000_init_hard_regno_mode_ok): Key ws constraint off of the + debug -mvsx-scalar-memory switch instead of -mvsx-scalar-double. + Set up rs6000_recip_bits based on the -mrecip* options. Print the + cost information if -mdebug=cost or -mdebug=reg. + (rs6000_override_options): Set -mrecip-precision for power6, and + power7 machines. If -mvsx or -mdfp, enable various options that + came in previous instruction set ISAs, unless the option was + explicitly disabled by the command line option. Parse + -mrecip= options. + (rs6000_builtin_vectorized_function): Add support for vectorizing + the reciprocal estimate builtins and expansions. + (rs6000_handle_option): Add -mrecip, -mrecip= support. + (bdesc_2arg): Add reciprocal estimate builtins. + (bdesc_1arg): Add reciprocal square root estimate builtins. + (rs6000_expand_builtin): Rewrite to use a switch statement, + instead of multiple if/then/elses. Add reciprocal estimate builtins. + (rs6000_init_builtins): Create declarations for reciprocal + estimate builtins. + (rs6000_preferred_reload_class): Simplify VSX preferences, if scalar + sized, prefer traditional floating point registers, if integer + vector types, prefer altivec registers. Don't actually look at + the memory address any more. + (rs6000_builtin_reciprocal): Add new builtin reciprocal estimate + builtins. + (rs6000_load_constant_and_splat): New helper function to load up + the constant for reciprocal estimate instructions. + (rs6000_emit_madd): New helper function for generating + multiply/add type instructions, based on the current switches. + (rs6000_emit_msub): Ditto. + (rs6000_emit_mnsub): Ditto. + (rs6000_emit_swdiv_high_precision): Replace rs6000_emit_swdivsf to + replace a divide with a reciprocal estimate and fixup, adding + support for machines with high precision and vectors. + (rs6000_emit_swdiv_low_precision): Rewrite rs6000_emit_swdivdf for + low precision machines. + (rs6000_emit_swdiv): New common function to be called to replace a + division with reciprocal estimate and fixup. + (rs6000_emit_swrsqrt): Replace rs6000_emit_swrsqrtsf. Add support + for double and vector types. Add support for high precision machines. + + * config/rs6000/rs6000.h (TARGET_FRES): New macro to say whether + the reciprocal estimate instructions can be generated. + (TARGET_FRE): Ditto. + (TARGET_FRSQRTES): Ditto. + (TARGET_FRSQRTE): Ditto. + (RS6000_RECIP_*): New macros for reciprocal estimate support. + + * config/rs6000/vector.md (rsqrte2): New insn for reciprocal + square root estimate on vectors. + (re2): New insn for reciprocal division estimate on vectors. + + * config/rs6000/rs6000-buitlins.def (ALTIVEC_BUILTIN_VRSQRTFP): + New builtin. + (ALTIVEC_BUILTIN_VRECIPFP): Ditto. + (ALTIVEC_BUITLIN_VEC_RE): Ditto. + (ALTIVEC_BUILTIN_VEC_RSQRT): Ditto. + (VSX_BUILTIN_RSQRT_V4SF): Ditto. + (VSX_BUITLIN_RSQRT_V2DF): Ditto. + (RS6000_BUILTIN_RSQRT): Ditto. + (ALTIVEC_BUILTIN_VEC_RSQRTE): Denote that the builtin is a + floating point builtin. + + * config/rs6000/rs6000-c.c (rs6000_cpu_cpp_builtins): Define + macros __RECIP__, __RECIPF__, __RSQRTE__, __RSQRTEF__, + __RECIP_PRECISION__ based on the command line switches. + (altivec_overloaded_builtins): Add reciprocal estimate builtins. + + * config/rs6000/rs6000.opt (-mrecip): Document add support for + replacing division instructions with reciprocal estimate and fixup. + (-mrecip=): New option. + (-mrecip-precision): Ditto. + + * config/rs6000/vsx.md (UNSPEC_VSX_RSQRTE): Delete. + (vsx_rsqrte2): Use UNSPEC_RSQRT not UNSPEC_VSX_RSQRTE. + (vsx_copysignsf3): If -mvsx, use double precision cpsign on single + precision scalar. + + * config/rs6000/altivec.md (UNSPEC_RSQRTEFP): Delete. + (UNSPEC_VREFP): Ditto. + (altivec_vnmsubfp*): Make altivec nmsub mirror the scalar and VSX + conterparts with regard to support of -mno-fused-madd and -ffast-math. + (altivec_vrsqrtefp): Use common UNSPEC to allow scalar/vector + reciprocal estimate instructions to be generated. + (altivec_vrefp): Ditto. + + * config/rs6000/rs6000.md (RECIPF): New iterator for reciprocal + estimate support. + (rreg): New mode attribute for reciprocal estimate support. + (recip3): New insn for division using reciprocal estimate + and fixup builtins. + (divide define_split): New define_split to convert floating point + division to use reciprocal estimate if the user used the + appropriate options and the split is run when we can add new + pseudo registers for the fixup. + (rsqrt2): New insn for reciprocal square root support. + (recipsf3): Move into recip3. + (recipdf3): Ditto. + (fres): Use TARGET_FRES. + (rsqrtsf2): Move into rsqrt2. + (rsqrtsf_internal1): Use TARGET_FRSQRTSES. + (copysignsf3): Add support for VSX. + (fred): Use TARGET_FRE. + (fred_fpr): Ditto. + (rsqrtdf_internal1): New function for frsqrte instruciton. + + * config/rs6000/altivec.h (vec_recipdiv): Define new vector builtin. + (vec_rsqrt): Ditto. + +2010-06-03 Richard Guenther + + PR middle-end/44291 + * optabs.c (init_one_libfunc): Use IDENTIFIER_HASH_VALUE. + (set_user_assembler_libfunc): Likewise. + +2010-06-02 Steven Bosscher + + * mkconfig.sh: Include insn-flags.h and insn-constants.h before + defaults.h. + * except.h: Move MUST_USE_SJLJ_EXCEPTIONS and USING_SJLJ_EXCEPTIONS + to defaults.h + * expr.h (BRANCH_COST, MOVE_RATIO, CLEAR_RATIO, SET_RATIO, + DEFAULT_FUNCTION_ARG_PADDING, FUNCTION_ARG_PADDING, + FUNCTION_ARG_BOUNDARY, STACK_SAVEAREA_MODE, STACK_SIZE_MODE, + STACK_CHECK_BUILTIN, STACK_CHECK_STATIC_BUILTIN, + STACK_CHECK_PROBE_INTERVAL_EXP, STACK_CHECK_MOVING_SP, + STACK_OLD_CHECK_PROTECT, STACK_CHECK_PROTECT, + STACK_CHECK_MAX_FRAME_SIZE, STACK_CHECK_FIXED_FRAME_SIZE, + STACK_CHECK_MAX_VAR_SIZE): Move target macro defaults to defaults.h. + * defaults.h: Updated for above mentioned changes. + 2010-06-02 Kai Tietz * c-common.c: Remove header include of tm_p.h. @@ -80,8 +4812,7 @@ (*mov_64 TD_TF, *mov_31 TD_TF, *mov_64dfp DD_DF, *mov_64 DD_DF, *mov_31, mov): Remove load zero instruction. - * config/s390/s390.c: Don't accept fp zeros as valid constants - anymore. + * config/s390/s390.c: Don't accept fp zeros as valid constants anymore. 2010-06-02 Jan Hubicka @@ -194,8 +4925,7 @@ Include rtl.h. (copy_decl_for_dup_finish): Do not use NULL_RTX. - * tree-loop-linear.c: Do not include diagnostic.h, expr.h, - and optabs.h. + * tree-loop-linear.c: Do not include diagnostic.h, expr.h and optabs.h. * tree-loop-distribution.c: Likewise. 2010-06-01 Jan Hubicka @@ -234,25 +4964,26 @@ * emit-rtl.c: (first_insn, last_insn): Remove defines. (get_insns, set_first_insn, get_last_insn, set_last_insn, get_max_uid): Move to emit-rtl.h. - (set_new_first_and_last_insn, get_last_insn_anywhere, get_first_nonnote_insn, - get_last_nonnote_insn, try_split, make_call_insn_raw, add_insn_after, - add_insn_before, remove_insn, delete_insns_since, reorder_insns_nobb, - emit_insn_after_1, emit_debug_insn_before, emit_insn, start_sequence, - push_to_sequence, push_to_sequence2, push_topmost_sequence, end_sequence, - copy_insn): Use accessor functions. + (set_new_first_and_last_insn, get_last_insn_anywhere, + get_first_nonnote_insn, get_last_nonnote_insn, try_split, + make_call_insn_raw, add_insn_after, add_insn_before, remove_insn, + delete_insns_since, reorder_insns_nobb, emit_insn_after_1, + emit_debug_insn_before, emit_insn, start_sequence, push_to_sequence, + push_to_sequence2, push_topmost_sequence, end_sequence, copy_insn): + Use accessor functions. * emit-rtl.h (gen_blockage, gen_rtvec, copy_insn_1, copy_insn, gen_int_mode, emit_copy_of_insn_after, set_reg_attrs_from_value, set_reg_attrs_for_parm, set_reg_attrs_for_decl_rtl, adjust_reg_mode, - mem_expr_equal_p): Move here from rtl.h + mem_expr_equal_p): Move here from rtl.h. (get_insns, set_first-insn, get_last_insn, set_last_insn, get_max_uid): Move here from emit-rtl.c; make inline. - * cfglayout.h: Include emit-rtl.h + * cfglayout.h: Include emit-rtl.h. * rtl.h (gen_blockage, gen_rtvec, copy_insn_1, copy_insn, gen_int_mode, emit_copy_of_insn_after, set_reg_attrs_from_value, set_reg_attrs_for_parm, set_reg_attrs_for_decl_rtl, adjust_reg_mode, - mem_expr_equal_p, get_insns, set_first-insn, get_last_insn, set_last_insn, - get_max_uid): Move to emit-rtl.h. - * reg-stack.c: Include emit-rtl.h + mem_expr_equal_p, get_insns, set_first-insn, + get_last_insn, set_last_insn, get_max_uid): Move to emit-rtl.h. + * reg-stack.c: Include emit-rtl.h. * dce.c: Likewise. 2010-06-01 Jan Hubicka @@ -261,11 +4992,11 @@ (cgraph_function_versioning): Update prototype. * cgraphunit.c (cgraph_copy_node_for_versioning): Accept bbs_to_copy bitmap. - (cgraph_function_versioning): Accept new_entry_block and bbs_to_copy. + (cgraph_function_versioning): Accept new_entry_block and bbs_to_copy. (cgraph_materialize_clone, save_inline_function_body): Update use of tree_function_versioning. - * tree-inline.c (copy_bb): Look for previous copied block to link after; - fix debug output. + * tree-inline.c (copy_bb): Look for previous copied block to link + after; fix debug output. (copy_cfg_body): Accept new_entry_block and bbs_to_copy. (copy_body): Likewise. (expand_call_inline): Update use of copy_body. @@ -293,7 +5024,7 @@ * c-opts.c (c_common_handle_option): Likewise. 2010-06-01 Arnaud Charlet - Matthew Gingell + Matthew Gingell * doc/invoke.texi: Mention -fdump-ada-spec. * tree-dump.c (dump_files): Add ada-spec. @@ -330,23 +5061,22 @@ 2010-06-01 Maxim Kuvyrkov * config/arm/t-linux-androideabi: New. - * config.gcc (arm*-*-linux-androideabi): Include multilib configuration. + * config.gcc (arm*-*-linux-androideabi): Include multilib config. 2010-06-01 Jan Hubicka * tree-inline.c (estimate_num_insns): For stdarg functions look into call statement to count cost of argument passing. -2010-06-01 Kai Tietz +2010-06-01 Kai Tietz - * config/i386.c (ix86_output_addr_vec_elt): Make LPREFIX - argument for fprintf. - (ix86_output_addr_diff_elt): Likewise. - (x86_function_profiler): Likewise. - * config/cygming.h (LOCAL_LABEL_PREFIX): Fix - for x64 no-underscore. - (LPREFIX): Likewise. - (ASM_GENERATE_INTERNAL_LABEL): Likewise. + * config/i386.c (ix86_output_addr_vec_elt): Make LPREFIX + argument for fprintf. + (ix86_output_addr_diff_elt): Likewise. + (x86_function_profiler): Likewise. + * config/cygming.h (LOCAL_LABEL_PREFIX): Fix for x64 no-underscore. + (LPREFIX): Likewise. + (ASM_GENERATE_INTERNAL_LABEL): Likewise. 2010-05-31 Jakub Jelinek @@ -394,8 +5124,7 @@ 2010-05-31 Kai Tietz PR target/44161 - * config/i386/cygming.h (SUBTARGET_OVERRIDE_OPTIONS): Handle - flag_pic. + * config/i386/cygming.h (SUBTARGET_OVERRIDE_OPTIONS): Handle flag_pic. 2010-05-31 Eric Botcazou @@ -404,8 +5133,7 @@ 2010-05-31 Richard Guenther - * tree-ssa-structalias.c (find_func_aliases): Handle - BUILT_IN_RETURN. + * tree-ssa-structalias.c (find_func_aliases): Handle BUILT_IN_RETURN. 2010-05-30 Jan Hubicka @@ -429,7 +5157,7 @@ * config/rs6000/darwin.h (ASM_OUTPUT_COMMON): Ditto. * config/darwin.h (GLOBAL_ASM_OP): Ditto. * config/darwin9.h (ASM_OUTPUT_ALIGNED_COMMON): Ditto. - + 2010-05-30 Eric Botcazou * config/rs6000/rs6000.c (rs6000_output_function_entry): Use @@ -450,8 +5178,7 @@ * cgraph.h (cgraph_dump_file): Declare. * cgraphunit.c (cgraph_dump_file): Export. - * ipa.c (dump_cgraph_node_set, dump_varpool_node_set): Be less - verbose. + * ipa.c (dump_cgraph_node_set, dump_varpool_node_set): Be less verbose. 2010-05-30 Jan Hubicka @@ -468,9 +5195,8 @@ * ipa-pure-const.c (pure_const_names): New static var. (check_call): Handle calls not leading to return. (pure_const_read_summary): Dump info read. - (propagate): Dump info about propagation process; ignore side - effects of functions not leading to exit; fix handling of - pure functions. + (propagate): Dump info about propagation process; ignore side effects + of functions not leading to exit; fix handling of pure functions. 2010-05-30 Jan Hubicka @@ -504,7 +5230,7 @@ debug_asserts_for, debug_all_asserts): Annotate with DEBUG_FUNCTION. * tree-into-ssa.c (debug_decl_set, debug_defs_stack, debug_currdefs, debug_tree_ssa, debug_tree_ssa_stats, debug_def_blocks, - debug_names_replaced_by, debug_update_ssa): Likewise. + debug_names_replaced_by, debug_update_ssa): Likewise. * sbitmap.c (debug_sbitmap): Likewise. * genrecog.c (debug_decision, debug_decision_list): Likewise. * tree-pretty-print.c (debug_generic_expr, debug_generic_stmt, @@ -690,8 +5416,7 @@ 2010-05-29 Jan Hubicka * cgraphunit.c (cgraph_materialize_clone): Only remove calles, - refs and body; not the whole node for masters of materialized - clones. + refs and body; not the whole node for masters of materialized clones. 2010-05-29 Mike Stump @@ -702,7 +5427,7 @@ * cgraph.c (clone_function_name): Take SUFFIX argument; export. (cgraph_create_virtual_clone): Take SUFFIX argument; udpate use of clone_function_name. - * cgraph.h (cgraph_create_virtual_clone, + * cgraph.h (cgraph_create_virtual_clone, cgraph_function_versioning): update prototypes. (clone_function_name): Declare. * ipa-cp.c (ipcp_insert_stage): Update call of @@ -721,10 +5446,10 @@ 2010-05-29 Steven Bosscher - * c-lex.c: Do not include c-tree.h. - * c-pretty-print.c: Likewise. - * c-opts.c: Likewise. - * c-gimplify.c: Likewise. + * c-lex.c: Do not include c-tree.h. + * c-pretty-print.c: Likewise. + * c-opts.c: Likewise. + * c-gimplify.c: Likewise. * c-common.c: Likewise. * c-dump.c: Likewise. Include c-common.h. @@ -831,8 +5556,7 @@ * gcc.c (inform, warning, inform): New functions. (fatal_ice): Rename to internal_error; change cmsgid parameter to gmsgid. All callers changed. - (notice): Rename to fnotice; add parameter fp. All callers - changed. + (notice): Rename to fnotice; add parameter fp. All callers changed. (fatal_error): Rename to fatal_signal. All users changed. (fatal): Rename to fatal_error; change cmsgid parameter to gmsgid. All callers changed. @@ -847,8 +5571,7 @@ (warning): Declare. * config/darwin-driver.c (darwin_default_min_version): Use warning instead of fprintf for warnings. - * cppspec.c (lang_specific_driver): Use fatal_error instead of - fatal. + * cppspec.c (lang_specific_driver): Use fatal_error instead of fatal. 2010-05-28 Julian Brown @@ -868,7 +5591,7 @@ 2010-05-28 Iain Sandoe - * config.gcc (*-*-darwin*): Adjust t-make fragments for Darwin. + * config.gcc (*-*-darwin*): Adjust t-make fragments for Darwin. 2010-05-28 Maxim Kuvyrkov @@ -1149,7 +5872,7 @@ 2010-05-27 Jon Beniston PR 43726 - * config/lm32/lm32.h: Remove definition of + * config/lm32/lm32.h: Remove definition of GO_IF_MODE_DEPENDENT_ADDRESS. Update copyright year. 2010-05-27 Eric Botcazou @@ -6149,7 +10872,7 @@ (next_operand_entry_id): New static variable. (sort_by_operand_rank): Stabilize qsort comparator by using unique IDs. (add_to_ops_vec): Assigned unique ID to operand entry. - (struct oecount_s): New field ID. + (struct oecount_s): New field ID. (oecount_cmp): Stabilize qsort comparotor by using unique IDs. (undistribute_ops_list): Assign unique IDs to oecounts. (init_reassoc): reset next_operand_entry_id. diff --git a/gcc/DATESTAMP b/gcc/DATESTAMP index 99c116de7b5..b5fc066d57c 100644 --- a/gcc/DATESTAMP +++ b/gcc/DATESTAMP @@ -1 +1 @@ -20100602 +20100701 diff --git a/gcc/Makefile.in b/gcc/Makefile.in index a5eca3ef682..ed53a79ddfc 100644 --- a/gcc/Makefile.in +++ b/gcc/Makefile.in @@ -261,7 +261,7 @@ TEXI2DVI = texi2dvi TEXI2PDF = texi2pdf TEXI2HTML = $(MAKEINFO) --html TEXI2POD = perl $(srcdir)/../contrib/texi2pod.pl -POD2MAN = pod2man --center="GNU" --release="gcc-$(version)" +POD2MAN = pod2man --center="GNU" --release="gcc-$(version)" --date=$(shell sed 's/\(....\)\(..\)\(..\)/\1-\2-\3/' <$(DATESTAMP)) # Some versions of `touch' (such as the version on Solaris 2.8) # do not correctly set the timestamp due to buggy versions of `utime' # in the kernel. So, we use `echo' instead. @@ -331,10 +331,10 @@ LTO_BINARY_READER = @LTO_BINARY_READER@ LTO_USE_LIBELF = @LTO_USE_LIBELF@ # Compiler needed for plugin support -PLUGINCC = @CC@ +PLUGINCC = $(COMPILER) # Flags needed for plugin support -PLUGINCFLAGS = @CFLAGS@ +PLUGINCFLAGS = $(COMPILER_FLAGS) # Libs and linker options needed for plugin support PLUGINLIBS = @pluginlibs@ @@ -502,7 +502,7 @@ check_gcc_parallelize=execute.exp=execute/2* \ compile.exp dg.exp \ dg-torture.exp,builtins.exp \ struct-layout-1.exp,unsorted.exp,stackalign.exp,i386.exp -lang_opt_files=@lang_opt_files@ $(srcdir)/c.opt $(srcdir)/common.opt +lang_opt_files=@lang_opt_files@ $(srcdir)/c-family/c.opt $(srcdir)/common.opt lang_specs_files=@lang_specs_files@ lang_tree_files=@lang_tree_files@ target_cpu_default=@target_cpu_default@ @@ -816,8 +816,8 @@ BCONFIG_H = bconfig.h $(build_xm_file_list) CONFIG_H = config.h $(host_xm_file_list) TCONFIG_H = tconfig.h $(xm_file_list) TM_P_H = tm_p.h $(tm_p_file_list) -GTM_H = tm.h $(tm_file_list) -TM_H = $(GTM_H) insn-constants.h insn-flags.h options.h +GTM_H = tm.h $(tm_file_list) insn-constants.h +TM_H = $(GTM_H) insn-flags.h options.h # Variables for version information. BASEVER := $(srcdir)/BASE-VER # 4.x.y @@ -861,23 +861,25 @@ endif VEC_H = vec.h statistics.h EXCEPT_H = except.h $(HASHTAB_H) vecprim.h vecir.h TOPLEV_H = toplev.h $(INPUT_H) bversion.h $(DIAGNOSTIC_CORE_H) -TARGET_H = $(TM_H) target.h insn-modes.h +TARGET_H = $(TM_H) target.h target.def insn-modes.h MACHMODE_H = machmode.h mode-classes.def insn-modes.h HOOKS_H = hooks.h $(MACHMODE_H) HOSTHOOKS_DEF_H = hosthooks-def.h $(HOOKS_H) LANGHOOKS_DEF_H = langhooks-def.h $(HOOKS_H) -TARGET_DEF_H = target-def.h $(HOOKS_H) targhooks.h +TARGET_DEF_H = target-def.h target-hooks-def.h $(HOOKS_H) targhooks.h RTL_BASE_H = rtl.h rtl.def $(MACHMODE_H) reg-notes.def insn-notes.def \ $(INPUT_H) $(REAL_H) statistics.h $(VEC_H) $(FIXED_VALUE_H) alias.h FIXED_VALUE_H = fixed-value.h $(MACHMODE_H) double-int.h RTL_H = $(RTL_BASE_H) genrtl.h vecir.h +RTL_ERROR_H = $(RTL_H) $(DIAGNOSTIC_CORE_H) +READ_MD_H = $(OBSTACK_H) $(HASHTAB_H) read-md.h PARAMS_H = params.h params.def BUILTINS_DEF = builtins.def sync-builtins.def omp-builtins.def -TREE_H = tree.h all-tree.def tree.def c-common.def $(lang_tree_files) \ - $(MACHMODE_H) tree-check.h $(BUILTINS_DEF) \ - $(INPUT_H) statistics.h $(VEC_H) treestruct.def $(HASHTAB_H) \ - double-int.h alias.h $(SYMTAB_H) options.h vecir.h \ - $(REAL_H) $(FIXED_VALUE_H) +TREE_H = tree.h all-tree.def tree.def c-family/c-common.def \ + $(lang_tree_files) $(MACHMODE_H) tree-check.h $(BUILTINS_DEF) \ + $(INPUT_H) statistics.h $(VEC_H) treestruct.def $(HASHTAB_H) \ + double-int.h alias.h $(SYMTAB_H) options.h vecir.h \ + $(REAL_H) $(FIXED_VALUE_H) REGSET_H = regset.h $(BITMAP_H) hard-reg-set.h BASIC_BLOCK_H = basic-block.h $(PREDICT_H) $(VEC_H) $(FUNCTION_H) cfghooks.h GIMPLE_H = gimple.h gimple.def gsstruct.def pointer-set.h $(VEC_H) \ @@ -914,11 +916,13 @@ RESOURCE_H = resource.h hard-reg-set.h $(DF_H) DDG_H = ddg.h sbitmap.h $(DF_H) GCC_H = gcc.h version.h $(DIAGNOSTIC_CORE_H) GGC_H = ggc.h gtype-desc.h statistics.h +GGC_INTERNAL_H = ggc-internal.h $(GGC_H) TIMEVAR_H = timevar.h timevar.def INSN_ATTR_H = insn-attr.h $(INSN_ADDR_H) INSN_ADDR_H = $(srcdir)/insn-addr.h vecprim.h -C_COMMON_H = c-common.h $(SPLAY_TREE_H) $(CPPLIB_H) $(GGC_H) $(DIAGNOSTIC_CORE_H) -C_PRAGMA_H = c-pragma.h $(CPPLIB_H) +C_COMMON_H = c-family/c-common.h c-family/c-common.def \ + $(SPLAY_TREE_H) $(CPPLIB_H) $(GGC_H) $(DIAGNOSTIC_CORE_H) +C_PRAGMA_H = c-family/c-pragma.h $(CPPLIB_H) C_TREE_H = c-tree.h $(C_COMMON_H) $(TOPLEV_H) $(DIAGNOSTIC_H) SYSTEM_H = system.h hwint.h $(srcdir)/../include/libiberty.h \ $(srcdir)/../include/safe-ctype.h $(srcdir)/../include/filenames.h @@ -945,7 +949,8 @@ SSAEXPAND_H = ssaexpand.h $(TREE_SSA_LIVE_H) PRETTY_PRINT_H = pretty-print.h $(INPUT_H) $(OBSTACK_H) DIAGNOSTIC_CORE_H = diagnostic-core.h input.h diagnostic.def DIAGNOSTIC_H = diagnostic.h $(DIAGNOSTIC_CORE_H) $(PRETTY_PRINT_H) -C_PRETTY_PRINT_H = c-pretty-print.h $(PRETTY_PRINT_H) $(C_COMMON_H) $(TREE_H) +C_PRETTY_PRINT_H = c-family/c-pretty-print.h $(PRETTY_PRINT_H) \ + $(C_COMMON_H) $(TREE_H) SCEV_H = tree-scalar-evolution.h $(GGC_H) tree-chrec.h $(PARAMS_H) LAMBDA_H = lambda.h $(TREE_H) $(VEC_H) $(GGC_H) TREE_DATA_REF_H = tree-data-ref.h $(LAMBDA_H) omega.h graphds.h $(SCEV_H) @@ -1033,8 +1038,10 @@ LDEXP_LIB = @LDEXP_LIB@ # even if we are cross-building GCC. BUILD_LIBS = $(BUILD_LIBIBERTY) -BUILD_RTL = build/rtl.o build/read-rtl.o build/ggc-none.o build/vec.o \ - build/min-insn-modes.o build/gensupport.o build/print-rtl.o +BUILD_RTL = build/rtl.o build/read-rtl.o build/ggc-none.o \ + build/vec.o build/min-insn-modes.o build/gensupport.o \ + build/print-rtl.o +BUILD_MD = build/read-md.o BUILD_ERRORS = build/errors.o # Specify the directories to be searched for header files. @@ -1128,15 +1135,20 @@ FORTRAN_TARGET_OBJS=@fortran_target_objs@ GCC_OBJS = gcc.o opts-common.o gcc-options.o diagnostic.o pretty-print.o \ input.o +# Language-specific object files shared by all C-family front ends. +C_COMMON_OBJS = c-family/c-common.o c-family/c-cppbuiltin.o c-family/c-dump.o \ + c-family/c-format.o c-family/c-gimplify.o c-family/c-lex.o \ + c-family/c-omp.o c-family/c-opts.o c-family/c-pch.o \ + c-family/c-ppoutput.o c-family/c-pragma.o c-family/c-pretty-print.o \ + c-family/c-semantics.o c-family/c-ada-spec.o + # Language-specific object files for C and Objective C. -C_AND_OBJC_OBJS = attribs.o c-errors.o c-lex.o c-pragma.o c-decl.o c-typeck.o \ - c-convert.o c-aux-info.o c-common.o c-opts.o c-format.o c-semantics.o \ - c-ppoutput.o c-cppbuiltin.o \ - c-objc-common.o c-dump.o c-pch.o c-parser.o $(C_TARGET_OBJS) \ - c-gimplify.o tree-mudflap.o c-pretty-print.o c-omp.o c-ada-spec.o +C_AND_OBJC_OBJS = attribs.o c-errors.o c-decl.o c-typeck.o \ + c-convert.o c-aux-info.o c-objc-common.o c-parser.o tree-mudflap.o \ + $(C_COMMON_OBJS) $(C_TARGET_OBJS) # Language-specific object files for C. -C_OBJS = c-lang.o stub-objc.o $(C_AND_OBJC_OBJS) +C_OBJS = c-lang.o c-family/stub-objc.o $(C_AND_OBJC_OBJS) # Language-independent object files. # We put the insn-*.o files first so that a parallel make will build @@ -1153,6 +1165,7 @@ OBJS-common = \ insn-peep.o \ insn-preds.o \ insn-recog.o \ + insn-enums.o \ $(GGC) \ alias.o \ alloc-pool.o \ @@ -1429,6 +1442,7 @@ OBJS-archive = \ cppdefault.o \ incpath.o \ ipa-cp.o \ + ipa-split.o \ ipa-inline.o \ ipa-prop.o \ ipa-pure-const.o \ @@ -1571,7 +1585,7 @@ s-alltree: Makefile rm -f tmp-all-tree.def echo '#include "tree.def"' > tmp-all-tree.def echo 'END_OF_BASE_TREE_CODES' >> tmp-all-tree.def - echo '#include "c-common.def"' >> tmp-all-tree.def + echo '#include "c-family/c-common.def"' >> tmp-all-tree.def ltf="$(lang_tree_files)"; for f in $$ltf; do \ echo "#include \"$$f\""; \ done | sed 's|$(srcdir)/||' >> tmp-all-tree.def @@ -1970,62 +1984,58 @@ s-crt0: $(CRT0_S) $(MCRT0_S) $(GCC_PASSES) $(CONFIG_H) # Note that dependencies on obstack.h are not written # because that file is not part of GCC. -# C language specific files. - -c-errors.o: c-errors.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) \ - $(C_TREE_H) $(FLAGS_H) $(DIAGNOSTIC_H) $(TM_P_H) -c-parser.o : c-parser.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) \ - $(GGC_H) $(TIMEVAR_H) $(C_TREE_H) $(INPUT_H) $(FLAGS_H) $(TOPLEV_H) output.h \ - $(CPPLIB_H) gt-c-parser.h $(RTL_H) langhooks.h $(C_COMMON_H) $(C_PRAGMA_H) \ - $(VEC_H) $(TARGET_H) $(CGRAPH_H) $(PLUGIN_H) - srcextra: gcc.srcextra lang.srcextra gcc.srcextra: gengtype-lex.c -cp -p $^ $(srcdir) -incpath.o: incpath.c incpath.h $(CONFIG_H) $(SYSTEM_H) $(CPPLIB_H) \ - intl.h prefix.h coretypes.h $(TM_H) cppdefault.h $(TARGET_H) \ - $(MACHMODE_H) +# C language specific files. +c-aux-info.o : c-aux-info.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ + $(C_TREE_H) $(TREE_H) $(FLAGS_H) $(TOPLEV_H) -c-decl.o : c-decl.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) \ - $(RTL_H) $(C_TREE_H) $(GGC_H) $(TARGET_H) $(FLAGS_H) $(FUNCTION_H) output.h \ - debug.h $(TOPLEV_H) intl.h $(TM_P_H) $(TREE_INLINE_H) $(TIMEVAR_H) \ - opts.h $(C_PRAGMA_H) gt-c-decl.h $(CGRAPH_H) $(HASHTAB_H) libfuncs.h \ - $(EXCEPT_H) $(LANGHOOKS_DEF_H) $(TREE_DUMP_H) $(C_COMMON_H) $(CPPLIB_H) \ - $(DIAGNOSTIC_CORE_H) $(INPUT_H) langhooks.h tree-mudflap.h \ - pointer-set.h tree-iterator.h c-lang.h $(PLUGIN_H) c-ada-spec.h -c-typeck.o : c-typeck.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ - $(TREE_H) $(C_TREE_H) $(TARGET_H) $(FLAGS_H) intl.h output.h $(EXPR_H) \ - $(TOPLEV_H) langhooks.h $(TREE_FLOW_H) tree-iterator.h c-lang.h -c-lang.o : c-lang.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) \ - $(C_TREE_H) $(DIAGNOSTIC_CORE_H) \ - langhooks.h $(LANGHOOKS_DEF_H) $(C_COMMON_H) gtype-c.h \ - c-objc-common.h $(C_PRAGMA_H) c-common.def $(TREE_INLINE_H) -stub-objc.o : stub-objc.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TREE_H) \ - $(C_COMMON_H) -c-lex.o : c-lex.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) \ - $(FIXED_VALUE_H) debug.h $(C_TREE_H) $(C_COMMON_H) $(SPLAY_TREE_H) \ - $(C_PRAGMA_H) $(INPUT_H) intl.h $(FLAGS_H) $(TOPLEV_H) output.h \ - $(CPPLIB_H) $(TARGET_H) $(TIMEVAR_H) -c-ppoutput.o : c-ppoutput.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ - $(C_COMMON_H) $(TREE_H) $(CPPLIB_H) $(CPP_INTERNAL_H) $(C_PRAGMA_H) -c-objc-common.o : c-objc-common.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ - $(TREE_H) $(C_TREE_H) $(FLAGS_H) $(DIAGNOSTIC_H) \ - langhooks.h $(GGC_H) $(C_PRETTY_PRINT_H) c-objc-common.h intl.h \ - tree-pretty-print.h -c-aux-info.o : c-aux-info.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) \ - $(C_TREE_H) $(FLAGS_H) $(TOPLEV_H) c-convert.o : c-convert.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ - $(TREE_H) $(FLAGS_H) $(TOPLEV_H) $(C_COMMON_H) convert.h $(C_TREE_H) \ - langhooks.h $(TARGET_H) -c-pragma.o: c-pragma.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(RTL_H) \ - $(TREE_H) $(FUNCTION_H) $(C_PRAGMA_H) $(TOPLEV_H) output.h $(TM_P_H) \ - $(C_COMMON_H) $(TARGET_H) gt-c-pragma.h $(CPPLIB_H) $(FLAGS_H) $(DIAGNOSTIC_H) \ - opts.h $(PLUGINS_H) + $(TREE_H) $(C_TREE_H) $(FLAGS_H) $(TOPLEV_H) $(C_COMMON_H) convert.h \ + langhooks.h $(TARGET_H) + +c-decl.o : c-decl.c c-lang.h $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ + $(TREE_H) $(C_TREE_H) $(GGC_H) $(TARGET_H) $(FLAGS_H) $(FUNCTION_H) \ + output.h debug.h $(TOPLEV_H) intl.h $(TM_P_H) $(TREE_INLINE_H) $(TIMEVAR_H) \ + opts.h $(C_PRAGMA_H) gt-c-decl.h $(CGRAPH_H) $(HASHTAB_H) libfuncs.h \ + $(EXCEPT_H) $(LANGHOOKS_DEF_H) $(TREE_DUMP_H) $(C_COMMON_H) $(CPPLIB_H) \ + $(DIAGNOSTIC_CORE_H) $(INPUT_H) langhooks.h tree-mudflap.h \ + pointer-set.h tree-iterator.h $(PLUGIN_H) c-family/c-ada-spec.h + +c-errors.o: c-errors.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) \ + $(C_TREE_H) $(FLAGS_H) $(DIAGNOSTIC_H) $(TM_P_H) + +c-lang.o : c-lang.c c-objc-common.h \ + $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) \ + $(C_TREE_H) $(DIAGNOSTIC_CORE_H) \ + langhooks.h $(LANGHOOKS_DEF_H) $(C_COMMON_H) gtype-c.h \ + $(C_PRAGMA_H) $(TREE_INLINE_H) + +c-objc-common.o : c-objc-common.c c-objc-common.h \ + $(CONFIG_H) $(SYSTEM_H) coretypes.h \ + $(TREE_H) $(C_TREE_H) $(FLAGS_H) $(DIAGNOSTIC_H) \ + langhooks.h $(GGC_H) $(C_PRETTY_PRINT_H) intl.h \ + tree-pretty-print.h + +c-parser.o : c-parser.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ + $(TM_H) $(TREE_H) $(C_TREE_H) $(C_COMMON_H) $(C_PRAGMA_H) $(CPPLIB_H) \ + $(GGC_H) $(TIMEVAR_H) $(INPUT_H) $(FLAGS_H) $(TOPLEV_H) output.h \ + gt-c-parser.h langhooks.h \ + $(VEC_H) $(TARGET_H) $(CGRAPH_H) $(PLUGIN_H) + +c-typeck.o : c-typeck.c c-lang.h $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ + $(TREE_H) $(C_TREE_H) $(TARGET_H) $(FLAGS_H) intl.h output.h $(EXPR_H) \ + $(TOPLEV_H) langhooks.h tree-iterator.h $(BITMAP_H) $(GIMPLE_H) + + + graph.o: graph.c $(SYSTEM_H) coretypes.h $(TM_H) $(TOPLEV_H) $(FLAGS_H) output.h \ $(RTL_H) $(FUNCTION_H) hard-reg-set.h $(BASIC_BLOCK_H) graph.h $(OBSTACK_H) \ $(CONFIG_H) $(EMIT_RTL_H) + sbitmap.o: sbitmap.c sbitmap.h $(CONFIG_H) $(SYSTEM_H) coretypes.h $(BASIC_BLOCK_H) ebitmap.o: ebitmap.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ $(EBITMAP_H) $(RTL_H) $(FLAGS_H) $(OBSTACK_H) @@ -2055,65 +2065,107 @@ lto-wrapper$(exeext): lto-wrapper.o intl.o $(LIBDEPS) $(COMPILER) $(ALL_COMPILERFLAGS) $(LDFLAGS) -o T$@ lto-wrapper.o intl.o $(LIBS) mv -f T$@ $@ -lto-wrapper.o: lto-wrapper.c $(CONFIG_H) $(SYSTEM_H) defaults.h intl.h \ +lto-wrapper.o: lto-wrapper.c $(CONFIG_H) $(SYSTEM_H) coretypes.h intl.h \ $(OBSTACK_H) -# A file used by all variants of C. - -c-common.o : c-common.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) \ +# Files used by all variants of C. +c-family/c-common.o : c-family/c-common.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ + $(TM_H) $(TREE_H) \ $(OBSTACK_H) $(C_COMMON_H) $(FLAGS_H) $(TOPLEV_H) output.h $(C_PRAGMA_H) \ - $(GGC_H) $(EXPR_H) $(TM_P_H) builtin-types.def builtin-attrs.def \ - $(DIAGNOSTIC_H) gt-c-common.h langhooks.h $(RTL_H) \ - $(TARGET_H) $(C_TREE_H) tree-iterator.h langhooks.h tree-mudflap.h \ + $(GGC_H) $(EXPR_H) builtin-types.def builtin-attrs.def \ + $(DIAGNOSTIC_H) langhooks.h $(RTL_H) \ + $(TARGET_H) tree-iterator.h langhooks.h tree-mudflap.h \ intl.h opts.h $(CPPLIB_H) $(TREE_INLINE_H) $(HASHTAB_H) \ $(BUILTINS_DEF) $(CGRAPH_H) $(BASIC_BLOCK_H) $(TARGET_DEF_H) \ - libfuncs.h + libfuncs.h \ + gt-c-family-c-common.h -c-pretty-print.o : c-pretty-print.c $(C_PRETTY_PRINT_H) \ - $(C_TREE_H) $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ - $(DIAGNOSTIC_H) tree-iterator.h intl.h tree-pretty-print.h +c-family/c-cppbuiltin.o : c-family/c-cppbuiltin.c $(CONFIG_H) $(SYSTEM_H) \ + coretypes.h $(TM_H) $(TREE_H) version.h $(C_COMMON_H) $(C_PRAGMA_H) \ + $(FLAGS_H) $(TOPLEV_H) output.h $(TREE_H) $(TARGET_H) \ + $(TM_P_H) $(BASEVER) debug.h $(CPP_ID_DATA_H) + $(COMPILER) -c $(ALL_COMPILERFLAGS) $(ALL_CPPFLAGS) \ + -DBASEVER=$(BASEVER_s) $< $(OUTPUT_OPTION) + +c-family/c-dump.o : c-family/c-dump.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ + $(TM_H) $(TREE_H) $(TREE_DUMP_H) + +c-family/c-format.o : c-family/c-format.c c-family/c-format.h \ + $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) langhooks.h \ + $(C_COMMON_H) $(FLAGS_H) $(TOPLEV_H) intl.h \ + $(DIAGNOSTIC_CORE_H) alloc-pool.h + +c-family/c-gimplify.o : c-family/c-gimplify.c $(CONFIG_H) $(SYSTEM_H) $(TREE_H) \ + $(C_COMMON_H) $(DIAGNOSTIC_CORE_H) $(GIMPLE_H) \ + $(FLAGS_H) langhooks.h $(TOPLEV_H) $(LANGHOOKS_DEF_H) \ + $(TM_H) coretypes.h $(C_PRETTY_PRINT_H) $(CGRAPH_H) $(BASIC_BLOCK_H) \ + hard-reg-set.h $(TREE_DUMP_H) $(TREE_INLINE_H) + +c-family/c-lex.o : c-family/c-lex.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ + $(TM_H) $(TREE_H) $(FIXED_VALUE_H) debug.h $(C_COMMON_H) $(SPLAY_TREE_H) \ + $(C_PRAGMA_H) $(INPUT_H) intl.h $(FLAGS_H) $(TOPLEV_H) output.h \ + $(CPPLIB_H) $(TARGET_H) $(TIMEVAR_H) -c-opts.o : c-opts.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ +c-family/c-omp.o : c-family/c-omp.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ + $(TREE_H) $(C_COMMON_H) $(TOPLEV_H) $(GIMPLE_H) langhooks.h + +c-family/c-opts.o : c-family/c-opts.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ $(TREE_H) $(C_PRAGMA_H) $(FLAGS_H) $(TOPLEV_H) langhooks.h \ $(DIAGNOSTIC_H) intl.h debug.h $(C_COMMON_H) \ - opts.h options.h $(MKDEPS_H) incpath.h cppdefault.h $(C_TREE_H) + opts.h options.h $(MKDEPS_H) incpath.h cppdefault.h $(COMPILER) -c $(ALL_COMPILERFLAGS) $(ALL_CPPFLAGS) \ $< $(OUTPUT_OPTION) @TARGET_SYSTEM_ROOT_DEFINE@ -c-cppbuiltin.o : c-cppbuiltin.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ - $(TREE_H) version.h $(C_COMMON_H) $(C_PRAGMA_H) $(FLAGS_H) \ - $(TOPLEV_H) output.h $(EXCEPT_H) $(TREE_H) $(TARGET_H) $(TM_P_H) \ - $(BASEVER) debug.h +c-family/c-pch.o : c-family/c-pch.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ + $(CPPLIB_H) $(TREE_H) $(C_COMMON_H) output.h $(TOPLEV_H) $(C_PRAGMA_H) \ + $(GGC_H) debug.h langhooks.h $(FLAGS_H) hosthooks.h version.h \ + $(TARGET_H) opts.h $(TIMEVAR_H) $(COMPILER) -c $(ALL_COMPILERFLAGS) $(ALL_CPPFLAGS) \ - -DBASEVER=$(BASEVER_s) $< $(OUTPUT_OPTION) + -DHOST_MACHINE=\"$(host)\" -DTARGET_MACHINE=\"$(target)\" \ + $< $(OUTPUT_OPTION) -# A file used by all variants of C and some other languages. +c-family/c-ppoutput.o : c-family/c-ppoutput.c $(CONFIG_H) $(SYSTEM_H) \ + coretypes.h $(C_COMMON_H) $(TREE_H) $(CPPLIB_H) $(CPP_INTERNAL_H) \ + $(C_PRAGMA_H) -attribs.o : attribs.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) \ - $(FLAGS_H) $(TOPLEV_H) output.h $(GGC_H) $(TM_P_H) \ - $(TARGET_H) langhooks.h $(CPPLIB_H) $(PLUGIN_H) +c-family/c-pragma.o: c-family/c-pragma.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ + $(TM_H) $(TREE_H) $(FUNCTION_H) $(C_PRAGMA_H) $(TOPLEV_H) output.h \ + $(TM_P_H) $(C_COMMON_H) $(TARGET_H) $(CPPLIB_H) $(FLAGS_H) \ + $(DIAGNOSTIC_H) opts.h $(PLUGINS_H) \ + gt-c-family-c-pragma.h -c-format.o : c-format.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) langhooks.h \ - $(C_COMMON_H) $(FLAGS_H) $(TOPLEV_H) intl.h $(DIAGNOSTIC_CORE_H) alloc-pool.h \ - c-format.h +c-family/c-pretty-print.o : c-family/c-pretty-print.c $(C_PRETTY_PRINT_H) \ + $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ + $(DIAGNOSTIC_H) tree-iterator.h intl.h tree-pretty-print.h -c-semantics.o : c-semantics.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ - $(TREE_H) $(FLAGS_H) $(TOPLEV_H) output.h $(C_COMMON_H) $(FUNCTION_H) \ - langhooks.h $(SPLAY_TREE_H) $(TIMEVAR_H) tree-iterator.h +c-family/c-semantics.o : c-family/c-semantics.c $(CONFIG_H) $(SYSTEM_H) \ + coretypes.h $(TM_H) $(TREE_H) $(FLAGS_H) $(TOPLEV_H) output.h \ + $(C_COMMON_H) $(FUNCTION_H) langhooks.h $(SPLAY_TREE_H) $(TIMEVAR_H) \ + tree-iterator.h -c-dump.o : c-dump.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) \ - $(C_TREE_H) $(TREE_DUMP_H) +c-family/c-ada-spec.o : c-family/c-ada-spec.c c-family/c-ada-spec.h \ + $(CONFIG_H) $(SYSTEM_H) $(TREE_H) $(CPP_ID_DATA_H) $(TM_H) \ + coretypes.h tree-iterator.h tree-pass.h output.h -c-pch.o : c-pch.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(CPPLIB_H) $(TREE_H) \ - $(C_COMMON_H) output.h $(TOPLEV_H) $(C_PRAGMA_H) $(GGC_H) debug.h \ - langhooks.h $(FLAGS_H) hosthooks.h version.h $(TARGET_H) opts.h \ - $(TIMEVAR_H) - $(COMPILER) -c $(ALL_COMPILERFLAGS) $(ALL_CPPFLAGS) \ - -DHOST_MACHINE=\"$(host)\" -DTARGET_MACHINE=\"$(target)\" \ - $< $(OUTPUT_OPTION) +c-family/stub-objc.o : c-family/stub-objc.c $(CONFIG_H) $(SYSTEM_H) \ + coretypes.h $(TREE_H) $(C_COMMON_H) -c-omp.o : c-omp.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TREE_H) \ - $(C_COMMON_H) $(TOPLEV_H) $(GIMPLE_H) langhooks.h + +# Files used by all variants of C and some other languages. + +attribs.o : attribs.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) \ + $(FLAGS_H) $(TOPLEV_H) output.h $(GGC_H) $(TM_P_H) \ + $(TARGET_H) langhooks.h $(CPPLIB_H) $(PLUGIN_H) + +incpath.o: incpath.c incpath.h $(CONFIG_H) $(SYSTEM_H) $(CPPLIB_H) \ + intl.h prefix.h coretypes.h $(TM_H) cppdefault.h $(TARGET_H) \ + $(MACHMODE_H) + +prefix.o: prefix.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) prefix.h \ + Makefile $(BASEVER) + $(COMPILER) $(ALL_COMPILERFLAGS) $(ALL_CPPFLAGS) \ + -DPREFIX=\"$(prefix)\" -DBASEVER=$(BASEVER_s) \ + -c $(srcdir)/prefix.c $(OUTPUT_OPTION) # Language-independent files. @@ -2201,26 +2253,21 @@ gtype-desc.o: gtype-desc.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ ggc-common.o: ggc-common.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ $(GGC_H) $(HASHTAB_H) $(TOPLEV_H) $(PARAMS_H) hosthooks.h \ - $(HOSTHOOKS_DEF_H) $(VEC_H) $(PLUGIN_H) $(TIMEVAR_H) + $(HOSTHOOKS_DEF_H) $(VEC_H) $(PLUGIN_H) $(GGC_INTERNAL_H) $(TIMEVAR_H) ggc-page.o: ggc-page.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(RTL_H) $(TREE_H) \ - $(FLAGS_H) $(TOPLEV_H) $(GGC_H) $(TIMEVAR_H) $(TM_P_H) $(PARAMS_H) $(TREE_FLOW_H) $(PLUGIN_H) + $(FLAGS_H) $(TOPLEV_H) $(GGC_H) $(TIMEVAR_H) $(TM_P_H) $(PARAMS_H) \ + $(TREE_FLOW_H) $(PLUGIN_H) $(GGC_INTERNAL_H) ggc-zone.o: ggc-zone.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(RTL_H) \ $(TREE_H) $(FLAGS_H) $(TOPLEV_H) $(GGC_H) $(TIMEVAR_H) $(TM_P_H) \ - $(PARAMS_H) $(BITMAP_H) $(PLUGIN_H) + $(PARAMS_H) $(BITMAP_H) $(PLUGIN_H) $(GGC_INTERNAL_H) ggc-none.o: ggc-none.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(GGC_H) \ $(BCONFIG_H) stringpool.o: stringpool.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ - $(TREE_H) $(GGC_H) gt-stringpool.h $(CPPLIB_H) $(SYMTAB_H) - -prefix.o: prefix.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) prefix.h \ - Makefile $(BASEVER) - $(COMPILER) $(ALL_COMPILERFLAGS) $(ALL_CPPFLAGS) \ - -DPREFIX=\"$(prefix)\" -DBASEVER=$(BASEVER_s) \ - -c $(srcdir)/prefix.c $(OUTPUT_OPTION) + $(TREE_H) $(GGC_H) $(GGC_INTERNAL_H) gt-stringpool.h $(CPPLIB_H) $(SYMTAB_H) convert.o: convert.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) \ $(FLAGS_H) convert.h $(TOPLEV_H) langhooks.h @@ -2237,26 +2284,26 @@ lto-cgraph.o: lto-cgraph.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ $(TM_H) $(TOPLEV_H) $(EXPR_H) $(FLAGS_H) $(PARAMS_H) input.h \ $(HASHTAB_H) langhooks.h $(BASIC_BLOCK_H) \ $(TREE_FLOW_H) $(CGRAPH_H) $(FUNCTION_H) $(GGC_H) $(DIAGNOSTIC_CORE_H) \ - except.h $(TIMEVAR_H) output.h pointer-set.h $(LTO_STREAMER_H) $(GCOV_IO_H) + $(EXCEPT_H) $(TIMEVAR_H) output.h pointer-set.h $(LTO_STREAMER_H) $(GCOV_IO_H) lto-streamer-in.o: lto-streamer-in.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ $(TM_H) $(TOPLEV_H) $(EXPR_H) $(FLAGS_H) $(PARAMS_H) input.h \ $(HASHTAB_H) $(BASIC_BLOCK_H) $(TREE_FLOW_H) $(TREE_PASS_H) $(CGRAPH_H) \ $(FUNCTION_H) $(GGC_H) $(DIAGNOSTIC_H) libfuncs.h $(EXCEPT_H) debug.h \ - $(TIMEVAR_H) output.h $(IPA_UTILS_H) $(LTO_STREAMER_H) + $(TIMEVAR_H) output.h $(IPA_UTILS_H) $(LTO_STREAMER_H) toplev.h lto-streamer-out.o : lto-streamer-out.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ $(TM_H) $(TOPLEV_H) $(TREE_H) $(EXPR_H) $(FLAGS_H) $(PARAMS_H) input.h \ $(HASHTAB_H) $(BASIC_BLOCK_H) tree-iterator.h \ $(TREE_FLOW_H) $(TREE_PASS_H) $(CGRAPH_H) $(FUNCTION_H) $(GGC_H) \ - $(DIAGNOSTIC_CORE_H) except.h $(LTO_STREAMER_H) $(TOPLEV_H) + $(DIAGNOSTIC_CORE_H) $(EXCEPT_H) $(LTO_STREAMER_H) $(TOPLEV_H) lto-section-in.o: lto-section-in.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ $(TOPLEV_H) $(EXPR_H) $(FLAGS_H) $(PARAMS_H) input.h \ $(HASHTAB_H) $(BASIC_BLOCK_H) $(TREE_FLOW_H) $(CGRAPH_H) $(FUNCTION_H) \ - $(GGC_H) $(DIAGNOSTIC_CORE_H) except.h $(TIMEVAR_H) output.h \ + $(GGC_H) $(DIAGNOSTIC_CORE_H) $(EXCEPT_H) $(TIMEVAR_H) output.h \ $(LTO_STREAMER_H) lto-compress.h lto-section-out.o : lto-section-out.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ $(TM_H) $(TOPLEV_H) $(TREE_H) $(EXPR_H) $(PARAMS_H) input.h \ $(HASHTAB_H) $(BASIC_BLOCK_H) $(TREE_FLOW_H) $(TREE_PASS_H) \ - $(CGRAPH_H) $(FUNCTION_H) $(GGC_H) except.h pointer-set.h \ + $(CGRAPH_H) $(FUNCTION_H) $(GGC_H) $(EXCEPT_H) pointer-set.h \ $(BITMAP_H) langhooks.h $(LTO_STREAMER_H) lto-compress.h lto-symtab.o: lto-symtab.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ toplev.h $(TREE_H) $(GIMPLE_H) $(GGC_H) $(LAMBDA_H) $(HASHTAB_H) \ @@ -2455,7 +2502,7 @@ tree-nested.o: tree-nested.c $(CONFIG_H) $(SYSTEM_H) $(TM_H) $(TREE_H) \ tree-if-conv.o: tree-if-conv.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ $(TREE_H) $(FLAGS_H) $(TIMEVAR_H) $(BASIC_BLOCK_H) $(TREE_FLOW_H) \ $(CFGLOOP_H) $(TREE_DATA_REF_H) $(TREE_PASS_H) $(DIAGNOSTIC_H) \ - $(TREE_DUMP_H) tree-pretty-print.h gimple-pretty-print.h + $(TREE_DUMP_H) $(DBGCNT_H) tree-pretty-print.h gimple-pretty-print.h tree-iterator.o : tree-iterator.c $(CONFIG_H) $(SYSTEM_H) $(TREE_H) \ coretypes.h $(GGC_H) tree-iterator.h $(GIMPLE_H) gt-tree-iterator.h tree-dfa.o : tree-dfa.c $(TREE_FLOW_H) $(CONFIG_H) $(SYSTEM_H) \ @@ -2463,7 +2510,7 @@ tree-dfa.o : tree-dfa.c $(TREE_FLOW_H) $(CONFIG_H) $(SYSTEM_H) \ $(TREE_INLINE_H) $(HASHTAB_H) pointer-set.h $(FLAGS_H) $(FUNCTION_H) \ $(TIMEVAR_H) convert.h $(TM_H) coretypes.h langhooks.h $(TREE_DUMP_H) \ $(TREE_PASS_H) $(PARAMS_H) $(CGRAPH_H) $(BASIC_BLOCK_H) $(GIMPLE_H) \ - tree-pretty-print.h + tree-pretty-print.h $(TOPLEV_H) tree-ssa-operands.o : tree-ssa-operands.c $(TREE_FLOW_H) $(CONFIG_H) \ $(SYSTEM_H) $(TREE_H) $(GGC_H) $(DIAGNOSTIC_H) $(TREE_INLINE_H) \ $(FLAGS_H) $(FUNCTION_H) $(TM_H) $(TIMEVAR_H) $(TREE_PASS_H) $(TOPLEV_H) \ @@ -2560,11 +2607,6 @@ tree-optimize.o : tree-optimize.c $(TREE_FLOW_H) $(CONFIG_H) $(SYSTEM_H) \ $(TREE_INLINE_H) tree-mudflap.h $(GGC_H) graph.h $(CGRAPH_H) \ $(TREE_PASS_H) $(CFGLOOP_H) $(EXCEPT_H) $(REGSET_H) -c-gimplify.o : c-gimplify.c $(CONFIG_H) $(SYSTEM_H) $(TREE_H) \ - $(C_TREE_H) $(C_COMMON_H) $(DIAGNOSTIC_CORE_H) $(GIMPLE_H) \ - $(FLAGS_H) langhooks.h $(TOPLEV_H) $(RTL_H) $(TREE_FLOW_H) $(LANGHOOKS_DEF_H) \ - $(TM_H) coretypes.h $(C_PRETTY_PRINT_H) $(CGRAPH_H) $(BASIC_BLOCK_H) \ - hard-reg-set.h $(TREE_DUMP_H) $(TREE_INLINE_H) gimplify.o : gimplify.c $(CONFIG_H) $(SYSTEM_H) $(TREE_H) $(GIMPLE_H) \ $(DIAGNOSTIC_H) $(GIMPLE_H) $(TREE_INLINE_H) langhooks.h \ $(LANGHOOKS_DEF_H) $(TREE_FLOW_H) $(CGRAPH_H) $(TIMEVAR_H) $(TM_H) \ @@ -2670,7 +2712,7 @@ tree-vect-loop.o: tree-vect-loop.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ $(TM_H) $(GGC_H) $(TREE_H) $(BASIC_BLOCK_H) $(DIAGNOSTIC_H) $(TREE_FLOW_H) \ $(TREE_DUMP_H) $(CFGLOOP_H) $(CFGLAYOUT_H) $(EXPR_H) $(RECOG_H) $(OPTABS_H) \ $(TOPLEV_H) $(SCEV_H) $(TREE_VECTORIZER_H) tree-pretty-print.h \ - gimple-pretty-print.h + gimple-pretty-print.h $(TARGET_H) tree-vect-loop-manip.o: tree-vect-loop-manip.c $(CONFIG_H) $(SYSTEM_H) \ coretypes.h $(TM_H) $(GGC_H) $(TREE_H) $(BASIC_BLOCK_H) $(DIAGNOSTIC_H) \ $(TREE_FLOW_H) $(TREE_DUMP_H) $(CFGLOOP_H) $(CFGLAYOUT_H) $(EXPR_H) $(TOPLEV_H) \ @@ -2744,14 +2786,10 @@ tree-pretty-print.o : tree-pretty-print.c $(CONFIG_H) $(SYSTEM_H) \ $(TREE_PASS_H) value-prof.h output.h tree-pretty-print.h tree-diagnostic.o : tree-diagnostic.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ $(TREE_H) $(DIAGNOSTIC_H) tree-diagnostic.h langhooks.h $(LANGHOOKS_DEF_H) -c-ada-spec.o : c-ada-spec.c c-ada-spec.h $(CONFIG_H) $(SYSTEM_H) \ - $(TREE_H) $(REAL_H) $(HASHTAB_H) $(TREE_FLOW_H) \ - $(CPP_ID_DATA_H) $(TM_H) coretypes.h tree-iterator.h tree-pass.h \ - value-prof.h fixed-value.h output.h fold-const.o : fold-const.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ $(TREE_H) $(FLAGS_H) $(TOPLEV_H) $(HASHTAB_H) $(EXPR_H) $(RTL_H) \ $(GGC_H) $(TM_P_H) langhooks.h $(MD5_H) intl.h $(TARGET_H) \ - $(GIMPLE_H) realmpfr.h + $(GIMPLE_H) realmpfr.h $(TREE_FLOW_H) diagnostic.o : diagnostic.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ version.h $(INPUT_H) intl.h $(DIAGNOSTIC_H) diagnostic.def opts.o : opts.c opts.h options.h $(TOPLEV_H) $(CONFIG_H) $(SYSTEM_H) \ @@ -2811,8 +2849,8 @@ main.o : main.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TOPLEV_H) host-default.o : host-default.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ hosthooks.h $(HOSTHOOKS_DEF_H) -rtl-error.o: rtl-error.c $(SYSTEM_H) coretypes.h $(TM_H) $(RTL_H) \ - $(INSN_ATTR_H) insn-config.h $(INPUT_H) $(TOPLEV_H) intl.h $(DIAGNOSTIC_H) \ +rtl-error.o: rtl-error.c $(SYSTEM_H) coretypes.h $(TM_H) $(RTL_ERROR_H) \ + $(INSN_ATTR_H) insn-config.h $(INPUT_H) intl.h $(DIAGNOSTIC_H) \ $(CONFIG_H) rtl.o : rtl.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(RTL_H) \ @@ -2832,10 +2870,10 @@ varasm.o : varasm.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) \ $(HASHTAB_H) $(TARGET_H) langhooks.h gt-varasm.h $(BASIC_BLOCK_H) \ $(CFGLAYOUT_H) $(CGRAPH_H) targhooks.h tree-mudflap.h \ tree-iterator.h -function.o : function.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(RTL_H) \ +function.o : function.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(RTL_ERROR_H) \ $(TREE_H) $(CFGLAYOUT_H) $(GIMPLE_H) $(FLAGS_H) $(FUNCTION_H) $(EXPR_H) \ $(OPTABS_H) libfuncs.h $(REGS_H) hard-reg-set.h insn-config.h $(RECOG_H) \ - output.h $(TOPLEV_H) $(EXCEPT_H) $(HASHTAB_H) $(GGC_H) $(TM_P_H) langhooks.h \ + output.h $(EXCEPT_H) $(HASHTAB_H) $(GGC_H) $(TM_P_H) langhooks.h \ gt-function.h $(TARGET_H) $(BASIC_BLOCK_H) $(INTEGRATE_H) $(PREDICT_H) \ $(TREE_PASS_H) $(DF_H) $(TIMEVAR_H) vecprim.h statistics.o : statistics.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ @@ -2959,7 +2997,7 @@ ipa-prop.o : ipa-prop.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ langhooks.h $(GGC_H) $(TARGET_H) $(CGRAPH_H) $(IPA_PROP_H) $(DIAGNOSTIC_H) \ $(TREE_FLOW_H) $(TM_H) $(TREE_PASS_H) $(FLAGS_H) $(TREE_H) \ $(TREE_INLINE_H) $(GIMPLE_H) $(GIMPLE_FOLD_H) $(TIMEVAR_H) \ - tree-pretty-print.h gimple-pretty-print.h + tree-pretty-print.h gimple-pretty-print.h $(LTO_STREAMER_H) ipa-ref.o : ipa-ref.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ langhooks.h $(GGC_H) $(TARGET_H) $(CGRAPH_H) $(TREE_H) $(TARGET_H) \ $(TREE_FLOW_H) $(TM_H) $(TREE_PASS_H) $(FLAGS_H) $(TREE_H) $(GGC_H) @@ -2967,6 +3005,10 @@ ipa-cp.o : ipa-cp.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ $(TREE_H) $(TARGET_H) $(CGRAPH_H) $(IPA_PROP_H) $(TREE_FLOW_H) \ $(TREE_PASS_H) $(FLAGS_H) $(TIMEVAR_H) $(DIAGNOSTIC_H) $(TREE_DUMP_H) \ $(TREE_INLINE_H) $(FIBHEAP_H) $(PARAMS_H) tree-pretty-print.h +ipa-split.o : ipa-split.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ + $(TREE_H) $(TARGET_H) $(CGRAPH_H) $(IPA_PROP_H) $(TREE_FLOW_H) \ + $(TREE_PASS_H) $(FLAGS_H) $(TIMEVAR_H) $(DIAGNOSTIC_H) $(TREE_DUMP_H) \ + $(TREE_INLINE_H) $(FIBHEAP_H) $(PARAMS_H) matrix-reorg.o : matrix-reorg.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ $(TM_H) $(TREE_H) $(RTL_H) $(TREE_INLINE_H) $(TREE_FLOW_H) \ tree-flow-inline.h langhooks.h $(HASHTAB_H) $(TOPLEV_H) $(FLAGS_H) $(GGC_H) \ @@ -3082,7 +3124,8 @@ tree-ssa-ccp.o : tree-ssa-ccp.c $(TREE_FLOW_H) $(CONFIG_H) \ tree-sra.o : tree-sra.c $(CONFIG_H) $(SYSTEM_H) coretypes.h alloc-pool.h \ $(TM_H) $(TREE_H) $(GIMPLE_H) $(CGRAPH_H) $(TREE_FLOW_H) $(IPA_PROP_H) \ $(DIAGNOSTIC_H) statistics.h $(TREE_DUMP_H) $(TIMEVAR_H) $(PARAMS_H) \ - $(TARGET_H) $(FLAGS_H) $(EXPR_H) tree-pretty-print.h + $(TARGET_H) $(FLAGS_H) $(EXPR_H) tree-pretty-print.h $(DBGCNT_H) \ + $(TREE_INLINE_H) tree-switch-conversion.o : tree-switch-conversion.c $(CONFIG_H) $(SYSTEM_H) \ $(TREE_H) $(TM_P_H) $(TREE_FLOW_H) $(DIAGNOSTIC_H) $(TREE_INLINE_H) \ $(TIMEVAR_H) $(TM_H) coretypes.h $(TREE_DUMP_H) $(GIMPLE_H) \ @@ -3156,10 +3199,10 @@ cfgexpand.o : cfgexpand.c $(TREE_FLOW_H) $(CONFIG_H) $(SYSTEM_H) \ coretypes.h $(TREE_DUMP_H) $(EXCEPT_H) langhooks.h $(TREE_PASS_H) $(RTL_H) \ $(DIAGNOSTIC_H) $(TOPLEV_H) $(BASIC_BLOCK_H) $(FLAGS_H) debug.h $(PARAMS_H) \ value-prof.h $(TREE_INLINE_H) $(TARGET_H) $(SSAEXPAND_H) \ - tree-pretty-print.h gimple-pretty-print.h $(BITMAP_H) sbitmap.h -cfgrtl.o : cfgrtl.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(RTL_H) \ + tree-pretty-print.h gimple-pretty-print.h $(BITMAP_H) sbitmap.h $(INSN_ATTR_H) +cfgrtl.o : cfgrtl.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(RTL_ERROR_H) \ $(FLAGS_H) insn-config.h $(BASIC_BLOCK_H) $(REGS_H) hard-reg-set.h \ - output.h $(TOPLEV_H) $(FUNCTION_H) $(EXCEPT_H) $(TM_P_H) $(INSN_ATTR_H) \ + output.h $(FUNCTION_H) $(EXCEPT_H) $(TM_P_H) $(INSN_ATTR_H) \ insn-config.h $(EXPR_H) \ $(CFGLAYOUT_H) $(CFGLOOP_H) $(OBSTACK_H) $(TARGET_H) $(TREE_H) \ $(TREE_PASS_H) $(DF_H) $(GGC_H) @@ -3223,13 +3266,13 @@ bitmap.o : bitmap.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(RTL_H) \ $(FLAGS_H) $(GGC_H) gt-bitmap.h $(BITMAP_H) $(OBSTACK_H) $(HASHTAB_H) vec.o : vec.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(VEC_H) $(GGC_H) \ $(TOPLEV_H) $(HASHTAB_H) -reload.o : reload.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(RTL_H) \ +reload.o : reload.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(RTL_ERROR_H) \ $(FLAGS_H) output.h $(EXPR_H) $(OPTABS_H) reload.h $(RECOG_H) \ - hard-reg-set.h insn-config.h $(REGS_H) $(FUNCTION_H) real.h $(TOPLEV_H) \ - addresses.h $(TM_P_H) $(PARAMS_H) $(TARGET_H) $(DF_H) ira.h -reload1.o : reload1.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(RTL_H) \ + hard-reg-set.h insn-config.h $(REGS_H) $(FUNCTION_H) real.h \ + addresses.h $(TM_P_H) $(PARAMS_H) $(TARGET_H) $(DF_H) ira.h $(TOPLEV_H) +reload1.o : reload1.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(RTL_ERROR_H) \ $(EXPR_H) $(OPTABS_H) reload.h $(REGS_H) hard-reg-set.h insn-config.h \ - $(BASIC_BLOCK_H) $(RECOG_H) output.h $(FUNCTION_H) $(TOPLEV_H) $(TM_P_H) \ + $(BASIC_BLOCK_H) $(RECOG_H) output.h $(FUNCTION_H) $(TM_P_H) \ addresses.h $(EXCEPT_H) $(TREE_H) $(FLAGS_H) $(MACHMODE_H) \ $(OBSTACK_H) $(DF_H) $(TARGET_H) $(EMIT_RTL_H) ira.h rtlhooks.o : rtlhooks.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(RTL_H) \ @@ -3276,7 +3319,7 @@ ira-build.o: ira-build.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ ira-costs.o: ira-costs.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ hard-reg-set.h $(RTL_H) $(EXPR_H) $(TM_P_H) $(FLAGS_H) $(BASIC_BLOCK_H) \ $(REGS_H) addresses.h insn-config.h $(RECOG_H) $(TOPLEV_H) $(TARGET_H) \ - $(PARAMS_H) $(IRA_INT_H) + $(PARAMS_H) $(IRA_INT_H) reload.h ira-conflicts.o: ira-conflicts.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ $(TARGET_H) $(RTL_H) $(REGS_H) hard-reg-set.h $(FLAGS_H) \ insn-config.h $(RECOG_H) $(BASIC_BLOCK_H) $(TOPLEV_H) $(TM_P_H) $(PARAMS_H) \ @@ -3338,8 +3381,8 @@ sched-vis.o : sched-vis.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ $(RTL_H) $(SCHED_INT_H) hard-reg-set.h $(BASIC_BLOCK_H) $(OBSTACK_H) \ $(TREE_PASS_H) $(INSN_ATTR_H) sel-sched.o : sel-sched.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ - $(RTL_H) $(REGS_H) hard-reg-set.h $(FLAGS_H) insn-config.h \ - $(FUNCTION_H) $(INSN_ATTR_H) $(TOPLEV_H) $(RECOG_H) $(EXCEPT_H) $(PARAMS_H) \ + $(RTL_ERROR_H) $(REGS_H) hard-reg-set.h $(FLAGS_H) insn-config.h \ + $(FUNCTION_H) $(INSN_ATTR_H) $(RECOG_H) $(EXCEPT_H) $(PARAMS_H) \ $(TM_P_H) output.h $(TARGET_H) $(TIMEVAR_H) $(TREE_PASS_H) \ $(SCHED_INT_H) $(GGC_H) $(TREE_H) langhooks.h rtlhooks-def.h \ $(SEL_SCHED_IR_H) $(SEL_SCHED_DUMP_H) sel-sched.h $(DBGCNT_H) $(EMIT_RTL_H) @@ -3355,21 +3398,21 @@ sel-sched-ir.o : sel-sched-ir.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ $(TM_P_H) $(TARGET_H) $(TIMEVAR_H) $(TREE_PASS_H) $(SCHED_INT_H) $(GGC_H) \ $(TREE_H) langhooks.h rtlhooks-def.h $(SEL_SCHED_IR_H) $(SEL_SCHED_DUMP_H) \ $(EMIT_RTL_H) -final.o : final.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(RTL_H) \ +final.o : final.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(RTL_ERROR_H) \ $(TREE_H) $(FLAGS_H) intl.h $(REGS_H) $(RECOG_H) conditions.h \ insn-config.h $(INSN_ATTR_H) $(FUNCTION_H) output.h hard-reg-set.h \ $(EXCEPT_H) debug.h xcoffout.h $(TOPLEV_H) reload.h dwarf2out.h \ $(TREE_PASS_H) $(BASIC_BLOCK_H) $(TM_P_H) $(TARGET_H) $(EXPR_H) \ $(CFGLAYOUT_H) dbxout.h $(TIMEVAR_H) $(CGRAPH_H) $(COVERAGE_H) \ $(DF_H) vecprim.h $(GGC_H) $(CFGLOOP_H) $(PARAMS_H) $(TREE_FLOW_H) -recog.o : recog.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(RTL_H) \ +recog.o : recog.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(RTL_ERROR_H) \ $(FUNCTION_H) $(BASIC_BLOCK_H) $(REGS_H) $(RECOG_H) $(EXPR_H) \ - $(FLAGS_H) insn-config.h $(INSN_ATTR_H) $(TOPLEV_H) output.h reload.h \ + $(FLAGS_H) insn-config.h $(INSN_ATTR_H) output.h reload.h \ addresses.h $(TM_P_H) $(TIMEVAR_H) $(TREE_PASS_H) hard-reg-set.h \ - $(DF_H) $(DBGCNT_H) $(TARGET_H) + $(DF_H) $(DBGCNT_H) $(TARGET_H) $(TOPLEV_H) reg-stack.o : reg-stack.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ - $(RTL_H) $(TREE_H) $(RECOG_H) $(REGS_H) hard-reg-set.h $(FLAGS_H) \ - insn-config.h $(TOPLEV_H) reload.h $(FUNCTION_H) $(TM_P_H) $(GGC_H) \ + $(RTL_ERROR_H) $(TREE_H) $(RECOG_H) $(REGS_H) hard-reg-set.h $(FLAGS_H) \ + insn-config.h reload.h $(FUNCTION_H) $(TM_P_H) $(GGC_H) \ $(BASIC_BLOCK_H) $(CFGLAYOUT_H) output.h $(TIMEVAR_H) \ $(TREE_PASS_H) $(TARGET_H) vecprim.h $(DF_H) $(EMIT_RTL_H) sreal.o: sreal.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) sreal.h @@ -3401,9 +3444,9 @@ regcprop.o : regcprop.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ output.h $(RECOG_H) $(FUNCTION_H) $(OBSTACK_H) $(FLAGS_H) $(TM_P_H) \ addresses.h reload.h $(TOPLEV_H) $(TIMEVAR_H) $(TREE_PASS_H) $(DF_H) regrename.o : regrename.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ - $(RTL_H) insn-config.h $(BASIC_BLOCK_H) $(REGS_H) hard-reg-set.h \ + $(RTL_ERROR_H) insn-config.h $(BASIC_BLOCK_H) $(REGS_H) hard-reg-set.h \ output.h $(RECOG_H) $(FUNCTION_H) $(OBSTACK_H) $(FLAGS_H) $(TM_P_H) \ - addresses.h reload.h $(TOPLEV_H) $(TIMEVAR_H) $(TREE_PASS_H) $(DF_H) + addresses.h reload.h $(TIMEVAR_H) $(TREE_PASS_H) $(DF_H) ifcvt.o : ifcvt.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(RTL_H) \ $(REGS_H) $(TOPLEV_H) $(FLAGS_H) insn-config.h $(FUNCTION_H) $(RECOG_H) \ $(TARGET_H) $(BASIC_BLOCK_H) $(EXPR_H) output.h $(EXCEPT_H) $(TM_P_H) \ @@ -3499,6 +3542,7 @@ insn-emit.o : insn-emit.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ dfp.h $(FLAGS_H) output.h insn-config.h hard-reg-set.h $(RECOG_H) \ $(RESOURCE_H) reload.h $(TOPLEV_H) $(REGS_H) tm-constrs.h $(GGC_H) \ $(BASIC_BLOCK_H) $(INTEGRATE_H) +insn-enums.o : insn-enums.c $(CONFIG_H) $(SYSTEM_H) insn-extract.o : insn-extract.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ $(TM_H) $(RTL_H) $(TOPLEV_H) insn-config.h $(RECOG_H) insn-modes.o : insn-modes.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ @@ -3524,54 +3568,43 @@ insn-recog.o : insn-recog.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ reload.h $(REGS_H) tm-constrs.h # For each of the files generated by running a generator program over -# the machine description, the following pair of static pattern rules -# runs the generator program only if the machine description has changed, -# but touches the target file only when its contents actually change. -# The "; @true" construct forces Make to recheck the timestamp on the -# target file. +# the machine description, the following static pattern rules run the +# generator program only if the machine description has changed, +# but touch the target file only when its contents actually change. +# The "; @true" construct forces Make to recheck the timestamp on +# the target file. -simple_generated_h = insn-attr.h insn-codes.h insn-config.h insn-flags.h +simple_rtl_generated_h = insn-attr.h insn-codes.h insn-config.h insn-flags.h -simple_generated_c = insn-attrtab.c insn-automata.c insn-emit.c \ - insn-extract.c insn-opinit.c insn-output.c \ - insn-peep.c insn-recog.c +simple_rtl_generated_c = insn-attrtab.c insn-automata.c insn-emit.c \ + insn-extract.c insn-opinit.c insn-output.c \ + insn-peep.c insn-recog.c + +simple_generated_h = $(simple_rtl_generated_h) insn-constants.h + +simple_generated_c = $(simple_rtl_generated_c) insn-enums.c + +$(simple_generated_h:insn-%.h=s-%) \ +$(simple_generated_c:insn-%.c=s-%): s-%: $(MD_DEPS) + +$(simple_rtl_generated_h:insn-%.h=s-%) \ +$(simple_rtl_generated_c:insn-%.c=s-%): s-%: insn-conditions.md $(simple_generated_h): insn-%.h: s-%; @true -$(simple_generated_h:insn-%.h=s-%): s-%: build/gen%$(build_exeext) \ - $(MD_DEPS) insn-conditions.md +$(simple_generated_h:insn-%.h=s-%): s-%: build/gen%$(build_exeext) $(RUN_GEN) build/gen$*$(build_exeext) $(md_file) \ - insn-conditions.md > tmp-$*.h + $(filter insn-conditions.md,$^) > tmp-$*.h $(SHELL) $(srcdir)/../move-if-change tmp-$*.h insn-$*.h $(STAMP) s-$* $(simple_generated_c): insn-%.c: s-%; @true -$(simple_generated_c:insn-%.c=s-%): s-%: build/gen%$(build_exeext) \ - $(MD_DEPS) insn-conditions.md +$(simple_generated_c:insn-%.c=s-%): s-%: build/gen%$(build_exeext) $(RUN_GEN) build/gen$*$(build_exeext) $(md_file) \ - insn-conditions.md > tmp-$*.c + $(filter insn-conditions.md,$^) > tmp-$*.c $(SHELL) $(srcdir)/../move-if-change tmp-$*.c insn-$*.c $(STAMP) s-$* -generated_files = config.h tm.h $(TM_P_H) $(TM_H) multilib.h \ - $(simple_generated_h) specs.h \ - tree-check.h genrtl.h insn-modes.h tm-preds.h tm-constrs.h \ - $(ALL_GTFILES_H) gtype-desc.c gtype-desc.h gcov-iov.h - -# In order for parallel make to really start compiling the expensive -# objects from $(OBJS-common) as early as possible, build all their -# prerequisites strictly before all objects. -$(ALL_HOST_OBJS) : | $(generated_files) - -# genconstants needs to run before insn-conditions.md is available -# (because the constants may be used in the conditions). -insn-constants.h: s-constants; @true -s-constants: build/genconstants$(build_exeext) $(MD_DEPS) - $(RUN_GEN) build/genconstants$(build_exeext) $(md_file) \ - > tmp-constants.h - $(SHELL) $(srcdir)/../move-if-change tmp-constants.h insn-constants.h - $(STAMP) s-constants - # gencheck doesn't read the machine description, and the file produced # doesn't use the insn-* convention. tree-check.h: s-check ; @true @@ -3642,6 +3675,36 @@ s-constrs-h: $(MD_DEPS) build/genpreds$(build_exeext) $(SHELL) $(srcdir)/../move-if-change tmp-constrs.h tm-constrs.h $(STAMP) s-constrs-h +target-hooks-def.h: s-target-hooks-def-h; @true +tm.texi: s-tm-texi; @true + +s-target-hooks-def-h: build/genhooks$(build_exeext) + $(RUN_GEN) build/genhooks$(build_exeext) > tmp-target-hooks-def.h + $(SHELL) $(srcdir)/../move-if-change tmp-target-hooks-def.h \ + target-hooks-def.h + $(STAMP) s-target-hooks-def-h + +# check if someone mistakenly only changed tm.texi. +s-tm-texi: $(srcdir)/doc/tm.texi + +s-tm-texi: build/genhooks$(build_exeext) $(srcdir)/doc/tm.texi.in + $(RUN_GEN) build/genhooks$(build_exeext) \ + $(srcdir)/doc/tm.texi.in > tmp-tm.texi + $(SHELL) $(srcdir)/../move-if-change tmp-tm.texi tm.texi + @if cmp -s $(srcdir)/doc/tm.texi tm.texi; then \ + $(STAMP) $@; \ + elif test $(srcdir)/doc/tm.texi -nt $(srcdir)/doc/tm.texi.in \ + && test $(srcdir)/doc/tm.texi -nt $(srcdir)/doc/target.def; then \ + echo >&2 ; \ + echo You should edit $(srcdir)/doc/tm.texi.in rather than $(srcdir)/doc/tm.texi . >&2 ; \ + false; \ + else \ + echo >&2 ; \ + echo Verify that you have permission to grant a GFDL license for all >&2 ; \ + echo new text in tm.texi, then copy it to $(srcdir)/doc/tm.texi. >&2 ; \ + false; \ + fi + GTFILES = $(CPP_ID_DATA_H) $(srcdir)/input.h $(srcdir)/coretypes.h \ $(srcdir)/vecprim.h $(srcdir)/vecir.h \ $(host_xm_file_list) \ @@ -3721,6 +3784,16 @@ s-gtype: build/gengtype$(build_exeext) $(filter-out [%], $(GTFILES)) \ $(RUN_GEN) build/gengtype$(build_exeext) $(srcdir) gtyp-input.list $(STAMP) s-gtype +generated_files = config.h tm.h $(TM_P_H) $(TM_H) multilib.h \ + $(simple_generated_h) specs.h \ + tree-check.h genrtl.h insn-modes.h tm-preds.h tm-constrs.h \ + $(ALL_GTFILES_H) gtype-desc.c gtype-desc.h gcov-iov.h + +# In order for parallel make to really start compiling the expensive +# objects from $(OBJS-common) as early as possible, build all their +# prerequisites strictly before all objects. +$(ALL_HOST_OBJS) : | $(generated_files) + # # How to compile object files to run on the build machine. @@ -3733,15 +3806,18 @@ build/%.o : # dependencies provided by explicit rule later build/errors.o : errors.c $(BCONFIG_H) $(SYSTEM_H) errors.h build/gensupport.o: gensupport.c $(BCONFIG_H) $(SYSTEM_H) coretypes.h \ $(GTM_H) $(RTL_BASE_H) $(OBSTACK_H) errors.h $(HASHTAB_H) \ - gensupport.h + $(READ_MD_H) gensupport.h build/ggc-none.o : ggc-none.c $(BCONFIG_H) $(SYSTEM_H) coretypes.h \ $(GGC_H) build/min-insn-modes.o : min-insn-modes.c $(BCONFIG_H) $(SYSTEM_H) \ $(MACHMODE_H) build/print-rtl.o: print-rtl.c $(BCONFIG_H) $(SYSTEM_H) coretypes.h \ $(GTM_H) $(RTL_BASE_H) +build/read-md.o: read-md.c $(BCONFIG_H) $(SYSTEM_H) coretypes.h \ + $(HASHTAB_H) errors.h $(READ_MD_H) build/read-rtl.o: read-rtl.c $(BCONFIG_H) $(SYSTEM_H) coretypes.h \ - $(GTM_H) $(RTL_BASE_H) $(OBSTACK_H) $(HASHTAB_H) gensupport.h + $(GTM_H) $(RTL_BASE_H) $(OBSTACK_H) $(HASHTAB_H) $(READ_MD_H) \ + gensupport.h build/rtl.o: rtl.c $(BCONFIG_H) coretypes.h $(GTM_H) $(SYSTEM_H) \ $(RTL_H) $(GGC_H) errors.h build/vec.o : vec.c $(BCONFIG_H) $(SYSTEM_H) coretypes.h $(VEC_H) \ @@ -3759,10 +3835,10 @@ build/gencondmd.o : \ # ...these are the programs themselves. build/genattr.o : genattr.c $(RTL_BASE_H) $(BCONFIG_H) $(SYSTEM_H) \ - coretypes.h $(GTM_H) errors.h gensupport.h + coretypes.h $(GTM_H) errors.h $(READ_MD_H) gensupport.h build/genattrtab.o : genattrtab.c $(RTL_BASE_H) $(OBSTACK_H) \ $(BCONFIG_H) $(SYSTEM_H) coretypes.h $(GTM_H) errors.h $(GGC_H) \ - gensupport.h + $(READ_MD_H) gensupport.h vecprim.h build/genautomata.o : genautomata.c $(RTL_BASE_H) $(OBSTACK_H) \ $(BCONFIG_H) $(SYSTEM_H) coretypes.h $(GTM_H) errors.h $(VEC_H) \ $(HASHTAB_H) gensupport.h @@ -3772,17 +3848,21 @@ build/genchecksum.o : genchecksum.c $(BCONFIG_H) $(SYSTEM_H) $(MD5_H) build/gencodes.o : gencodes.c $(RTL_BASE_H) $(BCONFIG_H) $(SYSTEM_H) \ coretypes.h $(GTM_H) errors.h gensupport.h build/genconditions.o : genconditions.c $(RTL_BASE_H) $(BCONFIG_H) \ - $(SYSTEM_H) coretypes.h $(GTM_H) errors.h + $(SYSTEM_H) coretypes.h $(GTM_H) errors.h $(HASHTAB_H) $(READ_MD_H) \ + gensupport.h build/genconfig.o : genconfig.c $(RTL_BASE_H) $(BCONFIG_H) $(SYSTEM_H) \ coretypes.h $(GTM_H) errors.h gensupport.h -build/genconstants.o : genconstants.c $(RTL_BASE_H) $(BCONFIG_H) \ - $(SYSTEM_H) coretypes.h $(GTM_H) errors.h +build/genconstants.o : genconstants.c $(BCONFIG_H) $(SYSTEM_H) \ + coretypes.h errors.h $(READ_MD_H) build/genemit.o : genemit.c $(RTL_BASE_H) $(BCONFIG_H) $(SYSTEM_H) \ - coretypes.h $(GTM_H) errors.h gensupport.h + coretypes.h $(GTM_H) errors.h $(READ_MD_H) gensupport.h +build/genenums.o : genenums.c $(BCONFIG_H) $(SYSTEM_H) \ + coretypes.h errors.h $(READ_MD_H) build/genextract.o : genextract.c $(RTL_BASE_H) $(BCONFIG_H) \ - $(SYSTEM_H) coretypes.h $(GTM_H) errors.h gensupport.h vecprim.h + $(SYSTEM_H) coretypes.h $(GTM_H) errors.h $(READ_MD_H) gensupport.h \ + vecprim.h build/genflags.o : genflags.c $(RTL_BASE_H) $(OBSTACK_H) $(BCONFIG_H) \ - $(SYSTEM_H) coretypes.h $(GTM_H) errors.h gensupport.h + $(SYSTEM_H) coretypes.h $(GTM_H) errors.h $(READ_MD_H) gensupport.h build/gengenrtl.o : gengenrtl.c $(BCONFIG_H) $(SYSTEM_H) rtl.def build/gengtype-lex.o : gengtype-lex.c gengtype.h $(BCONFIG_H) $(SYSTEM_H) build/gengtype-parse.o : gengtype-parse.c gengtype.h $(BCONFIG_H) \ @@ -3790,19 +3870,20 @@ build/gengtype-parse.o : gengtype-parse.c gengtype.h $(BCONFIG_H) \ build/gengtype.o : gengtype.c $(BCONFIG_H) $(SYSTEM_H) gengtype.h \ rtl.def insn-notes.def errors.h double-int.h $(HASHTAB_H) build/genmddeps.o: genmddeps.c $(BCONFIG_H) $(SYSTEM_H) coretypes.h \ - $(GTM_H) $(RTL_BASE_H) errors.h gensupport.h + errors.h $(READ_MD_H) build/genmodes.o : genmodes.c $(BCONFIG_H) $(SYSTEM_H) errors.h \ $(HASHTAB_H) machmode.def $(extra_modes_file) build/genopinit.o : genopinit.c $(RTL_BASE_H) $(BCONFIG_H) $(SYSTEM_H) \ coretypes.h $(GTM_H) errors.h gensupport.h build/genoutput.o : genoutput.c $(RTL_BASE_H) $(BCONFIG_H) $(SYSTEM_H) \ - coretypes.h $(GTM_H) errors.h gensupport.h + coretypes.h $(GTM_H) errors.h $(READ_MD_H) gensupport.h build/genpeep.o : genpeep.c $(RTL_BASE_H) $(BCONFIG_H) $(SYSTEM_H) \ coretypes.h $(GTM_H) errors.h gensupport.h $(TOPLEV_H) build/genpreds.o : genpreds.c $(RTL_BASE_H) $(BCONFIG_H) $(SYSTEM_H) \ - coretypes.h $(GTM_H) errors.h gensupport.h $(OBSTACK_H) + coretypes.h $(GTM_H) errors.h $(READ_MD_H) gensupport.h $(OBSTACK_H) build/genrecog.o : genrecog.c $(RTL_BASE_H) $(BCONFIG_H) $(SYSTEM_H) \ - coretypes.h $(GTM_H) errors.h gensupport.h + coretypes.h $(GTM_H) errors.h $(READ_MD_H) gensupport.h +build/genhooks.o : genhooks.c target.def $(BCONFIG_H) $(SYSTEM_H) errors.h # Compile the programs that generate insn-* from the machine description. # They are compiled with $(COMPILER_FOR_BUILD), and associated libraries, @@ -3814,19 +3895,25 @@ build/gen%$(build_exeext): build/gen%.o $(BUILD_LIBDEPS) $(LINKER_FOR_BUILD) $(BUILD_LINKERFLAGS) $(BUILD_LDFLAGS) -o $@ \ $(filter-out $(BUILD_LIBDEPS), $^) $(BUILD_LIBS) -# All these programs use the MD reader ($(BUILD_RTL)). -genprogmd = attr attrtab automata codes conditions config constants emit \ - extract flags mddeps opinit output peep preds recog -$(genprogmd:%=build/gen%$(build_exeext)): $(BUILD_RTL) $(BUILD_ERRORS) +# All these programs use the RTL reader ($(BUILD_RTL)). +genprogrtl = attr attrtab automata codes conditions config emit \ + extract flags opinit output peep preds recog +$(genprogrtl:%=build/gen%$(build_exeext)): $(BUILD_RTL) + +# All these programs use the MD reader ($(BUILD_MD)). +genprogmd = $(genprogrtl) mddeps constants enums +$(genprogmd:%=build/gen%$(build_exeext)): $(BUILD_MD) + +# All generator programs need to report errors +genprog = $(genprogmd) genrtl modes gtype +$(genprog:%=build/gen%$(build_exeext)): $(BUILD_ERRORS) # These programs need libs over and above what they get from the above list. build/genautomata$(build_exeext) : BUILD_LIBS += -lm # These programs are not linked with the MD reader. -build/gengenrtl$(build_exeext) : $(BUILD_ERRORS) -build/genmodes$(build_exeext) : $(BUILD_ERRORS) -build/gengtype$(build_exeext) : build/gengtype-lex.o build/gengtype-parse.o \ - $(BUILD_ERRORS) +build/gengtype$(build_exeext) : build/gengtype-lex.o build/gengtype-parse.o +build/genhooks$(build_exeext) : $(BUILD_ERRORS) # Generated source files for gengtype. gengtype-lex.c : gengtype-lex.l @@ -4365,7 +4452,7 @@ PLUGIN_HEADERS = $(TREE_H) $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ $(host_xm_file_list) $(host_xm_include_list) $(xm_include_list) \ intl.h $(PLUGIN_VERSION_H) $(DIAGNOSTIC_H) $(C_COMMON_H) $(C_PRETTY_PRINT_H) \ tree-iterator.h $(PLUGIN_H) $(TREE_FLOW_H) langhooks.h incpath.h debug.h \ - except.h tree-ssa-sccvn.h real.h output.h $(IPA_UTILS_H) \ + $(EXCEPT_H) tree-ssa-sccvn.h real.h output.h $(IPA_UTILS_H) \ $(C_PRAGMA_H) $(CPPLIB_H) $(FUNCTION_H) \ cppdefault.h flags.h $(MD5_H) params.def params.h prefix.h tree-inline.h \ $(IPA_PROP_H) $(RTL_H) $(TM_P_H) $(CFGLOOP_H) $(EMIT_RTL_H) version.h @@ -4967,7 +5054,7 @@ TAGS: lang.tags incs="$$incs --include $$dir/TAGS.sub"; \ fi; \ done; \ - etags -o TAGS.sub *.h *.c; \ + etags -o TAGS.sub c-family/*.h c-family/*.c *.h *.c; \ etags --include TAGS.sub $$incs) # ----------------------------------------------------- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 3340a4e6997..98680a8ab03 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,3143 @@ +2010-06-30 Manuel López-Ibáñez + + * gcc-interface/trans.c: Do not include tree-flow.h. + * gcc-interface/Make-lang.in: Adjust dependencies. + +2010-06-29 Nathan Froyd + + * gcc-interface/gigi.h (gnat_build_constructor): Take a VEC instead + of a TREE_LIST. Update comment. + * gcc-interface/trans.c (gigi): Build a VEC instead of a TREE_LIST. + Adjust call to gnat_build_constructor. + (Attribute_to_gnu): Likewise. + (gnat_to_gnu): Likewise. + (pos_to_constructor): Likewise. + (extract_values): Likewise. + * gcc-interface/utils.c (build_template): Likewise. + (convert_vms_descriptor64): Likewise. + (convert_vms_descriptor32): Likewise. + (convert_to_fat_pointer): Likewise. + (convert): Likewise. + (unchecked_convert): Likewise. + * gcc-interface/decl.c (gnat_to_gnu_entity): Likewise. + * gcc-interface/utils2.c (build_allocator): Likewise. + (fill_vms_descriptor): Likewise. + (gnat_build_constructor): Take a VEC instead of a TREE_LIST. + (compare_elmt_bitpos): Adjust for parameters being constructor_elts + instead of TREE_LISTs. + +2010-06-28 Steven Bosscher + + * gcc-interface/misc.c: Do not include except.h. + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-27 Eric Botcazou + + * gcc-interface/trans.c: Include tree-flow.h. + (gnu_switch_label_stack): Delete. + (Case_Statement_to_gnu): Do not emit the goto at the end of a case if + its associated block cannot fall through. Do not emit the final label + if no cases branch to it. + * gcc-interface/Make-lang.in (ada/trans.o): Add $(TREE_FLOW_H). + +2010-06-23 Thomas Quinot + + * exp_attr.adb (Expand_Access_To_Protected_Op): When rewriting a + reference to a protected subprogram outside of the protected's scope, + ensure the corresponding external subprogram is frozen before the + reference. + +2010-06-23 Ed Schonberg + + * sem_prag.adb: Fix typo in error message. + * sem.adb: Refine previous change. + +2010-06-23 Robert Dewar + + * impunit.adb, a-suewen.adb, a-suewen.ads, a-suenco.adb, a-suenco.ads, + a-suezen.adb, a-suezen.ads, a-stuten.adb, a-stuten.ads, Makefile.rtl: + Implement Ada 2012 string encoding packages. + +2010-06-23 Arnaud Charlet + + * a-stwiun-shared.adb, a-stwiun-shared.ads, a-stzunb-shared.adb, + a-stzunb-shared.ads, a-swunau-shared.adb, a-swuwti-shared.adb, + a-szunau-shared.adb, a-szuzti-shared.adb, a-strunb-shared.adb, + a-strunb-shared.ads, a-stunau-shared.adb, a-suteio-shared.adb: New + files. + * gcc-interface/Makefile.in: Enable use of above files. + +2010-06-23 Ed Schonberg + + * sem_ch13.adb (Check_Constant_Address_Clauses): Do not check legality + of address clauses if if Ignore_Rep_Clauses is active. + * freeze.adb (Check_Address_Clause): If Ignore_Rep_Clauses is active, + remove address clause from tree so that it does not reach the backend. + +2010-06-23 Arnaud Charlet + + * exp_attr.adb (Expand_N_Attribute_Reference [Attribute_Valid]): Do not + expand 'Valid from user code in CodePeer mode, will be handled by the + back-end directly. + +2010-06-23 Bob Duff + + * g-comlin.ads: Minor comment improvements. + +2010-06-23 Ed Schonberg + + * sem_res.adb (Uses_SS): The expression that initializes a controlled + component of a record type may be a user-defined operator that is + rewritten as a function call. + +2010-06-23 Bob Duff + + * g-comlin.ads, sem_ch13.adb: Minor comment fix. + +2010-06-23 Eric Botcazou + + * exp_ch11.adb (Expand_Local_Exception_Handlers): Propagate the end + label to the new sequence of statements. Set the sloc of the raise + statement onto the new goto statements. + +2010-06-23 Robert Dewar + + * a-stuten.ads, a-stuten.adb: New files. + * impunit.adb: Add engtry for Ada.Strings.UTF_Encoding (a-stuten.ads) + * Makefile.rtl: Add entry for a-stuten (Ada.Strings.UTF_Encoding) + +2010-06-23 Robert Dewar + + * gnat_ugn.texi: Add documentation of -gnat12 switch + Add documentation of -gnatX switch. + +2010-06-23 Ed Schonberg + + * inline.ads: Include the current Ada_Version in the info for pending + instance bodies, so that declaration and body are compiled with the + same Ada_Version. + * inline.adb: Move with_clause for Opt to spec. + * sem_ch12.adb (Analyze_Package_Instantiation, + Analyze_Subprogram_Instantiation): Save current Ada_Version in + Pending_Instantiation information. + (Instantiate_Package_Body, Instantiate_Subprogram_Body, + Inline_Package_Body): Use the Ada_Version present in the body + information. + +2010-06-23 Robert Dewar + + * usage.adb: Add documentation for -gnat12 switch. + * errout.ads: Add VMS alias entry for -gnat12 switch + * gnat_rm.texi: Add documentation for pragma Ada_12 and Ada_2012 + Add documentation for pragma Extensions_Allowed. + * opt.ads: Add entry for Ada 2012 mode. + * sem_ch4.adb, par-ch3.adb, par-ch4.adb: Use new Ada 2012 mode for 2012 + features. + * sem_prag.adb, par-prag.adb: Add processing for pragma Ada_12 and + Ada_2012. + * sem_ch13.adb: Add handling for Ada 2012 mode. + * snames.ads-tmpl: Add entries for pragma Ada_2012 and Ada_12. + * switch-c.adb: Add handling for -gnat12 switch. + Implement -gnat2005 and -gnat2012. + * usage.adb: Add documentation for -gnat12 switch. + * vms_data.ads: Add /12 switch for Ada 2012 mode. + +2010-06-23 Arnaud Charlet + + * exp_ch4.adb (Expand_N_Allocator): Fix potential crash when using + No_Task_Hierarchy restriction. Add comment. + * exp_ch9.adb, exp_ch3.adb: Update comments. + +2010-06-23 Robert Dewar + + * sem_ch5.adb (Process_Bounds): Remove some junk initializations. + * sem_res.adb: Add comments. + * sem_util.adb: Minor reformatting. Add comments. + Change increment on Actuals_In_Call table. + * opt.ads: Minor: add 'constant'. + +2010-06-23 Javier Miranda + + * exp_disp.adb (Make_DT): Initialize the Size_Func component of the + TSD to Null_Address if No_Dispatching_Calls is active. + +2010-06-23 Vincent Celier + + * a-comlin.ads: Indicate that use of this package is not supported + during the elaboration of an auto-initialized Stand-Alone Library. + +2010-06-23 Ed Schonberg + + * exp_util.adb (Is_Possibly_Misaligned_Object): Do not rely on an + alignment clause on a record type to determine if a component may be + misaligned. The decision must be taken in the back-end where target + alignment information is known. + +2010-06-23 Arnaud Charlet + + * gnat1drv.adb (Adjust_Global_Switches): Enable some restrictions + systematically in CodePeer mode to simplify generated code. + * restrict.adb (Check_Restriction): Do nothing in CodePeer mode. + * exp_ch4.adb (Expand_N_Allocator): Generate proper code when + No_Task_Hierarchy is set instead of crasshing. + +2010-06-23 Thomas Quinot + + * sem_util.adb: Minor code cleanup: test for proper entity instead of + testing just Chars attribute when checking whether a given scope is + System. + * exp_ch4.adb, einfo.adb: Minor reformatting. + +2010-06-23 Vincent Celier + + PR ada/44633 + * switch-m.adb (Normalize_Compiler_Switches): Take into account + switches -gnatB, -gnatD=nn, -gnatG (incuding -gnatG=nn), -gnatI, + -gnatl=file, -gnatS, -gnatjnn, -gnateI=nn and -gnatWx. + +2010-06-23 Ed Schonberg + + * sem_res.adb (Resolve_Membership_Op): If left operand is a mixed mode + operation with a universal real operand, and the right operand is a + range with universal bounds, find unique fixed point that may be + candidate, and warn appropriately. + +2010-06-23 Ed Schonberg + + * sem_res.adb (Resolve_Intrinsic_Operator): Add guards to handle + properly the rare cases where VMS operators are visible through + Extend_System, but the default System is being used and Address is a + private type. + * sem_util.adb: Widen predicate Is_VMS_Operator. + +2010-06-23 Vincent Celier + + * switch-m.adb (Normalize_Compiler_Switches): Take into account -gnatC + and -gnateS. + +2010-06-23 Olivier Hainque + + * einfo.adb (Has_Foreign_Convention): Consider Intrinsic with + Interface_Name as foreign. These are GCC builtin imports for + which Ada specific processing doesn't apply. + +2010-06-23 Thomas Quinot + + * sem_ch12.adb: Minor reformatting. + +2010-06-23 Ed Schonberg + + * sem_util.adb (Is_VMS_Operator): Use scope of system extension to + determine whether an intrinsic subprogram is VMS specific. + +2010-06-23 Hristian Kirtchev + + * treepr.adb (Print_Entity_Info): Output the contents of Field28 if it + is present in the entity. + +2010-06-23 Arnaud Charlet + + * xr_tabls.adb, xref_lib.adb: Update to latest lib-xref.ads + Fix handling of parameters. + Add protection against unexpected cases. + * sem_ch6.adb (Create_Extra_Formals): Use suffix "L" instead of "A" for + access level, since "A" suffix is already used elsewhere. Similarly, + use suffix "O" instead of "C" for 'Constrained since "C" suffix is used + for xxx'Class. + +2010-06-23 Thomas Quinot + + * sem_util.adb, sem_util.ads: Minor reformatting. + +2010-06-23 Vincent Celier + + * prj.ads (Gprclean_Flags.Missing_Source_Files): Set to Error to keep + the previous behavior of gprclean when there are missing files. + +2010-06-23 Ed Schonberg + + * sem_ch12.adb (Load_Body_Of_Generic): In CodePeer mode, a missing + generic body is not a fatal error. + (Mark_Context): Handle properly names of child units. + * sem.adb (Walk_Library_Items.Do_Action): Remove assertion on + instantiations. + +2010-06-23 Vincent Celier + + * ali.adb (Scan_ALI): When ignoring R lines, do not skip the next + non-empty line. + +2010-06-23 Bob Duff + + * g-pehage.ads, g-pehage.adb: Switch default optimization mode to + Memory_Space, because CPU_Time doesn't seem to provide any significant + speed advantage in practice. Cleanup: Get rid of constant + Default_Optimization; doesn't seem to add anything. Use case + statements instead of if statements; seems cleaner. + +2010-06-23 Olivier Hainque + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Use + Wshadow instead of Wextra to guard warning on absence of internal + builtin decl for an import. Fix use of quote in warning text. + (intrin_arglists_compatible_p): Remove processing of integer trailing + args on the Ada side. Fix use of literal > in warning text. + (intrin_return_compatible_p): Never warn on "function imported as + procedure". Defer the void/void case to the common type compatibility + check. + (gnat_to_gnu_param): Use void_ptr GCC type for System.Address argument + of GCC builtin imports. + +2010-06-23 Olivier Hainque + + * gcc-interface/decl.c (intrin_types_incompatible_p): New function, + helper for ... + (intrin_arglists_compatible_p, intrin_return_compatible_p): New + functions, helpers for ... + (intrin_profiles_compatible_p): New function, replacement for ... + (compatible_signatures_p): Removed. + (gnat_to_gnu_entity) : If -Wextra, warn on + attempt to bind an unregistered builtin function. When we have + one, use it and warn on profile incompatibilities. + +2010-06-23 Arnaud Charlet + + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-23 Ed Schonberg + + * sem_util.adb (Mark_Coextensions): If the expression in the allocator + for a coextension in an object declaration is a concatenation, treat + coextension as dynamic. + +2010-06-23 Javier Miranda + + * sem_ch3.adb (Add_Internal_Interface_Entities): Ensure that the + internal entities are added to the scope of the tagged type. + (Derive_Subprograms): Do not stop derivation when we find the first + internal entity that has attribute Interface_Alias. After the change + done to Override_Dispatching_Operations it is no longer true that + these primirives are always located at the end of the list of + primitives. + * einfo.ads (Primitive_Operations): Add documentation. + * exp_disp.adb (Write_DT): Improve output adding to the name of the + primitive a prefix indicating its corresponding tagged type. + * sem_disp.adb (Override_Dispatching_Operations): If the overridden + entity covers the primitive of an interface that is not an ancestor of + this tagged type then the new primitive is added at the end of the list + of primitives. Required to fulfill the C++ ABI. + +2010-06-23 Javier Miranda + + * atree.ads (Set_Reporting_Proc): New subprogram. + * atree.adb: Remove dependency on packages Opt and SCIL_LL. + (Allocate_Initialize_Node, Replace, Rewrite): Replace direct calls + to routines of package Scil_ll by indirect call to the registered + subprogram. + (Set_Reporting_Proc): New subprogram. Used to register a subprogram + that is invoked when a node is allocated, replaced or rewritten. + * scil_ll.adb (Copy_SCIL_Node): New routine that takes care of copying + the SCIL node. Used as argument for Set_Reporting_Proc. + (Initialize): Register Copy_SCIL_Node as the reporting routine that + is invoked by atree. + +2010-06-23 Thomas Quinot + + * sem_ch3.ads: Minor reformatting. + +2010-06-23 Ed Schonberg + + * sem_ch12.adb (Analyze_Package_Instantiation): In CodePeer mode, + always analyze the generic body and instance, because it may be needed + downstream. + (Mark_Context): Prepend the with clauses for needed generic units, so + they appear in a better order for CodePeer. + * sem_util.adb, sem_util.ads: Prototype code for AI05-0144. + +2010-06-23 Emmanuel Briot + + * prj.ads, prj-nmsc.adb (Error_Or_Warning): New subprogram. + +2010-06-23 Robert Dewar + + * g-pehage.adb, exp_ch13.adb: Minor reformatting. + +2010-06-23 Thomas Quinot + + * a-tags.ads: Fix description of TSD structure. + +2010-06-23 Ed Schonberg + + * sem_ch12.adb (Mark_Context): When indicating that the body of a + generic unit is needed prior to the unit containing an instantiation, + search recursively the context of the generic to add other generic + bodies that may be instantiated indirectly through the current instance. + +2010-06-23 Robert Dewar + + * freeze.adb: Minor reformatting. + +2010-06-23 Bob Duff + + * g-pehage.adb (Trim_Trailing_Nuls): Fix the code to match the comment. + +2010-06-23 Vincent Celier + + * make.adb (Compile_Sources): Complete previous change. + +2010-06-23 Ed Schonberg + + * sem_ch6.adb (Add_Extra_Formal): Use suffix "C" in the name of the + Constrained extra formal. + +2010-06-23 Ed Schonberg + + * exp_ch13.adb (Expand_Freeze_Actions): If validity checks and + Initialize_Scalars are enabled, compile the generated equality function + for a composite type with full checks enabled, so that validity checks + are performed on individual components. + +2010-06-23 Emmanuel Briot + + * prj.adb, prj.ads, prj-nmsc.adb (Processing_Flags): New flag + Missing_Source_Files. + +2010-06-23 Robert Dewar + + * exp_ch3.adb, exp_util.adb: Minor reformatting. + +2010-06-23 Jose Ruiz + + * a-reatim.adb, a-retide.adb: Move the initialization of the tasking + run time from Ada.Real_Time.Delays to Ada.Real_Time. This way, calls to + Clock (without delays) use a run time which is properly initialized. + +2010-06-23 Vincent Celier + + * make.adb: Do not set Check_Readonly_Files when setting Must_Compile, + when -f -u and a main is specified on the command line. However, + attempt to compile even when the ALI file is read-only when + Must_Compile is True. + +2010-06-23 Thomas Quinot + + * checks.adb, g-pehage.adb, cstand.adb: Minor code factorization. + +2010-06-23 Javier Miranda + + * sem_ch3.adb (Add_Internal_Interface_Entities): Generate internal + entities for parent types that are interfaces. Needed in generics to + handle formals that implement interfaces. + (Derive_Subprograms): Add assertion for derivation of tagged types that + do not cover interfaces. For generics, complete code that handles + derivation of type that covers interfaces because the previous + condition was weak (it required only name consistency; arguments were + not checked). Add new code to locate primitives covering interfaces + defined in generic units or instantiatons. + * sem_util.adb (Has_Interfaces): Add missing support for derived types. + * sem_ch6.adb (Check_Overriding_Indicator): Minor code cleanups. + * exp_disp.adb (Make_Select_Specific_Data_Table): Skip primitives of + interfaces that are parents of the type because they share the primary + dispatch table. + (Register_Primitive): Do not register primitives of interfaces that + are parents of the type. + * sem_ch13.adb (Analyze_Freeze_Entity): Add documentation. + * exp_cg.adb (Write_Type_Info): When displaying overriding of interface + primitives skip primitives of interfaces that are parents of the type. + +2010-06-23 Ed Schonberg + + * sem_attr.adb (Eval_Attribute): If the prefix is an array, the + attribute cannot be constant-folded if an index type is a formal type, + or is derived from one. + * checks.adb (Determine_Range): ditto. + +2010-06-23 Arnaud Charlet + + * gnat_ugn.texi, gnatxref.adb: Add support for --ext switch. + +2010-06-23 Bob Duff + + * g-pehage.ads, g-pehage.adb (Put): Fix off-by-one bug. + (Insert): Disallow nul characters. + (misc output routines): Assert no nul characters. + +2010-06-23 Ed Schonberg + + * exp_ch4.adb: Use predefined unsigned type in all cases. + +2010-06-23 Bob Duff + + * s-rannum.adb (Reset): Avoid overflow in calculation of Initiator. + * g-pehage.ads: Minor comment fixes. + * g-pehage.adb: Minor: Add some additional debugging printouts under + Verbose flag. + +2010-06-23 Robert Dewar + + * binde.adb (Better_Choice): Always prefer Pure/Preelab. + (Worse_Choice): Always prefer Pure/Preelab. + +2010-06-23 Vincent Celier + + * a-reatim.adb: Call System.OS_Primitives.Initialize during elaboration + +2010-06-23 Robert Dewar + + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Properly handle + checking returns in generic case. + (Check_Missing_Return): New procedure. + +2010-06-23 Robert Dewar + + * bindgen.adb, switch-b.adb: Minor reformatting. + +2010-06-23 Javier Miranda + + * frontend.adb (Frontend): Add call to initialize the new package + SCIL_LL. + * exp_ch7.adb (Wrap_Transient_Expression): Remove call to + Adjust_SCIL_Node. + (Wrap_Transient_Statement): Remove call to Adjust_SCIL_Node. + * sem_ch5.adb (Analyze_Iteration_Scheme.Process_Bounds): Remove call to + Adjust_SCIL_Node. + * exp_util.adb (Insert_Actions): Remove code for + N_SCIL_Dispatch_Table_Object_Init and N_SCIL_Tag_Init nodes. + (Remove_Side_Effects): Remove calls to Adjust_SCIL_Node. + * sinfo.adb (SCIL_Entity, SCIL_Tag_Value): Remove checks on + N_SCIL_Tag_Init and N_SCIL_Dispatch_Table_Object_Init in the assertion. + (SCIL_Related_Node, Set_SCIL_Related_Node): Removed. + * sinfo.ads (SCIL_Related_Node): Field removed. + (N_SCIL_Dispatch_Table_Object_Init): Node removed. + (N_SCIL_Tag_Init): Node removed. + * sem_scil.ads, sem_scil.adb (Adjust_SCIL_Node): Removed. + (Check_SCIL_Node): New implementation. + (Find_SCIL_Node): Removed. + * sem.adb (Analyze): Remove management of + N_SCIL_Dispatch_Table_Object_Init and N_SCIL_Tag_Init nodes. + * sem_util.adb (Insert_Explicit_Dereference): Remove call to + Adjust_SCIL_Node. + * exp_ch4.adb (Expand_N_In): Code cleanup: remove call to + Set_SCIL_Related_Node and avoid adding the SCIL node before the + referenced node using Insert_Action because this is not longer required. + (Expand_Short_Circuit_Operator): Remove call to SCIL node. + * exp_ch6.adb (Expand_Call): Remove call to Adjust_SCIL_Node. + * sem_ch4.adb (Analyze_Type_Conversion): Remove call to Adjust_SCIL_Node + * exp_disp.adb (Expand_Dispatching_Call): Minor code reorganization + because we no longer require to generate the SCIL node before the call. + (Make_DT): Remove generation of SCI_Dispatch_Table_Object_Init node. + Remove calls to Set_SCIL_Related_Node and avoid adding the SCIL + nodes before the referenced node using Insert_Action because this + is not longer required. + * atree.adb (Allocate_Initialize_Node, Replace, Rewrite): Add call to + update the SCIL_Node field. + * sprint.adb (Sprint_Node_Actual): Remove code for + N_SCIL_Dispatch_Table_Object_Init and N_SCIL_Tag_Init nodes. + * treepr.adb (Print_Node): Print the SCIL node field (if available). + * exp_ch3.adb (Build_Init_Procedure): Remove generation of + SCIL_Tag_Init nodes. + * scil_ll.ads, scil_ll.adb: New files. + * gcc-interface/Makefile.in, gcc-interface/Make-lang.in: Update + dependencies. + +2010-06-23 Robert Dewar + + * sem_ch6.adb: Minor reformatting. + +2010-06-23 Doug Rupp + + * bindusg.adb (Display): Write -Hnn line. + * bindgen.adb (Gen_Adainit_Ada): Write Heap_Size to binder file as + necessary. + * init.c (__gl_heap_size): Rename from __gl_no_malloc_64 and change + valid values to 32 and 64. + (GNAT$NO_MALLOC_64): Recognize TRUE, 1, FALSE, and 0 in addition to + ENABLE, DISABLE as valid settings. + * switch-b.adb (Scan_Binder_Switches): Process -Hnn switch. + * opt.ads (Heap_Size): New global variable. + * gcc-interface/utils2.c (maybe_wrap_malloc): Remove mostly redundant + TARGET_MALLOC64 check. Fix comment. + +2010-06-23 Robert Dewar + + * sem_ch6.adb, exp_ch4.adb, s-rannum.ads, sem.adb, sem_ch12.adb: Minor + reformatting. Add comments. + * errout.adb (Finalize): Properly adjust warning count when deleting + continuations. + +2010-06-22 Robert Dewar + + * errout.adb (Finalize): Set Prev pointers. + (Finalize): Delete continuations for deletion by warnings off(str). + * erroutc.ads: Add Prev pointer to error message structure. + +2010-06-22 Ed Schonberg + + * sem.adb (Do_Unit_And_Dependents): If the spec of the main unit is a + child unit, examine context of parent units to locate instantiated + generics whose bodies may be needed. + * sem_ch12.adb: (Mark_Context): if the enclosing unit does not have a + with_clause for the instantiated generic, examine the context of its + parents, to set Withed_Body flag, so that it can be visited earlier. + * exp_ch4.adb (Expand_N_Op_Not): If this is a VMS operator applied to + an unsigned type, use a type of the proper size for the intermediate + value, to prevent alignment problems on unchecked conversion. + +2010-06-22 Geert Bosch + + * s-rannum.ads Change Generator type to be self-referential to allow + Random to update its argument. Use "in" mode for the generator in the + Reset procedures to allow them to be called from the Ada.Numerics + packages without tricks. + * s-rannum.adb: Use the self-referencing argument to get write access + to the internal state of the random generator. + * a-nudira.ads: Make Generator a derived type of + System.Random_Numbers.Generator. + * a-nudira.adb: Remove use of 'Unrestricted_Access. + Put subprograms in alpha order and add headers. + * g-mbdira.ads: Change Generator type to be self-referential. + * g-mbdira.adb: Remove use of 'Unrestricted_Access. + +2010-06-22 Robert Dewar + + * freeze.adb: Minor reformatting + Minor code reorganization (use Nkind_In and Ekind_In). + +2010-06-22 Bob Duff + + * gnat1drv.adb (Gnat1drv): Remove the messages that recommend using + -gnatc when a file is compiled that we cannot generate code for, not + helpful and confusing. + +2010-06-22 Vincent Celier + + * switch-m.adb (Normalize_Compiler_Switches): Process correctly + switches -gnatknn. + +2010-06-22 Paul Hilfinger + + * s-rannum.adb: Replace constants with commented symbols. + * s-rannum.ads: Explain significance of the initial value of the data + structure. + +2010-06-22 Ed Schonberg + + * a-ngcoty.adb: Clarify comment. + +2010-06-22 Gary Dismukes + + * exp_pakd.adb (Expand_Bit_Packed_Element_Set): Return without + expansion for indexing packed arrays with small power-of-2 component + sizes when the target is AAMP. + (Expand_Packed_Element_Reference): Return without expansion for + indexing packed arrays with small power-of-2 component sizes when the + target is AAMP. + +2010-06-22 Geert Bosch + + * exp_ch4.adb (Expand_N_In): Do not substitute a valid check for X in + Float'Range. + +2010-06-22 Robert Dewar + + * g-mbdira.adb, g-mbflra.adb, a-nuflra.adb, a-nudira.adb: Minor comment + updates. + +2010-06-22 Doug Rupp + + * system-vms.ads, system-vms-zcx.ads: Remove old unused VMS system + packages. + * system-vms_64.ads, system-vms-ia64.ads: Minor reformatting. + (pragma Ident): Add a default ident string in the private part. + +2010-06-22 Robert Dewar + + * cstand.adb: Minor reformatting. + +2010-06-22 Ed Schonberg + + * freeze.adb (Build_And_Analyze_Renamed_Body): For expansion purposes, + recognize the Shift and Rotation intrinsics that are known to the + compiler but have no interface name. + +2010-06-22 Geert Bosch + + * a-ngcoty.adb ("*"): Rewrite complex multiplication to use proper + scaling in case of overflow or NaN results. + +2010-06-22 Robert Dewar + + * cstand.adb: Complete previous change. + * g-dirope.ads: Add comment. + * s-stchop.adb, sfn_scan.adb: Minor reformatting. + +2010-06-22 Ed Schonberg + + * cstand.adb: Add tree nodes for pragma Pack on string types. + +2010-06-22 Javier Miranda + + * einfo.ads, einfo.adb (Last_Formal): New synthesized attribute. + * exp_util.adb (Find_Prim_Op): Use new attribute to locate the last + formal of a primitive. + * exp_disp.adb (Is_Predefined_Dispatching_Operation, + Is_Predefined_Dispatching_Alias): Use new attribute to locate the last + formal of a primitive. + * exp_cg.adb (Is_Predefined_Dispatching_Operation): Use new attribute + to obtain the last formal of a primitive. + +2010-06-22 Geert Bosch + + * sysdep.c, init.c, adaint.c, cstreams.c: Remove conditional code + depending on __EMX__ or MSDOS being defined. + * i-cstrea.ads, gnat_rm.texi: Remove mentions of OS/2, DOS and Xenix. + * a-excpol-abort.adb: Update comment indicating users of the file. + * xref_lib.adb, sfn_scan.adb: Remove mention of OS/2, replace NT by + Windows. + * env.c: Remove empty conditional for MSDOS. + * s-stchop.adb, g-dirope.ads, s-fileio.adb, osint.ads: Remove mention + of OS/2 in comment. + +2010-06-22 Robert Dewar + + * s-rannum.adb: Minor reformatting. + +2010-06-22 Javier Miranda + + * sem_aux.adb, sem_aux.ads, sem_util.adb, sem_util.ads, sem_elim.adb, + exp_cg.adb: Minor code reorganization: Move routine Ultimate_Alias from + package Sem_Util to package Sem_Aux. + +2010-06-22 Javier Miranda + + * exp_disp.adb (Make_Secondary_DT, Make_DT): Minor code cleanup: + remove useless restriction on imported routines when building the + dispatch tables. + +2010-06-22 Robert Dewar + + * cstand.adb (Create_Standard): Set Has_Pragma_Pack for standard string + types. + +2010-06-22 Javier Miranda + + * sem_ch4.adb (Collect_Generic_Type_Ops): Protect code that handles + generic subprogram declarations to ensure proper context. Add missing + support for generic actuals. + (Try_Primitive_Operation): Add missing support for concurrent types that + have no Corresponding_Record_Type. Required to diagnose errors compiling + generics or when compiling with no code generation (-gnatc). + * sem_ch9.adb (Analyze_Protected_Type, Analyze_Task_Type): Do not build + the corresponding record type. + * sem_disp.ads, sem_disp.adb (Check_Dispatching_Operation): Complete + documentation. Do minimum decoration when processing a primitive of a + concurrent tagged type that covers interfaces. Required to diagnose + errors in the Object.Operation notation compiling generics or under + -gnatc. + * exp_ch9.ads, exp_ch9.adb (Build_Corresponding_Record): Add missing + propagation of attribute Interface_List to the corresponding record. + (Expand_N_Task_Type_Declaration): Code cleanup. + (Expand_N_Protected_Type_Declaration): Code cleanup. + +2010-06-22 Matthew Heaney + + * a-convec.adb, a-coinve.adb: Removed 64-bit types Int and UInt. + +2010-06-22 Paul Hilfinger + + * s-rannum.adb (Random_Float_Template): Replace with unbiased version + that is able to produce all representable floating-point numbers in the + unit interval. Remove template parameter Shift_Right, no longer used. + * gnat_rm.texi: Document the period of the pseudo-random number + generator under the description of its algorithm. + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-22 Thomas Quinot + + * exp_aggr.adb (Rewrite_Discriminant): Fix predicate used to identify + reference to discriminant (can be an expanded name as well as an + identifier). + +2010-06-22 Ed Schonberg + + * exp_ch6.adb: Clarify comment. + +2010-06-22 Geert Bosch + + * exp_imgv.adb (Expand_Image_Attribute): Treat ordinary fixed point + with decimal small as decimal types, avoiding floating-point arithmetic. + (Has_Decimal_Small): New function. + * einfo.ads, einfo.adb (Aft_Value): New synthesized attributed for + fixed point types. + * sem_attr.adb (Eval_Attribute): Remove Aft_Value function and update + callers to call the new function in Einfo that takes the entity as + parameter. + +2010-06-22 Robert Dewar + + * sem_ch3.adb, sem_ch8.adb: Minor reformatting. + +2010-06-22 Thomas Quinot + + * sem_elab.adb: Minor reformatting. + +2010-06-22 Vincent Celier + + * gnatsym.adb: Put the object files in the table in increasing + aphabetical order of base names. + +2010-06-22 Ed Schonberg + + * sem_ch8.adb (Set_Entity_Or_Discriminal): New procedure used by + Find_Direct_Name and Find_Expanded_Name, to replace a discriminant with + the corresponding discriminal within a record declaration. + +2010-06-22 Thomas Quinot + + * exp_aggr.adb (Rewrite_Discriminant): Rewriting must occur only for an + expression referring to a discriminal of the type of the aggregate (not + a discriminal of some other unrelated type), and the prefix in the + generated selected component must come from Lhs, not Obj. + +2010-06-22 Thomas Quinot + + * sem_ch3.adb (Build_Derived_Record_Type): Fix predicate determining + when to freeze the parent type. + +2010-06-22 Robert Dewar + + * s-rannum.adb, a-nudira.adb, types.ads, freeze.adb, sem_aggr.adb, + exp_aggr.adb: Minor reformatting. + * gnat_rm.texi: Document GNAT.MBBS_Discrete_Random and + GNAT.MBSS_Float_Random. + * g-mbdira.adb, g-mbflra.adb, g-mbdira.ads, g-mbflra.ads: Fix header. + +2010-06-22 Paul Hilfinger + + * a-nudira.adb, a-nudira.ads, a-nuflra.adb, a-nuflra.ads, + gnat_rm.texi, impunit.adb, Makefile.rtl, s-rannum.adb + (Random_Float_Template, Random): New method of creating + uniform floating-point variables that allow the creation of all machine + values in [0 .. 1). + + * g-mbdira.adb, g-mbflra.adb, g-mbdira.ads, g-mbflra.ads: New file. + +2010-06-22 Gary Dismukes + + * sem_ch5.adb (Analyze_Assignment): Revise test for illegal assignment + to abstract targets to check that the type is tagged and comes from + source, rather than only testing for targets of interface types. Remove + premature return. + +2010-06-22 Vincent Celier + + * vms_data.ads: Modify the declarations of qualifiers + /UNCHECKED_SHARED_LIB_IMPORTS to allow the generation of gnat.hlp + without error. + +2010-06-22 Ed Schonberg + + * exp_ch6.adb (Is_Build_In_Place_Function): Predicate is false if + expansion is disabled. + +2010-06-22 Robert Dewar + + * makeusg.adb: Minor reformatting. + +2010-06-22 Robert Dewar + + * types.ads: (Dint): Removed, no longer used anywhere. + * uintp.adb (UI_From_CC): Use UI_From_Int, range is sufficient. + (UI_Mul): Avoid use of UI_From_Dint. + (UI_From_Dint): Removed, not used. + * uintp.ads (UI_From_Dint): Removed, not used. + (Uint_Min/Max_Simple_Mul): New constants. + +2010-06-22 Vincent Celier + + * clean.adb (Parse_Cmd_Line): Recognize switch + --unchecked-shared-lib-imports. + (Usage): Add line for switch --unchecked-shared-lib-imports + * makeusg.adb: Add line for switch --unchecked-shared-lib-imports + * makeutl.ads: (Unchecked_Shared_Lib_Imports): New constant string + moved from GPR_Util. + * switch-m.adb (Scan_Make_Switches): Recognize switch + --unchecked-shared-lib-imports. + * vms_data.ads: Add VMS qualifiers /UNCHECKED_SHARED_LIB_IMPORTS. + * gnat_ugn.texi: Add documentation for new switch + --unchecked-shared-lib-imports. Add also documentation for --subdirs. + +2010-06-22 Javier Miranda + + * sem_prag.adb, sem_util.adb, sem_util.ads, sem_attr.adb, exp_ch6.adb, + exp_disp.adb, sem_eval.adb, exp_dist.adb lib-xref.adb: Code cleanup, + this patch replaces duplication of code that traverses the chain of + aliased primitives by a call to routine Ultimate_Alias that + provides this functionality. + +2010-06-22 Arnaud Charlet + + * fmap.adb, opt.ads, osint.adb, osint.ads, output.ads, scng.adb, + sinput-c.adb, switch-m.ads, tree_io.ads: Use simpler form of + Warnings Off/On. + +2010-06-22 Thomas Quinot + + * einfo.ads: Minor reformatting. + +2010-06-22 Javier Miranda + + * exp_disp.adb (Expand_Interface_Thunk): Do not generate thunk of + eliminated primitives. + (Make_DT): Avoid referencing eliminated primitives. + (Register_Primitive): Do not register eliminated primitives in the + dispatch table. Required to add this functionality when the program is + compiled without static dispatch tables (-gnatd.t) + +2010-06-22 Emmanuel Briot + + * fmap.adb, scng.adb, switch-m.ads, sinput-c.adb, opt.ads, output.ads, + tree_io.ads, osint.adb, osint.ads: Use configuration pragmas to prevent + warnings on use of internal GNAT units. + +2010-06-22 Jose Ruiz + + * s-taprop-vxworks.adb (Set_Priority): Update comments. + +2010-06-22 Paul Hilfinger + + * s-rannum.adb: Make stylistic change to remove mystery constant in + Extract_Value. Image_Numeral_Length: new symbolic constant. + +2010-06-22 Ed Schonberg + + * einfo.ads, einfo.adb: Make Is_Protected_Interface, + Is_Synchronized_Interface, Is_Task_Interface into computable + predicates, to free three flags in entity nodes. + * sem_ch3.adb: Remove setting of these flags. + +2010-06-22 Robert Dewar + + * uintp.adb, osint.adb, prj-conf.adb, prj-part.adb, prj.adb: Minor + reformatting. + * s-taprop-vxworks.adb: Add comment for Set_Priority. + * impunit.adb (Map_Array): Add entries for s-htable.ads and s-crc32.ads + * projects.texi: Move @cindex to the left margin, since otherwise we + are missing entries in the index. + +2010-06-22 Emmanuel Briot + + * prj-part.adb, prj.adb, tempdir.ads, makeutl.adb: Use + packages from the GNAT hierarchy instead of System when possible. + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-22 Jose Ruiz + + * s-taprop-vxworks.adb (Set_Priority): Remove the code that was + previously in place to reorder the ready queue when a task drops its + priority due to the loss of inherited priority. + +2010-06-22 Vincent Celier + + * projects.texi: Minor spelling error fixes. + Minor reformatting. + +2010-06-22 Emmanuel Briot + + * prj-part.adb, prj-ext.adb, prj.adb, makeutl.adb, prj-conf.adb: Remove + warnings for some with clauses. + +2010-06-22 Robert Dewar + + * errout.adb (Unwind_Internal_Type): Improve handling of First_Subtype + test to catch more cases where first subtype is the results we want. + * sem_res.adb (Make_Call_Into_Operator): Don't go to First_Subtype in + error case, since Errout will now handle this correctly. + * gcc-interface/Make-lang.in: Add Sem_Aux to list of GNATBIND objects. + Update dependencies. + +2010-06-22 Arnaud Charlet + + * exp_ch4.adb (Expand_Allocator_Expression): Set Related_Node properly + when calling Make_Temporary. + +2010-06-22 Ed Schonberg + + * sem_ch3.adb (Access_Subprogram_Declaration): An anonymous access to + subprogram can be associated with an entry body. + +2010-06-22 Robert Dewar + + * scos.ads: Add note on membership test handling. + +2010-06-22 Vincent Celier + + * projects.texi: Minor spelling fixes. + Minor reformatting. + +2010-06-22 Paul Hilfinger + + * s-rannum.adb: Correct off-by-one error in Extract_Value. + +2010-06-22 Vincent Celier + + * mlib-prj.adb (Display): In non verbose mode, truncate after fourth + argument. + * mlib-utl.adb (Gcc): In non verbose mode, truncate the display of the + gcc command if it is too long. + +2010-06-22 Robert Dewar + + * errout.adb (Set_Msg_Node): Fix incorrect reference to node. + +2010-06-22 Arnaud Charlet + + * exp_ch6.adb (Expand_Actuals): Use Actual as the related node when + calling Make_Temporary. + +2010-06-22 Robert Dewar + + * sem_res.adb, sem_aux.adb, errout.adb: Minor reformatting. + +2010-06-22 Ed Schonberg + + * sem_res.adb: Additional special-case for VMS. + +2010-06-22 Vincent Celier + + * gnatsym.adb: Minor comment fix. + +2010-06-22 Vincent Celier + + * prj-nmsc.adb (Process_Naming_Scheme): Initialize table Lib_Data_Table. + +2010-06-22 Robert Dewar + + * par-ch4.adb (P_Name): Recognize 'Mod attribute in Ada 95 mode + * sem_attr.adb (Attribute_05): Add Name_Mod so that 'Mod recognized in + Ada 95 mode as an implementation defined attribute. + +2010-06-22 Vincent Celier + + * bindusg.adb (Display): Update line for -R + * switch-b.adb (Scan_Binder_Switches): Allow generation of the binder + generated files when -R is used. + +2010-06-22 Vincent Celier + + * prj-nmsc.adb (Lib_Data_Table): New table. + (Check_Library_Attributes): Check if the same library name is used in + two different projects that do not extend each other. + +2010-06-22 Robert Dewar + + * lib-writ.ads, errout.adb, einfo.adb, einfo.ads: Minor reformatting. + +2010-06-22 Vincent Celier + + * adaint.c (__gnat_locate_regular_file): If a directory in the path is + empty, make it the current working directory. + +2010-06-22 Thomas Quinot + + * sem_ch3.adb (Build_Derived_Record_Type): When deriving a tagged + private type with discriminants, make sure the parent type is frozen. + +2010-06-22 Eric Botcazou + + * exp_attr.adb (Expand_N_Attribute_Reference) : Deal + with packed array references specially. + * exp_ch4.adb (Expand_N_Indexed_Component): Do not convert a reference + to a component of a bit packed array if it is the prefix of 'Bit. + * exp_pakd.ads (Expand_Packed_Bit_Reference): Declare. + * exp_pakd.adb (Expand_Packed_Bit_Reference): New procedure. Expand a + 'Bit reference, where the prefix involves a packed array reference. + (Get_Base_And_Bit_Offset): New helper, extracted from... + (Expand_Packed_Address_Reference): ...here. Call above procedure to + get the outer object and offset expression. + +2010-06-22 Thomas Quinot + + * exp_attr.adb, lib-writ.ads, bindgen.adb: Minor reformatting. + * einfo.adb (Related_Expression, Set_Related_Expression): Add + assertions. + +2010-06-22 Javier Miranda + + * sem_ch3.adb (Add_Internal_Interface_Entities): Minor code + reorganization to properly check if the operation has been inherited as + an abstract operation. + +2010-06-22 Ed Falis + + * s-osinte-vxworks.ads: Complete previous change. + +2010-06-22 Thomas Quinot + + * sem_res.adb: Add comment. + * projects.texi, gnat_ugn.texi: Remove macro. + +2010-06-22 Vincent Celier + + * prj-attr.adb: Remove project level attribute Main_Language. + +2010-06-22 Robert Dewar + + * switch-b.adb, osint-b.adb: Minor reformatting. + +2010-06-22 Pascal Obry + + * g-socthi-mingw.adb (C_Sendmsg): Do not attempt to send data from a + vector if previous send was not fully successful. If only part of + the vector data was sent, we exit the loop. + +2010-06-22 Thomas Quinot + + * sem_res.adb (Make_Call_Into_Operator): Use First_Subtype for better + error reporting with generic types. + +2010-06-22 Thomas Quinot + + * bindgen.adb, bindusg.adb, gnatbind.adb, gnat_ugn.texi, opt.ads, + osint-b.adb, osint-b.ads, output.adb, output.ads, switch-b.adb, + vms_data.ads: Add a new command line switch -A to gnatbind to output + the list of all ALI files for the partition. + +2010-06-22 Arnaud Charlet + + * s-osinte-vxworks.ads: Fix casing. + * s-vxwext-kernel.ads, s-vxwext-rtp.ads: Complete previous + change: Interfaces.C does not provide a long_long type. + +2010-06-22 Emmanuel Briot + + * gnat_ugn.texi, projects.texi: Preprocess projects.texi for VMS and + native user's guide, since this document contains the two versions. + * gcc-interface/Make-lang.in: Update doc dependencies. + +2010-06-22 Robert Dewar + + * sem_ch3.adb: Minor reformatting. Minor code reorganization. + +2010-06-22 Emmanuel Briot + + * gnat_ugn.texi, projects.texi: Remove toplevel menu, since we should + not build this file on its own (only through gnat_ugn.texi). + Remove macro definitions and insert simpler version in gnat_ugn.texi. + +2010-06-22 Robert Dewar + + * ali-util.ads: Minor comment update. + * g-socthi-mingw.adb: Minor reformatting. + +2010-06-22 Ed Falis + + * s-osinte-vxworks.ads: take sigset_t definition from System.VxWorks.Ext + * s-vxwext.ads, s-vxwext-kernel.ads, s-vxwext-rtp.ads: Define sigset_t + for specific versions of VxWorks. + +2010-06-22 Emmanuel Briot + + * gnat_rm.texi, gnat_ugn.texi, projects.texi: Remove all project files + related sections from user's guide and reference manual, since they + have now been merged together into a separate document (projects.texi). + This removes a lot of duplication where attributes where described + in several places. + The grammar for the project files is now in each of the sections + (packages,expressions,...) instead of being duplicates in two other + sections (one in the user's guide that contained the full grammar, + and various sections in the rm that contained extracts of the same + grammar). + Added the full list of all supported attributes, since existing lists + were incomplete + Rename "associative array" into "indexed attribute" + Remove sections that were duplicates ("External References in + Project Files" and "External Values", and "Project Extensions" + for instance). The list of valid packages in project files is now in + a single place. + +2010-06-22 Ed Schonberg + + * sem_ch3.adb (Add_Internal_Interface_Entities): If + Find_Primitive_Covering_Interface does not find the operation, it may + be because of a name conflict between the inherited operation and a + local non-overloadable name. In that case look for the operation among + the primitive operations of the type. This search must succeed + regardless of visibility. + +2010-06-22 Pascal Obry + + * g-socthi-mingw.adb: Properly honor MSG_WAITALL in recvmsg. + (C_Recvmsg): Propely honor the MSG_WAITALL flag in Windows + recvmsg emulation. + +2010-06-22 Robert Dewar + + * sem_ch4.adb (Analyze_Conditional_Expression): Defend against + malformed tree. + * sprint.adb (Sprint_Node_Actual, case N_Conditional_Expression): Ditto. + +2010-06-22 Arnaud Charlet + + * s-intman-vxworks.ads: Code clean up. + +2010-06-22 Thomas Quinot + + * sem_res.adb (Resolve_Slice): When the prefix is an explicit + dereference, construct actual subtype of designated object to generate + proper bounds checks. + +2010-06-22 Thomas Quinot + + * ali-util.adb, ali-util.ads, gnatbind.adb (Read_ALI): Rename to + Read_Withed_ALIs, which is more descriptive. + +2010-06-22 Pascal Obry + + * g-sothco.ads: Minor reformatting. + * g-socthi-mingw.adb: Remove part of work on the C_Recvmsg and + C_Sendmsg implementation. + (C_Sendmsg): Do not use lock (not needed). + (C_Recvmsg): Likewise and also do not wait for incoming data. + +2010-06-22 Ed Schonberg + + * uintp.adb: Fix scope error in operator call. + +2010-06-22 Vincent Celier + + * makeutl.adb (Executable_Prefix_Path): on VMS, return "/gnu/". + * prj-conf.adb (Get_Or_Create_Configuration_File): On VMS, if + autoconfiguration is needed, fail indicating that no config project + file can be found, as there is no autoconfiguration on VMS. + +2010-06-22 Ed Schonberg + + * sem_res.adb (Make_Call_Into_Operator): Diagnose an incorrect scope + for an operator in a functional notation, when operands are universal. + +2010-06-22 Arnaud Charlet + + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-22 Robert Dewar + + * sem_aggr.adb (Resolve_Record_Aggregate): Do style check on component + name. + * sem_ch10.adb (Analyze_Subunit): Do style check on parent unit name. + * sem_ch8.adb (Find_Direct_Name): For non-overloadable entities, do + style check. + * sem_res.adb (Resolve_Entity_Name): Do style check for enumeration + literals. + +2010-06-22 Vincent Celier + + * make.adb (Scan_Make_Arg): No longer pass -nostdlib to the compiler as + it has no effect. Always pass -nostdlib to gnatlink, even on VMS. + +2010-06-22 Pascal Obry + + * g-socthi-mingw.adb: Fix implementation of the vectored sockets on + Windows. + (C_Recvmsg): Make sure the routine is atomic. Also fully + fill vectors in the proper order. + (C_Sendmsg): Make sure the routine is atomic. + +2010-06-22 Robert Dewar + + * sem_ch8.adb: Update comment. + * sem_res.adb: Minor code reorganization (use Ekind_In). + +2010-06-22 Ed Schonberg + + * sem_ch8.adb (Add_Implicit_Operator): If the context of the expanded + name is a call, use the number of actuals to determine whether this is + a binary or unary operator, rather than relying on later information + to resolve the overload. + +2010-06-22 Robert Dewar + + * sem_ch10.adb, sem_aggr.adb: Minor reformatting. + +2010-06-22 Robert Dewar + + * sem_ch3.adb, sem_disp.adb: Minor code fixes. + * sem_eval.adb: Minor reformatting. + +2010-06-22 Vincent Celier + + * make.adb (Scan_Make_Arg): When invoked with -nostdlib, pass -nostdlib + to gnatlink, except on Open VMS. + * osint.adb (Add_Default_Search_Dirs): Do not suppress the default + object directories if -nostdlib is used. + +2010-06-22 Robert Dewar + + * sem_util.adb (Is_Delegate): Put in proper alpha order. + * sem_eval.adb: Minor reformatting. + +2010-06-22 Robert Dewar + + * g-expect-vms.adb, sem_res.adb: Minor reformatting. + * exp_aggr.adb: Minor comment changes and reformatting. + * sem_eval.adb (Find_Universal_Operator_Type): Put in proper alpha order + * sem_util.ads: Add some missing pragma Inline's (efficiency issue only) + +2010-06-22 Thomas Quinot + + * sem_util.adb (Build_Actual_Subtype): Record original expression in + Related_Expression attribute of the constructed subtype. + * einfo.adb, einfo.ads (Underlying_View): Move to Node28 to free up + Node24 on types for... + (Related_Expression): Make attribute available on types as well. + +2010-06-22 Gary Dismukes + + * exp_util.adb (Find_Interface_ADT): Retrieve Designated_Type instead of + Directly_Designated_Type when the type argument is an access type. + (Find_Interface_Tag): Retrieve Designated_Type instead of + Directly_Designated_Type when the type argument is an access type. + (Has_Controlled_Coextensions): Retrieve Designated_Type instead of + Directly_Designated_Type of each access discriminant. + * sem_res.adb (Resolve_Type_Conversion): Retrieve Designated_Type + instead of Directly_Designated_Type when the operand and target types + are access types. + +2010-06-22 Thomas Quinot + + * exp_aggr.adb (Flatten): Return False if one choice is statically + known to be out of bounds. + +2010-06-22 Ed Schonberg + + * sem_res.adb (Resolve_Call): If the call is rewritten as an indexed of + a parameterless function call, preserve parentheses of original + expression, for proper handling by pretty printer. + * sem_attr.adb (Analyze_Attribute, case 'Old): Add guard to Process + procedure, to handle quietly identifiers that have no entity names. + * exp_util.adb (Get_Current_Value_Condition): If the parent of an + elsif_part is missing, it has been rewritten as a nested if, and there + is no useful information on the current value of the variable. + +2010-06-22 Gary Dismukes + + * sem_ch3.adb (Build_Discriminal): Set default scopes for newly created + discriminals to the current scope. + * sem_util.adb (Find_Body_Discriminal): Remove setting of discriminal's + scope, which could overwrite a different already set value. + +2010-06-22 Ed Schonberg + + * sem_res.adb (Valid_Conversion): If expression is a predefined + operator, use sloc of type of interpretation to improve error message + when operand is of some derived type. + * sem_eval.adb (Is_Mixed_Mode_Operand): New function, use it. + +2010-06-22 Emmanuel Briot + + * g-expect-vms.adb (Expect_Internal): No longer raises an exception, so + that it can set out parameters as well. When a process has died, reset + its Input_Fd to Invalid_Fd, so that when using multiple processes we + can find out which process has died. + +2010-06-22 Thomas Quinot + + * sem_eval.adb (Find_Universal_Operator_Type): New + subprogram to identify the operand type of an operator on universal + operands, when an explicit scope indication is present. Diagnose the + case where such a call is ambiguous. + (Eval_Arithmetic_Op, Eval_Relational_Op, Eval_Unary_Op): + Use the above to identify the operand type so it can be properly frozen. + * sem_res.adb (Make_Call_Into_Operator): Remove bogus freeze of operand + type, done in an arbitrary, possibly incorrect type (the presence of + some numeric type in the scope is checked for legality, but when more + than one such type is in the scope, we just pick a random one, not + necessarily the expected one). + * sem_utils.ads, sem_utils.adb (Is_Universal_Numeric_Type): New utility + subprogram. + +2010-06-22 Robert Dewar + + * sem_eval.adb: Minor reformatting. + +2010-06-22 Robert Dewar + + * exp_ch4.adb (Expand_N_Conditional_Expression): Use + Expression_With_Actions to clean up the code generated when folding + constant expressions. + +2010-06-22 Vincent Celier + + * g-expect-vms.adb: Add new subprograms Free, First_Dead_Process and + Has_Process. + +2010-06-22 Vincent Celier + + * prj-nmsc.adb (Find_Sources): When a source from a multi-unit file is + found, check if it's path has aready been found, whatever its index. + +2010-06-22 Robert Dewar + + * atree.adb, gnatbind.adb: Minor reformatting. + Minor code reorganization. + +2010-06-21 Robert Dewar + + * exp_ch4.adb (Expand_N_Conditional_Expression): Fold if condition + known at compile time. + +2010-06-21 Gary Dismukes + + * atree.adb: Fix comment typo. + +2010-06-21 Ed Schonberg + + * sem_eval.adb (Test_Ambiguous_Operator): New procedure to check + whether a universal arithmetic expression in a conversion, which is + rewritten from a function call with an expanded name, is ambiguous. + +2010-06-21 Vincent Celier + + * prj-nmsc.adb (Name_Location): New Boolean component Listed, to record + source files in specified list of sources. + (Check_Package_Naming): Remove out parameters Bodies and Specs, as they + are never used. + (Add_Source): Set the Location of the new source + (Process_Exceptions_File_Based): Call Add_Source with the Location + (Get_Sources_From_File): If an exception is found, set its Listed to + True + (Find_Sources): When Source_Files is specified, if an exception is + found, set its Listed to True. Remove any exception that is not in a + specified list of sources. + * prj.ads (Source_Data): New component Location + +2010-06-21 Vincent Celier + + * gnatbind.adb (Closure_Sources): Global table, moved from block. + +2010-06-21 Thomas Quinot + + * sem_res.adb: Minor reformatting. + * atree.adb: New debugging hook "rr" for node rewrites. + +2010-06-21 Robert Dewar + + * g-expect.ads, g-expect.adb: Minor reformatting. + +2010-06-21 Emmanuel Briot + + * s-regpat.adb (Next_Pointer_Bytes): New named constant. Code clean up. + +2010-06-21 Arnaud Charlet + + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-21 Thomas Quinot + + * bindgen.ads: Update comments. + +2010-06-21 Vincent Celier + + * gnatbind.adb: Suppress dupicates when listing the sources in the + closure (switch -R). + +2010-06-21 Emmanuel Briot + + * s-regpat.adb (Link_Tail): Fix error when size of the pattern matcher + is too small. + +2010-06-21 Emmanuel Briot + + * g-expect.adb, g-expect.ads (First_Dead_Process, Free, Has_Process): + New subprograms. + (Expect_Internal): No longer raises an exception, so that it can set + out parameters as well. When a process has died, reset its Input_Fd + to Invalid_Fd, so that when using multiple processes we can find out + which process has died. + +2010-06-21 Robert Dewar + + * s-regpat.adb, s-tpoben.adb, sem_attr.adb, sem_util.adb, sem_util.ads, + checks.adb, sem_res.adb: Minor reformatting. Add comments. + +2010-06-21 Ed Schonberg + + * sem_ch6.adb (New_Overloaded_Entity): If the new entity is a + rederivation associated with a full declaration in a private part, and + there is a partial view that derives the same parent subprogram, the + new entity does not become visible. This check must be applied to + interface operations as well. + +2010-06-21 Thomas Quinot + + * checks.adb: Add comments. + * prj-nmsc.adb: Minor reformatting. + +2010-06-21 Thomas Quinot + + * sem_ch9.adb, checks.adb, sem_util.adb, sem_util.ads, sem_res.adb, + sem_attr.adb (Get_E_First_Or_Last): Use attribute references on E to + extract bounds, to ensure that we get the proper captured values, + rather than an expression that may have changed value since the point + where the subtype was elaborated. + (Find_Body_Discriminal): New utility subprogram to share code between... + (Eval_Attribute): For the case of a subtype bound that references a + discriminant of the current concurrent type, insert appropriate + discriminal reference. + (Resolve_Entry.Actual_Index_Type.Actual_Discriminant_Ref): For a + requeue to an entry in a family in the current task, use corresponding + body discriminal. + (Analyze_Accept_Statement): Rely on expansion of attribute references + to insert proper discriminal references in range check for entry in + family. + +2010-06-21 Emmanuel Briot + + * s-regpat.adb (Compile): Fix handling of big patterns. + +2010-06-21 Robert Dewar + + * a-tifiio.adb: Minor reformatting. + +2010-06-21 Pascal Obry + + * prj-nmsc.adb (Search_Directories): Use the non-translated directory + path to open it. + +2010-06-21 Javier Miranda + + * exp_cg.adb (Write_Call_Info): Fill the component sourcename using the + external name. + +2010-06-21 Ed Schonberg + + * exp_ch4.adb (Expand_Concatenate): If an object declaration is created + to hold the result, indicate that the target of the declaration does + not need an initialization, to prevent spurious errors when + Initialize_Scalars is enabled. + +2010-06-21 Ed Schonberg + + * a-tifiio.adb (Put): In the procedure that performs I/O on a String, + Fore is not bound by line length. The Fore parameter of the internal + procedure that performs the operation is an integer. + +2010-06-21 Thomas Quinot + + * sem_res.adb, checks.adb: Minor reformatting. + +2010-06-21 Emmanuel Briot + + * s-regpat.adb (Next_Instruction, Get_Next_Offset): Removed, merged + into Get_Next. + (Insert_Operator_Before): New subprogram, avoids duplicated code + (Compile): Avoid doing two compilations when the pattern matcher ends + up being small. + +2010-06-21 Emmanuel Briot + + * s-regpat.adb: Improve debug traces + (Dump): Change output format to keep it smaller. + +2010-06-21 Javier Miranda + + * exp_cg.adb (Generate_CG_Output): Disable redirection of standard + output to the output file when this routine completes its work. + +2010-06-20 Eric Botcazou + + * gcc-interface/trans.c (Subprogram_Body_to_gnu): Use while instead of + for loop. Call build_constructor_from_list directly in the CICO case. + +2010-06-18 Ed Schonberg + + * freeze.adb (Build_And_Analyze_Renamed_Body): If the renaming + declaration appears in the same unit and ealier than the renamed + entity, retain generated body to prevent order-of-elaboration issues in + gigi. + +2010-06-18 Arnaud Charlet + + * s-tpoben.adb: Update comments. + +2010-06-18 Robert Dewar + + * debug.adb: Minor comment change. + +2010-06-18 Javier Miranda + + * exp_cg.adb: Code clean up. + * debug.adb: Complete documentation of switch -gnatd.Z. + * gcc-interface/misc.c (callgraph_info_file): Declare. + +2010-06-18 Javier Miranda + + * exp_cg.adb (Homonym_Suffix_Length): Minor code reorganization. + +2010-06-18 Thomas Quinot + + * sprint.ads: Minor reformatting. + * output.ads: Update obsolete comment. + +2010-06-18 Ed Schonberg + + * freeze.adb (Build_And_Analyze_Renamed_Body): if the renamed entity is + an external intrinsic operation (e.g. a GCC numeric function) indicate + that the renaming entity has the same characteristics, so a call to it + is properly expanded. + +2010-06-18 Javier Miranda + + * exp_cg.adb, exp_cg.ads, exp_disp.adb, gnat1drv.adb: Add initial + support for dispatch table/callgraph info generation. + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-18 Robert Dewar + + * exp_ch6.adb: Minor reformatting. + * gnatname.adb: Add comment. + +2010-06-18 Vincent Celier + + * gnatname.adb (Scan_Args): When --and is used, make sure that the + dynamic tables in the newly allocated Argument_Data are properly + initialized. + +2010-06-18 Eric Botcazou + + * gnat1drv.adb: Fix comment. + +2010-06-18 Ed Schonberg + + * exp_ch6.adb (Expand_Inlined_Call): If the inlined subprogram is a + renaming, re-expand the call with the renamed subprogram if that one + is marked inlined as well. + +2010-06-18 Gary Dismukes + + * gnat1drv.adb (Adjust_Global_Switches): Enable + Use_Expression_With_Actions for AAMP and VM targets. + +2010-06-18 Vincent Celier + + * prj-nmsc.adb (Process_Linker): Recognize response file format GCC. + +2010-06-18 Thomas Quinot + + * exp_ch4.adb: Minor reformatting. + +2010-06-18 Javier Miranda + + * debug.ads Add documentation on -gnatd.Z. + +2010-06-18 Ed Schonberg + + * sem_elim.adb: Proper error message on improperly eliminated instances + +2010-06-18 Vincent Celier + + * prj.ads (Response_File_Format): New value GCC. + +2010-06-18 Thomas Quinot + + * gnat1drv.adb: Minor reformatting. + +2010-06-18 Robert Dewar + + * make.adb, sem_cat.adb: Minor reformatting. + * sem_eval.adb: Fix typos. + +2010-06-18 Pascal Obry + + * prj-nmsc.adb: Fix source filenames casing in debug output. + +2010-06-18 Robert Dewar + + * gnatcmd.adb: Minor reformatting. + +2010-06-18 Robert Dewar + + * sem_eval.adb (Eval_Conditional_Expression): Result is static if + condition and both sub-expressions are static (and result is selected + expression). + +2010-06-18 Robert Dewar + + * g-pehage.adb: Minor reformatting + +2010-06-18 Pascal Obry + + * prj-nmsc.adb (Search_Directories): Insert canonical filenames into + source hash table. + +2010-06-18 Arnaud Charlet + + * gcc-interface/Makefile.in, gcc-interface/Make-lang.in: Update + dependencies. Fix target pairs on darwin. + (gnatlib-sjlj, gnatlib-zcx): Pass THREAD_KIND. + +2010-06-18 Pascal Obry + + * make.adb, prj-nmsc.adb: Fix source filenames casing in debug output. + +2010-06-18 Vincent Celier + + * gnatcmd.adb: For gnatcheck, add -gnatec= switch for a global + configuration pragmas file and, if -U is not used, for a local one. + +2010-06-18 Ed Schonberg + + * sem_elim.adb (Check_Eliminated): Use full information on entity name + when it is given in the pragma by a selected component. + (Check_For_Eliminated_Subprogram): Do no emit error if within a + instance body that is itself within a generic unit. + * sem_ch12.adb (Analyze_Subprogram_Instance): If the subprogram is + eliminated, mark as well the anonymous subprogram that is its alias + and appears within the wrapper package. + +2010-06-18 Bob Duff + + * g-pehage.ads, g-pehage.adb (Produce): Clean up some of the code. + Raise an exception if the output file cannot be opened. Add comments. + +2010-06-18 Thomas Quinot + + * sem_cat.adb (Validate_Object_Declaration): A variable declaration is + not illegal per E.2.2(7) if it occurs in the private part of a + Remote_Types unit. + +2010-06-18 Arnaud Charlet + + * par-ch9.adb, sem_aggr.adb, sem_ch3.adb, layout.adb, sem_ch4.adb, + sem_ch5.adb, sem_mech.adb, exp_util.adb, par-ch10.adb, sem_ch6.adb, + par-ch11.adb, sem_ch7.adb, par-prag.adb, exp_disp.adb, par-ch12.adb, + sem_ch8.adb, style.adb, sem_ch9.adb, sem_ch10.adb, prep.adb, + sem_warn.adb, par-util.adb, scng.adb, sem_eval.adb, checks.adb, + sem_prag.adb, sem_ch12.adb, styleg.adb, sem_ch13.adb, par-ch3.adb, + par-tchk.adb, freeze.adb, sfn_scan.adb, par-ch4.adb, sem_util.adb, + sem_res.adb, par-ch5.adb, lib-xref.adb, sem_attr.adb, par-ch6.adb, + sem_disp.adb, prepcomp.adb, par-ch7.adb, sem_elab.adb, exp_ch4.adb, + errout.ads: Update comments. Minor reformatting. + + * g-spipat.adb, a-swunau.adb, a-swunau.ads, g-spitbo.adb, + a-szunau.adb, a-szunau.ads, a-stunau.adb, a-stunau.ads, + a-strunb.adb (Big_String. Big_String_Access): New type. + + * par-labl.adb, restrict.adb, s-osinte-hpux-dce.ads, sem_ch11.adb, + exp_pakd.adb, s-filofl.ads, par-endh.adb, exp_intr.adb, sem_cat.adb, + sem_case.adb, exp_ch11.adb, s-osinte-linux.ads: Fix copyright notices. + +2010-06-18 Geert Bosch + + * i-forbla-darwin.adb: Include -lgnala and -lm in linker options for + Darwin. + +2010-06-18 Robert Dewar + + * gnat1drv.adb (Adjust_Global_Switches): Set Use_Expression_With_Actions + true for gcc. + +2010-06-18 Robert Dewar + + * sprint.adb: Minor format change for N_Expression_With_Actions. + * repinfo.adb: Minor reformatting. + +2010-06-18 Ed Schonberg + + * sem_elim.adb (Check_Eliminated): If within a subunit, use + Defining_Entity to obtain the name of the entity in the proper body, to + properly handle both separate packages and subprograms. + +2010-06-18 Emmanuel Briot + + * prj-nmsc.adb (Check_File): New parameter Display_Path. + +2010-06-18 Thomas Quinot + + * g-socket.adb, g-socket.ads (Null_Selector): New object. + +2010-06-18 Pascal Obry + + * gnat_ugn.texi: Minor clarification. + +2010-06-18 Emmanuel Briot + + * prj-nmsc.adb (Find_Source_Dirs): Minor refactoring to avoid duplicate + code when using the project dir as the source dir. + (Search_Directories): use the normalized name for the source directory, + where symbolic names have potentially been resolved. + +2010-06-18 Robert Dewar + + * exp_ch4.adb (Expand_N_Conditional_Expression): Clear Actions field + when we create N_Expression_With_Actions node. + (Expand_Short_Circuit): Ditto. + +2010-06-18 Robert Dewar + + * exp_util.adb: Minor reformatting. + +2010-06-18 Thomas Quinot + + * types.ads: Clean up obsolete comments + * tbuild.adb: Minor reformatting. + * exp_ch5.adb, sem_intr.adb, sem_ch10.adb, rtsfind.adb, s-shasto.adb, + exp_strm.adb, aa_drive.adb: Minor reformatting. + * sem_res.adb (Is_Predefined_Operator): An operator that is an imported + intrinsic with an Interface_Name denotes an imported back-end builtin, + and must be rewritten into a call, not left in the tree as an operator, + so return False in that case. + +2010-06-18 Eric Botcazou + + * exp_util.adb (Remove_Side_Effects): Make a copy for an allocator. + +2010-06-18 Robert Dewar + + * scos.ads: Add proposed output for case expression + +2010-06-18 Jose Ruiz + + * gnat_ugn.texi: Document that, when using the RTX compiler to generate + RTSS modules, we need to use the Microsoft linker. + +2010-06-18 Robert Dewar + + * checks.adb (Safe_To_Capture_In_Parameter_Value): Deal with case + expression (cannot count on a particular branch being executed). + * exp_ch4.adb (Expand_N_Case_Expression): New procedure. + * exp_ch4.ads (Expand_N_Case_Expression): New procedure. + * exp_util.adb (Insert_Actions): Deal with proper insertion of actions + within case expression. + * expander.adb (Expand): Add call to Expand_N_Case_Expression + * par-ch4.adb Add calls to P_Case_Expression at appropriate points + (P_Case_Expression): New procedure + (P_Case_Expression_Alternative): New procedure + * par.adb (P_Case_Expression): New procedure + * par_sco.adb (Process_Decisions): Add dummy place holder entry for + N_Case_Expression. + * sem.adb (Analyze): Add call to Analyze_Case_Expression + * sem_case.ads (Analyze_Choices): Also used for case expressions now, + this is a documentation change only. + * sem_ch4.ads, sem_ch4.adb (Analyze_Case_Expression): New procedure. + * sem_ch6.adb (Fully_Conformant_Expressions): Add handling of case + expressions. + * sem_eval.ads, sem_eval.adb (Eval_Case_Expression): New procedure. + * sem_res.adb (Resolve_Case_Expression): New procedure. + * sem_scil.adb (Find_SCIL_Node): Add processing for + N_Case_Expression_Alternative. + * sinfo.ads, sinfo.adb (N_Case_Expression): New node. + (N_Case_Expression_Alternative): New node. + * sprint.adb (Sprint_Node_Actual): Add processing for new nodes + N_Case_Expression and N_Case_Expression_Alternative. + +2010-06-18 Robert Dewar + + * par-ch7.adb, sem_warn.adb, types.ads, par-ch3.adb: Minor reformatting. + * gnat1drv.adb: Fix typo. + +2010-06-18 Robert Dewar + + * par-prag.adb (Prag, case Style_Checks): All_Checks sets gnat style + for -gnatg. + * sem_prag.adb (Analyze_Pragma, case Style_Checks): All_Checks sets + gnat style for -gnatg. + * gnat_rm.texi: Add documentation for ALL_CHECKS in GNAT mode. + +2010-06-18 Thomas Quinot + + * sem_eval.adb (Test_In_Range): New subprogram, factoring duplicated + code between... + (Is_In_Range, Is_Out_Of_Range): Reimplement in terms of call to + Test_In_Range. + +2010-06-18 Robert Dewar + + * sprint.adb: Minor change in output format for expression wi actions. + * par-ch3.adb: Minor code reorganization. Minor reformatting. + * sem_ch5.adb: Minor comment fix. + +2010-06-18 Robert Dewar + + * debug.adb: New debug flag -gnatd.L to control + Back_End_Handles_Limited_Types. + * exp_ch4.adb (Expand_N_Conditional_Expression): Let back end handle + limited case if Back_End_Handles_Limited_Types is True. + (Expand_N_Conditional_Expression): Use N_Expression_With_Actions to + simplify expansion if Use_Expression_With_Actions is True. + * gnat1drv.adb (Adjust_Global_Switches): Set + Back_End_Handles_Limited_Types. + * opt.ads (Back_End_Handles_Limited_Types): New flag. + +2010-06-18 Ed Schonberg + + * sem_res.adb (Rewrite_Operator_As_Call): Do not rewrite user-defined + intrinsic operator if expansion is not enabled, because in an + instantiation the original operator must be present to verify the + legality of the operation. + +2010-06-18 Robert Dewar + + * exp_disp.adb, sem_ch12.adb: Minor reformatting + +2010-06-18 Ed Schonberg + + * exp_util.adb (Make_Subtype_From_Expr): If the unconstrained type is + the class-wide type for a private extension, and the completion is a + subtype, set the type of the class-wide type to the base type of the + full view. + +2010-06-18 Robert Dewar + + * g-socket.ads, sem_aggr.adb, einfo.ads, sem_elim.adb, + sem_intr.adb, sem_eval.adb: Minor reformatting + +2010-06-18 Ed Schonberg + + * sem_type.adb (Is_Ancestor): If either type is private, examine full + view. + +2010-06-18 Thomas Quinot + + * g-socket.adb, g-socket.ads (Check_Selector): Make Selector an IN + parameter rather than IN OUT. + +2010-06-18 Ed Schonberg + + * exp_ch6.adb: Add extra guard. + +2010-06-18 Gary Dismukes + + * sem_util.adb (Object_Access_Level): For Ada 2005, determine the + accessibility level of a function call from the level of the innermost + enclosing dynamic scope. + (Innermost_Master_Scope_Depth): New function to find the depth of the + nearest dynamic scope enclosing a node. + +2010-06-18 Tristan Gingold + + * adaint.c: Make ATTR_UNSET static as it is not used outside this file. + +2010-06-18 Thomas Quinot + + * g-socket.ads: Minor reformatting. + +2010-06-18 Vincent Celier + + * make.adb (Must_Compile): New Boolean global variable + (Main_On_Command_Line): New Boolean global variable + (Collect_Arguments_And_Compile): Do compile if Must_Compile is True, + even when the project is externally built. + (Start_Compile_If_Possible): Compile in -aL directories if + Check_Readonly_Files is True. Do compile if Must_Compile is True, even + when the project is externally built. + (Gnatmake): Set Must_Compile and Check_Readonly_Files to True when + invoked with -f -u and one or several mains on the command line. + (Scan_Make_Arg): Set Main_On_Command_Line to True when at least one main + is specified on the command line. + +2010-06-18 Ed Schonberg + + * sem_ch6.adb (Build_Body_For_Inline): Handle extended_return_statements + * exp_ch6.adb (Expand_Inlined_Call): when possible, inline a body + containing extented_return statements. + * exp_util.adb (Make_CW_Equivalent_Type): If the root type is already + constrained, do not build subtype declaration. + +2010-06-18 Robert Dewar + + * sem_res.adb (Analyze_Indexed_Component, Analyze_Selected_Component): + Warn on assigning to packed atomic component. + +2010-06-18 Robert Dewar + + * sem_util.ads: Minor reformatting + * einfo.ads, einfo.adb: Minor doc clarification (scope of decls in + Expression_With_Actions). + * snames.ads-tmpl: Minor comment fix + +2010-06-18 Robert Dewar + + * sem_prag.adb (Diagnose_Multiple_Pragmas): New procedure + (Set_Imported): Use Import_Interface_Present to control message output + * sinfo.ads, sinfo.adb (Import_Interface_Present): New flag + * gnat_rm.texi: Document that we can have pragma Import and pragma + Interface for the same subprogram. + +2010-06-18 Robert Dewar + + * lib-xref.adb (Generate_Reference): Fix bad reference to + Has_Pragma_Unreferenced (clients should always use Has_Unreferenced). + +2010-06-17 Eric Botcazou + + * gcc-interface/trans.c (set_gnu_expr_location_from_node): New static + function. + (gnat_to_gnu) : New case. + Use set_gnu_expr_location_from_node to set location information on the + result. + +2010-06-17 Arnaud Charlet + + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-17 Ed Schonberg + + * sem_util.adb (Is_Atomic_Object): Predicate does not apply to + subprograms. + +2010-06-17 Robert Dewar + + * gnat_rm.texi, gnat_ugn.texi: Clean up documentation on warning and + style check messages. + * sem_res.adb (Resolve_Call): Don't call + Check_For_Eliminated_Subprogram if we are analyzing within a spec + expression. + +2010-06-17 Robert Dewar + + * debug.adb: Add documentation for debug flags .X and .Y + * exp_ch4.adb (Expand_Short_Circuit_Operator): Use + Use_Expression_With_Actions. + * gnat1drv.adb (Adjust_Global_Switches): Set + Use_Expression_With_Actions. + * opt.ads (Use_Expression_With_Actions): New switch. + +2010-06-17 Robert Dewar + + * exp_intr.adb: Minor code reorganization (use UI_Max) + * sem_intr.adb: use underlying type to check legality. + * einfo.adb (Known_Static_Esize): False for generic types + (Known_Static_RM_Size): False for generic types + * einfo.ads (Known_Static_Esize): False for generic types + (Known_Static_RM_Size): False for generic types + +2010-06-17 Robert Dewar + + * exp_ch4.ads: Minor code reorganization (specs in alpha order). + +2010-06-17 Robert Dewar + + * debug.adb: New debug flag -gnatd.X to use Expression_With_Actions + node when expanding short circuit form with actions present for right + opnd. + * exp_ch4.adb: Minor reformatting + (Expand_Short_Circuit_Operator): Use new Expression_With_Actions node if + right opeand has actions present, and debug flag -gnatd.X is set. + * exp_util.adb (Insert_Actions): Handle case of Expression_With_Actions + node. + * nlists.adb (Prepend_List): New procedure + (Prepend_List_To): New procedure + * nlists.ads (Prepend_List): New procedure + (Prepend_List_To): New procedure + * sem.adb: Add processing for Expression_With_Actions + * sem_ch4.adb (Analyze_Expression_With_Actions): New procedure + * sem_ch4.ads (Analyze_Expression_With_Actions): New procedure + * sem_res.adb: Add processing for Expression_With_Actions. + * sem_scil.adb: Add processing for Expression_With_Actions + * sinfo.ads, sinfo.adb (N_Expression_With_Actions): New node. + * sprint.ads, sprint.adb: Add processing for Expression_With_Actions + +2010-06-17 Doug Rupp + + * sem_intr.adb (Check_Intrinsic_Operator): Check that the types + involved both have underlying integer types. + * exp_intr.adb (Expand_Binary_Operator) New subprogram to expand a call + to an intrinsic operator when the operand types or sizes are not + identical. + * s-auxdec-vms_64.ads: Revert "+" "-" ops back to Address now that + 64/32 Address/Integer works. + +2010-06-17 Ed Schonberg + + * sem_ch12.adb (Mark_Context): Refine placement of Withed_Body flag, so + that it marks a unit as needed by a spec only if the corresponding + instantiation appears in that spec (and not in the corresponding body). + * sem_elim.adb (Check_Eliminated): If we are within a subunit, the name + in the pragma Eliminate has been parsed as a child unit, but the + current compilation unit is in fact the parent in which the subunit is + embedded. + +2010-06-17 Vincent Celier + + * gnat_rm.texi: Fix typo + +2010-06-17 Robert Dewar + + * sem_util.adb: Minor reformatting + +2010-06-17 Ed Schonberg + + * sem.adb (Do_Withed_Unit): if the unit in the with_clause is a generic + instance, the clause now denotes the instance body. Traverse the + corresponding spec because there may be no other dependence that will + force the traversal of its own context. + +2010-06-17 Ed Schonberg + + * sem_ch10.adb (Is_Ancestor_Unit): Subsidiary to + Install_Limited_Context_Clauses, to determine whether a limited_with in + some parent of the current unit designates some other parent, in which + case the limited_with clause must not be installed. + (In_Context): Refine test. + +2010-06-17 Gary Dismukes + + * sem_util.adb (Collect_Primitive_Operations): In the of an untagged + type with a dispatching equality operator that is overridden (for a + tagged full type), don't include the overridden equality in the list of + primitives. The overridden equality is detected by testing for an + Aliased field that references the overriding equality. + +2010-06-17 Robert Dewar + + * freeze.adb: Minor reformatting. + +2010-06-17 Joel Brobecker + + * gnat_ugn.texi: Add a section introducing gdbserver. + +2010-06-17 Thomas Quinot + + * sem_res.adb, sem_ch4.adb, s-stoele.adb, par-labl.adb: Minor + reformatting. + +2010-06-17 Ed Schonberg + + * sem_aggr.adb (Valid_Ancestor_Type): handle properly the case of a + constrained discriminated parent that is a private type. + (Analyze_Record_Aggregate): when collecting inherited discriminants, + handle properly an ancestor type that is a constrained private type. + +2010-06-17 Ed Schonberg + + * sem_util.adb (Enclosing_Subprogram): If the called subprogram is + protected, use the protected_subprogram_body only if the original + subprogram has not been eliminated. + +2010-06-17 Ed Schonberg + + * freeze.adb (Freeze_Expression): The designated type of an + access_to_suprogram type can only be frozen if all types in its profile + are fully defined. + +2010-06-17 Robert Dewar + + * par.adb: Minor comment fix + * sem_aggr.adb, sem_ch3.adb: Minor reformatting + +2010-06-17 Doug Rupp + + * s-auxdec-vms_64.ads: Revert Integer to Long_Integer change, instead + change Address to Short_Address in functions where both must be the + same size for intrinsics to work. + +2010-06-17 Thomas Quinot + + * sem_ch4.adb (Analyze_Selected_Component): A selected component may + not denote a (private) component of a protected object. + +2010-06-17 Bob Duff + + * par-labl.adb (Try_Loop): Test whether the label and the goto are in + the same list. + +2010-06-17 Joel Brobecker + + * gnat_ugn.texi: Update the documentation about GDB re: exception + catchpoints. + +2010-06-17 Arnaud Charlet + + * gnatvsn.ads: Bump to 4.6 version. + +2010-06-17 Ed Schonberg + + * exp_ch6.adb (Make_Build_In_Place_Call_In_Object_Declaration): The + designated type of the generated pointer is the type of the original + expression, not that of the function call itself, because the return + type may be an untagged derived type and the function may be an + inherited operation. + +2010-06-17 Robert Dewar + + * exp_ch4.adb: Minor reformatting. + +2010-06-17 Ed Schonberg + + * sinfo.ads, sinfo.adb (Inherited_Discriminant): New flag on + N_Component_Association nodes, to indicate that a component association + of an extension aggregate denotes the value of a discriminant of an + ancestor type that has been constrained by the derivation. + * sem_aggr.adb (Discr_Present): use Inherited_Discriminant to prevent a + double expansion of the aggregate appearing in a context that delays + expansion, to prevent double insertion of discriminant values when the + aggregate is reanalyzed. + +2010-06-17 Arnaud Charlet + + * exp_ch6.adb (Make_Build_In_Place_Call_In_Allocator): Do not use + Allocator as the Related_Node of Return_Obj_Access in call to + Make_Temporary below as this would create a sort of infinite + "recursion". + +2010-06-17 Ben Brosgol + + * gnat_ugn.texi: Update gnatcheck doc. + +2010-06-17 Ed Schonberg + + * sem_ch3.adb (Build_Incomplete_Type_Declaration): If there is an + incomplete view of the type that is not tagged, and the full type is a + tagged extension, create class_wide type now, and warn that the + incomplete view should be tagged as well. + +2010-06-17 Vincent Celier + + * gnatcmd.adb (Non_VMS_Usage): Do not issue usage for gnat sync. + Update the last line of the usage, indicating what commands do not + accept project file switches. + * vms_conv.adb: Do not issue usage line for GNAT SYNC + * vms_data.ads: Fix errors in the qualifiers /LOGFILE and /MAIN of + GNAT ELIM. + * gnat_ugn.texi: Document the relaxed rules for library directories in + externally built library projects. + +2010-06-17 Doug Rupp + + * s-auxdec-vms_64.ads: Make boolean and arithmetic operations intrinsic + where possible. + * s-auxdec-vms-alpha.adb: Remove kludges for aforemention. + * gcc-interface/Makefile.in: Update VMS target pairs. + +2010-06-17 Vasiliy Fofanov + + * adaint.c: Reorganized in order to avoid use of GetProcessId to stay + compatible with Windows NT 4.0 which doesn't provide this function. + +2010-06-17 Vincent Celier + + * ali-util.adb (Time_Stamp_Mismatch): In Verbose mode, if there is + different timestamps but the checksum is the same, issue a short + message saying so. + +2010-06-17 Arnaud Charlet + + * s-interr.adb (Finalize): If the Abort_Task signal is set to system, + it means that we cannot reset interrupt handlers since this would + require potentially sending the abort signal to the Server_Task. + +2010-06-17 Ed Schonberg + + * exp_ch4.adb: expand NOT for VMS types. + * sem_util.adb: Use OpenVMS_On_Target for IS_VMS_Operator. + +2010-06-17 Sergey Rybin + + * vms_data.ads: Add qualifier for '--no-elim-dispatch' gnatelim option. + * gnat_ugn.texi (gnatelim): add description for --no-elim-dispatch + option. + +2010-06-17 Ed Schonberg + + * exp_ch6.adb (Expand_Call): Do not expand a call to an internal + protected operation if the subprogram has been eliminated. + +2010-06-17 Vincent Celier + + * prj-nmsc.adb (Check_Library_Attributes): Allow the different + directories associated with a library to be any directory when the + library project is externally built. + +2010-06-17 Vincent Celier + + * make.adb (Check): If switch -m is used, deallocate the memory that + may be allocated when computing the checksum. + +2010-06-17 Eric Botcazou + + * g-socthi-mingw.adb (C_Recvmsg): Add 'use type' clause for C.size_t; + (C_Sendmsg): Likewise. + +2010-06-17 Thomas Quinot + + * sem_res.adb: Update comments. + +2010-06-17 Vincent Celier + + * back_end.adb (Scan_Compiler_Arguments): Process last argument + +2010-06-17 Robert Dewar + + * exp_ch3.adb, exp_ch6.adb, exp_smem.adb, exp_util.adb: Use Ekind_In. + * layout.adb, freeze.adb: Use Make_Temporary. + +2010-06-17 Jerome Lambourg + + * exp_ch11.adb (Expand_N_Raise_Statement): Expand raise statements in + .NET/JVM normally as this is now perfectly supported by the backend. + +2010-06-17 Pascal Obry + + * gnat_rm.texi: Fix minor typo, remove duplicate blank lines. + +2010-06-17 Vincent Celier + + * make.adb (Collect_Arguments_And_Compile): Create include path file + only when -x is specified. + (Gnatmake): Ditto + * opt.ads (Use_Include_Path_File): New Boolean flag, initialized to + False. + * prj-env.adb (Set_Ada_Paths): New Boolean parameters Include_Path and + Objects_Path, defaulted to True. Only create include path file if + Include_Path is True, only create objects path file if Objects_Path is + True. + * prj-env.ads (Set_Ada_Paths): New Boolean parameters Include_Path and + Objects_Path, defaulted to True. + * switch-m.adb (Scan_Make_Switches): Set Use_Include_Path_File to True + when -x is used. + +2010-06-17 Ed Schonberg + + * exp_disp.adb (Build_Interface_Thunk): Use base type of formal to + determine whether it has the controlling type, when the formal is an + access parameter. + +2010-06-17 Eric Botcazou + + * s-crtl.ads (ssize_t): New type. + (read): Fix signature. + (write): Likewise. + * g-socthi.ads: Add 'with System.CRTL' clause. Remove ssize_t and + 'use type' directive for C.size_t, add one for System.CRTL.ssize_t. + (C_Recvmsg): Replace ssize_t with System.CRTL.ssize_t. + (C_Sendmsg): Likewise. + * g-socthi.adb (Syscall_Recvmsg): Likewise. + (Syscall_Sendmsg): Likewise. + (C_Recvmsg): Likewise. + (C_Sendmsg): Likewise. + * g-socthi-mingw.ads: Add 'with System.CRTL' clause. Remove ssize_t + and 'use type' directive for C.size_t, add one for System.CRTL.ssize_t. + (C_Recvmsg): Replace ssize_t with System.CRTL.ssize_t. + (C_Sendmsg): Likewise. + * g-socthi-mingw.adb (C_Recvmsg): Likewise. + (C_Sendmsg): Likewise. + * g-socthi-vms.ads: Add 'with System.CRTL' clause. Remove ssize_t and + 'use type' directive for C.size_t, add one for System.CRTL.ssize_t. + (C_Recvmsg): Replace ssize_t with System.CRTL.ssize_t. + (C_Sendmsg): Likewise. + * g-socthi-vms.adb (C_Recvmsg): Likewise. + (C_Sendmsg): Likewise. + * g-socthi-vxworks.ads Add 'with System.CRTL' clause. Remove ssize_t + and 'use type' directive for C.size_t, add one for System.CRTL.ssize_t. + (C_Recvmsg): Replace ssize_t with System.CRTL.ssize_t. + (C_Sendmsg): Likewise. + * g-socthi-vxworks.adb (C_Recvmsg): Likewise. + (C_Sendmsg): Likewise. + * g-sercom-linux.adb (Read): Use correct types to call 'read'. + (Write): Likewise to call 'write'. + * s-os_lib.adb (Read): Use correct type to call System.CRTL.read. + (Write): Use correct type to call System.CRTL.write. + * s-tasdeb.adb (Write): Likewise. + +2010-06-17 Vincent Celier + + * prj-proc.adb (Copy_Package_Declarations): Change argument name + Naming_Restricted to Restricted. If Restricted is True, do not copy the + value of attribute Linker_Options. + +2010-06-17 Eric Botcazou + + * gcc-interface/trans.c (push_stack, pop_stack): Delete. + (Case_Statement_to_gnu): Adjust. + (Loop_Statement_to_gnu): Likewise. + (Subprogram_Body_to_gnu): Likewise. + (Handled_Sequence_Of_Statements_to_gnu): Likewise. + (Compilation_Unit_to_gnu): Likewise. + +2010-06-17 Robert Dewar + + * exp_fixd.adb, exp_imgv.adb, exp_intr.adb, exp_pakd.adb, exp_prag.adb, + exp_sel.adb, exp_util.adb, sem_ch10.adb, sem_ch12.adb, sem_ch13.adb, + sem_ch3.adb, sem_ch4.adb, sem_ch5.adb, sem_ch8.adb, sem_ch9.adb, + sem_dist.adb, sem_util.adb: Use Make_Temporary + * itypes.ads, tbuild.ads: Minor comment update + * exp_ch9.adb, exp_dist.adb: Minor reformatting + +2010-06-17 Thomas Quinot + + * exp_imgv.adb, exp_ch7.ads: Minor reformatting. + +2010-06-17 Robert Dewar + + * exp_ch9.adb, exp_disp.adb, exp_dist.adb: Use Make_Temporary. + +2010-06-17 Thomas Quinot + + * sprint.adb (pg): Set Dump_Freeze_Null, to be consistent with -gnatdg. + +2010-06-17 Robert Dewar + + * exp_ch6.adb, exp_ch7.adb, exp_ch5.adb: Use Make_Temporary + * tbuild.ads (Make_Temporary): More comment updates + * tbuild.adb: Minor reformatting + +2010-06-17 Robert Dewar + + * checks.adb, exp_aggr.adb, exp_atag.adb, exp_attr.adb, exp_ch11.adb, + exp_ch3.adb, exp_ch4.adb: Minor code reorganization. + Use Make_Temporary. + * tbuild.ads, tbuild.adb (Make_Temporary): Clean up, use Entity_Id + instead of Node_Id. + (Make_Temporary): Add more extensive documentation + +2010-06-17 Robert Dewar + + * sem_intr.adb, sem_prag.adb, sem_res.adb, sem_type.adb, sem_util.adb, + sem_warn.adb, sem_eval.adb: Minor reformatting. Use Ekind_In. + (Set_Slice_Subtype): Explicitly freeze the slice's itype at the point + where the slice's actions are inserted. + (Decompose_Expr): Account for possible rewriting of slice bounds + resulting from side effects suppression caused by the above freezing, + so that folding of bounds is preserved by such rewriting. + +2010-06-17 Robert Dewar + + * einfo.ads, einfo.adb (Get_Record_Representation_Clause): New function. + * freeze.adb (Freeze_Record_Type): Add call to + Check_Record_Representation_Clause. + * sem_ch13.adb (Check_Record_Representation_Clause): New function + (Analyze_Record_Representation_Clause): Split out overlap code into this + new function. + (Check_Component_Overlap): Moved inside + Check_Record_Representation_Clause. + * sem_ch13.ads (Check_Record_Representation_Clause): New function. + +2010-06-17 Robert Dewar + + * back_end.adb, sem_res.adb, switch-c.adb, sem_scil.adb: Minor + reformatting. + * sem_attr.adb, sem_cat.adb, sem_disp.adb, sem_elab.adb, sem_elim.adb, + sem_eval.adb: Use Ekind_In + +2010-06-17 Ed Schonberg + + * sem_ch8.adb: better error message for illegal inherited discriminant + +2010-06-17 Vincent Celier + + * bindusg.adb: Remove lines for -A and -C + * gnat_ugn.texi: Remove all documentation and examples of switches -A + and -C for gnatbind and gnatlink. + * gnatlink.adb (Usage): Remove lines for -A and -C + * switch-b.adb (Scan_Binder_Switches): Issue warning when switch -C is + specified. + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-17 Vincent Celier + + * back_end.adb (Scan_Compiler_Arguments): Put all arguments in new + local Argument_List variable Args. + * switch-c.adb (Scan_Front_End_Switches): New Argument_List argument + Args. + (Switch_Subsequently_Cancelled): New Argument_List argument Args. Look + for subsequent switches in Args. + * switch-c.ads (Scan_Front_End_Switches): New Argument_List argument + Args. + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-17 Robert Dewar + + * einfo.adb: Minor code fix, allow E_Class_Wide_Type for + Equivalent_Type to match documentation. + +2010-06-17 Robert Dewar + + * sem_ch6.adb, sem_ch7.adb: Minor reformatting. + * sem_ch3.adb, sem_ch5.adb, sem_ch9.adb, sem_ch10.adb, sem_ch12.adb, + sem_ch4.adb, sem_ch8.adb, sem_ch13.adb: Make use of Ekind_In. + +2010-06-17 Thomas Quinot + + * sem_res.adb (Set_Slice_Subtype): Always freeze the slice's itype. + +2010-06-17 Thomas Quinot + + * freeze.adb (Freeze_Expression): Short circuit operators are valid + freeze node insertion points. + +2010-06-17 Robert Dewar + + * switch-c.ads, switch-c.adb, sem_ch13.adb: Minor reformatting. + * sem_ch12.adb: Add pragmas Assert and Check to previous change. + +2010-06-17 Gary Dismukes + + * layout.adb (Layout_Type): Broaden test for setting an array type's + Component_Size to include all scalar types, not just discrete types + (components of real types were missed). + * sem_ch3.adb (Constrain_Index): Add missing setting of First_Literal + on the itype created for an index (consistent with Make_Index and + avoids possible Assert_Failures). + +2010-06-17 Robert Dewar + + * atree.ads, atree.adb: Add 6-parameter version of Ekind_In + * einfo.adb: Minor code reformatting (use Ekind_In) + +2010-06-17 Robert Dewar + + * sem_warn.adb (Test_Ref): Abandon scan if access subprogram parameter + found. + +2010-06-17 Vincent Celier + + * back_end.adb: Minor comment updates + * switch-c.adb: Remove dependencies on gcc C sources + * gcc-interface/Make-lang.in: Add a-comlin.o to the object file list + for the compiler. + +2010-06-17 Ed Schonberg + + * sem_ch12.adb: propagate Pragma_Enabled flag to generic. + * get_scos.adb: Set C2 flag in decision entry of pragma to 'e' (enabled) + * par_sco.ads, par_sco.adb (Set_SCO_Pragma_Enabled): New procedure + Remove use of Node field in SCOs table + (Output_Header): Set 'd' to initially disable pragma entry + * put_scos.adb (Put_SCOs): New flag indicating if pragma is enabled + * scos.ads, scos.adb: Remove Node field from internal SCOs table. + Use C2 field of pragma decision header to indicate enabled. + * sem_prag.adb: Add calls to Set_SCO_Pragma_Enabled. + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-17 Vincent Celier + + * back_end.adb (Next_Arg): Moved to procedure Scan_Compiler_Arguments + (Scan_Compiler_Arguments): Call Scan_Front_End_Switches with Next_Arg + (Switch_Subsequently_Cancelled): Function moved to the body of Switch.C + * back_end.ads (Scan_Front_End_Switches): Function moved to the body of + Switch.C. + * switch-c.adb: Copied a number of global declarations from back_end.adb + (Len_Arg): New function copied from back_end.adb + (Switch_Subsequently_Cancelled): New function moved from back_end.adb + (Scan_Front_End_Switches): New parameter Arg_Rank used to call + Switch_Subsequently_Cancelled. + * switch-c.ads (Scan_Front_End_Switches): New parameter Arg_Rank. + * gcc-interface/Makefile.in: Add line so that shared libgnat is linked + with -lexc on Tru64. + +2010-06-17 Robert Dewar + + * prj.ads, prj.adb: Minor reformatting + +2010-06-17 Thomas Quinot + + * put_scos.adb: Do not generate a blank line in SCOs when omitting the + CP line for a disabled pragma. + +2010-06-17 Emmanuel Briot + + * prj-proc.adb, prj.adb, prj.ads (Check_Or_Set_Typed_Variable): New + subprogram. + (Process_Declarative_Item): An invalid value in an typed variable + declaration is no longer always fatal. + +2010-06-16 Arnaud Charlet + + * get_scos.adb, par_sco.adb, par_sco.ads, put_scos.adb, scos.adb, + scos.ads, exp_ch4.adb, sem_warn.adb: Code clean up, update + documentation. + +2010-06-16 Javier Miranda + + * exp_disp.adb (Expand_Dispatching_Call): Adjust the decoration of the + node referenced by the SCIL node of dispatching "=" to skip the tags + comparison. + +2010-06-16 Ed Schonberg + + * sem_ch5.adb (Analyze_Exit_Statement): Return if no enclosing loop, + to prevent cascaded errors and compilation aborts. + +2010-06-16 Robert Dewar + + * back_end.adb (Switch_Subsequently_Cancelled): New function + Move declarations to package body level to support this change + * back_end.ads (Switch_Subsequently_Cancelled): New function + * gnat_ugn.texi: Document -gnat-p switch + * switch-c.adb (Scan_Front_End_Switches): Implement -gnat-p switch + * ug_words: Add entry for -gnat-p (UNSUPPRESS_ALL) + * usage.adb: Add line for -gnat-p switch + * vms_data.ads: Add entry for UNSUPPRESS_ALL (-gnat-p) + +2010-06-16 Robert Dewar + + * sem_warn.adb (Check_Infinite_Loop_Warning): Declaration counts as + modification. + +2010-06-16 Robert Dewar + + * exp_disp.adb: Minor reformatting + +2010-06-16 Ed Schonberg + + * sem_ch3.adb (Complete_Private_Subtype): Inherit class_wide type from + base type only if it was not previously created for the partial view. + +2010-06-16 Thomas Quinot + + * tbuild.ads: Minor comment fix + +2010-06-15 Nathan Froyd + + * gcc-interface/trans.c (gnu_stack_free_list): Delete. + (gnu_except_ptr_stack): Change type to VEC. Update comment. + (gnu_elab_proc_stack): Likewise. + (gnu_return_label_stack): Likewise. + (gnu_loop_label_stack): Likewise. + (gnu_switch_label_stack): Likewise. + (gnu_constraint_label_stack): Likewise. + (gnu_storage_error_label_stack): Likewise. + (gnu_program_error_label_stack): Likewise. + (push_exception_label_stack): Take a VEC ** instead of a tree *. + (push_stack): Likewise. Remove unused second parameter. Update + callers. + (pop_stack): Take a VEC * instead of a tree *. Update callers. + (gigi): Initialize stacks as VECs. + (Identifier_to_gnu): Use VEC_last instead of TREE_VALUE. + (Case_Statement_to_gnu): Likewise. + (Subprogram_Body_to_gnu): Likewise. + (call_to_gnu): Likewise. + (Exception_Handler_to_gnu_sjlj): Likewise. + (gnat_to_gnu): Likewise. + (get_exception_label): Likewise. + +2010-06-14 Ed Schonberg + + * sem_ch3.adb (Build_Derived_Record_Type): if derived type is an + anonymous base generated when the parent is a constrained discriminated + type, propagate interface list to first subtype because it may appear + in a current instance within the extension part of the derived type + declaration, and its own subtype declaration has not been elaborated + yet. + * exp_disp.adb (Build_Interface_Thunk): Use base type of formal to + determine whether it has the controlling type. + +2010-06-14 Jerome Lambourg + + * exp_ch11.adb (Expand_N_Raise_Statement): Make sure that the explicit + raise of CE, SE and PE have the reason correctly set and are properly + expanded before stopping the expansions of .NET/JVM exceptions. + +2010-06-14 Robert Dewar + + * opt.ads (Check_Policy_List): Add some clarifying comments + * sem_prag.adb (Analyze_Pragma, case Check): Set Pragma_Enabled flag + on rewritten Assert pragma. + +2010-06-14 Gary Dismukes + + * sem_ch6.adb (Check_Overriding_Indicator): Add a special check for + controlled operations, so that they will be treated as overriding even + if the overridden subprogram is marked Is_Hidden, as long as the + overridden subprogram's parent subprogram is not hidden. + +2010-06-14 Robert Dewar + + * debug.adb: Entry for gnatw.d no longer specific for while loops + * einfo.adb (First_Exit_Statement): New attribute for E_Loop + * einfo.ads (First_Exit_Statement): New attribute for E_Loop + * sem_ch5.adb (Analyze_Loop_Statement): Check_Infinite_Loop_Warning has + new calling sequence to include test for EXIT WHEN. + (Analyze_Exit_Statement): Chain EXIT statement into exit statement chain + * sem_warn.ads, sem_warn.adb (Check_Infinite_Loop_Warning): Now handles + EXIT WHEN case. + * sinfo.adb (Next_Exit_Statement): New attribute of N_Exit_Statement + node. + * sinfo.ads (N_Pragma): Correct comment on Sloc field (points to + PRAGMA, not to pragma identifier). + (Next_Exit_Statement): New attribute of N_Exit_Statement node + +2010-06-14 Robert Dewar + + * sem_res.adb (Resolve_Short_Circuit): Fix sloc of "assertion/check + would fail" msg. + +2010-06-14 Robert Dewar + + * par-ch2.adb (Scan_Pragma_Argument_Association): Clarify message for + missing pragma argument identifier. + +2010-06-14 Robert Dewar + + * atree.ads, atree.adb (Ekind_In): New functions. + +2010-06-14 Robert Dewar + + * exp_ch4.adb (Expand_N_Op_Expon): Optimize 2**N in stand alone context + +2010-06-14 Robert Dewar + + * usage.adb (Usage): Redo documentation of -gnatwa. + +2010-06-14 Ed Schonberg + + * sem_ch8.adb (Find_Type): The attribute 'class cannot be applied to + an untagged incomplete type that is a limited view. + +2010-06-14 Sergey Rybin + + * gnat_ugn.texi: Add description of '-cargs gcc_switches' to gnatstub + and gnatppa. + +2010-06-14 Thomas Quinot + + * exp_ch4.adb (Expand_Short_Circuit_Operator): New subprogram, + factoring duplicated code between... + (Expand_N_And_Than, Expand_N_Or_Else): Remove duplicated code. + * a-envvar.ads: Minor reformatting + +2010-06-14 Arnaud Charlet + + * ali.adb, ali.ads, lib-xref.ads: Document new '+' letter for C/C++ + static entities. + (Scan_ALI): Take into account new Visibility field. + (Visibility_Kind): New type. + (Xref_Entity_Record): Replace Lib field by Visibility. + + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-14 Pascal Obry + + * raise.h: Remove unused defintions. + +2010-06-14 Bob Duff + + * par-ch10.adb (P_Subunit): If the next token after "separate(X)" is + Tok_Not or Tok_Overriding, call P_Subprogram. We had previously given + the incorrect error "proper body expected". + * par-ch6.adb (P_Subprogram): Suppress "overriding indicator not + allowed here" error in case of subunits, which was triggered by the + above change to P_Subunit. + +2010-06-14 Sergey Rybin + + * gnat_ugn.texi, vms_data.ads: Update gnatelim doc. + +2010-06-14 Thomas Quinot + + * lib-util.adb: Minor code reorganization. + +2010-06-14 Robert Dewar + + * ali.adb (Scan_ALI): Implement reading and storing of N lines + (Known_ALI_Lines): Add entry for 'N' (notes) + * ali.ads (Notes): New table to store Notes information + * alloc.ads: Add entries for Notes table + * lib-util.adb (Write_Info_Int): New procedure + (Write_Info_Slit): New procedure + (Write_Info_Uint): New procedure + * lib-util.ads (Write_Info_Int): New procedure + (Write_Info_Slit): New procedure + (Write_Info_Uint): New procedure + * lib-writ.adb (Write_Unit_Information): Output N (notes) lines + * lib-writ.ads: Update documentation for N (Notes) lines + * lib.adb (Store_Note): New procedure + * lib.ads (Notes): New table + (Store_Note): New procedure + * sem_prag.adb: Call Store_Note for affected pragmas + +2010-06-14 Thomas Quinot + + * socket.c: Fix wrong condition in #ifdef + * g-socket.adb, g-sothco.ads: Functions imported from socket.c that + take or return char* values can't use Interfaces.C.Strings.chars_ptr, + because on VMS this type is a 32-bit pointer which is not compatible + with the default for C pointers for code compiled with gcc on that + platform. + +2010-06-14 Ed Schonberg + + * sem_util (Is_VMS_Operator): New predicate to determine whether an + operator is an intrinsic operator declared in the DEC system extension. + * sem_res.adb (Resolve_Logical_Op): operation is legal on signed types + if the operator is a VMS intrinsic. + * sem_eval.adb (Eval_Logical_Op): Operation is legal and be + constant-folded if the operands are signed and the operator is a VMS + intrinsic. + +2010-06-14 Robert Dewar + + * g-socket.adb, gnatcmd.adb: Minor reformatting. + +2010-06-14 Pascal Obry + + * s-finimp.adb: Fix typo. + * raise.h: Remove duplicate blank line. + +2010-06-14 Vincent Celier + + * prj-nmsc.adb (Add_Sources): Always set the object file and the + switches file names, as the configuration of the language may change + in an extending project. + (Process_Naming_Scheme): For sources of projects that are extended, set + the configuration of the language from the highest extending project + where the language is declared. + +2010-06-14 Gary Dismukes + + * sem_res.adb (Resolve_Call): For infinite recursion check, test + whether the called subprogram is inherited from a containing subprogram. + (Same_Or_Aliased_Subprograms): New function + +2010-06-14 Ed Schonberg + + * sem_ch8.adb (End_Use_Type): Before indicating that an operator is not + use-visible, check whether it is a primitive for more than one type. + +2010-06-14 Robert Dewar + + * sem_ch3.adb (Copy_And_Swap): Copy Has_Pragma_Unmodified flag. + + * sem_ch7.adb (Preserve_Full_Attributes): Preserve + Has_Pragma_Unmodified flag. + +2010-06-14 Thomas Quinot + + * g-sttsne-locking.adb, g-sttsne-locking.ads, g-sttsne.ads, + g-sttsne-vxworks.adb, g-sttsne-dummy.ads: Removed. Mutual exclusion is + now done in GNAT.Sockets if necessary. + * gsocket.h, g-socket.adb, g-sothco.ads (GNAT.Sockets.Get_XXX_By_YYY): + Ensure mutual exclusion for netdb operations if the target platform + requires it. + (GNAT.Sockets.Thin_Common): New binding for getXXXbyYYY, treating struct + hostent as an opaque type to improve portability. + * s-oscons-tmplt.c, socket.c: For the case of Vxworks, emulate + gethostbyYYY using proprietary VxWorks API so that a uniform interface + is available for the Ada side. + * gcc-interface/Makefile.in: Remove g-sttsne-* + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-14 Vincent Celier + + * gnatcmd.adb (Mapping_File): New function. + +2010-06-14 Javier Miranda + + * sem_ch3.adb (Derive_Subprograms): Remove over-restrictive assertion. + +2010-06-14 Arnaud Charlet + + * ali.adb: Fix typo. + * s-auxdec-vms-alpha.adb, scng.ads: Minor reformatting. + +2010-06-14 Ed Schonberg + + * sem_ch12.adb: Make Mark_Context transitive, and apply to subprogram + instances. + + * sem_ch8.adb (Find_Expanded_Name): If a candidate compilation unit in + the context does not have a homonym of the selector, emit default + error message. + +2010-06-14 Robert Dewar + + * sem.adb, sem_ch12.adb, sem_util.adb: Minor reformatting and + comment addition. + +2010-06-14 Arnaud Charlet + + * lib-xref.ads: Doc updates: + - Allocate 'Q' for #include entity kind + - Free 'Z' + - Allocate 'g' for regular macros + - Allocate 'G' for function-like macros + +2010-06-14 Ed Schonberg + + * sinfo.ads, sinfo.adb (Withed_Body): New attribute of a with_clause. + Indicates that there is an instantiation in the current unit that + loaded the body of the unit denoted by the with_clause. + * sem_ch12.adb (Mark_Context): When instanting a generic body, check + whether a with_clause in the current context denotes the unit that + holds the generic declaration, and mark the with_clause accordingly. + (Instantiate_Package_Body): call Mark_Context. + * sem.adb (Process_Bodies_In_Context): Use Withed_Body to determine + whether a given body should be traversed before the spec of the main + unit. + +2010-06-14 Ed Falis + + * sysdep.c: Fix 653 build against vThreads headers. + +2010-06-14 Robert Dewar + + * sinfo.ads: Minor reformatting. + +2010-06-14 Ed Schonberg + + * sem_ch6.adb (Analyze_Subprogram_Body): Do not check conformance when + the spec has been generated for a body without spec that carries an + Inline_Always pragma. + +2010-06-14 Arnaud Charlet + + * lib-xref.ads: Documentation change: allocate 'Z' letter to C/C++ + macro. + +2010-06-14 Jerome Lambourg + + * exp_dbug.adb (Debug_Renaming_Declaration): Do not output any debug + declaration for VMs, as those are useless and might lead to duplicated + local variable names in the generated code. + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-14 Robert Dewar + + * opt.ads, sem.adb, sem_elab.adb: Minor reformatting + +2010-06-14 Robert Dewar + + * exp_aggr.adb (Has_Address_Clause): Moved to Exp_Util, and there it + is renamed as Has_Following_Address_Clause. + * exp_ch3.adb (Needs_Simple_Initialization): Add Consider_IS argument + to allow the caller to avoid Initialize_Scalars having an effect. + (Expand_N_Object_Declaration): Do not do Initialize_Scalars stuff for + scalars with an address clause specified. + * exp_ch3.ads (Needs_Simple_Initialization): Add Consider_IS argument + to allow the caller to avoid Initialize_Scalars having an effect. + * exp_util.adb (Has_Following_Address_Clause): Moved here from Exp_Aggr + (where it was called Has_Address_Clause). + * exp_util.ads (Has_Following_Address_Clause): Moved here from Exp_Aggr + (where it was called Has_Address_Clause). + * freeze.adb (Warn_Overlay): Suppress message about overlaying causing + problems for Initialize_Scalars (since we no longer initialize objects + with an address clause. + +2010-06-14 Robert Dewar + + * exp_prag.adb (Expand_Pragma_Check): Set Loc of generated code from + condition. + +2010-06-14 Gary Dismukes + + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Set Debug_Info_Needed + on the entity of an implicitly generated postcondition procedure. + +2010-06-14 Thomas Quinot + + * sem_ch7.adb (Preserve_Full_Attributes): Propagate + Discriminant_Constraint elist from full view to private view. + +2010-06-14 Robert Dewar + + * sem_res.adb: Minor reformatting. + +2010-06-14 Ed Schonberg + + * sem.adb: New version of unit traversal. + + * sem_elab.adb (Check_Internal_Call): Do not place a call appearing + within a generic unit in the table of delayed calls. + +2010-06-14 Robert Dewar + + * gnatcmd.adb, sem_util.adb, exp_ch3.adb: Minor reformatting + +2010-06-14 Ed Schonberg + + * sem_ch12.adb (Save_References): If an identifier has been rewritten + during analysis as an explicit dereference, keep the reference implicit + in the generic, but preserve the entity if global. This prevents + malformed generic trees in the presence of some nested generics. + +2010-06-14 Sergey Rybin + + * gnat_ugn.texi: For the GNAT driver, clarify the effect of calling the + tool with '-files=' option. Also fix some small errors (wrong brackets) + +2010-06-14 Vincent Celier + + * gnatbind.adb: Call Scan_ALI with Directly_Scanned set to True for all + the ALI files on the command line. + + * ali.adb (Scan_ALI): Set component Directly_Scanned of the unit(s) to + the same value as the parameter of the same name. + * ali.ads (Scan_ALI): New Boolean parameter Directly_Scanned, defaulted + to False. + * bindgen.adb (Gen_Versions_Ada): Never emit version symbols for + Stand-Alone Library interfaces. When binding Stand-Alone Libraries, + emit version symbols only for the units of the library. + (Gen_Versions_C): Ditto. + +2010-06-14 Gary Dismukes + + * sem_ch4.adb: Fix typo. + +2010-06-14 Vasiliy Fofanov + + * s-oscons-tmplt.c (IOV_MAX): redefine on Tru64 and VMS since the + vector IO doesn't work at default value properly. + +2010-06-14 Doug Rupp + + * s-stoele.adb: Remove unnecessary qualification of To_Address for VMS. + +2010-06-14 Vincent Celier + + * gnatcmd.adb (Check_Files): Do not invoke the tool with all the + sources of the project if a switch -files= is used. + +2010-06-14 Thomas Quinot + + * exp_attr.adb: Minor reformatting. + +2010-06-14 Gary Dismukes + + * gnat_ugn.texi: Minor typo fixes and wording changes. + +2010-06-14 Ed Schonberg + + * sem_ch4.adb (Analyze_One_Call): If the call has been rewritten from a + prefixed form, do not re-analyze first actual, which may need an + implicit dereference. + * sem_ch6.adb (Analyze_Procedure_Call): If the call is given in + prefixed notation, the analysis will rewrite the node, and possible + errors appear in the rewritten name of the node. + * sem_res.adb: If a call is ambiguous because its first parameter is + an overloaded call, report list of candidates, to clarify ambiguity of + enclosing call. + +2010-06-14 Doug Rupp + + * s-auxdec-vms-alpha.adb: New package body implementing legacy + VAX instructions with Asm insertions. + * s-auxdec-vms_64.ads: Inline VAX queue functions + * s-stoele.adb: Resolve some ambiguities in To_Addresss with s-suxdec + that show up only on VMS. + * gcc-interface/Makefile.in: Provide translation for + s-auxdec-vms-alpha.adb. + +2010-06-14 Olivier Hainque + + * initialize.c (VxWorks section): Update comments. + +2010-06-14 Robert Dewar + + * a-convec.adb, sem_prag.adb, checks.adb: Minor reformatting. + +2010-06-14 Eric Botcazou + + * init.c: Code clean up. + +2010-06-14 Ed Schonberg + + * sem_ch13.adb (Analyze_Attribute_Definition_Clause, case Address): Do + not insert address clause in table for later validation if type of + entity is generic, to prevent possible spurious errors. + + * sem_ch8.adb: Code clean up. + +2010-06-14 Ben Brosgol + + * gnat_ugn.texi: Expanded @ovar macro inline to solve problem with + texi2pdf and texi2html. + Document how to change scheduling properties on HP-UX. + +2010-06-14 Thomas Quinot + + * g-socket.ads: Remove misleading comments. + +2010-06-14 Jerome Lambourg + + * sem_prag.adb (Check_Duplicated_Export_Name): Remove check for + CLI_Target as this prevents proper detection of exported names + duplicates when the exported language is different to CIL. + (Process_Interface_Name): Add check for CIL convention exports, + replacing the old one from Check_Duplicated_Export_Name. + +2010-06-14 Matthew Heaney + + * a-coinve.adb, a-convec.adb (operator "&"): Check both that new length + and new last satisfy constraints. + (Delete_Last): prevent overflow for subtraction of index values + (To_Vector): prevent overflow for addition of index values + +2010-06-14 Ed Schonberg + + * sem_ch4.adb (Complete_Object_Operation): After analyzing the + rewritten call, preserve the resulting type to prevent spurious errors, + when the call is implicitly dereferenced in the context of an in-out + actual. + + * checks.adb (Apply_Discriminant_Check): If the target of the + assignment is a renaming of a heap object, create constrained type for + it to apply check. + +2010-06-14 Pascal Obry + + * prj-proc.adb: Fix copy of object directory for extending projects. + +2010-06-14 Jose Ruiz + + * init.c (__gnat_alternate_stack): Define this space for PowerPC linux + (__gnat_install_handler, PowerPC linux): Activate the alternative + signal stack. + +2010-06-13 Gerald Pfeifer + + * gnat_rm.texi: Move to GFDL version 1.3. + * gnat-style.texi: Ditto. + * gnat_ugn.texi: Ditto. + +2010-06-12 Kai Tietz + + PR ada/43731 + * gcc-interface/Makefile.in: Add rules for multilib x86/x64 + mingw targets. + +2010-06-11 Alexandre Oliva + + * gcc-interface/utils.c (update_pointer_to): Initialize last. + +2010-06-09 Eric Botcazou + + * gcc-interface/ada-tree.h: Fix formatting nits. + +2010-06-08 Laurynas Biveinis + + * gcc-interface/utils.c (init_gnat_to_gnu): Use typed GC + allocation. + (init_dummy_type): Likewise. + (gnat_pushlevel): Likewise. + + * gcc-interface/trans.c (Attribute_to_gnu): Likewise. + (Subprogram_Body_to_gnu): Likewise. + (Compilation_Unit_to_gnu): Likewise. + (start_stmt_group): Likewise. + (extract_encoding): Likewise. + (decode_name): Likewise. + + * gcc-interface/misc.c (gnat_printable_name): Likewise. + + * gcc-interface/decl.c (annotate_value): Likewise. + + * gcc-interface/ada-tree.h (struct lang_type): Add variable_size + GTY option. + (struct lang_decl): Likewise. + (SET_TYPE_LANG_SPECIFIC): Use typed GC allocation. + (SET_DECL_LANG_SPECIFIC): Likewise. + +2010-06-04 Eric Botcazou + + * gnatlink.adb (gnatlink): Remove support for -fsjlj switch. + * gcc-interface/lang-specs.h: Likewise. + +2010-06-03 H.J. Lu + + PR c++/44294 + * gcc-interface/decl.c (MAX_FIXED_MODE_SIZE): Removed. + 2010-06-01 Arnaud Charlet * gnat_ugn.texi: Improve doc on -fdump-ada-spec, mention limitations. diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index f101a52e025..6e7d4eba44a 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -1,5 +1,5 @@ # Makefile.rtl for GNU Ada Compiler (GNAT). -# Copyright (C) 2003-2008, Free Software Foundation, Inc. +# Copyright (C) 2003-2010, Free Software Foundation, Inc. #This file is part of GCC. @@ -211,6 +211,7 @@ GNATRTL_NONTASKING_OBJS= \ a-ststio$(objext) \ a-stunau$(objext) \ a-stunha$(objext) \ + a-stuten$(objext) \ a-stwibo$(objext) \ a-stwifi$(objext) \ a-stwiha$(objext) \ @@ -225,6 +226,9 @@ GNATRTL_NONTASKING_OBJS= \ a-stzsea$(objext) \ a-stzsup$(objext) \ a-stzunb$(objext) \ + a-suenco$(objext) \ + a-suewen$(objext) \ + a-suezen$(objext) \ a-suteio$(objext) \ a-swbwha$(objext) \ a-swfwha$(objext) \ @@ -359,6 +363,8 @@ GNATRTL_NONTASKING_OBJS= \ g-io$(objext) \ g-io_aux$(objext) \ g-locfil$(objext) \ + g-mbdira$(objext) \ + g-mbflra$(objext) \ g-md5$(objext) \ g-memdum$(objext) \ g-moreex$(objext) \ diff --git a/gcc/ada/a-coinve.adb b/gcc/ada/a-coinve.adb index 84ad22ec1f9..6443644b4f6 100644 --- a/gcc/ada/a-coinve.adb +++ b/gcc/ada/a-coinve.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -33,9 +33,6 @@ with System; use type System.Address; package body Ada.Containers.Indefinite_Vectors is - type Int is range System.Min_Int .. System.Max_Int; - type UInt is mod System.Max_Binary_Modulus; - procedure Free is new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access); @@ -47,10 +44,22 @@ package body Ada.Containers.Indefinite_Vectors is --------- function "&" (Left, Right : Vector) return Vector is - LN : constant Count_Type := Length (Left); - RN : constant Count_Type := Length (Right); + LN : constant Count_Type := Length (Left); + RN : constant Count_Type := Length (Right); + N : Count_Type'Base; -- length of result + J : Count_Type'Base; -- for computing intermediate values + Last : Index_Type'Base; -- Last index of result begin + -- We decide that the capacity of the result is the sum of the lengths + -- of the vector parameters. We could decide to make it larger, but we + -- have no basis for knowing how much larger, so we just allocate the + -- minimum amount of storage. + + -- Here we handle the easy cases first, when one of the vector + -- parameters is empty. (We say "easy" because there's nothing to + -- compute, that can potentially overflow.) + if LN = 0 then if RN = 0 then return Empty_Vector; @@ -64,6 +73,11 @@ package body Ada.Containers.Indefinite_Vectors is new Elements_Type (Right.Last); begin + -- Elements of an indefinite vector are allocated, so we cannot + -- use simple slice assignment to give a value to our result. + -- Hence we must walk the array of the Right vector, and copy + -- each source element individually. + for I in Elements.EA'Range loop begin if RE (I) /= null then @@ -95,6 +109,11 @@ package body Ada.Containers.Indefinite_Vectors is new Elements_Type (Left.Last); begin + -- Elements of an indefinite vector are allocated, so we cannot + -- use simple slice assignment to give a value to our result. + -- Hence we must walk the array of the Left vector, and copy + -- each source element individually. + for I in Elements.EA'Range loop begin if LE (I) /= null then @@ -116,83 +135,162 @@ package body Ada.Containers.Indefinite_Vectors is end; end if; - declare - N : constant Int'Base := Int (LN) + Int (RN); - Last_As_Int : Int'Base; + -- Neither of the vector parameters is empty, so we must compute the + -- length of the result vector and its last index. (This is the harder + -- case, because our computations must avoid overflow.) - begin - if Int (No_Index) > Int'Last - N then + -- There are two constraints we need to satisfy. The first constraint is + -- that a container cannot have more than Count_Type'Last elements, so + -- we must check the sum of the combined lengths. Note that we cannot + -- simply add the lengths, because of the possibilty of overflow. + + if LN > Count_Type'Last - RN then + raise Constraint_Error with "new length is out of range"; + end if; + + -- It is now safe compute the length of the new vector. + + N := LN + RN; + + -- The second constraint is that the new Last index value cannot + -- exceed Index_Type'Last. We use the wider of Index_Type'Base and + -- Count_Type'Base as the type for intermediate values. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + + -- We perform a two-part test. First we determine whether the + -- computed Last value lies in the base range of the type, and then + -- determine whether it lies in the range of the index (sub)type. + + -- Last must satisfy this relation: + -- First + Length - 1 <= Last + -- We regroup terms: + -- First - 1 <= Last - Length + -- Which can rewrite as: + -- No_Index <= Last - Length + + if Index_Type'Base'Last - Index_Type'Base (N) < No_Index then raise Constraint_Error with "new length is out of range"; end if; - Last_As_Int := Int (No_Index) + N; + -- We now know that the computed value of Last is within the base + -- range of the type, so it is safe to compute its value: + + Last := No_Index + Index_Type'Base (N); + + -- Finally we test whether the value is within the range of the + -- generic actual index subtype: - if Last_As_Int > Int (Index_Type'Last) then + if Last > Index_Type'Last then raise Constraint_Error with "new length is out of range"; end if; - declare - Last : constant Index_Type := Index_Type (Last_As_Int); + elsif Index_Type'First <= 0 then - LE : Elements_Array renames - Left.Elements.EA (Index_Type'First .. Left.Last); + -- Here we can compute Last directly, in the normal way. We know that + -- No_Index is less than 0, so there is no danger of overflow when + -- adding the (positive) value of length. - RE : Elements_Array renames - Right.Elements.EA (Index_Type'First .. Right.Last); + J := Count_Type'Base (No_Index) + N; -- Last - Elements : Elements_Access := new Elements_Type (Last); + if J > Count_Type'Base (Index_Type'Last) then + raise Constraint_Error with "new length is out of range"; + end if; - I : Index_Type'Base := No_Index; + -- We know that the computed value (having type Count_Type) of Last + -- is within the range of the generic actual index subtype, so it is + -- safe to convert to Index_Type: - begin - for LI in LE'Range loop - I := I + 1; + Last := Index_Type'Base (J); - begin - if LE (LI) /= null then - Elements.EA (I) := new Element_Type'(LE (LI).all); - end if; + else + -- Here Index_Type'First (and Index_Type'Last) is positive, so we + -- must test the length indirectly (by working backwards from the + -- largest possible value of Last), in order to prevent overflow. - exception - when others => - for J in Index_Type'First .. I - 1 loop - Free (Elements.EA (J)); - end loop; + J := Count_Type'Base (Index_Type'Last) - N; -- No_Index - Free (Elements); - raise; - end; - end loop; + if J < Count_Type'Base (No_Index) then + raise Constraint_Error with "new length is out of range"; + end if; - for RI in RE'Range loop - I := I + 1; + -- We have determined that the result length would not create a Last + -- index value outside of the range of Index_Type, so we can now + -- safely compute its value. - begin - if RE (RI) /= null then - Elements.EA (I) := new Element_Type'(RE (RI).all); - end if; + Last := Index_Type'Base (Count_Type'Base (No_Index) + N); + end if; - exception - when others => - for J in Index_Type'First .. I - 1 loop - Free (Elements.EA (J)); - end loop; + declare + LE : Elements_Array renames + Left.Elements.EA (Index_Type'First .. Left.Last); - Free (Elements); - raise; - end; - end loop; + RE : Elements_Array renames + Right.Elements.EA (Index_Type'First .. Right.Last); - return (Controlled with Elements, Last, 0, 0); - end; + Elements : Elements_Access := new Elements_Type (Last); + + I : Index_Type'Base := No_Index; + + begin + -- Elements of an indefinite vector are allocated, so we cannot use + -- simple slice assignment to give a value to our result. Hence we + -- must walk the array of each vector parameter, and copy each source + -- element individually. + + for LI in LE'Range loop + I := I + 1; + + begin + if LE (LI) /= null then + Elements.EA (I) := new Element_Type'(LE (LI).all); + end if; + + exception + when others => + for J in Index_Type'First .. I - 1 loop + Free (Elements.EA (J)); + end loop; + + Free (Elements); + raise; + end; + end loop; + + for RI in RE'Range loop + I := I + 1; + + begin + if RE (RI) /= null then + Elements.EA (I) := new Element_Type'(RE (RI).all); + end if; + + exception + when others => + for J in Index_Type'First .. I - 1 loop + Free (Elements.EA (J)); + end loop; + + Free (Elements); + raise; + end; + end loop; + + return (Controlled with Elements, Last, 0, 0); end; end "&"; function "&" (Left : Vector; Right : Element_Type) return Vector is - LN : constant Count_Type := Length (Left); - begin - if LN = 0 then + -- We decide that the capacity of the result is the sum of the lengths + -- of the parameters. We could decide to make it larger, but we have no + -- basis for knowing how much larger, so we just allocate the minimum + -- amount of storage. + + -- Here we handle the easy case first, when the vector parameter (Left) + -- is empty. + + if Left.Is_Empty then declare Elements : Elements_Access := new Elements_Type (Index_Type'First); @@ -209,70 +307,75 @@ package body Ada.Containers.Indefinite_Vectors is end; end if; - declare - Last_As_Int : Int'Base; + -- The vector parameter is not empty, so we must compute the length of + -- the result vector and its last index, but in such a way that overflow + -- is avoided. We must satisfy two constraints: the new length cannot + -- exceed Count_Type'Last, and the new Last index cannot exceed + -- Index_Type'Last. - begin - if Int (Index_Type'First) > Int'Last - Int (LN) then - raise Constraint_Error with "new length is out of range"; - end if; - - Last_As_Int := Int (Index_Type'First) + Int (LN); - - if Last_As_Int > Int (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; - end if; - - declare - Last : constant Index_Type := Index_Type (Last_As_Int); - - LE : Elements_Array renames - Left.Elements.EA (Index_Type'First .. Left.Last); + if Left.Length = Count_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; - Elements : Elements_Access := - new Elements_Type (Last); + if Left.Last >= Index_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; - begin - for I in LE'Range loop - begin - if LE (I) /= null then - Elements.EA (I) := new Element_Type'(LE (I).all); - end if; + declare + Last : constant Index_Type := Left.Last + 1; - exception - when others => - for J in Index_Type'First .. I - 1 loop - Free (Elements.EA (J)); - end loop; + LE : Elements_Array renames + Left.Elements.EA (Index_Type'First .. Left.Last); - Free (Elements); - raise; - end; - end loop; + Elements : Elements_Access := + new Elements_Type (Last); + begin + for I in LE'Range loop begin - Elements.EA (Last) := new Element_Type'(Right); + if LE (I) /= null then + Elements.EA (I) := new Element_Type'(LE (I).all); + end if; exception when others => - for J in Index_Type'First .. Last - 1 loop + for J in Index_Type'First .. I - 1 loop Free (Elements.EA (J)); end loop; Free (Elements); raise; end; + end loop; + + begin + Elements.EA (Last) := new Element_Type'(Right); + + exception + when others => + for J in Index_Type'First .. Last - 1 loop + Free (Elements.EA (J)); + end loop; - return (Controlled with Elements, Last, 0, 0); + Free (Elements); + raise; end; + + return (Controlled with Elements, Last, 0, 0); end; end "&"; function "&" (Left : Element_Type; Right : Vector) return Vector is - RN : constant Count_Type := Length (Right); - begin - if RN = 0 then + -- We decide that the capacity of the result is the sum of the lengths + -- of the parameters. We could decide to make it larger, but we have no + -- basis for knowing how much larger, so we just allocate the minimum + -- amount of storage. + + -- Here we handle the easy case first, when the vector parameter (Right) + -- is empty. + + if Right.Is_Empty then declare Elements : Elements_Access := new Elements_Type (Index_Type'First); @@ -289,66 +392,76 @@ package body Ada.Containers.Indefinite_Vectors is end; end if; - declare - Last_As_Int : Int'Base; + -- The vector parameter is not empty, so we must compute the length of + -- the result vector and its last index, but in such a way that overflow + -- is avoided. We must satisfy two constraints: the new length cannot + -- exceed Count_Type'Last, and the new Last index cannot exceed + -- Index_Type'Last. - begin - if Int (Index_Type'First) > Int'Last - Int (RN) then - raise Constraint_Error with "new length is out of range"; - end if; + if Right.Length = Count_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; - Last_As_Int := Int (Index_Type'First) + Int (RN); + if Right.Last >= Index_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; - if Last_As_Int > Int (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; - end if; + declare + Last : constant Index_Type := Right.Last + 1; - declare - Last : constant Index_Type := Index_Type (Last_As_Int); + RE : Elements_Array renames + Right.Elements.EA (Index_Type'First .. Right.Last); - RE : Elements_Array renames - Right.Elements.EA (Index_Type'First .. Right.Last); + Elements : Elements_Access := + new Elements_Type (Last); - Elements : Elements_Access := - new Elements_Type (Last); - - I : Index_Type'Base := Index_Type'First; + I : Index_Type'Base := Index_Type'First; + begin begin + Elements.EA (I) := new Element_Type'(Left); + exception + when others => + Free (Elements); + raise; + end; + + for RI in RE'Range loop + I := I + 1; + begin - Elements.EA (I) := new Element_Type'(Left); + if RE (RI) /= null then + Elements.EA (I) := new Element_Type'(RE (RI).all); + end if; + exception when others => + for J in Index_Type'First .. I - 1 loop + Free (Elements.EA (J)); + end loop; + Free (Elements); raise; end; + end loop; - for RI in RE'Range loop - I := I + 1; - - begin - if RE (RI) /= null then - Elements.EA (I) := new Element_Type'(RE (RI).all); - end if; - - exception - when others => - for J in Index_Type'First .. I - 1 loop - Free (Elements.EA (J)); - end loop; - - Free (Elements); - raise; - end; - end loop; - - return (Controlled with Elements, Last, 0, 0); - end; + return (Controlled with Elements, Last, 0, 0); end; end "&"; function "&" (Left, Right : Element_Type) return Vector is begin + -- We decide that the capacity of the result is the sum of the lengths + -- of the parameters. We could decide to make it larger, but we have no + -- basis for knowing how much larger, so we just allocate the minimum + -- amount of storage. + + -- We must compute the length of the result vector and its last index, + -- but in such a way that overflow is avoided. We must satisfy two + -- constraints: the new length cannot exceed Count_Type'Last (here, we + -- know that that condition is satisfied), and the new Last index cannot + -- exceed Index_Type'Last. + if Index_Type'First >= Index_Type'Last then raise Constraint_Error with "new length is out of range"; end if; @@ -541,75 +654,177 @@ package body Ada.Containers.Indefinite_Vectors is Index : Extended_Index; Count : Count_Type := 1) is - begin + Old_Last : constant Index_Type'Base := Container.Last; + New_Last : Index_Type'Base; + Count2 : Count_Type'Base; -- count of items from Index to Old_Last + J : Index_Type'Base; -- first index of items that slide down + + begin + -- Delete removes items from the vector, the number of which is the + -- minimum of the specified Count and the items (if any) that exist from + -- Index to Container.Last. There are no constraints on the specified + -- value of Count (it can be larger than what's available at this + -- position in the vector, for example), but there are constraints on + -- the allowed values of the Index. + + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we do + -- not allow that as the value for Index when specifying which items + -- should be deleted, so we must manually check. (That the user is + -- allowed to specify the value at all here is a consequence of the + -- declaration of the Extended_Index subtype, which includes the values + -- in the base range that immediately precede and immediately follow the + -- values in the Index_Type.) + if Index < Index_Type'First then raise Constraint_Error with "Index is out of range (too small)"; end if; - if Index > Container.Last then - if Index > Container.Last + 1 then + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows the + -- corner case of deleting no items from the back end of the vector to + -- be treated as a no-op. (It is assumed that specifying an index value + -- greater than Last + 1 indicates some deeper flaw in the caller's + -- algorithm, so that case is treated as a proper error.) + + if Index > Old_Last then + if Index > Old_Last + 1 then raise Constraint_Error with "Index is out of range (too large)"; end if; return; end if; + -- Here and elsewhere we treat deleting 0 items from the container as a + -- no-op, even when the container is busy, so we simply return. + if Count = 0 then return; end if; + -- The internal elements array isn't guaranteed to exist unless we have + -- elements, so we handle that case here in order to avoid having to + -- check it later. (Note that an empty vector can never be busy, so + -- there's no semantic harm in returning early.) + + if Container.Is_Empty then + return; + end if; + + -- The tampering bits exist to prevent an item from being deleted (or + -- otherwise harmfully manipulated) while it is being visited. Query, + -- Update, and Iterate increment the busy count on entry, and decrement + -- the count on exit. Delete checks the count to determine whether it is + -- being called while the associated callback procedure is executing. + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; - declare - Index_As_Int : constant Int := Int (Index); - Old_Last_As_Int : constant Int := Int (Container.Last); + -- We first calculate what's available for deletion starting at + -- Index. Here and elsewhere we use the wider of Index_Type'Base and + -- Count_Type'Base as the type for intermediate values. (See function + -- Length for more information.) - Count1 : constant Int'Base := Int (Count); - Count2 : constant Int'Base := Old_Last_As_Int - Index_As_Int + 1; - N : constant Int'Base := Int'Min (Count1, Count2); + if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then + Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1; - J_As_Int : constant Int'Base := Index_As_Int + N; - E : Elements_Array renames Container.Elements.EA; + else + Count2 := Count_Type'Base (Old_Last - Index + 1); + end if; - begin - if J_As_Int > Old_Last_As_Int then + -- If the number of elements requested (Count) for deletion is equal to + -- (or greater than) the number of elements available (Count2) for + -- deletion beginning at Index, then everything from Index to + -- Container.Last is deleted (this is equivalent to Delete_Last). + + if Count >= Count2 then + -- Elements in an indefinite vector are allocated, so we must iterate + -- over the loop and deallocate elements one-at-a-time. We work from + -- back to front, deleting the last element during each pass, in + -- order to gracefully handle deallocation failures. + + declare + EA : Elements_Array renames Container.Elements.EA; + + begin while Container.Last >= Index loop declare K : constant Index_Type := Container.Last; - X : Element_Access := E (K); + X : Element_Access := EA (K); begin - E (K) := null; + -- We first isolate the element we're deleting, removing it + -- from the vector before we attempt to deallocate it, in + -- case the deallocation fails. + + EA (K) := null; Container.Last := K - 1; + + -- Container invariants have been restored, so it is now + -- safe to attempt to deallocate the element. + Free (X); end; end loop; + end; - else - declare - J : constant Index_Type := Index_Type (J_As_Int); + return; + end if; + + -- There are some elements that aren't being deleted (the requested + -- count was less than the available count), so we must slide them down + -- to Index. We first calculate the index values of the respective array + -- slices, using the wider of Index_Type'Base and Count_Type'Base as the + -- type for intermediate calculations. For the elements that slide down, + -- index value New_Last is the last index value of their new home, and + -- index value J is the first index of their old home. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + New_Last := Old_Last - Index_Type'Base (Count); + J := Index + Index_Type'Base (Count); - New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N; - New_Last : constant Index_Type := - Index_Type (New_Last_As_Int); + else + New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count); + J := Index_Type'Base (Count_Type'Base (Index) + Count); + end if; + + -- The internal elements array isn't guaranteed to exist unless we have + -- elements, but we have that guarantee here because we know we have + -- elements to slide. The array index values for each slice have + -- already been determined, so what remains to be done is to first + -- deallocate the elements that are being deleted, and then slide down + -- to Index the elements that aren't being deleted. + + declare + EA : Elements_Array renames Container.Elements.EA; + + begin + -- Before we can slide down the elements that aren't being deleted, + -- we need to deallocate the elements that are being deleted. + + for K in Index .. J - 1 loop + declare + X : Element_Access := EA (K); begin - for K in Index .. J - 1 loop - declare - X : Element_Access := E (K); - begin - E (K) := null; - Free (X); - end; - end loop; + -- First we remove the element we're about to deallocate from + -- the vector, in case the deallocation fails, in order to + -- preserve representation invariants. - E (Index .. New_Last) := E (J .. Container.Last); - Container.Last := New_Last; + EA (K) := null; + + -- The element has been removed from the vector, so it is now + -- safe to attempt to deallocate it. + + Free (X); end; - end if; + end loop; + + EA (Index .. New_Last) := EA (J .. Old_Last); + Container.Last := New_Last; end; end Delete; @@ -667,32 +882,64 @@ package body Ada.Containers.Indefinite_Vectors is (Container : in out Vector; Count : Count_Type := 1) is - N : constant Count_Type := Length (Container); - begin - if Count = 0 - or else N = 0 - then + -- It is not permitted to delete items while the container is busy (for + -- example, we're in the middle of a passive iteration). However, we + -- always treat deleting 0 items as a no-op, even when we're busy, so we + -- simply return without checking. + + if Count = 0 then + return; + end if; + + -- We cannot simply subsume the empty case into the loop below (the loop + -- would iterate 0 times), because we rename the internal array object + -- (which is allocated), but an empty vector isn't guaranteed to have + -- actually allocated an array. (Note that an empty vector can never be + -- busy, so there's no semantic harm in returning early here.) + + if Container.Is_Empty then return; end if; + -- The tampering bits exist to prevent an item from being deleted (or + -- otherwise harmfully manipulated) while it is being visited. Query, + -- Update, and Iterate increment the busy count on entry, and decrement + -- the count on exit. Delete_Last checks the count to determine whether + -- it is being called while the associated callback procedure is + -- executing. + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; + -- Elements in an indefinite vector are allocated, so we must iterate + -- over the loop and deallocate elements one-at-a-time. We work from + -- back to front, deleting the last element during each pass, in order + -- to gracefully handle deallocation failures. + declare E : Elements_Array renames Container.Elements.EA; begin - for Indx in 1 .. Count_Type'Min (Count, N) loop + for Indx in 1 .. Count_Type'Min (Count, Container.Length) loop declare J : constant Index_Type := Container.Last; X : Element_Access := E (J); begin + -- Note that we first isolate the element we're deleting, + -- removing it from the vector, before we actually deallocate + -- it, in order to preserve representation invariants even if + -- the deallocation fails. + E (J) := null; Container.Last := J - 1; + + -- Container invariants have been restored, so it is now safe + -- to deallocate the element. + Free (X); end; end loop; @@ -1042,22 +1289,42 @@ package body Ada.Containers.Indefinite_Vectors is New_Item : Element_Type; Count : Count_Type := 1) is - N : constant Int := Int (Count); + Old_Length : constant Count_Type := Container.Length; - First : constant Int := Int (Index_Type'First); - New_Last_As_Int : Int'Base; - New_Last : Index_Type; - New_Length : UInt; - Max_Length : constant UInt := UInt (Count_Type'Last); + Max_Length : Count_Type'Base; -- determined from range of Index_Type + New_Length : Count_Type'Base; -- sum of current length and Count + New_Last : Index_Type'Base; -- last index of vector after insertion - Dst : Elements_Access; + Index : Index_Type'Base; -- scratch for intermediate values + J : Count_Type'Base; -- scratch + + New_Capacity : Count_Type'Base; -- length of new, expanded array + Dst_Last : Index_Type'Base; -- last index of new, expanded array + Dst : Elements_Access; -- new, expanded internal array begin + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we do + -- not allow that as the value for Index when specifying where the new + -- items should be inserted, so we must manually check. (That the user + -- is allowed to specify the value at all here is a consequence of the + -- declaration of the Extended_Index subtype, which includes the values + -- in the base range that immediately precede and immediately follow the + -- values in the Index_Type.) + if Before < Index_Type'First then raise Constraint_Error with "Before index is out of range (too small)"; end if; + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows for the + -- case of appending items to the back end of the vector. (It is assumed + -- that specifying an index value greater than Last + 1 indicates some + -- deeper flaw in the caller's algorithm, so that case is treated as a + -- proper error.) + if Before > Container.Last and then Before > Container.Last + 1 then @@ -1065,197 +1332,371 @@ package body Ada.Containers.Indefinite_Vectors is "Before index is out of range (too large)"; end if; + -- We treat inserting 0 items into the container as a no-op, even when + -- the container is busy, so we simply return. + if Count = 0 then return; end if; - declare - Old_Last_As_Int : constant Int := Int (Container.Last); + -- There are two constraints we need to satisfy. The first constraint is + -- that a container cannot have more than Count_Type'Last elements, so + -- we must check the sum of the current length and the insertion + -- count. Note that we cannot simply add these values, because of the + -- possibilty of overflow. - begin - if Old_Last_As_Int > Int'Last - N then - raise Constraint_Error with "new length is out of range"; - end if; + if Old_Length > Count_Type'Last - Count then + raise Constraint_Error with "Count is out of range"; + end if; - New_Last_As_Int := Old_Last_As_Int + N; + -- It is now safe compute the length of the new vector, without fear of + -- overflow. - if New_Last_As_Int > Int (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; + New_Length := Old_Length + Count; + + -- The second constraint is that the new Last index value cannot exceed + -- Index_Type'Last. In each branch below, we calculate the maximum + -- length (computed from the range of values in Index_Type), and then + -- compare the new length to the maximum length. If the new length is + -- acceptable, then we compute the new last index from that. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + -- We have to handle the case when there might be more values in the + -- range of Index_Type than in the range of Count_Type. + + if Index_Type'First <= 0 then + -- We know that No_Index (the same as Index_Type'First - 1) is + -- less than 0, so it is safe to compute the following sum without + -- fear of overflow. + + Index := No_Index + Index_Type'Base (Count_Type'Last); + + if Index <= Index_Type'Last then + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the + -- maximum number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than in Count_Type, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; + + else + -- No_Index is equal or greater than 0, so we can safely compute + -- the difference without fear of overflow (which we would have to + -- worry about if No_Index were less than 0, but that case is + -- handled above). + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); end if; - New_Length := UInt (New_Last_As_Int - First + 1); + elsif Index_Type'First <= 0 then + -- We know that No_Index (the same as Index_Type'First - 1) is less + -- than 0, so it is safe to compute the following sum without fear of + -- overflow. - if New_Length > Max_Length then - raise Constraint_Error with "new length is out of range"; + J := Count_Type'Base (No_Index) + Count_Type'Last; + + if J <= Count_Type'Base (Index_Type'Last) then + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the maximum + -- number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than Count_Type does, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); end if; - New_Last := Index_Type (New_Last_As_Int); - end; + else + -- No_Index is equal or greater than 0, so we can safely compute the + -- difference without fear of overflow (which we would have to worry + -- about if No_Index were less than 0, but that case is handled + -- above). - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is busy)"; + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; + + -- We have just computed the maximum length (number of items). We must + -- now compare the requested length to the maximum length, as we do not + -- allow a vector expand beyond the maximum (because that would create + -- an internal array with a last index value greater than + -- Index_Type'Last, with no way to index those elements). + + if New_Length > Max_Length then + raise Constraint_Error with "Count is out of range"; + end if; + + -- New_Last is the last index value of the items in the container after + -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to + -- compute its value from the New_Length. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + New_Last := No_Index + Index_Type'Base (New_Length); + + else + New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length); end if; if Container.Elements = null then + pragma Assert (Container.Last = No_Index); + + -- This is the simplest case, with which we must always begin: we're + -- inserting items into an empty vector that hasn't allocated an + -- internal array yet. Note that we don't need to check the busy bit + -- here, because an empty container cannot be busy. + + -- In an indefinite vector, elements are allocated individually, and + -- stored as access values on the internal array (the length of which + -- represents the vector "capacity"), which is separately allocated. + Container.Elements := new Elements_Type (New_Last); - Container.Last := No_Index; - for J in Container.Elements.EA'Range loop - Container.Elements.EA (J) := new Element_Type'(New_Item); - Container.Last := J; + -- The element backbone has been successfully allocated, so now we + -- allocate the elements. + + for Idx in Container.Elements.EA'Range loop + -- In order to preserve container invariants, we always attempt + -- the element allocation first, before setting the Last index + -- value, in case the allocation fails (either because there is no + -- storage available, or because element initialization fails). + + Container.Elements.EA (Idx) := new Element_Type'(New_Item); + + -- The allocation of the element succeeded, so it is now safe to + -- update the Last index, restoring container invariants. + + Container.Last := Idx; end loop; return; end if; - if New_Last <= Container.Elements.Last then + -- The tampering bits exist to prevent an item from being harmfully + -- manipulated while it is being visited. Query, Update, and Iterate + -- increment the busy count on entry, and decrement the count on + -- exit. Insert checks the count to determine whether it is being called + -- while the associated callback procedure is executing. + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with elements (vector is busy)"; + end if; + + if New_Length <= Container.Elements.EA'Length then + -- In this case, we're inserting elements into a vector that has + -- already allocated an internal array, and the existing array has + -- enough unused storage for the new items. + declare E : Elements_Array renames Container.Elements.EA; + K : Index_Type'Base; begin - if Before <= Container.Last then - declare - Index_As_Int : constant Int'Base := - Index_Type'Pos (Before) + N; + if Before > Container.Last then + -- The new items are being appended to the vector, so no + -- sliding of existing elements is required. + + for Idx in Before .. New_Last loop + -- In order to preserve container invariants, we always + -- attempt the element allocation first, before setting the + -- Last index value, in case the allocation fails (either + -- because there is no storage available, or because element + -- initialization fails). + + E (Idx) := new Element_Type'(New_Item); + + -- The allocation of the element succeeded, so it is now + -- safe to update the Last index, restoring container + -- invariants. + + Container.Last := Idx; + end loop; + + else + -- The new items are being inserted before some existing + -- elements, so we must slide the existing elements up to their + -- new home. We use the wider of Index_Type'Base and + -- Count_Type'Base as the type for intermediate index values. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Index := Before + Index_Type'Base (Count); - Index : constant Index_Type := Index_Type (Index_As_Int); + else + Index := Index_Type'Base (Count_Type'Base (Before) + Count); + end if; - J : Index_Type'Base; + -- The new items are being inserted in the middle of the array, + -- in the range [Before, Index). Copy the existing elements to + -- the end of the array, to make room for the new items. + + E (Index .. New_Last) := E (Before .. Container.Last); + Container.Last := New_Last; + -- We have copied the existing items up to the end of the + -- array, to make room for the new items in the middle of + -- the array. Now we actually allocate the new items. + + -- Note: initialize K outside loop to make it clear that + -- K always has a value if the exception handler triggers. + + K := Before; begin - -- The new items are being inserted in the middle of the - -- array, in the range [Before, Index). Copy the existing - -- elements to the end of the array, to make room for the - -- new items. - - E (Index .. New_Last) := E (Before .. Container.Last); - Container.Last := New_Last; - - -- We have copied the existing items up to the end of the - -- array, to make room for the new items in the middle of - -- the array. Now we actually allocate the new items. - - -- Note: initialize J outside loop to make it clear that - -- J always has a value if the exception handler triggers. - - J := Before; - begin - while J < Index loop - E (J) := new Element_Type'(New_Item); - J := J + 1; - end loop; + while K < Index loop + E (K) := new Element_Type'(New_Item); + K := K + 1; + end loop; - exception - when others => + exception + when others => - -- Values in the range [Before, J) were successfully - -- allocated, but values in the range [J, Index) are - -- stale (these array positions contain copies of the - -- old items, that did not get assigned a new item, - -- because the allocation failed). We must finish what - -- we started by clearing out all of the stale values, - -- leaving a "hole" in the middle of the array. + -- Values in the range [Before, K) were successfully + -- allocated, but values in the range [K, Index) are + -- stale (these array positions contain copies of the + -- old items, that did not get assigned a new item, + -- because the allocation failed). We must finish what + -- we started by clearing out all of the stale values, + -- leaving a "hole" in the middle of the array. - E (J .. Index - 1) := (others => null); - raise; - end; + E (K .. Index - 1) := (others => null); + raise; end; - - else - for J in Before .. New_Last loop - E (J) := new Element_Type'(New_Item); - Container.Last := J; - end loop; end if; end; return; end if; - -- There follows LOTS of code completely devoid of comments ??? - -- This is not our general style ??? + -- In this case, we're inserting elements into a vector that has already + -- allocated an internal array, but the existing array does not have + -- enough storage, so we must allocate a new, longer array. In order to + -- guarantee that the amortized insertion cost is O(1), we always + -- allocate an array whose length is some power-of-two factor of the + -- current array length. (The new array cannot have a length less than + -- the New_Length of the container, but its last index value cannot be + -- greater than Index_Type'Last.) + + New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length); + while New_Capacity < New_Length loop + if New_Capacity > Count_Type'Last / 2 then + New_Capacity := Count_Type'Last; + exit; + end if; - declare - C, CC : UInt; + New_Capacity := 2 * New_Capacity; + end loop; - begin - C := UInt'Max (1, Container.Elements.EA'Length); -- ??? - while C < New_Length loop - if C > UInt'Last / 2 then - C := UInt'Last; - exit; - end if; + if New_Capacity > Max_Length then + -- We have reached the limit of capacity, so no further expansion + -- will occur. (This is not a problem, as there is never a need to + -- have more capacity than the maximum container length.) - C := 2 * C; - end loop; + New_Capacity := Max_Length; + end if; - if C > Max_Length then - C := Max_Length; - end if; + -- We have computed the length of the new internal array (and this is + -- what "vector capacity" means), so use that to compute its last index. - if Index_Type'First <= 0 - and then Index_Type'Last >= 0 - then - CC := UInt (Index_Type'Last) + UInt (-Index_Type'First) + 1; - else - CC := UInt (Int (Index_Type'Last) - First + 1); - end if; + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Dst_Last := No_Index + Index_Type'Base (New_Capacity); - if C > CC then - C := CC; - end if; + else + Dst_Last := + Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity); + end if; - declare - Dst_Last : constant Index_Type := - Index_Type (First + UInt'Pos (C) - Int'(1)); + -- Now we allocate the new, longer internal array. If the allocation + -- fails, we have not changed any container state, so no side-effect + -- will occur as a result of propagating the exception. - begin - Dst := new Elements_Type (Dst_Last); - end; - end; + Dst := new Elements_Type (Dst_Last); - if Before <= Container.Last then - declare - Index_As_Int : constant Int'Base := - Index_Type'Pos (Before) + N; + -- We have our new internal array. All that needs to be done now is to + -- copy the existing items (if any) from the old array (the "source" + -- array) to the new array (the "destination" array), and then + -- deallocate the old array. - Index : constant Index_Type := Index_Type (Index_As_Int); + declare + Src : Elements_Access := Container.Elements; - Src : Elements_Access := Container.Elements; + begin + Dst.EA (Index_Type'First .. Before - 1) := + Src.EA (Index_Type'First .. Before - 1); - begin - Dst.EA (Index_Type'First .. Before - 1) := - Src.EA (Index_Type'First .. Before - 1); + if Before > Container.Last then + -- The new items are being appended to the vector, so no + -- sliding of existing elements is required. - Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last); + -- We have copied the elements from to the old, source array to + -- the new, destination array, so we can now deallocate the old + -- array. Container.Elements := Dst; - Container.Last := New_Last; Free (Src); - for J in Before .. Index - 1 loop - Dst.EA (J) := new Element_Type'(New_Item); + -- Now we append the new items. + + for Idx in Before .. New_Last loop + -- In order to preserve container invariants, we always + -- attempt the element allocation first, before setting the + -- Last index value, in case the allocation fails (either + -- because there is no storage available, or because element + -- initialization fails). + + Dst.EA (Idx) := new Element_Type'(New_Item); + + -- The allocation of the element succeeded, so it is now safe + -- to update the Last index, restoring container invariants. + + Container.Last := Idx; end loop; - end; - else - declare - Src : Elements_Access := Container.Elements; + else + -- The new items are being inserted before some existing elements, + -- so we must slide the existing elements up to their new home. - begin - Dst.EA (Index_Type'First .. Container.Last) := - Src.EA (Index_Type'First .. Container.Last); + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Index := Before + Index_Type'Base (Count); + + else + Index := Index_Type'Base (Count_Type'Base (Before) + Count); + end if; + + Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last); + + -- We have copied the elements from to the old, source array to + -- the new, destination array, so we can now deallocate the old + -- array. Container.Elements := Dst; + Container.Last := New_Last; Free (Src); - for J in Before .. New_Last loop - Dst.EA (J) := new Element_Type'(New_Item); - Container.Last := J; + -- The new array has a range in the middle containing null access + -- values. We now fill in that partion of the array with the new + -- items. + + for Idx in Before .. Index - 1 loop + -- Note that container invariants have already been satisfied + -- (in particular, the Last index value of the vector has + -- already been updated), so if this allocation fails we simply + -- let it propagate. + + Dst.EA (Idx) := new Element_Type'(New_Item); end loop; - end; - end if; + end if; + end; end Insert; procedure Insert @@ -1264,67 +1705,40 @@ package body Ada.Containers.Indefinite_Vectors is New_Item : Vector) is N : constant Count_Type := Length (New_Item); + J : Index_Type'Base; begin - if Before < Index_Type'First then - raise Constraint_Error with - "Before index is out of range (too small)"; - end if; + -- Use Insert_Space to create the "hole" (the destination slice) into + -- which we copy the source items. - if Before > Container.Last - and then Before > Container.Last + 1 - then - raise Constraint_Error with - "Before index is out of range (too large)"; - end if; + Insert_Space (Container, Before, Count => N); if N = 0 then + -- There's nothing else to do here (vetting of parameters was + -- performed already in Insert_Space), so we simply return. + return; end if; - Insert_Space (Container, Before, Count => N); - - declare - Dst_Last_As_Int : constant Int'Base := - Int'Base (Before) + Int'Base (N) - 1; - - Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int); - - Dst : Elements_Array renames - Container.Elements.EA (Before .. Dst_Last); - - Dst_Index : Index_Type'Base := Before - 1; - - begin - if Container'Address /= New_Item'Address then - declare - subtype Src_Index_Subtype is Index_Type'Base range - Index_Type'First .. New_Item.Last; - - Src : Elements_Array renames - New_Item.Elements.EA (Src_Index_Subtype); - - begin - for Src_Index in Src'Range loop - Dst_Index := Dst_Index + 1; - - if Src (Src_Index) /= null then - Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); - end if; - end loop; - end; - - return; - end if; + if Container'Address /= New_Item'Address then + -- This is the simple case. New_Item denotes an object different + -- from Container, so there's nothing special we need to do to copy + -- the source items to their destination, because all of the source + -- items are contiguous. declare subtype Src_Index_Subtype is Index_Type'Base range - Index_Type'First .. Before - 1; + Index_Type'First .. New_Item.Last; Src : Elements_Array renames - Container.Elements.EA (Src_Index_Subtype); + New_Item.Elements.EA (Src_Index_Subtype); + + Dst : Elements_Array renames Container.Elements.EA; + + Dst_Index : Index_Type'Base; begin + Dst_Index := Before - 1; for Src_Index in Src'Range loop Dst_Index := Dst_Index + 1; @@ -1334,26 +1748,104 @@ package body Ada.Containers.Indefinite_Vectors is end loop; end; - if Dst_Last = Container.Last then + return; + end if; + + -- New_Item denotes the same object as Container, so an insertion has + -- potentially split the source items. The first source slice is + -- [Index_Type'First, Before), and the second source slice is + -- [J, Container.Last], where index value J is the first index of the + -- second slice. (J gets computed below, but only after we have + -- determined that the second source slice is non-empty.) The + -- destination slice is always the range [Before, J). We perform the + -- copy in two steps, using each of the two slices of the source items. + + declare + L : constant Index_Type'Base := Before - 1; + + subtype Src_Index_Subtype is Index_Type'Base range + Index_Type'First .. L; + + Src : Elements_Array renames + Container.Elements.EA (Src_Index_Subtype); + + Dst : Elements_Array renames Container.Elements.EA; + + Dst_Index : Index_Type'Base; + + begin + -- We first copy the source items that precede the space we + -- inserted. (If Before equals Index_Type'First, then this first + -- source slice will be empty, which is harmless.) + + Dst_Index := Before - 1; + for Src_Index in Src'Range loop + Dst_Index := Dst_Index + 1; + + if Src (Src_Index) /= null then + Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); + end if; + end loop; + + if Src'Length = N then + -- The new items were effectively appended to the container, so we + -- have already copied all of the items that need to be copied. + -- We return early here, even though the source slice below is + -- empty (so the assignment would be harmless), because we want to + -- avoid computing J, which will overflow if J is greater than + -- Index_Type'Base'Last. + return; end if; + end; - declare - subtype Src_Index_Subtype is Index_Type'Base range - Dst_Last + 1 .. Container.Last; + -- Index value J is the first index of the second source slice. (It is + -- also 1 greater than the last index of the destination slice.) Note + -- that we want to avoid computing J, if J is greater than + -- Index_Type'Base'Last, in order to avoid overflow. We prevent that by + -- returning early above, immediately after copying the first slice of + -- the source, and determining that this second slice of the source is + -- empty. - Src : Elements_Array renames - Container.Elements.EA (Src_Index_Subtype); + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + J := Before + Index_Type'Base (N); - begin - for Src_Index in Src'Range loop - Dst_Index := Dst_Index + 1; + else + J := Index_Type'Base (Count_Type'Base (Before) + N); + end if; - if Src (Src_Index) /= null then - Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); - end if; - end loop; - end; + declare + subtype Src_Index_Subtype is Index_Type'Base range + J .. Container.Last; + + Src : Elements_Array renames + Container.Elements.EA (Src_Index_Subtype); + + Dst : Elements_Array renames Container.Elements.EA; + + Dst_Index : Index_Type'Base; + + begin + -- We next copy the source items that follow the space we + -- inserted. Index value Dst_Index is the first index of that portion + -- of the destination that receives this slice of the source. (For + -- the reasons given above, this slice is guaranteed to be + -- non-empty.) + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Dst_Index := J - Index_Type'Base (Src'Length); + + else + Dst_Index := Index_Type'Base (Count_Type'Base (J) - Src'Length); + end if; + + for Src_Index in Src'Range loop + if Src (Src_Index) /= null then + Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); + end if; + + Dst_Index := Dst_Index + 1; + end loop; end; end Insert; @@ -1530,22 +2022,42 @@ package body Ada.Containers.Indefinite_Vectors is Before : Extended_Index; Count : Count_Type := 1) is - N : constant Int := Int (Count); + Old_Length : constant Count_Type := Container.Length; + + Max_Length : Count_Type'Base; -- determined from range of Index_Type + New_Length : Count_Type'Base; -- sum of current length and Count + New_Last : Index_Type'Base; -- last index of vector after insertion - First : constant Int := Int (Index_Type'First); - New_Last_As_Int : Int'Base; - New_Last : Index_Type; - New_Length : UInt; - Max_Length : constant UInt := UInt (Count_Type'Last); + Index : Index_Type'Base; -- scratch for intermediate values + J : Count_Type'Base; -- scratch - Dst : Elements_Access; + New_Capacity : Count_Type'Base; -- length of new, expanded array + Dst_Last : Index_Type'Base; -- last index of new, expanded array + Dst : Elements_Access; -- new, expanded internal array begin + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we do + -- not allow that as the value for Index when specifying where the new + -- items should be inserted, so we must manually check. (That the user + -- is allowed to specify the value at all here is a consequence of the + -- declaration of the Extended_Index subtype, which includes the values + -- in the base range that immediately precede and immediately follow the + -- values in the Index_Type.) + if Before < Index_Type'First then raise Constraint_Error with "Before index is out of range (too small)"; end if; + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows for the + -- case of appending items to the back end of the vector. (It is assumed + -- that specifying an index value greater than Last + 1 indicates some + -- deeper flaw in the caller's algorithm, so that case is treated as a + -- proper error.) + if Before > Container.Last and then Before > Container.Last + 1 then @@ -1553,60 +2065,178 @@ package body Ada.Containers.Indefinite_Vectors is "Before index is out of range (too large)"; end if; + -- We treat inserting 0 items into the container as a no-op, even when + -- the container is busy, so we simply return. + if Count = 0 then return; end if; - declare - Old_Last_As_Int : constant Int := Int (Container.Last); + -- There are two constraints we need to satisfy. The first constraint is + -- that a container cannot have more than Count_Type'Last elements, so + -- we must check the sum of the current length and the insertion + -- count. Note that we cannot simply add these values, because of the + -- possibilty of overflow. - begin - if Old_Last_As_Int > Int'Last - N then - raise Constraint_Error with "new length is out of range"; - end if; + if Old_Length > Count_Type'Last - Count then + raise Constraint_Error with "Count is out of range"; + end if; - New_Last_As_Int := Old_Last_As_Int + N; + -- It is now safe compute the length of the new vector, without fear of + -- overflow. - if New_Last_As_Int > Int (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; + New_Length := Old_Length + Count; + + -- The second constraint is that the new Last index value cannot exceed + -- Index_Type'Last. In each branch below, we calculate the maximum + -- length (computed from the range of values in Index_Type), and then + -- compare the new length to the maximum length. If the new length is + -- acceptable, then we compute the new last index from that. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + -- We have to handle the case when there might be more values in the + -- range of Index_Type than in the range of Count_Type. + + if Index_Type'First <= 0 then + -- We know that No_Index (the same as Index_Type'First - 1) is + -- less than 0, so it is safe to compute the following sum without + -- fear of overflow. + + Index := No_Index + Index_Type'Base (Count_Type'Last); + + if Index <= Index_Type'Last then + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the + -- maximum number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than in Count_Type, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; + + else + -- No_Index is equal or greater than 0, so we can safely compute + -- the difference without fear of overflow (which we would have to + -- worry about if No_Index were less than 0, but that case is + -- handled above). + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); end if; - New_Length := UInt (New_Last_As_Int - First + 1); + elsif Index_Type'First <= 0 then + -- We know that No_Index (the same as Index_Type'First - 1) is less + -- than 0, so it is safe to compute the following sum without fear of + -- overflow. - if New_Length > Max_Length then - raise Constraint_Error with "new length is out of range"; + J := Count_Type'Base (No_Index) + Count_Type'Last; + + if J <= Count_Type'Base (Index_Type'Last) then + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the maximum + -- number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than Count_Type does, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); end if; - New_Last := Index_Type (New_Last_As_Int); - end; + else + -- No_Index is equal or greater than 0, so we can safely compute the + -- difference without fear of overflow (which we would have to worry + -- about if No_Index were less than 0, but that case is handled + -- above). - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is busy)"; + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; + + -- We have just computed the maximum length (number of items). We must + -- now compare the requested length to the maximum length, as we do not + -- allow a vector expand beyond the maximum (because that would create + -- an internal array with a last index value greater than + -- Index_Type'Last, with no way to index those elements). + + if New_Length > Max_Length then + raise Constraint_Error with "Count is out of range"; + end if; + + -- New_Last is the last index value of the items in the container after + -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to + -- compute its value from the New_Length. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + New_Last := No_Index + Index_Type'Base (New_Length); + + else + New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length); end if; if Container.Elements = null then + pragma Assert (Container.Last = No_Index); + + -- This is the simplest case, with which we must always begin: we're + -- inserting items into an empty vector that hasn't allocated an + -- internal array yet. Note that we don't need to check the busy bit + -- here, because an empty container cannot be busy. + + -- In an indefinite vector, elements are allocated individually, and + -- stored as access values on the internal array (the length of which + -- represents the vector "capacity"), which is separately + -- allocated. We have no elements here (because we're inserting + -- "space"), so all we need to do is allocate the backbone. + Container.Elements := new Elements_Type (New_Last); Container.Last := New_Last; + return; end if; - if New_Last <= Container.Elements.Last then + -- The tampering bits exist to prevent an item from being harmfully + -- manipulated while it is being visited. Query, Update, and Iterate + -- increment the busy count on entry, and decrement the count on + -- exit. Insert checks the count to determine whether it is being called + -- while the associated callback procedure is executing. + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with elements (vector is busy)"; + end if; + + if New_Length <= Container.Elements.EA'Length then + -- In this case, we're inserting elements into a vector that has + -- already allocated an internal array, and the existing array has + -- enough unused storage for the new items. + declare E : Elements_Array renames Container.Elements.EA; begin if Before <= Container.Last then - declare - Index_As_Int : constant Int'Base := - Index_Type'Pos (Before) + N; + -- The new space is being inserted before some existing + -- elements, so we must slide the existing elements up to their + -- new home. We use the wider of Index_Type'Base and + -- Count_Type'Base as the type for intermediate index values. - Index : constant Index_Type := Index_Type (Index_As_Int); + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Index := Before + Index_Type'Base (Count); - begin - E (Index .. New_Last) := E (Before .. Container.Last); - E (Before .. Index - 1) := (others => null); - end; + else + Index := Index_Type'Base (Count_Type'Base (Before) + Count); + end if; + + E (Index .. New_Last) := E (Before .. Container.Last); + E (Before .. Index - 1) := (others => null); end if; end; @@ -1614,68 +2244,80 @@ package body Ada.Containers.Indefinite_Vectors is return; end if; - declare - C, CC : UInt; + -- In this case, we're inserting elements into a vector that has already + -- allocated an internal array, but the existing array does not have + -- enough storage, so we must allocate a new, longer array. In order to + -- guarantee that the amortized insertion cost is O(1), we always + -- allocate an array whose length is some power-of-two factor of the + -- current array length. (The new array cannot have a length less than + -- the New_Length of the container, but its last index value cannot be + -- greater than Index_Type'Last.) + + New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length); + while New_Capacity < New_Length loop + if New_Capacity > Count_Type'Last / 2 then + New_Capacity := Count_Type'Last; + exit; + end if; - begin - C := UInt'Max (1, Container.Elements.EA'Length); -- ??? - while C < New_Length loop - if C > UInt'Last / 2 then - C := UInt'Last; - exit; - end if; + New_Capacity := 2 * New_Capacity; + end loop; - C := 2 * C; - end loop; + if New_Capacity > Max_Length then + -- We have reached the limit of capacity, so no further expansion + -- will occur. (This is not a problem, as there is never a need to + -- have more capacity than the maximum container length.) - if C > Max_Length then - C := Max_Length; - end if; + New_Capacity := Max_Length; + end if; - if Index_Type'First <= 0 - and then Index_Type'Last >= 0 - then - CC := UInt (Index_Type'Last) + UInt (-Index_Type'First) + 1; - else - CC := UInt (Int (Index_Type'Last) - First + 1); - end if; + -- We have computed the length of the new internal array (and this is + -- what "vector capacity" means), so use that to compute its last index. - if C > CC then - C := CC; - end if; + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Dst_Last := No_Index + Index_Type'Base (New_Capacity); - declare - Dst_Last : constant Index_Type := - Index_Type (First + UInt'Pos (C) - 1); + else + Dst_Last := + Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity); + end if; - begin - Dst := new Elements_Type (Dst_Last); - end; - end; + -- Now we allocate the new, longer internal array. If the allocation + -- fails, we have not changed any container state, so no side-effect + -- will occur as a result of propagating the exception. + + Dst := new Elements_Type (Dst_Last); + + -- We have our new internal array. All that needs to be done now is to + -- copy the existing items (if any) from the old array (the "source" + -- array) to the new array (the "destination" array), and then + -- deallocate the old array. declare Src : Elements_Access := Container.Elements; begin - if Before <= Container.Last then - declare - Index_As_Int : constant Int'Base := - Index_Type'Pos (Before) + N; + Dst.EA (Index_Type'First .. Before - 1) := + Src.EA (Index_Type'First .. Before - 1); - Index : constant Index_Type := Index_Type (Index_As_Int); + if Before <= Container.Last then + -- The new items are being inserted before some existing elements, + -- so we must slide the existing elements up to their new home. - begin - Dst.EA (Index_Type'First .. Before - 1) := - Src.EA (Index_Type'First .. Before - 1); + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Index := Before + Index_Type'Base (Count); - Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last); - end; + else + Index := Index_Type'Base (Count_Type'Base (Before) + Count); + end if; - else - Dst.EA (Index_Type'First .. Container.Last) := - Src.EA (Index_Type'First .. Container.Last); + Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last); end if; + -- We have copied the elements from to the old, source array to the + -- new, destination array, so we can now restore invariants, and + -- deallocate the old array. + Container.Elements := Dst; Container.Last := New_Last; Free (Src); @@ -1777,7 +2419,7 @@ package body Ada.Containers.Indefinite_Vectors is return (Container'Unchecked_Access, Container.Last); end Last; - ------------------ + ----------------- -- Last_Element -- ------------------ @@ -1814,12 +2456,33 @@ package body Ada.Containers.Indefinite_Vectors is ------------ function Length (Container : Vector) return Count_Type is - L : constant Int := Int (Container.Last); - F : constant Int := Int (Index_Type'First); - N : constant Int'Base := L - F + 1; - - begin - return Count_Type (N); + L : constant Index_Type'Base := Container.Last; + F : constant Index_Type := Index_Type'First; + + begin + -- The base range of the index type (Index_Type'Base) might not include + -- all values for length (Count_Type). Contrariwise, the index type + -- might include values outside the range of length. Hence we use + -- whatever type is wider for intermediate values when calculating + -- length. Note that no matter what the index type is, the maximum + -- length to which a vector is allowed to grow is always the minimum + -- of Count_Type'Last and (IT'Last - IT'First + 1). + + -- For example, an Index_Type with range -127 .. 127 is only guaranteed + -- to have a base range of -128 .. 127, but the corresponding vector + -- would have lengths in the range 0 .. 255. In this case we would need + -- to use Count_Type'Base for intermediate values. + + -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The + -- vector would have a maximum length of 10, but the index values lie + -- outside the range of Count_Type (which is only 32 bits). In this + -- case we would need to use Index_Type'Base for intermediate values. + + if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then + return Count_Type'Base (L) - Count_Type'Base (F) + 1; + else + return Count_Type (L - F + 1); + end if; end Length; ---------- @@ -2100,17 +2763,53 @@ package body Ada.Containers.Indefinite_Vectors is is N : constant Count_Type := Length (Container); + Index : Count_Type'Base; + Last : Index_Type'Base; + begin + -- Reserve_Capacity can be used to either expand the storage available + -- for elements (this would be its typical use, in anticipation of + -- future insertion), or to trim back storage. In the latter case, + -- storage can only be trimmed back to the limit of the container + -- length. Note that Reserve_Capacity neither deletes (active) elements + -- nor inserts elements; it only affects container capacity, never + -- container length. + if Capacity = 0 then + -- This is a request to trim back storage, to the minimum amount + -- possible given the current state of the container. + if N = 0 then + -- The container is empty, so in this unique case we can + -- deallocate the entire internal array. Note that an empty + -- container can never be busy, so there's no need to check the + -- tampering bits. + declare X : Elements_Access := Container.Elements; begin + -- First we remove the internal array from the container, to + -- handle the case when the deallocation raises an exception + -- (although that's unlikely, since this is simply an array of + -- access values, all of which are null). + Container.Elements := null; + + -- Container invariants have been restored, so it is now safe + -- to attempt to deallocate the internal array. + Free (X); end; elsif N < Container.Elements.EA'Length then + -- The container is not empty, and the current length is less than + -- the current capacity, so there's storage available to trim. In + -- this case, we allocate a new internal array having a length + -- that exactly matches the number of items in the + -- container. (Reserve_Capacity does not delete active elements, + -- so this is the best we can do with respect to minimizing + -- storage). + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; @@ -2126,7 +2825,19 @@ package body Ada.Containers.Indefinite_Vectors is X : Elements_Access := Container.Elements; begin + -- Although we have isolated the old internal array that we're + -- going to deallocate, we don't deallocate it until we have + -- successfully allocated a new one. If there is an exception + -- during allocation (because there is not enough storage), we + -- let it propagate without causing any side-effect. + Container.Elements := new Elements_Type'(Container.Last, Src); + + -- We have succesfully allocated a new internal array (with a + -- smaller length than the old one, and containing a copy of + -- just the active elements in the container), so we can + -- deallocate the old array. + Free (X); end; end if; @@ -2134,29 +2845,102 @@ package body Ada.Containers.Indefinite_Vectors is return; end if; - if Container.Elements = null then - declare - Last_As_Int : constant Int'Base := - Int (Index_Type'First) + Int (Capacity) - 1; + -- Reserve_Capacity can be used to expand the storage available for + -- elements, but we do not let the capacity grow beyond the number of + -- values in Index_Type'Range. (Were it otherwise, there would be no way + -- to refer to the elements with index values greater than + -- Index_Type'Last, so that storage would be wasted.) Here we compute + -- the Last index value of the new internal array, in a way that avoids + -- any possibility of overflow. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + -- We perform a two-part test. First we determine whether the + -- computed Last value lies in the base range of the type, and then + -- determine whether it lies in the range of the index (sub)type. + + -- Last must satisfy this relation: + -- First + Length - 1 <= Last + -- We regroup terms: + -- First - 1 <= Last - Length + -- Which can rewrite as: + -- No_Index <= Last - Length + + if Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index then + raise Constraint_Error with "Capacity is out of range"; + end if; - begin - if Last_As_Int > Index_Type'Pos (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; - end if; + -- We now know that the computed value of Last is within the base + -- range of the type, so it is safe to compute its value: - declare - Last : constant Index_Type := Index_Type (Last_As_Int); + Last := No_Index + Index_Type'Base (Capacity); - begin - Container.Elements := new Elements_Type (Last); - end; - end; + -- Finally we test whether the value is within the range of the + -- generic actual index subtype: + + if Last > Index_Type'Last then + raise Constraint_Error with "Capacity is out of range"; + end if; + + elsif Index_Type'First <= 0 then + -- Here we can compute Last directly, in the normal way. We know that + -- No_Index is less than 0, so there is no danger of overflow when + -- adding the (positive) value of Capacity. + + Index := Count_Type'Base (No_Index) + Capacity; -- Last + + if Index > Count_Type'Base (Index_Type'Last) then + raise Constraint_Error with "Capacity is out of range"; + end if; + + -- We know that the computed value (having type Count_Type) of Last + -- is within the range of the generic actual index subtype, so it is + -- safe to convert to Index_Type: + + Last := Index_Type'Base (Index); + + else + -- Here Index_Type'First (and Index_Type'Last) is positive, so we + -- must test the length indirectly (by working backwards from the + -- largest possible value of Last), in order to prevent overflow. + + Index := Count_Type'Base (Index_Type'Last) - Capacity; -- No_Index + + if Index < Count_Type'Base (No_Index) then + raise Constraint_Error with "Capacity is out of range"; + end if; + + -- We have determined that the value of Capacity would not create a + -- Last index value outside of the range of Index_Type, so we can now + -- safely compute its value. + Last := Index_Type'Base (Count_Type'Base (No_Index) + Capacity); + end if; + + -- The requested capacity is non-zero, but we don't know yet whether + -- this is a request for expansion or contraction of storage. + + if Container.Elements = null then + -- The container is empty (it doesn't even have an internal array), + -- so this represents a request to allocate storage having the given + -- capacity. + + Container.Elements := new Elements_Type (Last); return; end if; if Capacity <= N then + -- This is a request to trim back storage, but only to the limit of + -- what's already in the container. (Reserve_Capacity never deletes + -- active elements, it only reclaims excess storage.) + if N < Container.Elements.EA'Length then + -- The container is not empty (because the requested capacity is + -- positive, and less than or equal to the container length), and + -- the current length is less than the current capacity, so + -- there's storage available to trim. In this case, we allocate a + -- new internal array having a length that exactly matches the + -- number of items in the container. + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; @@ -2172,7 +2956,19 @@ package body Ada.Containers.Indefinite_Vectors is X : Elements_Access := Container.Elements; begin + -- Although we have isolated the old internal array that we're + -- going to deallocate, we don't deallocate it until we have + -- successfully allocated a new one. If there is an exception + -- during allocation (because there is not enough storage), we + -- let it propagate without causing any side-effect. + Container.Elements := new Elements_Type'(Container.Last, Src); + + -- We have succesfully allocated a new internal array (with a + -- smaller length than the old one, and containing a copy of + -- just the active elements in the container), so it is now + -- safe to deallocate the old array. + Free (X); end; end if; @@ -2180,47 +2976,57 @@ package body Ada.Containers.Indefinite_Vectors is return; end if; + -- The requested capacity is larger than the container length (the + -- number of active elements). Whether this represents a request for + -- expansion or contraction of the current capacity depends on what the + -- current capacity is. + if Capacity = Container.Elements.EA'Length then + -- The requested capacity matches the existing capacity, so there's + -- nothing to do here. We treat this case as a no-op, and simply + -- return without checking the busy bit. + return; end if; + -- There is a change in the capacity of a non-empty container, so a new + -- internal array will be allocated. (The length of the new internal + -- array could be less or greater than the old internal array. We know + -- only that the length of the new internal array is greater than the + -- number of active elements in the container.) We must check whether + -- the container is busy before doing anything else. + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; - declare - Last_As_Int : constant Int'Base := - Int (Index_Type'First) + Int (Capacity) - 1; + -- We now allocate a new internal array, having a length different from + -- its current value. - begin - if Last_As_Int > Index_Type'Pos (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; - end if; + declare + X : Elements_Access := Container.Elements; - declare - Last : constant Index_Type := Index_Type (Last_As_Int); - X : Elements_Access := Container.Elements; + subtype Index_Subtype is Index_Type'Base range + Index_Type'First .. Container.Last; - subtype Index_Subtype is Index_Type'Base range - Index_Type'First .. Container.Last; + begin + -- We now allocate a new internal array, having a length different + -- from its current value. - begin - Container.Elements := new Elements_Type (Last); + Container.Elements := new Elements_Type (Last); - declare - Src : Elements_Array renames - X.EA (Index_Subtype); + -- We have successfully allocated the new internal array, so now we + -- move the existing elements from the existing the old internal + -- array onto the new one. Note that we're just copying access + -- values, to this should not raise any exceptions. - Tgt : Elements_Array renames - Container.Elements.EA (Index_Subtype); + Container.Elements.EA (Index_Subtype) := X.EA (Index_Subtype); - begin - Tgt := Src; - end; + -- We have moved the elements from the old interal array, so now we + -- can deallocate it. - Free (X); - end; + Free (X); end; end Reserve_Capacity; @@ -2357,45 +3163,25 @@ package body Ada.Containers.Indefinite_Vectors is (Container : in out Vector; Length : Count_Type) is - N : constant Count_Type := Indefinite_Vectors.Length (Container); + Count : constant Count_Type'Base := Container.Length - Length; begin - if Length = N then - return; - end if; - - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is busy)"; - end if; + -- Set_Length allows the user to set the length explicitly, instead of + -- implicitly as a side-effect of deletion or insertion. If the + -- requested length is less than the current length, this is equivalent + -- to deleting items from the back end of the vector. If the requested + -- length is greater than the current length, then this is equivalent to + -- inserting "space" (nonce items) at the end. - if Length < N then - for Index in 1 .. N - Length loop - declare - J : constant Index_Type := Container.Last; - X : Element_Access := Container.Elements.EA (J); - - begin - Container.Elements.EA (J) := null; - Container.Last := J - 1; - Free (X); - end; - end loop; + if Count >= 0 then + Container.Delete_Last (Count); - return; - end if; + elsif Container.Last >= Index_Type'Last then + raise Constraint_Error with "vector is already at its maximum length"; - if Length > Capacity (Container) then - Reserve_Capacity (Container, Capacity => Length); + else + Container.Insert_Space (Container.Last + 1, -Count); end if; - - declare - Last_As_Int : constant Int'Base := - Int (Index_Type'First) + Int (Length) - 1; - - begin - Container.Last := Index_Type (Last_As_Int); - end; end Set_Length; ---------- @@ -2498,73 +3284,205 @@ package body Ada.Containers.Indefinite_Vectors is --------------- function To_Vector (Length : Count_Type) return Vector is + Index : Count_Type'Base; + Last : Index_Type'Base; + Elements : Elements_Access; + begin if Length = 0 then return Empty_Vector; end if; - declare - First : constant Int := Int (Index_Type'First); - Last_As_Int : constant Int'Base := First + Int (Length) - 1; - Last : Index_Type; - Elements : Elements_Access; + -- We create a vector object with a capacity that matches the specified + -- Length, but we do not allow the vector capacity (the length of the + -- internal array) to exceed the number of values in Index_Type'Range + -- (otherwise, there would be no way to refer to those components via an + -- index). We must therefore check whether the specified Length would + -- create a Last index value greater than Index_Type'Last. - begin - if Last_As_Int > Index_Type'Pos (Index_Type'Last) then + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + -- We perform a two-part test. First we determine whether the + -- computed Last value lies in the base range of the type, and then + -- determine whether it lies in the range of the index (sub)type. + + -- Last must satisfy this relation: + -- First + Length - 1 <= Last + -- We regroup terms: + -- First - 1 <= Last - Length + -- Which can rewrite as: + -- No_Index <= Last - Length + + if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then raise Constraint_Error with "Length is out of range"; end if; - Last := Index_Type (Last_As_Int); - Elements := new Elements_Type (Last); + -- We now know that the computed value of Last is within the base + -- range of the type, so it is safe to compute its value: - return (Controlled with Elements, Last, 0, 0); - end; + Last := No_Index + Index_Type'Base (Length); + + -- Finally we test whether the value is within the range of the + -- generic actual index subtype: + + if Last > Index_Type'Last then + raise Constraint_Error with "Length is out of range"; + end if; + + elsif Index_Type'First <= 0 then + -- Here we can compute Last directly, in the normal way. We know that + -- No_Index is less than 0, so there is no danger of overflow when + -- adding the (positive) value of Length. + + Index := Count_Type'Base (No_Index) + Length; -- Last + + if Index > Count_Type'Base (Index_Type'Last) then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We know that the computed value (having type Count_Type) of Last + -- is within the range of the generic actual index subtype, so it is + -- safe to convert to Index_Type: + + Last := Index_Type'Base (Index); + + else + -- Here Index_Type'First (and Index_Type'Last) is positive, so we + -- must test the length indirectly (by working backwards from the + -- largest possible value of Last), in order to prevent overflow. + + Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index + + if Index < Count_Type'Base (No_Index) then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We have determined that the value of Length would not create a + -- Last index value outside of the range of Index_Type, so we can now + -- safely compute its value. + + Last := Index_Type'Base (Count_Type'Base (No_Index) + Length); + end if; + + Elements := new Elements_Type (Last); + + return Vector'(Controlled with Elements, Last, 0, 0); end To_Vector; function To_Vector (New_Item : Element_Type; Length : Count_Type) return Vector is + Index : Count_Type'Base; + Last : Index_Type'Base; + Elements : Elements_Access; + begin if Length = 0 then return Empty_Vector; end if; - declare - First : constant Int := Int (Index_Type'First); - Last_As_Int : constant Int'Base := First + Int (Length) - 1; - Last : Index_Type'Base; - Elements : Elements_Access; + -- We create a vector object with a capacity that matches the specified + -- Length, but we do not allow the vector capacity (the length of the + -- internal array) to exceed the number of values in Index_Type'Range + -- (otherwise, there would be no way to refer to those components via an + -- index). We must therefore check whether the specified Length would + -- create a Last index value greater than Index_Type'Last. - begin - if Last_As_Int > Index_Type'Pos (Index_Type'Last) then + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + -- We perform a two-part test. First we determine whether the + -- computed Last value lies in the base range of the type, and then + -- determine whether it lies in the range of the index (sub)type. + + -- Last must satisfy this relation: + -- First + Length - 1 <= Last + -- We regroup terms: + -- First - 1 <= Last - Length + -- Which can rewrite as: + -- No_Index <= Last - Length + + if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then raise Constraint_Error with "Length is out of range"; end if; - Last := Index_Type (Last_As_Int); - Elements := new Elements_Type (Last); + -- We now know that the computed value of Last is within the base + -- range of the type, so it is safe to compute its value: - Last := Index_Type'First; + Last := No_Index + Index_Type'Base (Length); - begin - loop - Elements.EA (Last) := new Element_Type'(New_Item); - exit when Last = Elements.Last; - Last := Last + 1; - end loop; + -- Finally we test whether the value is within the range of the + -- generic actual index subtype: - exception - when others => - for J in Index_Type'First .. Last - 1 loop - Free (Elements.EA (J)); - end loop; + if Last > Index_Type'Last then + raise Constraint_Error with "Length is out of range"; + end if; - Free (Elements); - raise; - end; + elsif Index_Type'First <= 0 then + -- Here we can compute Last directly, in the normal way. We know that + -- No_Index is less than 0, so there is no danger of overflow when + -- adding the (positive) value of Length. - return (Controlled with Elements, Last, 0, 0); + Index := Count_Type'Base (No_Index) + Length; -- Last + + if Index > Count_Type'Base (Index_Type'Last) then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We know that the computed value (having type Count_Type) of Last + -- is within the range of the generic actual index subtype, so it is + -- safe to convert to Index_Type: + + Last := Index_Type'Base (Index); + + else + -- Here Index_Type'First (and Index_Type'Last) is positive, so we + -- must test the length indirectly (by working backwards from the + -- largest possible value of Last), in order to prevent overflow. + + Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index + + if Index < Count_Type'Base (No_Index) then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We have determined that the value of Length would not create a + -- Last index value outside of the range of Index_Type, so we can now + -- safely compute its value. + + Last := Index_Type'Base (Count_Type'Base (No_Index) + Length); + end if; + + Elements := new Elements_Type (Last); + + -- We use Last as the index of the loop used to populate the internal + -- array with items. In general, we prefer to initialize the loop index + -- immediately prior to entering the loop. However, Last is also used in + -- the exception handler (to reclaim elements that have been allocated, + -- before propagating the exception), and the initialization of Last + -- after entering the block containing the handler confuses some static + -- analysis tools, with respect to whether Last has been properly + -- initialized when the handler executes. So here we initialize our loop + -- variable earlier than we prefer, before entering the block, so there + -- is no ambiguity. + Last := Index_Type'First; + + begin + loop + Elements.EA (Last) := new Element_Type'(New_Item); + exit when Last = Elements.Last; + Last := Last + 1; + end loop; + + exception + when others => + for J in Index_Type'First .. Last - 1 loop + Free (Elements.EA (J)); + end loop; + + Free (Elements); + raise; end; + + return (Controlled with Elements, Last, 0, 0); end To_Vector; -------------------- diff --git a/gcc/ada/a-comlin.ads b/gcc/ada/a-comlin.ads index 8d66e1542b9..55d0a500525 100644 --- a/gcc/ada/a-comlin.ads +++ b/gcc/ada/a-comlin.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -73,6 +73,9 @@ package Ada.Command_Line is -- Note on Interface Requirements -- ------------------------------------ + -- Services in this package are not supported during the elaboration of an + -- auto-initialized Stand-Alone Library. + -- If the main program is in Ada, this package works as specified without -- any other work than the normal steps of WITH'ing the package and then -- calling the desired routines. diff --git a/gcc/ada/a-convec.adb b/gcc/ada/a-convec.adb index 64b1b07d927..501128b9d89 100644 --- a/gcc/ada/a-convec.adb +++ b/gcc/ada/a-convec.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -34,9 +34,6 @@ with System; use type System.Address; package body Ada.Containers.Vectors is - type Int is range System.Min_Int .. System.Max_Int; - type UInt is mod System.Max_Binary_Modulus; - procedure Free is new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access); @@ -45,10 +42,22 @@ package body Ada.Containers.Vectors is --------- function "&" (Left, Right : Vector) return Vector is - LN : constant Count_Type := Length (Left); - RN : constant Count_Type := Length (Right); + LN : constant Count_Type := Length (Left); + RN : constant Count_Type := Length (Right); + N : Count_Type'Base; -- length of result + J : Count_Type'Base; -- for computing intermediate index values + Last : Index_Type'Base; -- Last index of result begin + -- We decide that the capacity of the result is the sum of the lengths + -- of the vector parameters. We could decide to make it larger, but we + -- have no basis for knowing how much larger, so we just allocate the + -- minimum amount of storage. + + -- Here we handle the easy cases first, when one of the vector + -- parameters is empty. (We say "easy" because there's nothing to + -- compute, that can potentially overflow.) + if LN = 0 then if RN = 0 then return Empty_Vector; @@ -80,44 +89,117 @@ package body Ada.Containers.Vectors is end if; - declare - N : constant Int'Base := Int (LN) + Int (RN); - Last_As_Int : Int'Base; + -- Neither of the vector parameters is empty, so must compute the length + -- of the result vector and its last index. (This is the harder case, + -- because our computations must avoid overflow.) - begin - if Int (No_Index) > Int'Last - N then + -- There are two constraints we need to satisfy. The first constraint is + -- that a container cannot have more than Count_Type'Last elements, so + -- we must check the sum of the combined lengths. Note that we cannot + -- simply add the lengths, because of the possibilty of overflow. + + if LN > Count_Type'Last - RN then + raise Constraint_Error with "new length is out of range"; + end if; + + -- It is now safe compute the length of the new vector, without fear of + -- overflow. + + N := LN + RN; + + -- The second constraint is that the new Last index value cannot + -- exceed Index_Type'Last. We use the wider of Index_Type'Base and + -- Count_Type'Base as the type for intermediate values. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + -- We perform a two-part test. First we determine whether the + -- computed Last value lies in the base range of the type, and then + -- determine whether it lies in the range of the index (sub)type. + + -- Last must satisfy this relation: + -- First + Length - 1 <= Last + -- We regroup terms: + -- First - 1 <= Last - Length + -- Which can rewrite as: + -- No_Index <= Last - Length + + if Index_Type'Base'Last - Index_Type'Base (N) < No_Index then + raise Constraint_Error with "new length is out of range"; + end if; + + -- We now know that the computed value of Last is within the base + -- range of the type, so it is safe to compute its value: + + Last := No_Index + Index_Type'Base (N); + + -- Finally we test whether the value is within the range of the + -- generic actual index subtype: + + if Last > Index_Type'Last then raise Constraint_Error with "new length is out of range"; end if; - Last_As_Int := Int (No_Index) + N; + elsif Index_Type'First <= 0 then + -- Here we can compute Last directly, in the normal way. We know that + -- No_Index is less than 0, so there is no danger of overflow when + -- adding the (positive) value of length. - if Last_As_Int > Int (Index_Type'Last) then + J := Count_Type'Base (No_Index) + N; -- Last + + if J > Count_Type'Base (Index_Type'Last) then raise Constraint_Error with "new length is out of range"; end if; - declare - Last : constant Index_Type := Index_Type (Last_As_Int); + -- We know that the computed value (having type Count_Type) of Last + -- is within the range of the generic actual index subtype, so it is + -- safe to convert to Index_Type: - LE : Elements_Array renames - Left.Elements.EA (Index_Type'First .. Left.Last); + Last := Index_Type'Base (J); - RE : Elements_Array renames - Right.Elements.EA (Index_Type'First .. Right.Last); + else + -- Here Index_Type'First (and Index_Type'Last) is positive, so we + -- must test the length indirectly (by working backwards from the + -- largest possible value of Last), in order to prevent overflow. - Elements : constant Elements_Access := - new Elements_Type'(Last, LE & RE); + J := Count_Type'Base (Index_Type'Last) - N; -- No_Index - begin - return (Controlled with Elements, Last, 0, 0); - end; + if J < Count_Type'Base (No_Index) then + raise Constraint_Error with "new length is out of range"; + end if; + + -- We have determined that the result length would not create a Last + -- index value outside of the range of Index_Type, so we can now + -- safely compute its value. + + Last := Index_Type'Base (Count_Type'Base (No_Index) + N); + end if; + + declare + LE : Elements_Array renames + Left.Elements.EA (Index_Type'First .. Left.Last); + + RE : Elements_Array renames + Right.Elements.EA (Index_Type'First .. Right.Last); + + Elements : constant Elements_Access := + new Elements_Type'(Last, LE & RE); + + begin + return (Controlled with Elements, Last, 0, 0); end; end "&"; function "&" (Left : Vector; Right : Element_Type) return Vector is - LN : constant Count_Type := Length (Left); - begin - if LN = 0 then + -- We decide that the capacity of the result is the sum of the lengths + -- of the parameters. We could decide to make it larger, but we have no + -- basis for knowing how much larger, so we just allocate the minimum + -- amount of storage. + + -- Here we handle the easy case first, when the vector parameter (Left) + -- is empty. + + if Left.Is_Empty then declare Elements : constant Elements_Access := new Elements_Type' @@ -129,42 +211,47 @@ package body Ada.Containers.Vectors is end; end if; - declare - Last_As_Int : Int'Base; - - begin - if Int (Index_Type'First) > Int'Last - Int (LN) then - raise Constraint_Error with "new length is out of range"; - end if; + -- The vector parameter is not empty, so we must compute the length of + -- the result vector and its last index, but in such a way that overflow + -- is avoided. We must satisfy two constraints: the new length cannot + -- exceed Count_Type'Last, and the new Last index cannot exceed + -- Index_Type'Last. - Last_As_Int := Int (Index_Type'First) + Int (LN); + if Left.Length = Count_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; - if Last_As_Int > Int (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; - end if; + if Left.Last >= Index_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; - declare - Last : constant Index_Type := Index_Type (Last_As_Int); + declare + Last : constant Index_Type := Left.Last + 1; - LE : Elements_Array renames - Left.Elements.EA (Index_Type'First .. Left.Last); + LE : Elements_Array renames + Left.Elements.EA (Index_Type'First .. Left.Last); - Elements : constant Elements_Access := - new Elements_Type' - (Last => Last, - EA => LE & Right); + Elements : constant Elements_Access := + new Elements_Type' + (Last => Last, + EA => LE & Right); - begin - return (Controlled with Elements, Last, 0, 0); - end; + begin + return (Controlled with Elements, Last, 0, 0); end; end "&"; function "&" (Left : Element_Type; Right : Vector) return Vector is - RN : constant Count_Type := Length (Right); - begin - if RN = 0 then + -- We decide that the capacity of the result is the sum of the lengths + -- of the parameters. We could decide to make it larger, but we have no + -- basis for knowing how much larger, so we just allocate the minimum + -- amount of storage. + + -- Here we handle the easy case first, when the vector parameter (Right) + -- is empty. + + if Right.Is_Empty then declare Elements : constant Elements_Access := new Elements_Type' @@ -176,39 +263,49 @@ package body Ada.Containers.Vectors is end; end if; - declare - Last_As_Int : Int'Base; - - begin - if Int (Index_Type'First) > Int'Last - Int (RN) then - raise Constraint_Error with "new length is out of range"; - end if; + -- The vector parameter is not empty, so we must compute the length of + -- the result vector and its last index, but in such a way that overflow + -- is avoided. We must satisfy two constraints: the new length cannot + -- exceed Count_Type'Last, and the new Last index cannot exceed + -- Index_Type'Last. - Last_As_Int := Int (Index_Type'First) + Int (RN); + if Right.Length = Count_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; - if Last_As_Int > Int (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; - end if; + if Right.Last >= Index_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; - declare - Last : constant Index_Type := Index_Type (Last_As_Int); + declare + Last : constant Index_Type := Right.Last + 1; - RE : Elements_Array renames - Right.Elements.EA (Index_Type'First .. Right.Last); + RE : Elements_Array renames + Right.Elements.EA (Index_Type'First .. Right.Last); - Elements : constant Elements_Access := - new Elements_Type' - (Last => Last, - EA => Left & RE); + Elements : constant Elements_Access := + new Elements_Type' + (Last => Last, + EA => Left & RE); - begin - return (Controlled with Elements, Last, 0, 0); - end; + begin + return (Controlled with Elements, Last, 0, 0); end; end "&"; function "&" (Left, Right : Element_Type) return Vector is begin + -- We decide that the capacity of the result is the sum of the lengths + -- of the parameters. We could decide to make it larger, but we have no + -- basis for knowing how much larger, so we just allocate the minimum + -- amount of storage. + + -- We must compute the length of the result vector and its last index, + -- but in such a way that overflow is avoided. We must satisfy two + -- constraints: the new length cannot exceed Count_Type'Last (here, we + -- know that that condition is satisfied), and the new Last index cannot + -- exceed Index_Type'Last. + if Index_Type'First >= Index_Type'Last then raise Constraint_Error with "new length is out of range"; end if; @@ -370,56 +467,117 @@ package body Ada.Containers.Vectors is Index : Extended_Index; Count : Count_Type := 1) is - begin + Old_Last : constant Index_Type'Base := Container.Last; + New_Last : Index_Type'Base; + Count2 : Count_Type'Base; -- count of items from Index to Old_Last + J : Index_Type'Base; -- first index of items that slide down + + begin + -- Delete removes items from the vector, the number of which is the + -- minimum of the specified Count and the items (if any) that exist from + -- Index to Container.Last. There are no constraints on the specified + -- value of Count (it can be larger than what's available at this + -- position in the vector, for example), but there are constraints on + -- the allowed values of the Index. + + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we do + -- not allow that as the value for Index when specifying which items + -- should be deleted, so we must manually check. (That the user is + -- allowed to specify the value at all here is a consequence of the + -- declaration of the Extended_Index subtype, which includes the values + -- in the base range that immediately precede and immediately follow the + -- values in the Index_Type.) + if Index < Index_Type'First then raise Constraint_Error with "Index is out of range (too small)"; end if; - if Index > Container.Last then - if Index > Container.Last + 1 then + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows the + -- corner case of deleting no items from the back end of the vector to + -- be treated as a no-op. (It is assumed that specifying an index value + -- greater than Last + 1 indicates some deeper flaw in the caller's + -- algorithm, so that case is treated as a proper error.) + + if Index > Old_Last then + if Index > Old_Last + 1 then raise Constraint_Error with "Index is out of range (too large)"; end if; return; end if; + -- Here and elsewhere we treat deleting 0 items from the container as a + -- no-op, even when the container is busy, so we simply return. + if Count = 0 then return; end if; + -- The tampering bits exist to prevent an item from being deleted (or + -- otherwise harmfully manipulated) while it is being visited. Query, + -- Update, and Iterate increment the busy count on entry, and decrement + -- the count on exit. Delete checks the count to determine whether it is + -- being called while the associated callback procedure is executing. + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; - declare - I_As_Int : constant Int := Int (Index); - Old_Last_As_Int : constant Int := Index_Type'Pos (Container.Last); + -- We first calculate what's available for deletion starting at + -- Index. Here and elsewhere we use the wider of Index_Type'Base and + -- Count_Type'Base as the type for intermediate values. (See function + -- Length for more information.) - Count1 : constant Int'Base := Count_Type'Pos (Count); - Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1; - N : constant Int'Base := Int'Min (Count1, Count2); + if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then + Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1; - J_As_Int : constant Int'Base := I_As_Int + N; + else + Count2 := Count_Type'Base (Old_Last - Index + 1); + end if; - begin - if J_As_Int > Old_Last_As_Int then - Container.Last := Index - 1; + -- If more elements are requested (Count) for deletion than are + -- available (Count2) for deletion beginning at Index, then everything + -- from Index is deleted. There are no elements to slide down, and so + -- all we need to do is set the value of Container.Last. - else - declare - J : constant Index_Type := Index_Type (J_As_Int); - EA : Elements_Array renames Container.Elements.EA; + if Count >= Count2 then + Container.Last := Index - 1; + return; + end if; - New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N; - New_Last : constant Index_Type := - Index_Type (New_Last_As_Int); + -- There are some elements aren't being deleted (the requested count was + -- less than the available count), so we must slide them down to + -- Index. We first calculate the index values of the respective array + -- slices, using the wider of Index_Type'Base and Count_Type'Base as the + -- type for intermediate calculations. For the elements that slide down, + -- index value New_Last is the last index value of their new home, and + -- index value J is the first index of their old home. - begin - EA (Index .. New_Last) := EA (J .. Container.Last); - Container.Last := New_Last; - end; - end if; + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + New_Last := Old_Last - Index_Type'Base (Count); + J := Index + Index_Type'Base (Count); + + else + New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count); + J := Index_Type'Base (Count_Type'Base (Index) + Count); + end if; + + -- The internal elements array isn't guaranteed to exist unless we have + -- elements, but we have that guarantee here because we know we have + -- elements to slide. The array index values for each slice have + -- already been determined, so we just slide down to Index the elements + -- that weren't deleted. + + declare + EA : Elements_Array renames Container.Elements.EA; + + begin + EA (Index .. New_Last) := EA (J .. Old_Last); + Container.Last := New_Last; end; end Delete; @@ -476,24 +634,48 @@ package body Ada.Containers.Vectors is (Container : in out Vector; Count : Count_Type := 1) is - Index : Int'Base; - begin + -- It is not permitted to delete items while the container is busy (for + -- example, we're in the middle of a passive iteration). However, we + -- always treat deleting 0 items as a no-op, even when we're busy, so we + -- simply return without checking. + if Count = 0 then return; end if; + -- The tampering bits exist to prevent an item from being deleted (or + -- otherwise harmfully manipulated) while it is being visited. Query, + -- Update, and Iterate increment the busy count on entry, and decrement + -- the count on exit. Delete_Last checks the count to determine whether + -- it is being called while the associated callback procedure is + -- executing. + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; - Index := Int'Base (Container.Last) - Int'Base (Count); + -- There is no restriction on how large Count can be when deleting + -- items. If it is equal or greater than the current length, then this + -- is equivalent to clearing the vector. (In particular, there's no need + -- for us to actually calculate the new value for Last.) + + -- If the requested count is less than the current length, then we must + -- calculate the new value for Last. For the type we use the widest of + -- Index_Type'Base and Count_Type'Base for the intermediate values of + -- our calculation. (See the comments in Length for more information.) - Container.Last := - (if Index < Index_Type'Pos (Index_Type'First) - then No_Index - else Index_Type (Index)); + if Count >= Container.Length then + Container.Last := No_Index; + + elsif Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Container.Last := Container.Last - Index_Type'Base (Count); + + else + Container.Last := + Index_Type'Base (Count_Type'Base (Container.Last) - Count); + end if; end Delete_Last; ------------- @@ -772,22 +954,42 @@ package body Ada.Containers.Vectors is New_Item : Element_Type; Count : Count_Type := 1) is - N : constant Int := Count_Type'Pos (Count); + Old_Length : constant Count_Type := Container.Length; + + Max_Length : Count_Type'Base; -- determined from range of Index_Type + New_Length : Count_Type'Base; -- sum of current length and Count + New_Last : Index_Type'Base; -- last index of vector after insertion - First : constant Int := Int (Index_Type'First); - New_Last_As_Int : Int'Base; - New_Last : Index_Type; - New_Length : UInt; - Max_Length : constant UInt := UInt (Count_Type'Last); + Index : Index_Type'Base; -- scratch for intermediate values + J : Count_Type'Base; -- scratch - Dst : Elements_Access; + New_Capacity : Count_Type'Base; -- length of new, expanded array + Dst_Last : Index_Type'Base; -- last index of new, expanded array + Dst : Elements_Access; -- new, expanded internal array begin + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we do + -- not allow that as the value for Index when specifying where the new + -- items should be inserted, so we must manually check. (That the user + -- is allowed to specify the value at all here is a consequence of the + -- declaration of the Extended_Index subtype, which includes the values + -- in the base range that immediately precede and immediately follow the + -- values in the Index_Type.) + if Before < Index_Type'First then raise Constraint_Error with "Before index is out of range (too small)"; end if; + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows for the + -- case of appending items to the back end of the vector. (It is assumed + -- that specifying an index value greater than Last + 1 indicates some + -- deeper flaw in the caller's algorithm, so that case is treated as a + -- proper error.) + if Before > Container.Last and then Before > Container.Last + 1 then @@ -795,67 +997,192 @@ package body Ada.Containers.Vectors is "Before index is out of range (too large)"; end if; + -- We treat inserting 0 items into the container as a no-op, even when + -- the container is busy, so we simply return. + if Count = 0 then return; end if; - declare - Old_Last_As_Int : constant Int := Int (Container.Last); + -- There are two constraints we need to satisfy. The first constraint is + -- that a container cannot have more than Count_Type'Last elements, so + -- we must check the sum of the current length and the insertion + -- count. Note that we cannot simply add these values, because of the + -- possibilty of overflow. - begin - if Old_Last_As_Int > Int'Last - N then - raise Constraint_Error with "new length is out of range"; - end if; + if Old_Length > Count_Type'Last - Count then + raise Constraint_Error with "Count is out of range"; + end if; - New_Last_As_Int := Old_Last_As_Int + N; + -- It is now safe compute the length of the new vector, without fear of + -- overflow. - if New_Last_As_Int > Int (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; + New_Length := Old_Length + Count; + + -- The second constraint is that the new Last index value cannot exceed + -- Index_Type'Last. In each branch below, we calculate the maximum + -- length (computed from the range of values in Index_Type), and then + -- compare the new length to the maximum length. If the new length is + -- acceptable, then we compute the new last index from that. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + -- We have to handle the case when there might be more values in the + -- range of Index_Type than in the range of Count_Type. + + if Index_Type'First <= 0 then + -- We know that No_Index (the same as Index_Type'First - 1) is + -- less than 0, so it is safe to compute the following sum without + -- fear of overflow. + + Index := No_Index + Index_Type'Base (Count_Type'Last); + + if Index <= Index_Type'Last then + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the + -- maximum number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than in Count_Type, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; + + else + -- No_Index is equal or greater than 0, so we can safely compute + -- the difference without fear of overflow (which we would have to + -- worry about if No_Index were less than 0, but that case is + -- handled above). + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); end if; - New_Length := UInt (New_Last_As_Int - First + Int'(1)); + elsif Index_Type'First <= 0 then + -- We know that No_Index (the same as Index_Type'First - 1) is less + -- than 0, so it is safe to compute the following sum without fear of + -- overflow. - if New_Length > Max_Length then - raise Constraint_Error with "new length is out of range"; + J := Count_Type'Base (No_Index) + Count_Type'Last; + + if J <= Count_Type'Base (Index_Type'Last) then + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the maximum + -- number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than Count_Type does, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); end if; - New_Last := Index_Type (New_Last_As_Int); - end; + else + -- No_Index is equal or greater than 0, so we can safely compute the + -- difference without fear of overflow (which we would have to worry + -- about if No_Index were less than 0, but that case is handled + -- above). - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is busy)"; + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; + + -- We have just computed the maximum length (number of items). We must + -- now compare the requested length to the maximum length, as we do not + -- allow a vector expand beyond the maximum (because that would create + -- an internal array with a last index value greater than + -- Index_Type'Last, with no way to index those elements). + + if New_Length > Max_Length then + raise Constraint_Error with "Count is out of range"; + end if; + + -- New_Last is the last index value of the items in the container after + -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to + -- compute its value from the New_Length. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + New_Last := No_Index + Index_Type'Base (New_Length); + + else + New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length); end if; if Container.Elements = null then + pragma Assert (Container.Last = No_Index); + + -- This is the simplest case, with which we must always begin: we're + -- inserting items into an empty vector that hasn't allocated an + -- internal array yet. Note that we don't need to check the busy bit + -- here, because an empty container cannot be busy. + + -- In order to preserve container invariants, we allocate the new + -- internal array first, before setting the Last index value, in case + -- the allocation fails (which can happen either because there is no + -- storage available, or because element initialization fails). + Container.Elements := new Elements_Type' (Last => New_Last, EA => (others => New_Item)); + + -- The allocation of the new, internal array succeeded, so it is now + -- safe to update the Last index, restoring container invariants. + Container.Last := New_Last; + return; end if; - if New_Last <= Container.Elements.Last then + -- The tampering bits exist to prevent an item from being harmfully + -- manipulated while it is being visited. Query, Update, and Iterate + -- increment the busy count on entry, and decrement the count on + -- exit. Insert checks the count to determine whether it is being called + -- while the associated callback procedure is executing. + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with elements (vector is busy)"; + end if; + + -- An internal array has already been allocated, so we must determine + -- whether there is enough unused storage for the new items. + + if New_Length <= Container.Elements.EA'Length then + -- In this case, we're inserting elements into a vector that has + -- already allocated an internal array, and the existing array has + -- enough unused storage for the new items. + declare EA : Elements_Array renames Container.Elements.EA; begin - if Before <= Container.Last then - declare - Index_As_Int : constant Int'Base := - Index_Type'Pos (Before) + N; + if Before > Container.Last then + -- The new items are being appended to the vector, so no + -- sliding of existing elements is required. - Index : constant Index_Type := Index_Type (Index_As_Int); + EA (Before .. New_Last) := (others => New_Item); - begin - EA (Index .. New_Last) := EA (Before .. Container.Last); + else + -- The new items are being inserted before some existing + -- elements, so we must slide the existing elements up to their + -- new home. We use the wider of Index_Type'Base and + -- Count_Type'Base as the type for intermediate index values. - EA (Before .. Index_Type'Pred (Index)) := - (others => New_Item); - end; + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Index := Before + Index_Type'Base (Count); - else - EA (Before .. New_Last) := (others => New_Item); + else + Index := Index_Type'Base (Count_Type'Base (Before) + Count); + end if; + + EA (Index .. New_Last) := EA (Before .. Container.Last); + EA (Before .. Index - 1) := (others => New_Item); end if; end; @@ -863,67 +1190,79 @@ package body Ada.Containers.Vectors is return; end if; - declare - C, CC : UInt; + -- In this case, we're inserting elements into a vector that has already + -- allocated an internal array, but the existing array does not have + -- enough storage, so we must allocate a new, longer array. In order to + -- guarantee that the amortized insertion cost is O(1), we always + -- allocate an array whose length is some power-of-two factor of the + -- current array length. (The new array cannot have a length less than + -- the New_Length of the container, but its last index value cannot be + -- greater than Index_Type'Last.) + + New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length); + while New_Capacity < New_Length loop + if New_Capacity > Count_Type'Last / 2 then + New_Capacity := Count_Type'Last; + exit; + end if; - begin - C := UInt'Max (1, Container.Elements.EA'Length); -- ??? - while C < New_Length loop - if C > UInt'Last / 2 then - C := UInt'Last; - exit; - end if; + New_Capacity := 2 * New_Capacity; + end loop; - C := 2 * C; - end loop; + if New_Capacity > Max_Length then + -- We have reached the limit of capacity, so no further expansion + -- will occur. (This is not a problem, as there is never a need to + -- have more capacity than the maximum container length.) - if C > Max_Length then - C := Max_Length; - end if; + New_Capacity := Max_Length; + end if; - if Index_Type'First <= 0 - and then Index_Type'Last >= 0 - then - CC := UInt (Index_Type'Last) + UInt (-Index_Type'First) + 1; - else - CC := UInt (Int (Index_Type'Last) - First + 1); - end if; + -- We have computed the length of the new internal array (and this is + -- what "vector capacity" means), so use that to compute its last index. - if C > CC then - C := CC; - end if; + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Dst_Last := No_Index + Index_Type'Base (New_Capacity); - declare - Dst_Last : constant Index_Type := - Index_Type (First + UInt'Pos (C) - 1); + else + Dst_Last := + Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity); + end if; - begin - Dst := new Elements_Type (Dst_Last); - end; - end; + -- Now we allocate the new, longer internal array. If the allocation + -- fails, we have not changed any container state, so no side-effect + -- will occur as a result of propagating the exception. + + Dst := new Elements_Type (Dst_Last); + + -- We have our new internal array. All that needs to be done now is to + -- copy the existing items (if any) from the old array (the "source" + -- array, object SA below) to the new array (the "destination" array, + -- object DA below), and then deallocate the old array. declare - SA : Elements_Array renames Container.Elements.EA; - DA : Elements_Array renames Dst.EA; + SA : Elements_Array renames Container.Elements.EA; -- source + DA : Elements_Array renames Dst.EA; -- destination begin - DA (Index_Type'First .. Index_Type'Pred (Before)) := - SA (Index_Type'First .. Index_Type'Pred (Before)); + DA (Index_Type'First .. Before - 1) := + SA (Index_Type'First .. Before - 1); - if Before <= Container.Last then - declare - Index_As_Int : constant Int'Base := - Index_Type'Pos (Before) + N; + if Before > Container.Last then + DA (Before .. New_Last) := (others => New_Item); - Index : constant Index_Type := Index_Type (Index_As_Int); + else + -- The new items are being inserted before some existing elements, + -- so we must slide the existing elements up to their new home. - begin - DA (Before .. Index_Type'Pred (Index)) := (others => New_Item); - DA (Index .. New_Last) := SA (Before .. Container.Last); - end; + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Index := Before + Index_Type'Base (Count); - else - DA (Before .. New_Last) := (others => New_Item); + else + Index := Index_Type'Base (Count_Type'Base (Before) + Count); + end if; + + DA (Before .. Index - 1) := (others => New_Item); + DA (Index .. New_Last) := SA (Before .. Container.Last); end if; exception when others => @@ -931,11 +1270,23 @@ package body Ada.Containers.Vectors is raise; end; + -- We have successfully copied the items onto the new array, so the + -- final thing to do is deallocate the old array. + declare X : Elements_Access := Container.Elements; begin + -- We first isolate the old internal array, removing it from the + -- container and replacing it with the new internal array, before we + -- deallocate the old array (which can fail if finalization of + -- elements propagates an exception). + Container.Elements := Dst; Container.Last := New_Last; + + -- The container invariants have been restored, so it is now safe to + -- attempt to deallocate the old array. + Free (X); end; end Insert; @@ -946,83 +1297,118 @@ package body Ada.Containers.Vectors is New_Item : Vector) is N : constant Count_Type := Length (New_Item); + J : Index_Type'Base; begin - if Before < Index_Type'First then - raise Constraint_Error with - "Before index is out of range (too small)"; + -- Use Insert_Space to create the "hole" (the destination slice) into + -- which we copy the source items. + + Insert_Space (Container, Before, Count => N); + + if N = 0 then + -- There's nothing else to do here (vetting of parameters was + -- performed already in Insert_Space), so we simply return. + + return; end if; - if Before > Container.Last - and then Before > Container.Last + 1 - then - raise Constraint_Error with - "Before index is out of range (too large)"; + -- We calculate the last index value of the destination slice using the + -- wider of Index_Type'Base and count_Type'Base. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + J := (Before - 1) + Index_Type'Base (N); + + else + J := Index_Type'Base (Count_Type'Base (Before - 1) + N); end if; - if N = 0 then + if Container'Address /= New_Item'Address then + -- This is the simple case. New_Item denotes an object different + -- from Container, so there's nothing special we need to do to copy + -- the source items to their destination, because all of the source + -- items are contiguous. + + Container.Elements.EA (Before .. J) := + New_Item.Elements.EA (Index_Type'First .. New_Item.Last); + return; end if; - Insert_Space (Container, Before, Count => N); + -- New_Item denotes the same object as Container, so an insertion has + -- potentially split the source items. The destination is always the + -- range [Before, J], but the source is [Index_Type'First, Before) and + -- (J, Container.Last]. We perform the copy in two steps, using each of + -- the two slices of the source items. declare - Dst_Last_As_Int : constant Int'Base := - Int'Base (Before) + Int'Base (N) - 1; - - Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int); + L : constant Index_Type'Base := Before - 1; - begin - if Container'Address /= New_Item'Address then - Container.Elements.EA (Before .. Dst_Last) := - New_Item.Elements.EA (Index_Type'First .. New_Item.Last); + subtype Src_Index_Subtype is Index_Type'Base range + Index_Type'First .. L; - return; - end if; + Src : Elements_Array renames + Container.Elements.EA (Src_Index_Subtype); - declare - subtype Src_Index_Subtype is Index_Type'Base range - Index_Type'First .. Before - 1; + K : Index_Type'Base; - Src : Elements_Array renames - Container.Elements.EA (Src_Index_Subtype); + begin + -- We first copy the source items that precede the space we + -- inserted. Index value K is the last index of that portion + -- destination that receives this slice of the source. (If Before + -- equals Index_Type'First, then this first source slice will be + -- empty, which is harmless.) - Index_As_Int : constant Int'Base := - Int (Before) + Src'Length - 1; + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + K := L + Index_Type'Base (Src'Length); - Index : constant Index_Type'Base := - Index_Type'Base (Index_As_Int); + else + K := Index_Type'Base (Count_Type'Base (L) + Src'Length); + end if; - Dst : Elements_Array renames - Container.Elements.EA (Before .. Index); + Container.Elements.EA (Before .. K) := Src; - begin - Dst := Src; - end; + if Src'Length = N then + -- The new items were effectively appended to the container, so we + -- have already copied all of the items that need to be copied. + -- We return early here, even though the source slice below is + -- empty (so the assignment would be harmless), because we want to + -- avoid computing J + 1, which will overflow if J equals + -- Index_Type'Base'Last. - if Dst_Last = Container.Last then return; end if; + end; - declare - subtype Src_Index_Subtype is Index_Type'Base range - Dst_Last + 1 .. Container.Last; + declare + -- Note that we want to avoid computing J + 1 here, in case J equals + -- Index_Type'Base'Last. We prevent that by returning early above, + -- immediately after copying the first slice of the source, and + -- determining that this second slice of the source is empty. - Src : Elements_Array renames - Container.Elements.EA (Src_Index_Subtype); + F : constant Index_Type'Base := J + 1; - Index_As_Int : constant Int'Base := - Dst_Last_As_Int - Src'Length + 1; + subtype Src_Index_Subtype is Index_Type'Base range + F .. Container.Last; - Index : constant Index_Type := - Index_Type (Index_As_Int); + Src : Elements_Array renames + Container.Elements.EA (Src_Index_Subtype); - Dst : Elements_Array renames - Container.Elements.EA (Index .. Dst_Last); + K : Index_Type'Base; - begin - Dst := Src; - end; + begin + -- We next copy the source items that follow the space we + -- inserted. Index value K is the first index of that portion of the + -- destination that receives this slice of the source. (For the + -- reasons given above, this slice is guaranteed to be non-empty.) + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + K := F - Index_Type'Base (Src'Length); + + else + K := Index_Type'Base (Count_Type'Base (F) - Src'Length); + end if; + + Container.Elements.EA (K .. J) := Src; end; end Insert; @@ -1224,22 +1610,42 @@ package body Ada.Containers.Vectors is Before : Extended_Index; Count : Count_Type := 1) is - N : constant Int := Count_Type'Pos (Count); + Old_Length : constant Count_Type := Container.Length; - First : constant Int := Int (Index_Type'First); - New_Last_As_Int : Int'Base; - New_Last : Index_Type; - New_Length : UInt; - Max_Length : constant UInt := UInt (Count_Type'Last); + Max_Length : Count_Type'Base; -- determined from range of Index_Type + New_Length : Count_Type'Base; -- sum of current length and Count + New_Last : Index_Type'Base; -- last index of vector after insertion - Dst : Elements_Access; + Index : Index_Type'Base; -- scratch for intermediate values + J : Count_Type'Base; -- scratch + + New_Capacity : Count_Type'Base; -- length of new, expanded array + Dst_Last : Index_Type'Base; -- last index of new, expanded array + Dst : Elements_Access; -- new, expanded internal array begin + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we do + -- not allow that as the value for Index when specifying where the new + -- items should be inserted, so we must manually check. (That the user + -- is allowed to specify the value at all here is a consequence of the + -- declaration of the Extended_Index subtype, which includes the values + -- in the base range that immediately precede and immediately follow the + -- values in the Index_Type.) + if Before < Index_Type'First then raise Constraint_Error with "Before index is out of range (too small)"; end if; + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows for the + -- case of appending items to the back end of the vector. (It is assumed + -- that specifying an index value greater than Last + 1 indicates some + -- deeper flaw in the caller's algorithm, so that case is treated as a + -- proper error.) + if Before > Container.Last and then Before > Container.Last + 1 then @@ -1247,58 +1653,184 @@ package body Ada.Containers.Vectors is "Before index is out of range (too large)"; end if; + -- We treat inserting 0 items into the container as a no-op, even when + -- the container is busy, so we simply return. + if Count = 0 then return; end if; - declare - Old_Last_As_Int : constant Int := Int (Container.Last); + -- There are two constraints we need to satisfy. The first constraint is + -- that a container cannot have more than Count_Type'Last elements, so + -- we must check the sum of the current length and the insertion + -- count. Note that we cannot simply add these values, because of the + -- possibilty of overflow. - begin - if Old_Last_As_Int > Int'Last - N then - raise Constraint_Error with "new length is out of range"; - end if; + if Old_Length > Count_Type'Last - Count then + raise Constraint_Error with "Count is out of range"; + end if; - New_Last_As_Int := Old_Last_As_Int + N; + -- It is now safe compute the length of the new vector, without fear of + -- overflow. - if New_Last_As_Int > Int (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; + New_Length := Old_Length + Count; + + -- The second constraint is that the new Last index value cannot exceed + -- Index_Type'Last. In each branch below, we calculate the maximum + -- length (computed from the range of values in Index_Type), and then + -- compare the new length to the maximum length. If the new length is + -- acceptable, then we compute the new last index from that. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + -- We have to handle the case when there might be more values in the + -- range of Index_Type than in the range of Count_Type. + + if Index_Type'First <= 0 then + -- We know that No_Index (the same as Index_Type'First - 1) is + -- less than 0, so it is safe to compute the following sum without + -- fear of overflow. + + Index := No_Index + Index_Type'Base (Count_Type'Last); + + if Index <= Index_Type'Last then + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the + -- maximum number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than in Count_Type, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; + + else + -- No_Index is equal or greater than 0, so we can safely compute + -- the difference without fear of overflow (which we would have to + -- worry about if No_Index were less than 0, but that case is + -- handled above). + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); end if; - New_Length := UInt (New_Last_As_Int - First + Int'(1)); + elsif Index_Type'First <= 0 then + -- We know that No_Index (the same as Index_Type'First - 1) is less + -- than 0, so it is safe to compute the following sum without fear of + -- overflow. - if New_Length > Max_Length then - raise Constraint_Error with "new length is out of range"; + J := Count_Type'Base (No_Index) + Count_Type'Last; + + if J <= Count_Type'Base (Index_Type'Last) then + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the maximum + -- number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than Count_Type does, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); end if; - New_Last := Index_Type (New_Last_As_Int); - end; + else + -- No_Index is equal or greater than 0, so we can safely compute the + -- difference without fear of overflow (which we would have to worry + -- about if No_Index were less than 0, but that case is handled + -- above). - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is busy)"; + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; + + -- We have just computed the maximum length (number of items). We must + -- now compare the requested length to the maximum length, as we do not + -- allow a vector expand beyond the maximum (because that would create + -- an internal array with a last index value greater than + -- Index_Type'Last, with no way to index those elements). + + if New_Length > Max_Length then + raise Constraint_Error with "Count is out of range"; + end if; + + -- New_Last is the last index value of the items in the container after + -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to + -- compute its value from the New_Length. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + New_Last := No_Index + Index_Type'Base (New_Length); + + else + New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length); end if; if Container.Elements = null then + pragma Assert (Container.Last = No_Index); + + -- This is the simplest case, with which we must always begin: we're + -- inserting items into an empty vector that hasn't allocated an + -- internal array yet. Note that we don't need to check the busy bit + -- here, because an empty container cannot be busy. + + -- In order to preserve container invariants, we allocate the new + -- internal array first, before setting the Last index value, in case + -- the allocation fails (which can happen either because there is no + -- storage available, or because default-valued element + -- initialization fails). + Container.Elements := new Elements_Type (New_Last); + + -- The allocation of the new, internal array succeeded, so it is now + -- safe to update the Last index, restoring container invariants. + Container.Last := New_Last; + return; end if; + -- The tampering bits exist to prevent an item from being harmfully + -- manipulated while it is being visited. Query, Update, and Iterate + -- increment the busy count on entry, and decrement the count on + -- exit. Insert checks the count to determine whether it is being called + -- while the associated callback procedure is executing. + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with elements (vector is busy)"; + end if; + + -- An internal array has already been allocated, so we must determine + -- whether there is enough unused storage for the new items. + if New_Last <= Container.Elements.Last then + -- In this case, we're inserting space into a vector that has already + -- allocated an internal array, and the existing array has enough + -- unused storage for the new items. + declare EA : Elements_Array renames Container.Elements.EA; + begin if Before <= Container.Last then - declare - Index_As_Int : constant Int'Base := - Index_Type'Pos (Before) + N; + -- The space is being inserted before some existing elements, + -- so we must slide the existing elements up to their new + -- home. We use the wider of Index_Type'Base and + -- Count_Type'Base as the type for intermediate index values. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Index := Before + Index_Type'Base (Count); - Index : constant Index_Type := Index_Type (Index_As_Int); + else + Index := Index_Type'Base (Count_Type'Base (Before) + Count); + end if; - begin - EA (Index .. New_Last) := EA (Before .. Container.Last); - end; + EA (Index .. New_Last) := EA (Before .. Container.Last); end if; end; @@ -1306,63 +1838,75 @@ package body Ada.Containers.Vectors is return; end if; - declare - C, CC : UInt; + -- In this case, we're inserting space into a vector that has already + -- allocated an internal array, but the existing array does not have + -- enough storage, so we must allocate a new, longer array. In order to + -- guarantee that the amortized insertion cost is O(1), we always + -- allocate an array whose length is some power-of-two factor of the + -- current array length. (The new array cannot have a length less than + -- the New_Length of the container, but its last index value cannot be + -- greater than Index_Type'Last.) + + New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length); + while New_Capacity < New_Length loop + if New_Capacity > Count_Type'Last / 2 then + New_Capacity := Count_Type'Last; + exit; + end if; - begin - C := UInt'Max (1, Container.Elements.EA'Length); -- ??? - while C < New_Length loop - if C > UInt'Last / 2 then - C := UInt'Last; - exit; - end if; + New_Capacity := 2 * New_Capacity; + end loop; - C := 2 * C; - end loop; + if New_Capacity > Max_Length then + -- We have reached the limit of capacity, so no further expansion + -- will occur. (This is not a problem, as there is never a need to + -- have more capacity than the maximum container length.) - if C > Max_Length then - C := Max_Length; - end if; + New_Capacity := Max_Length; + end if; - if Index_Type'First <= 0 - and then Index_Type'Last >= 0 - then - CC := UInt (Index_Type'Last) + UInt (-Index_Type'First) + 1; - else - CC := UInt (Int (Index_Type'Last) - First + 1); - end if; + -- We have computed the length of the new internal array (and this is + -- what "vector capacity" means), so use that to compute its last index. - if C > CC then - C := CC; - end if; + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Dst_Last := No_Index + Index_Type'Base (New_Capacity); - declare - Dst_Last : constant Index_Type := - Index_Type (First + UInt'Pos (C) - 1); + else + Dst_Last := + Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity); + end if; - begin - Dst := new Elements_Type (Dst_Last); - end; - end; + -- Now we allocate the new, longer internal array. If the allocation + -- fails, we have not changed any container state, so no side-effect + -- will occur as a result of propagating the exception. + + Dst := new Elements_Type (Dst_Last); + + -- We have our new internal array. All that needs to be done now is to + -- copy the existing items (if any) from the old array (the "source" + -- array, object SA below) to the new array (the "destination" array, + -- object DA below), and then deallocate the old array. declare - SA : Elements_Array renames Container.Elements.EA; - DA : Elements_Array renames Dst.EA; + SA : Elements_Array renames Container.Elements.EA; -- source + DA : Elements_Array renames Dst.EA; -- destination begin - DA (Index_Type'First .. Index_Type'Pred (Before)) := - SA (Index_Type'First .. Index_Type'Pred (Before)); + DA (Index_Type'First .. Before - 1) := + SA (Index_Type'First .. Before - 1); if Before <= Container.Last then - declare - Index_As_Int : constant Int'Base := - Index_Type'Pos (Before) + N; + -- The space is being inserted before some existing elements, so + -- we must slide the existing elements up to their new home. - Index : constant Index_Type := Index_Type (Index_As_Int); + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Index := Before + Index_Type'Base (Count); - begin - DA (Index .. New_Last) := SA (Before .. Container.Last); - end; + else + Index := Index_Type'Base (Count_Type'Base (Before) + Count); + end if; + + DA (Index .. New_Last) := SA (Before .. Container.Last); end if; exception when others => @@ -1370,11 +1914,24 @@ package body Ada.Containers.Vectors is raise; end; + -- We have successfully copied the items onto the new array, so the + -- final thing to do is restore invariants, and deallocate the old + -- array. + declare X : Elements_Access := Container.Elements; begin + -- We first isolate the old internal array, removing it from the + -- container and replacing it with the new internal array, before we + -- deallocate the old array (which can fail if finalization of + -- elements propagates an exception). + Container.Elements := Dst; Container.Last := New_Last; + + -- The container invariants have been restored, so it is now safe to + -- attempt to deallocate the old array. + Free (X); end; end Insert_Space; @@ -1501,12 +2058,33 @@ package body Ada.Containers.Vectors is ------------ function Length (Container : Vector) return Count_Type is - L : constant Int := Int (Container.Last); - F : constant Int := Int (Index_Type'First); - N : constant Int'Base := L - F + 1; - - begin - return Count_Type (N); + L : constant Index_Type'Base := Container.Last; + F : constant Index_Type := Index_Type'First; + + begin + -- The base range of the index type (Index_Type'Base) might not include + -- all values for length (Count_Type). Contrariwise, the index type + -- might include values outside the range of length. Hence we use + -- whatever type is wider for intermediate values when calculating + -- length. Note that no matter what the index type is, the maximum + -- length to which a vector is allowed to grow is always the minimum + -- of Count_Type'Last and (IT'Last - IT'First + 1). + + -- For example, an Index_Type with range -127 .. 127 is only guaranteed + -- to have a base range of -128 .. 127, but the corresponding vector + -- would have lengths in the range 0 .. 255. In this case we would need + -- to use Count_Type'Base for intermediate values. + + -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The + -- vector would have a maximum length of 10, but the index values lie + -- outside the range of Count_Type (which is only 32 bits). In this + -- case we would need to use Index_Type'Base for intermediate values. + + if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then + return Count_Type'Base (L) - Count_Type'Base (F) + 1; + else + return Count_Type (L - F + 1); + end if; end Length; ---------- @@ -1767,17 +2345,51 @@ package body Ada.Containers.Vectors is is N : constant Count_Type := Length (Container); + Index : Count_Type'Base; + Last : Index_Type'Base; + begin + -- Reserve_Capacity can be used to either expand the storage available + -- for elements (this would be its typical use, in anticipation of + -- future insertion), or to trim back storage. In the latter case, + -- storage can only be trimmed back to the limit of the container + -- length. Note that Reserve_Capacity neither deletes (active) elements + -- nor inserts elements; it only affects container capacity, never + -- container length. + if Capacity = 0 then + -- This is a request to trim back storage, to the minimum amount + -- possible given the current state of the container. + if N = 0 then + -- The container is empty, so in this unique case we can + -- deallocate the entire internal array. Note that an empty + -- container can never be busy, so there's no need to check the + -- tampering bits. + declare X : Elements_Access := Container.Elements; begin + -- First we remove the internal array from the container, to + -- handle the case when the deallocation raises an exception. + Container.Elements := null; + + -- Container invariants have been restored, so it is now safe + -- to attempt to deallocate the internal array. + Free (X); end; elsif N < Container.Elements.EA'Length then + -- The container is not empty, and the current length is less than + -- the current capacity, so there's storage available to trim. In + -- this case, we allocate a new internal array having a length + -- that exactly matches the number of items in the + -- container. (Reserve_Capacity does not delete active elements, + -- so this is the best we can do with respect to minimizing + -- storage). + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; @@ -1793,7 +2405,23 @@ package body Ada.Containers.Vectors is X : Elements_Access := Container.Elements; begin + -- Although we have isolated the old internal array that we're + -- going to deallocate, we don't deallocate it until we have + -- successfully allocated a new one. If there is an exception + -- during allocation (either because there is not enough + -- storage, or because initialization of the elements fails), + -- we let it propagate without causing any side-effect. + Container.Elements := new Elements_Type'(Container.Last, Src); + + -- We have succesfully allocated a new internal array (with a + -- smaller length than the old one, and containing a copy of + -- just the active elements in the container), so it is now + -- safe to attempt to deallocate the old array. The old array + -- has been isolated, and container invariants have been + -- restored, so if the deallocation fails (because finalization + -- of the elements fails), we simply let it propagate. + Free (X); end; end if; @@ -1801,29 +2429,102 @@ package body Ada.Containers.Vectors is return; end if; - if Container.Elements = null then - declare - Last_As_Int : constant Int'Base := - Int (Index_Type'First) + Int (Capacity) - 1; + -- Reserve_Capacity can be used to expand the storage available for + -- elements, but we do not let the capacity grow beyond the number of + -- values in Index_Type'Range. (Were it otherwise, there would be no way + -- to refer to the elements with an index value greater than + -- Index_Type'Last, so that storage would be wasted.) Here we compute + -- the Last index value of the new internal array, in a way that avoids + -- any possibility of overflow. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + -- We perform a two-part test. First we determine whether the + -- computed Last value lies in the base range of the type, and then + -- determine whether it lies in the range of the index (sub)type. + + -- Last must satisfy this relation: + -- First + Length - 1 <= Last + -- We regroup terms: + -- First - 1 <= Last - Length + -- Which can rewrite as: + -- No_Index <= Last - Length + + if Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index then + raise Constraint_Error with "Capacity is out of range"; + end if; - begin - if Last_As_Int > Index_Type'Pos (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; - end if; + -- We now know that the computed value of Last is within the base + -- range of the type, so it is safe to compute its value: - declare - Last : constant Index_Type := Index_Type (Last_As_Int); + Last := No_Index + Index_Type'Base (Capacity); - begin - Container.Elements := new Elements_Type (Last); - end; - end; + -- Finally we test whether the value is within the range of the + -- generic actual index subtype: + + if Last > Index_Type'Last then + raise Constraint_Error with "Capacity is out of range"; + end if; + + elsif Index_Type'First <= 0 then + -- Here we can compute Last directly, in the normal way. We know that + -- No_Index is less than 0, so there is no danger of overflow when + -- adding the (positive) value of Capacity. + + Index := Count_Type'Base (No_Index) + Capacity; -- Last + + if Index > Count_Type'Base (Index_Type'Last) then + raise Constraint_Error with "Capacity is out of range"; + end if; + + -- We know that the computed value (having type Count_Type) of Last + -- is within the range of the generic actual index subtype, so it is + -- safe to convert to Index_Type: + + Last := Index_Type'Base (Index); + else + -- Here Index_Type'First (and Index_Type'Last) is positive, so we + -- must test the length indirectly (by working backwards from the + -- largest possible value of Last), in order to prevent overflow. + + Index := Count_Type'Base (Index_Type'Last) - Capacity; -- No_Index + + if Index < Count_Type'Base (No_Index) then + raise Constraint_Error with "Capacity is out of range"; + end if; + + -- We have determined that the value of Capacity would not create a + -- Last index value outside of the range of Index_Type, so we can now + -- safely compute its value. + + Last := Index_Type'Base (Count_Type'Base (No_Index) + Capacity); + end if; + + -- The requested capacity is non-zero, but we don't know yet whether + -- this is a request for expansion or contraction of storage. + + if Container.Elements = null then + -- The container is empty (it doesn't even have an internal array), + -- so this represents a request to allocate (expand) storage having + -- the given capacity. + + Container.Elements := new Elements_Type (Last); return; end if; if Capacity <= N then + -- This is a request to trim back storage, but only to the limit of + -- what's already in the container. (Reserve_Capacity never deletes + -- active elements, it only reclaims excess storage.) + if N < Container.Elements.EA'Length then + -- The container is not empty (because the requested capacity is + -- positive, and less than or equal to the container length), and + -- the current length is less than the current capacity, so + -- there's storage available to trim. In this case, we allocate a + -- new internal array having a length that exactly matches the + -- number of items in the container. + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; @@ -1839,63 +2540,99 @@ package body Ada.Containers.Vectors is X : Elements_Access := Container.Elements; begin + -- Although we have isolated the old internal array that we're + -- going to deallocate, we don't deallocate it until we have + -- successfully allocated a new one. If there is an exception + -- during allocation (either because there is not enough + -- storage, or because initialization of the elements fails), + -- we let it propagate without causing any side-effect. + Container.Elements := new Elements_Type'(Container.Last, Src); + + -- We have succesfully allocated a new internal array (with a + -- smaller length than the old one, and containing a copy of + -- just the active elements in the container), so it is now + -- safe to attempt to deallocate the old array. The old array + -- has been isolated, and container invariants have been + -- restored, so if the deallocation fails (because finalization + -- of the elements fails), we simply let it propagate. + Free (X); end; - end if; return; end if; + -- The requested capacity is larger than the container length (the + -- number of active elements). Whether this represents a request for + -- expansion or contraction of the current capacity depends on what the + -- current capacity is. + if Capacity = Container.Elements.EA'Length then + -- The requested capacity matches the existing capacity, so there's + -- nothing to do here. We treat this case as a no-op, and simply + -- return without checking the busy bit. + return; end if; + -- There is a change in the capacity of a non-empty container, so a new + -- internal array will be allocated. (The length of the new internal + -- array could be less or greater than the old internal array. We know + -- only that the length of the new internal array is greater than the + -- number of active elements in the container.) We must check whether + -- the container is busy before doing anything else. + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; + -- We now allocate a new internal array, having a length different from + -- its current value. + declare - Last_As_Int : constant Int'Base := - Int (Index_Type'First) + Int (Capacity) - 1; + E : Elements_Access := new Elements_Type (Last); begin - if Last_As_Int > Index_Type'Pos (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; - end if; + -- We have successfully allocated the new internal array. We first + -- attempt to copy the existing elements from the old internal array + -- ("src" elements) onto the new internal array ("tgt" elements). declare - Last : constant Index_Type := Index_Type (Last_As_Int); + subtype Index_Subtype is Index_Type'Base range + Index_Type'First .. Container.Last; + + Src : Elements_Array renames + Container.Elements.EA (Index_Subtype); - E : Elements_Access := new Elements_Type (Last); + Tgt : Elements_Array renames E.EA (Index_Subtype); begin - declare - subtype Index_Subtype is Index_Type'Base range - Index_Type'First .. Container.Last; + Tgt := Src; - Src : Elements_Array renames - Container.Elements.EA (Index_Subtype); + exception + when others => + Free (E); + raise; + end; - Tgt : Elements_Array renames E.EA (Index_Subtype); + -- We have successfully copied the existing elements onto the new + -- internal array, so now we can attempt to deallocate the old one. - begin - Tgt := Src; + declare + X : Elements_Access := Container.Elements; + begin + -- First we isolate the old internal array, and replace it in the + -- container with the new internal array. - exception - when others => - Free (E); - raise; - end; + Container.Elements := E; - declare - X : Elements_Access := Container.Elements; - begin - Container.Elements := E; - Free (X); - end; + -- Container invariants have been restored, so it is now safe to + -- attempt to deallocate the old internal array. + + Free (X); end; end; end Reserve_Capacity; @@ -2023,26 +2760,25 @@ package body Ada.Containers.Vectors is ---------------- procedure Set_Length (Container : in out Vector; Length : Count_Type) is + Count : constant Count_Type'Base := Container.Length - Length; + begin - if Length = Vectors.Length (Container) then - return; - end if; + -- Set_Length allows the user to set the length explicitly, instead of + -- implicitly as a side-effect of deletion or insertion. If the + -- requested length is less then the current length, this is equivalent + -- to deleting items from the back end of the vector. If the requested + -- length is greater than the current length, then this is equivalent to + -- inserting "space" (nonce items) at the end. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is busy)"; - end if; + if Count >= 0 then + Container.Delete_Last (Count); - if Length > Capacity (Container) then - Reserve_Capacity (Container, Capacity => Length); - end if; + elsif Container.Last >= Index_Type'Last then + raise Constraint_Error with "vector is already at its maximum length"; - declare - Last_As_Int : constant Int'Base := - Int (Index_Type'First) + Int (Length) - 1; - begin - Container.Last := Index_Type'Base (Last_As_Int); - end; + else + Container.Insert_Space (Container.Last + 1, -Count); + end if; end Set_Length; ---------- @@ -2135,54 +2871,176 @@ package body Ada.Containers.Vectors is --------------- function To_Vector (Length : Count_Type) return Vector is + Index : Count_Type'Base; + Last : Index_Type'Base; + Elements : Elements_Access; + begin if Length = 0 then return Empty_Vector; end if; - declare - First : constant Int := Int (Index_Type'First); - Last_As_Int : constant Int'Base := First + Int (Length) - 1; - Last : Index_Type; - Elements : Elements_Access; + -- We create a vector object with a capacity that matches the specified + -- Length, but we do not allow the vector capacity (the length of the + -- internal array) to exceed the number of values in Index_Type'Range + -- (otherwise, there would be no way to refer to those components via an + -- index). We must therefore check whether the specified Length would + -- create a Last index value greater than Index_Type'Last. - begin - if Last_As_Int > Index_Type'Pos (Index_Type'Last) then + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + -- We perform a two-part test. First we determine whether the + -- computed Last value lies in the base range of the type, and then + -- determine whether it lies in the range of the index (sub)type. + + -- Last must satisfy this relation: + -- First + Length - 1 <= Last + -- We regroup terms: + -- First - 1 <= Last - Length + -- Which can rewrite as: + -- No_Index <= Last - Length + + if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then raise Constraint_Error with "Length is out of range"; end if; - Last := Index_Type (Last_As_Int); - Elements := new Elements_Type (Last); + -- We now know that the computed value of Last is within the base + -- range of the type, so it is safe to compute its value: - return Vector'(Controlled with Elements, Last, 0, 0); - end; + Last := No_Index + Index_Type'Base (Length); + + -- Finally we test whether the value is within the range of the + -- generic actual index subtype: + + if Last > Index_Type'Last then + raise Constraint_Error with "Length is out of range"; + end if; + + elsif Index_Type'First <= 0 then + -- Here we can compute Last directly, in the normal way. We know that + -- No_Index is less than 0, so there is no danger of overflow when + -- adding the (positive) value of Length. + + Index := Count_Type'Base (No_Index) + Length; -- Last + + if Index > Count_Type'Base (Index_Type'Last) then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We know that the computed value (having type Count_Type) of Last + -- is within the range of the generic actual index subtype, so it is + -- safe to convert to Index_Type: + + Last := Index_Type'Base (Index); + + else + -- Here Index_Type'First (and Index_Type'Last) is positive, so we + -- must test the length indirectly (by working backwards from the + -- largest possible value of Last), in order to prevent overflow. + + Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index + + if Index < Count_Type'Base (No_Index) then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We have determined that the value of Length would not create a + -- Last index value outside of the range of Index_Type, so we can now + -- safely compute its value. + + Last := Index_Type'Base (Count_Type'Base (No_Index) + Length); + end if; + + Elements := new Elements_Type (Last); + + return Vector'(Controlled with Elements, Last, 0, 0); end To_Vector; function To_Vector (New_Item : Element_Type; Length : Count_Type) return Vector is + Index : Count_Type'Base; + Last : Index_Type'Base; + Elements : Elements_Access; + begin if Length = 0 then return Empty_Vector; end if; - declare - First : constant Int := Int (Index_Type'First); - Last_As_Int : constant Int'Base := First + Int (Length) - 1; - Last : Index_Type; - Elements : Elements_Access; + -- We create a vector object with a capacity that matches the specified + -- Length, but we do not allow the vector capacity (the length of the + -- internal array) to exceed the number of values in Index_Type'Range + -- (otherwise, there would be no way to refer to those components via an + -- index). We must therefore check whether the specified Length would + -- create a Last index value greater than Index_Type'Last. - begin - if Last_As_Int > Index_Type'Pos (Index_Type'Last) then + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + -- We perform a two-part test. First we determine whether the + -- computed Last value lies in the base range of the type, and then + -- determine whether it lies in the range of the index (sub)type. + + -- Last must satisfy this relation: + -- First + Length - 1 <= Last + -- We regroup terms: + -- First - 1 <= Last - Length + -- Which can rewrite as: + -- No_Index <= Last - Length + + if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then raise Constraint_Error with "Length is out of range"; end if; - Last := Index_Type (Last_As_Int); - Elements := new Elements_Type'(Last, EA => (others => New_Item)); + -- We now know that the computed value of Last is within the base + -- range of the type, so it is safe to compute its value: - return Vector'(Controlled with Elements, Last, 0, 0); - end; + Last := No_Index + Index_Type'Base (Length); + + -- Finally we test whether the value is within the range of the + -- generic actual index subtype: + + if Last > Index_Type'Last then + raise Constraint_Error with "Length is out of range"; + end if; + + elsif Index_Type'First <= 0 then + -- Here we can compute Last directly, in the normal way. We know that + -- No_Index is less than 0, so there is no danger of overflow when + -- adding the (positive) value of Length. + + Index := Count_Type'Base (No_Index) + Length; -- same value as V.Last + + if Index > Count_Type'Base (Index_Type'Last) then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We know that the computed value (having type Count_Type) of Last + -- is within the range of the generic actual index subtype, so it is + -- safe to convert to Index_Type: + + Last := Index_Type'Base (Index); + + else + -- Here Index_Type'First (and Index_Type'Last) is positive, so we + -- must test the length indirectly (by working backwards from the + -- largest possible value of Last), in order to prevent overflow. + + Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index + + if Index < Count_Type'Base (No_Index) then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We have determined that the value of Length would not create a + -- Last index value outside of the range of Index_Type, so we can now + -- safely compute its value. + + Last := Index_Type'Base (Count_Type'Base (No_Index) + Length); + end if; + + Elements := new Elements_Type'(Last, EA => (others => New_Item)); + + return Vector'(Controlled with Elements, Last, 0, 0); end To_Vector; -------------------- diff --git a/gcc/ada/a-envvar.ads b/gcc/ada/a-envvar.ads index a2415603e4e..9769c9bb1ee 100755 --- a/gcc/ada/a-envvar.ads +++ b/gcc/ada/a-envvar.ads @@ -37,7 +37,7 @@ package Ada.Environment_Variables is -- environment variable with the given name and value, then -- Constraint_Error is propagated. -- It is implementation defined whether there exist values for which the - -- call Set(Name, Value) has the same effect as Clear (Name). + -- call Set (Name, Value) has the same effect as Clear (Name). procedure Clear (Name : String); -- If the external execution environment supports environment variables, diff --git a/gcc/ada/a-excpol-abort.adb b/gcc/ada/a-excpol-abort.adb index daea6fb80da..94acae6a10b 100644 --- a/gcc/ada/a-excpol-abort.adb +++ b/gcc/ada/a-excpol-abort.adb @@ -7,7 +7,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -35,7 +35,7 @@ -- that activates periodic polling. Then in the body of the polling routine -- we test for asynchronous abort. --- NT, OS/2, HPUX/DCE and SCO currently use this file +-- Windows, HPUX 10 and VMS currently use this file pragma Warnings (Off); -- Allow withing of non-Preelaborated units in Ada 2005 mode where this diff --git a/gcc/ada/a-ngcoty.adb b/gcc/ada/a-ngcoty.adb index 81cc68a718a..7cf48713a6b 100644 --- a/gcc/ada/a-ngcoty.adb +++ b/gcc/ada/a-ngcoty.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -43,6 +43,12 @@ package body Ada.Numerics.Generic_Complex_Types is --------- function "*" (Left, Right : Complex) return Complex is + + Scale : constant R := R (R'Machine_Radix) ** ((R'Machine_Emax - 1) / 2); + -- In case of overflow, scale the operands by the largest power of the + -- radix (to avoid rounding error), so that the square of the scale does + -- not overflow itself. + X : R; Y : R; @@ -53,14 +59,20 @@ package body Ada.Numerics.Generic_Complex_Types is -- If either component overflows, try to scale (skip in fast math mode) if not Standard'Fast_Math then - if abs (X) > R'Last then - X := R'(4.0) * (R'(Left.Re / 2.0) * R'(Right.Re / 2.0) - - R'(Left.Im / 2.0) * R'(Right.Im / 2.0)); + + -- Note that the test below is written as a negation. This is to + -- account for the fact that X and Y may be NaNs, because both of + -- their operands could overflow. Given that all operations on NaNs + -- return false, the test can only be written thus. + + if not (abs (X) <= R'Last) then + X := Scale**2 * ((Left.Re / Scale) * (Right.Re / Scale) - + (Left.Im / Scale) * (Right.Im / Scale)); end if; - if abs (Y) > R'Last then - Y := R'(4.0) * (R'(Left.Re / 2.0) * R'(Right.Im / 2.0) - - R'(Left.Im / 2.0) * R'(Right.Re / 2.0)); + if not (abs (Y) <= R'Last) then + Y := Scale**2 * ((Left.Re / Scale) * (Right.Im / Scale) + + (Left.Im / Scale) * (Right.Re / Scale)); end if; end if; @@ -569,7 +581,8 @@ package body Ada.Numerics.Generic_Complex_Types is -- in order to prevent inaccuracies on machines where not all -- immediate expressions are rounded, such as PowerPC. - if Re2 > R'Last then + -- ??? same weird test, why not Re2 > R'Last ??? + if not (Re2 <= R'Last) then raise Constraint_Error; end if; @@ -582,7 +595,8 @@ package body Ada.Numerics.Generic_Complex_Types is begin Im2 := X.Im ** 2; - if Im2 > R'Last then + -- ??? same weird test + if not (Im2 <= R'Last) then raise Constraint_Error; end if; diff --git a/gcc/ada/a-nudira.adb b/gcc/ada/a-nudira.adb index 87abcd8f100..ca81ba51895 100644 --- a/gcc/ada/a-nudira.adb +++ b/gcc/ada/a-nudira.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,64 +29,10 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Calendar; - -with Interfaces; use Interfaces; - package body Ada.Numerics.Discrete_Random is - ------------------------- - -- Implementation Note -- - ------------------------- - - -- The design of this spec is very awkward, as a result of Ada 95 not - -- permitting in-out parameters for function formals (most naturally - -- Generator values would be passed this way). In pure Ada 95, the only - -- solution is to use the heap and pointers, and, to avoid memory leaks, - -- controlled types. - - -- This is awfully heavy, so what we do is to use Unrestricted_Access to - -- get a pointer to the state in the passed Generator. This works because - -- Generator is a limited type and will thus always be passed by reference. - - type Pointer is access all State; - - Fits_In_32_Bits : constant Boolean := - Rst'Size < 31 - or else (Rst'Size = 31 - and then Rst'Pos (Rst'First) < 0); - -- This is set True if we do not need more than 32 bits in the result. If - -- we need 64-bits, we will only use the meaningful 48 bits of any 64-bit - -- number generated, since if more than 48 bits are required, we split the - -- computation into two separate parts, since the algorithm does not behave - -- above 48 bits. - - -- The way this expression works is that obviously if the size is 31 bits, - -- it fits in 32 bits. In the 32-bit case, it fits in 32-bit signed if the - -- range has negative values. It is too conservative in the case that the - -- programmer has set a size greater than the default, e.g. a size of 33 - -- for an integer type with a range of 1..10, but an over-conservative - -- result is OK. The important thing is that the value is only True if - -- we know the result will fit in 32-bits signed. If the value is False - -- when it could be True, the behavior will be correct, just a bit less - -- efficient than it could have been in some unusual cases. - -- - -- One might assume that we could get a more accurate result by testing - -- the lower and upper bounds of the type Rst against the bounds of 32-bit - -- Integer. However, there is no easy way to do that. Why? Because in the - -- relatively rare case where this expresion has to be evaluated at run - -- time rather than compile time (when the bounds are dynamic), we need a - -- type to use for the computation. But the possible range of upper bound - -- values for Rst (remembering the possibility of 64-bit modular types) is - -- from -2**63 to 2**64-1, and no run-time type has a big enough range. - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Square_Mod_N (X, N : Int) return Int; - pragma Inline (Square_Mod_N); - -- Computes X**2 mod N avoiding intermediate overflow + package SRN renames System.Random_Numbers; + use SRN; ----------- -- Image -- @@ -94,204 +40,55 @@ package body Ada.Numerics.Discrete_Random is function Image (Of_State : State) return String is begin - return Int'Image (Of_State.X1) & - ',' & - Int'Image (Of_State.X2) & - ',' & - Int'Image (Of_State.Q); + return Image (SRN.State (Of_State)); end Image; ------------ -- Random -- ------------ - function Random (Gen : Generator) return Rst is - Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; - Temp : Int; - TF : Flt; - + function Random (Gen : Generator) return Result_Subtype is + function Random is + new SRN.Random_Discrete (Result_Subtype, Result_Subtype'First); begin - -- Check for flat range here, since we are typically run with checks - -- off, note that in practice, this condition will usually be static - -- so we will not actually generate any code for the normal case. - - if Rst'Last < Rst'First then - raise Constraint_Error; - end if; - - -- Continue with computation if non-flat range - - Genp.X1 := Square_Mod_N (Genp.X1, Genp.P); - Genp.X2 := Square_Mod_N (Genp.X2, Genp.Q); - Temp := Genp.X2 - Genp.X1; - - -- Following duplication is not an error, it is a loop unwinding! - - if Temp < 0 then - Temp := Temp + Genp.Q; - end if; - - if Temp < 0 then - Temp := Temp + Genp.Q; - end if; - - TF := Offs + (Flt (Temp) * Flt (Genp.P) + Flt (Genp.X1)) * Genp.Scl; - - -- Pathological, but there do exist cases where the rounding implicit - -- in calculating the scale factor will cause rounding to 'Last + 1. - -- In those cases, returning 'First results in the least bias. - - if TF >= Flt (Rst'Pos (Rst'Last)) + 0.5 then - return Rst'First; - - elsif not Fits_In_32_Bits then - return Rst'Val (Interfaces.Integer_64 (TF)); - - else - return Rst'Val (Int (TF)); - end if; + return Random (SRN.Generator (Gen)); end Random; ----------- -- Reset -- ----------- - procedure Reset (Gen : Generator; Initiator : Integer) is - Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; - X1, X2 : Int; - + procedure Reset (Gen : Generator) is begin - X1 := 2 + Int (Initiator) mod (K1 - 3); - X2 := 2 + Int (Initiator) mod (K2 - 3); - - for J in 1 .. 5 loop - X1 := Square_Mod_N (X1, K1); - X2 := Square_Mod_N (X2, K2); - end loop; - - -- Eliminate effects of small Initiators - - Genp.all := - (X1 => X1, - X2 => X2, - P => K1, - Q => K2, - FP => K1F, - Scl => Scal); + Reset (SRN.Generator (Gen)); end Reset; - ----------- - -- Reset -- - ----------- - - procedure Reset (Gen : Generator) is - Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; - Now : constant Calendar.Time := Calendar.Clock; - X1 : Int; - X2 : Int; - + procedure Reset (Gen : Generator; Initiator : Integer) is begin - X1 := Int (Calendar.Year (Now)) * 12 * 31 + - Int (Calendar.Month (Now) * 31) + - Int (Calendar.Day (Now)); - - X2 := Int (Calendar.Seconds (Now) * Duration (1000.0)); - - X1 := 2 + X1 mod (K1 - 3); - X2 := 2 + X2 mod (K2 - 3); - - -- Eliminate visible effects of same day starts - - for J in 1 .. 5 loop - X1 := Square_Mod_N (X1, K1); - X2 := Square_Mod_N (X2, K2); - end loop; - - Genp.all := - (X1 => X1, - X2 => X2, - P => K1, - Q => K2, - FP => K1F, - Scl => Scal); - + Reset (SRN.Generator (Gen), Initiator); end Reset; - ----------- - -- Reset -- - ----------- - procedure Reset (Gen : Generator; From_State : State) is - Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; begin - Genp.all := From_State; + Reset (SRN.Generator (Gen), SRN.State (From_State)); end Reset; ---------- -- Save -- ---------- - procedure Save (Gen : Generator; To_State : out State) is + procedure Save (Gen : Generator; To_State : out State) is begin - To_State := Gen.Gen_State; + Save (SRN.Generator (Gen), SRN.State (To_State)); end Save; - ------------------ - -- Square_Mod_N -- - ------------------ - - function Square_Mod_N (X, N : Int) return Int is - begin - return Int ((Integer_64 (X) ** 2) mod (Integer_64 (N))); - end Square_Mod_N; - ----------- -- Value -- ----------- function Value (Coded_State : String) return State is - Last : constant Natural := Coded_State'Last; - Start : Positive := Coded_State'First; - Stop : Positive := Coded_State'First; - Outs : State; - begin - while Stop <= Last and then Coded_State (Stop) /= ',' loop - Stop := Stop + 1; - end loop; - - if Stop > Last then - raise Constraint_Error; - end if; - - Outs.X1 := Int'Value (Coded_State (Start .. Stop - 1)); - Start := Stop + 1; - - loop - Stop := Stop + 1; - exit when Stop > Last or else Coded_State (Stop) = ','; - end loop; - - if Stop > Last then - raise Constraint_Error; - end if; - - Outs.X2 := Int'Value (Coded_State (Start .. Stop - 1)); - Outs.Q := Int'Value (Coded_State (Stop + 1 .. Last)); - Outs.P := Outs.Q * 2 + 1; - Outs.FP := Flt (Outs.P); - Outs.Scl := (RstL - RstF + 1.0) / (Flt (Outs.P) * Flt (Outs.Q)); - - -- Now do *some* sanity checks - - if Outs.Q < 31 - or else Outs.X1 not in 2 .. Outs.P - 1 - or else Outs.X2 not in 2 .. Outs.Q - 1 - then - raise Constraint_Error; - end if; - - return Outs; + return State (SRN.State'(Value (Coded_State))); end Value; end Ada.Numerics.Discrete_Random; diff --git a/gcc/ada/a-nudira.ads b/gcc/ada/a-nudira.ads index 425aa6f9bc9..385f33619f3 100644 --- a/gcc/ada/a-nudira.ads +++ b/gcc/ada/a-nudira.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -33,39 +33,24 @@ -- -- ------------------------------------------------------------------------------ --- Note: the implementation used in this package was contributed by Robert --- Eachus. It is based on the work of L. Blum, M. Blum, and M. Shub, SIAM --- Journal of Computing, Vol 15. No 2, May 1986. The particular choices for P --- and Q chosen here guarantee a period of 562,085,314,430,582 (about 2**49), --- and the generated sequence has excellent randomness properties. For further --- details, see the paper "Fast Generation of Trustworthy Random Numbers", by --- Robert Eachus, which describes both the algorithm and the efficient --- implementation approach used here. +-- Note: the implementation used in this package is a version of the +-- Mersenne Twister. See s-rannum.adb for details and references. -with Interfaces; +with System.Random_Numbers; generic type Result_Subtype is (<>); package Ada.Numerics.Discrete_Random is - -- The algorithm used here is reliable from a required statistical point of - -- view only up to 48 bits. We try to behave reasonably in the case of - -- larger types, but we can't guarantee the required properties. So - -- generate a warning for these (slightly) dubious cases. - - pragma Compile_Time_Warning - (Result_Subtype'Size > 48, - "statistical properties not guaranteed for size > 48"); - -- Basic facilities type Generator is limited private; function Random (Gen : Generator) return Result_Subtype; - procedure Reset (Gen : Generator); procedure Reset (Gen : Generator; Initiator : Integer); + procedure Reset (Gen : Generator); -- Advanced facilities @@ -74,41 +59,15 @@ package Ada.Numerics.Discrete_Random is procedure Save (Gen : Generator; To_State : out State); procedure Reset (Gen : Generator; From_State : State); - Max_Image_Width : constant := 80; + Max_Image_Width : constant := System.Random_Numbers.Max_Image_Width; function Image (Of_State : State) return String; function Value (Coded_State : String) return State; private - subtype Int is Interfaces.Integer_32; - subtype Rst is Result_Subtype; - - -- We prefer to use 14 digits for Flt, but some targets are more limited - - type Flt is digits Positive'Min (14, Long_Long_Float'Digits); - - RstF : constant Flt := Flt (Rst'Pos (Rst'First)); - RstL : constant Flt := Flt (Rst'Pos (Rst'Last)); - - Offs : constant Flt := RstF - 0.5; - - K1 : constant := 94_833_359; - K1F : constant := 94_833_359.0; - K2 : constant := 47_416_679; - K2F : constant := 47_416_679.0; - Scal : constant Flt := (RstL - RstF + 1.0) / (K1F * K2F); - type State is record - X1 : Int := Int (2999 ** 2); - X2 : Int := Int (1439 ** 2); - P : Int := K1; - Q : Int := K2; - FP : Flt := K1F; - Scl : Flt := Scal; - end record; + type Generator is new System.Random_Numbers.Generator; - type Generator is limited record - Gen_State : State; - end record; + type State is new System.Random_Numbers.State; end Ada.Numerics.Discrete_Random; diff --git a/gcc/ada/a-nuflra.adb b/gcc/ada/a-nuflra.adb index 7e6323b8e8d..2c6fbc47f6d 100644 --- a/gcc/ada/a-nuflra.adb +++ b/gcc/ada/a-nuflra.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,97 +29,10 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Calendar; - package body Ada.Numerics.Float_Random is - ------------------------- - -- Implementation Note -- - ------------------------- - - -- The design of this spec is very awkward, as a result of Ada 95 not - -- permitting in-out parameters for function formals (most naturally - -- Generator values would be passed this way). In pure Ada 95, the only - -- solution is to use the heap and pointers, and, to avoid memory leaks, - -- controlled types. - - -- This is awfully heavy, so what we do is to use Unrestricted_Access to - -- get a pointer to the state in the passed Generator. This works because - -- Generator is a limited type and will thus always be passed by reference. - - type Pointer is access all State; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Euclid (P, Q : Int; X, Y : out Int; GCD : out Int); - - function Euclid (P, Q : Int) return Int; - - function Square_Mod_N (X, N : Int) return Int; - - ------------ - -- Euclid -- - ------------ - - procedure Euclid (P, Q : Int; X, Y : out Int; GCD : out Int) is - - XT : Int := 1; - YT : Int := 0; - - procedure Recur - (P, Q : Int; -- a (i-1), a (i) - X, Y : Int; -- x (i), y (i) - XP, YP : in out Int; -- x (i-1), y (i-1) - GCD : out Int); - - procedure Recur - (P, Q : Int; - X, Y : Int; - XP, YP : in out Int; - GCD : out Int) - is - Quo : Int := P / Q; -- q <-- |_ a (i-1) / a (i) _| - XT : Int := X; -- x (i) - YT : Int := Y; -- y (i) - - begin - if P rem Q = 0 then -- while does not divide - GCD := Q; - XP := X; - YP := Y; - else - Recur (Q, P - Q * Quo, XP - Quo * X, YP - Quo * Y, XT, YT, Quo); - - -- a (i) <== a (i) - -- a (i+1) <-- a (i-1) - q*a (i) - -- x (i+1) <-- x (i-1) - q*x (i) - -- y (i+1) <-- y (i-1) - q*y (i) - -- x (i) <== x (i) - -- y (i) <== y (i) - - XP := XT; - YP := YT; - GCD := Quo; - end if; - end Recur; - - -- Start of processing for Euclid - - begin - Recur (P, Q, 0, 1, XT, YT, GCD); - X := XT; - Y := YT; - end Euclid; - - function Euclid (P, Q : Int) return Int is - X, Y, GCD : Int; - pragma Unreferenced (Y, GCD); - begin - Euclid (P, Q, X, Y, GCD); - return X; - end Euclid; + package SRN renames System.Random_Numbers; + use SRN; ----------- -- Image -- @@ -127,185 +40,63 @@ package body Ada.Numerics.Float_Random is function Image (Of_State : State) return String is begin - return Int'Image (Of_State.X1) & ',' & Int'Image (Of_State.X2) - & ',' & - Int'Image (Of_State.P) & ',' & Int'Image (Of_State.Q); + return Image (SRN.State (Of_State)); end Image; ------------ -- Random -- ------------ - function Random (Gen : Generator) return Uniformly_Distributed is - Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; - + function Random (Gen : Generator) return Uniformly_Distributed is begin - Genp.X1 := Square_Mod_N (Genp.X1, Genp.P); - Genp.X2 := Square_Mod_N (Genp.X2, Genp.Q); - return - Float ((Flt (((Genp.X2 - Genp.X1) * Genp.X) - mod Genp.Q) * Flt (Genp.P) - + Flt (Genp.X1)) * Genp.Scl); + return Random (SRN.Generator (Gen)); end Random; ----------- -- Reset -- ----------- - -- Version that works from given initiator value - - procedure Reset (Gen : Generator; Initiator : Integer) is - Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; - X1, X2 : Int; + -- Version that works from calendar + procedure Reset (Gen : Generator) is begin - X1 := 2 + Int (Initiator) mod (K1 - 3); - X2 := 2 + Int (Initiator) mod (K2 - 3); - - -- Eliminate effects of small initiators - - for J in 1 .. 5 loop - X1 := Square_Mod_N (X1, K1); - X2 := Square_Mod_N (X2, K2); - end loop; - - Genp.all := - (X1 => X1, - X2 => X2, - P => K1, - Q => K2, - X => 1, - Scl => Scal); + Reset (SRN.Generator (Gen)); end Reset; - -- Version that works from specific saved state - - procedure Reset (Gen : Generator; From_State : State) is - Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; + -- Version that works from given initiator value + procedure Reset (Gen : Generator; Initiator : Integer) is begin - Genp.all := From_State; + Reset (SRN.Generator (Gen), Initiator); end Reset; - -- Version that works from calendar - - procedure Reset (Gen : Generator) is - Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; - Now : constant Calendar.Time := Calendar.Clock; - X1, X2 : Int; + -- Version that works from specific saved state + procedure Reset (Gen : Generator; From_State : State) is begin - X1 := Int (Calendar.Year (Now)) * 12 * 31 + - Int (Calendar.Month (Now)) * 31 + - Int (Calendar.Day (Now)); - - X2 := Int (Calendar.Seconds (Now) * Duration (1000.0)); - - X1 := 2 + X1 mod (K1 - 3); - X2 := 2 + X2 mod (K2 - 3); - - -- Eliminate visible effects of same day starts - - for J in 1 .. 5 loop - X1 := Square_Mod_N (X1, K1); - X2 := Square_Mod_N (X2, K2); - end loop; - - Genp.all := - (X1 => X1, - X2 => X2, - P => K1, - Q => K2, - X => 1, - Scl => Scal); - + Reset (SRN.Generator (Gen), From_State); end Reset; ---------- -- Save -- ---------- - procedure Save (Gen : Generator; To_State : out State) is + procedure Save (Gen : Generator; To_State : out State) is begin - To_State := Gen.Gen_State; + Save (SRN.Generator (Gen), To_State); end Save; - ------------------ - -- Square_Mod_N -- - ------------------ - - function Square_Mod_N (X, N : Int) return Int is - Temp : constant Flt := Flt (X) * Flt (X); - Div : Int; - - begin - Div := Int (Temp / Flt (N)); - Div := Int (Temp - Flt (Div) * Flt (N)); - - if Div < 0 then - return Div + N; - else - return Div; - end if; - end Square_Mod_N; - ----------- -- Value -- ----------- function Value (Coded_State : String) return State is - Last : constant Natural := Coded_State'Last; - Start : Positive := Coded_State'First; - Stop : Positive := Coded_State'First; - Outs : State; - + G : SRN.Generator; + S : SRN.State; begin - while Stop <= Last and then Coded_State (Stop) /= ',' loop - Stop := Stop + 1; - end loop; - - if Stop > Last then - raise Constraint_Error; - end if; - - Outs.X1 := Int'Value (Coded_State (Start .. Stop - 1)); - Start := Stop + 1; - - loop - Stop := Stop + 1; - exit when Stop > Last or else Coded_State (Stop) = ','; - end loop; - - if Stop > Last then - raise Constraint_Error; - end if; - - Outs.X2 := Int'Value (Coded_State (Start .. Stop - 1)); - Start := Stop + 1; - - loop - Stop := Stop + 1; - exit when Stop > Last or else Coded_State (Stop) = ','; - end loop; - - if Stop > Last then - raise Constraint_Error; - end if; - - Outs.P := Int'Value (Coded_State (Start .. Stop - 1)); - Outs.Q := Int'Value (Coded_State (Stop + 1 .. Last)); - Outs.X := Euclid (Outs.P, Outs.Q); - Outs.Scl := 1.0 / (Flt (Outs.P) * Flt (Outs.Q)); - - -- Now do *some* sanity checks - - if Outs.Q < 31 or else Outs.P < 31 - or else Outs.X1 not in 2 .. Outs.P - 1 - or else Outs.X2 not in 2 .. Outs.Q - 1 - then - raise Constraint_Error; - end if; - - return Outs; + Reset (G, Coded_State); + Save (G, S); + return State (S); end Value; + end Ada.Numerics.Float_Random; diff --git a/gcc/ada/a-nuflra.ads b/gcc/ada/a-nuflra.ads index e81842e23d8..5a448a7811e 100644 --- a/gcc/ada/a-nuflra.ads +++ b/gcc/ada/a-nuflra.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -33,17 +33,10 @@ -- -- ------------------------------------------------------------------------------ --- Note: the implementation used in this package was contributed by --- Robert Eachus. It is based on the work of L. Blum, M. Blum, and --- M. Shub, SIAM Journal of Computing, Vol 15. No 2, May 1986. The --- particular choices for P and Q chosen here guarantee a period of --- 562,085,314,430,582 (about 2**49), and the generated sequence has --- excellent randomness properties. For further details, see the --- paper "Fast Generation of Trustworthy Random Numbers", by Robert --- Eachus, which describes both the algorithm and the efficient --- implementation approach used here. +-- Note: the implementation used in this package is a version of the +-- Mersenne Twister. See s-rannum.adb for details and references. -with Interfaces; +with System.Random_Numbers; package Ada.Numerics.Float_Random is @@ -65,35 +58,15 @@ package Ada.Numerics.Float_Random is procedure Save (Gen : Generator; To_State : out State); procedure Reset (Gen : Generator; From_State : State); - Max_Image_Width : constant := 80; + Max_Image_Width : constant := System.Random_Numbers.Max_Image_Width; function Image (Of_State : State) return String; function Value (Coded_State : String) return State; private - type Int is new Interfaces.Integer_32; - - -- We prefer to use 14 digits for Flt, but some targets are more limited - - type Flt is digits Positive'Min (14, Long_Long_Float'Digits); - - K1 : constant := 94_833_359; - K1F : constant := 94_833_359.0; - K2 : constant := 47_416_679; - K2F : constant := 47_416_679.0; - Scal : constant := 1.0 / (K1F * K2F); - - type State is record - X1 : Int := 2999 ** 2; -- Square mod p - X2 : Int := 1439 ** 2; -- Square mod q - P : Int := K1; - Q : Int := K2; - X : Int := 1; - Scl : Flt := Scal; - end record; - - type Generator is limited record - Gen_State : State; - end record; + + type Generator is new System.Random_Numbers.Generator; + + type State is new System.Random_Numbers.State; end Ada.Numerics.Float_Random; diff --git a/gcc/ada/a-reatim.adb b/gcc/ada/a-reatim.adb index c3cbec69ddc..026c28941a0 100644 --- a/gcc/ada/a-reatim.adb +++ b/gcc/ada/a-reatim.adb @@ -7,7 +7,7 @@ -- B o d y -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2009, AdaCore -- +-- Copyright (C) 1995-2010, AdaCore -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -32,6 +32,8 @@ -- -- ------------------------------------------------------------------------------ +with System.Tasking; + package body Ada.Real_Time is --------- @@ -242,4 +244,10 @@ package body Ada.Real_Time is return Time_Span (D); end To_Time_Span; +begin + -- Ensure that the tasking run time is initialized when using clock and/or + -- delay operations. The initialization routine has the required machinery + -- to prevent multiple calls to Initialize. + + System.Tasking.Initialize; end Ada.Real_Time; diff --git a/gcc/ada/a-retide.adb b/gcc/ada/a-retide.adb index f159ed6fc33..ecc61f6913a 100644 --- a/gcc/ada/a-retide.adb +++ b/gcc/ada/a-retide.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -75,10 +75,4 @@ package body Ada.Real_Time.Delays is return To_Duration (Time_Span (T)); end To_Duration; -begin - -- Ensure that the tasking run time is initialized when using delay - -- operations. The initialization routine has the required machinery to - -- prevent multiple calls to Initialize. - - System.Tasking.Initialize; end Ada.Real_Time.Delays; diff --git a/gcc/ada/a-strunb-shared.adb b/gcc/ada/a-strunb-shared.adb new file mode 100644 index 00000000000..f4083b59e93 --- /dev/null +++ b/gcc/ada/a-strunb-shared.adb @@ -0,0 +1,2086 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . U N B O U N D E D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Search; +with Ada.Unchecked_Deallocation; + +package body Ada.Strings.Unbounded is + + use Ada.Strings.Maps; + + Growth_Factor : constant := 32; + -- The growth factor controls how much extra space is allocated when + -- we have to increase the size of an allocated unbounded string. By + -- allocating extra space, we avoid the need to reallocate on every + -- append, particularly important when a string is built up by repeated + -- append operations of small pieces. This is expressed as a factor so + -- 32 means add 1/32 of the length of the string as growth space. + + Min_Mul_Alloc : constant := Standard'Maximum_Alignment; + -- Allocation will be done by a multiple of Min_Mul_Alloc. This causes + -- no memory loss as most (all?) malloc implementations are obliged to + -- align the returned memory on the maximum alignment as malloc does not + -- know the target alignment. + + procedure Sync_Add_And_Fetch + (Ptr : access Interfaces.Unsigned_32; + Value : Interfaces.Unsigned_32); + pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_4"); + + function Sync_Sub_And_Fetch + (Ptr : access Interfaces.Unsigned_32; + Value : Interfaces.Unsigned_32) return Interfaces.Unsigned_32; + pragma Import (Intrinsic, Sync_Sub_And_Fetch, "__sync_sub_and_fetch_4"); + + function Aligned_Max_Length (Max_Length : Natural) return Natural; + -- Returns recommended length of the shared string which is greater or + -- equal to specified length. Calculation take in sense alignment of the + -- allocated memory segments to use memory effectively by Append/Insert/etc + -- operations. + + --------- + -- "&" -- + --------- + + function "&" + (Left : Unbounded_String; + Right : Unbounded_String) return Unbounded_String + is + LR : constant Shared_String_Access := Left.Reference; + RR : constant Shared_String_Access := Right.Reference; + DL : constant Natural := LR.Last + RR.Last; + DR : Shared_String_Access; + + begin + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Left string is empty, return Rigth string + + elsif LR.Last = 0 then + Reference (RR); + DR := RR; + + -- Right string is empty, return Left string + + elsif RR.Last = 0 then + Reference (LR); + DR := LR; + + -- Overwise, allocate new shared string and fill data + + else + DR := Allocate (LR.Last + RR.Last); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (LR.Last + 1 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Unbounded_String; + Right : String) return Unbounded_String + is + LR : constant Shared_String_Access := Left.Reference; + DL : constant Natural := LR.Last + Right'Length; + DR : Shared_String_Access; + + begin + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Right is an empty string, return Left string + + elsif Right'Length = 0 then + Reference (LR); + DR := LR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (LR.Last + 1 .. DL) := Right; + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : String; + Right : Unbounded_String) return Unbounded_String + is + RR : constant Shared_String_Access := Right.Reference; + DL : constant Natural := Left'Length + RR.Last; + DR : Shared_String_Access; + + begin + -- Result is an empty string, reuse shared one + + if DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Left is empty string, return Right string + + elsif Left'Length = 0 then + Reference (RR); + DR := RR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Left'Length) := Left; + DR.Data (Left'Length + 1 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Unbounded_String; + Right : Character) return Unbounded_String + is + LR : constant Shared_String_Access := Left.Reference; + DL : constant Natural := LR.Last + 1; + DR : Shared_String_Access; + + begin + DR := Allocate (DL); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (DL) := Right; + DR.Last := DL; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Character; + Right : Unbounded_String) return Unbounded_String + is + RR : constant Shared_String_Access := Right.Reference; + DL : constant Natural := 1 + RR.Last; + DR : Shared_String_Access; + + begin + DR := Allocate (DL); + DR.Data (1) := Left; + DR.Data (2 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + + return (AF.Controlled with Reference => DR); + end "&"; + + --------- + -- "*" -- + --------- + + function "*" + (Left : Natural; + Right : Character) return Unbounded_String + is + DR : Shared_String_Access; + + begin + -- Result is an empty string, reuse shared empty string + + if Left = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (Left); + + for J in 1 .. Left loop + DR.Data (J) := Right; + end loop; + + DR.Last := Left; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + function "*" + (Left : Natural; + Right : String) return Unbounded_String + is + DL : constant Natural := Left * Right'Length; + DR : Shared_String_Access; + K : Positive; + + begin + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + K := 1; + + for J in 1 .. Left loop + DR.Data (K .. K + Right'Length - 1) := Right; + K := K + Right'Length; + end loop; + + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + function "*" + (Left : Natural; + Right : Unbounded_String) return Unbounded_String + is + RR : constant Shared_String_Access := Right.Reference; + DL : constant Natural := Left * RR.Last; + DR : Shared_String_Access; + K : Positive; + + begin + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Coefficient is one, just return string itself + + elsif Left = 1 then + Reference (RR); + DR := RR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + K := 1; + + for J in 1 .. Left loop + DR.Data (K .. K + RR.Last - 1) := RR.Data (1 .. RR.Last); + K := K + RR.Last; + end loop; + + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + --------- + -- "<" -- + --------- + + function "<" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + RR : constant Shared_String_Access := Right.Reference; + begin + return LR.Data (1 .. LR.Last) < RR.Data (1 .. RR.Last); + end "<"; + + function "<" + (Left : Unbounded_String; + Right : String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) < Right; + end "<"; + + function "<" + (Left : String; + Right : Unbounded_String) return Boolean + is + RR : constant Shared_String_Access := Right.Reference; + begin + return Left < RR.Data (1 .. RR.Last); + end "<"; + + ---------- + -- "<=" -- + ---------- + + function "<=" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + RR : constant Shared_String_Access := Right.Reference; + + begin + -- LR = RR means two strings shares shared string, thus they are equal + + return LR = RR or else LR.Data (1 .. LR.Last) <= RR.Data (1 .. RR.Last); + end "<="; + + function "<=" + (Left : Unbounded_String; + Right : String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) <= Right; + end "<="; + + function "<=" + (Left : String; + Right : Unbounded_String) return Boolean + is + RR : constant Shared_String_Access := Right.Reference; + begin + return Left <= RR.Data (1 .. RR.Last); + end "<="; + + --------- + -- "=" -- + --------- + + function "=" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + RR : constant Shared_String_Access := Right.Reference; + + begin + return LR = RR or else LR.Data (1 .. LR.Last) = RR.Data (1 .. RR.Last); + -- LR = RR means two strings shares shared string, thus they are equal + end "="; + + function "=" + (Left : Unbounded_String; + Right : String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) = Right; + end "="; + + function "=" + (Left : String; + Right : Unbounded_String) return Boolean + is + RR : constant Shared_String_Access := Right.Reference; + begin + return Left = RR.Data (1 .. RR.Last); + end "="; + + --------- + -- ">" -- + --------- + + function ">" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + RR : constant Shared_String_Access := Right.Reference; + begin + return LR.Data (1 .. LR.Last) > RR.Data (1 .. RR.Last); + end ">"; + + function ">" + (Left : Unbounded_String; + Right : String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) > Right; + end ">"; + + function ">" + (Left : String; + Right : Unbounded_String) return Boolean + is + RR : constant Shared_String_Access := Right.Reference; + begin + return Left > RR.Data (1 .. RR.Last); + end ">"; + + ---------- + -- ">=" -- + ---------- + + function ">=" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + RR : constant Shared_String_Access := Right.Reference; + + begin + -- LR = RR means two strings shares shared string, thus they are equal + + return LR = RR or else LR.Data (1 .. LR.Last) >= RR.Data (1 .. RR.Last); + end ">="; + + function ">=" + (Left : Unbounded_String; + Right : String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) >= Right; + end ">="; + + function ">=" + (Left : String; + Right : Unbounded_String) return Boolean + is + RR : constant Shared_String_Access := Right.Reference; + begin + return Left >= RR.Data (1 .. RR.Last); + end ">="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Object : in out Unbounded_String) is + begin + Reference (Object.Reference); + end Adjust; + + ------------------------ + -- Aligned_Max_Length -- + ------------------------ + + function Aligned_Max_Length (Max_Length : Natural) return Natural is + Static_Size : constant Natural := + Empty_Shared_String'Size / Standard'Storage_Unit; + -- Total size of all static components + + begin + return + ((Static_Size + Max_Length - 1) / Min_Mul_Alloc + 2) * Min_Mul_Alloc + - Static_Size; + end Aligned_Max_Length; + + -------------- + -- Allocate -- + -------------- + + function Allocate (Max_Length : Natural) return Shared_String_Access is + begin + -- Empty string requested, return shared empty string + + if Max_Length = 0 then + Reference (Empty_Shared_String'Access); + return Empty_Shared_String'Access; + + -- Otherwise, allocate requested space (and probably some more room) + + else + return new Shared_String (Aligned_Max_Length (Max_Length)); + end if; + end Allocate; + + ------------ + -- Append -- + ------------ + + procedure Append + (Source : in out Unbounded_String; + New_Item : Unbounded_String) + is + SR : constant Shared_String_Access := Source.Reference; + NR : constant Shared_String_Access := New_Item.Reference; + DL : constant Natural := SR.Last + NR.Last; + DR : Shared_String_Access; + + begin + -- Source is an empty string, reuse New_Item data + + if SR.Last = 0 then + Reference (NR); + Source.Reference := NR; + Unreference (SR); + + -- New_Item is empty string, nothing to do + + elsif NR.Last = 0 then + null; + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); + SR.Last := DL; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + procedure Append + (Source : in out Unbounded_String; + New_Item : String) + is + SR : constant Shared_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_String_Access; + + begin + -- New_Item is an empty string, nothing to do + + if New_Item'Length = 0 then + null; + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (SR.Last + 1 .. DL) := New_Item; + SR.Last := DL; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (SR.Last + 1 .. DL) := New_Item; + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + procedure Append + (Source : in out Unbounded_String; + New_Item : Character) + is + SR : constant Shared_String_Access := Source.Reference; + DL : constant Natural := SR.Last + 1; + DR : Shared_String_Access; + + begin + -- Try to reuse existing shared string + + if Can_Be_Reused (SR, SR.Last + 1) then + SR.Data (SR.Last + 1) := New_Item; + SR.Last := SR.Last + 1; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (DL) := New_Item; + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + ------------------- + -- Can_Be_Reused -- + ------------------- + + function Can_Be_Reused + (Item : Shared_String_Access; + Length : Natural) return Boolean + is + use Interfaces; + begin + return + Item.Counter = 1 + and then Item.Max_Length >= Length + and then Item.Max_Length <= + Aligned_Max_Length (Length + Length / Growth_Factor); + end Can_Be_Reused; + + ----------- + -- Count -- + ----------- + + function Count + (Source : Unbounded_String; + Pattern : String; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); + end Count; + + function Count + (Source : Unbounded_String; + Pattern : String; + Mapping : Maps.Character_Mapping_Function) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); + end Count; + + function Count + (Source : Unbounded_String; + Set : Maps.Character_Set) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Count (SR.Data (1 .. SR.Last), Set); + end Count; + + ------------ + -- Delete -- + ------------ + + function Delete + (Source : Unbounded_String; + From : Positive; + Through : Natural) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + + begin + -- Empty slice is deleted, use the same shared string + + if From > Through then + Reference (SR); + DR := SR; + + -- Index is out of range + + elsif Through > SR.Last then + raise Index_Error; + + -- Compute size of the result + + else + DL := SR.Last - (Through - From + 1); + + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); + DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Delete; + + procedure Delete + (Source : in out Unbounded_String; + From : Positive; + Through : Natural) + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + + begin + -- Nothing changed, return + + if From > Through then + null; + + -- Through is outside of the range + + elsif Through > SR.Last then + raise Index_Error; + + else + DL := SR.Last - (Through - From + 1); + + -- Result is empty, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + Source.Reference := Empty_Shared_String'Access; + Unreference (SR); + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + SR.Last := DL; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); + DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Delete; + + ------------- + -- Element -- + ------------- + + function Element + (Source : Unbounded_String; + Index : Positive) return Character + is + SR : constant Shared_String_Access := Source.Reference; + begin + if Index <= SR.Last then + return SR.Data (Index); + else + raise Index_Error; + end if; + end Element; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Unbounded_String) is + SR : constant Shared_String_Access := Object.Reference; + + begin + if SR /= null then + + -- The same controlled object can be finalized several times for + -- some reason. As per 7.6.1(24) this should have no ill effect, + -- so we need to add a guard for the case of finalizing the same + -- object twice. + + Object.Reference := null; + Unreference (SR); + end if; + end Finalize; + + ---------------- + -- Find_Token -- + ---------------- + + procedure Find_Token + (Source : Unbounded_String; + Set : Maps.Character_Set; + Test : Strings.Membership; + First : out Positive; + Last : out Natural) + is + SR : constant Shared_String_Access := Source.Reference; + begin + Search.Find_Token (SR.Data (1 .. SR.Last), Set, Test, First, Last); + end Find_Token; + + ---------- + -- Free -- + ---------- + + procedure Free (X : in out String_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (String, String_Access); + begin + Deallocate (X); + end Free; + + ---------- + -- Head -- + ---------- + + function Head + (Source : Unbounded_String; + Count : Natural; + Pad : Character := Space) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DR : Shared_String_Access; + + begin + -- Result is empty, reuse shared empty string + + if Count = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Length of the string is the same as requested, reuse source shared + -- string. + + elsif Count = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (Count); + + -- Length of the source string is more than requested, copy + -- corresponding slice. + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (1 .. Count); + + -- Length of the source string is less then requested, copy all + -- contents and fill others by Pad character. + + else + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + + for J in SR.Last + 1 .. Count loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + end if; + + return (AF.Controlled with Reference => DR); + end Head; + + procedure Head + (Source : in out Unbounded_String; + Count : Natural; + Pad : Character := Space) + is + SR : constant Shared_String_Access := Source.Reference; + DR : Shared_String_Access; + + begin + -- Result is empty, reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_String'Access); + Source.Reference := Empty_Shared_String'Access; + Unreference (SR); + + -- Result is same as source string, reuse source shared string + + elsif Count = SR.Last then + null; + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, Count) then + if Count > SR.Last then + for J in SR.Last + 1 .. Count loop + SR.Data (J) := Pad; + end loop; + end if; + + SR.Last := Count; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (Count); + + -- Length of the source string is greater then requested, copy + -- corresponding slice. + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (1 .. Count); + + -- Length of the source string is less the requested, copy all + -- existing data and fill remaining positions with Pad characters. + + else + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + + for J in SR.Last + 1 .. Count loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + Source.Reference := DR; + Unreference (SR); + end if; + end Head; + + ----------- + -- Index -- + ----------- + + function Index + (Source : Unbounded_String; + Pattern : String; + Going : Strings.Direction := Strings.Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Index (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Index (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_String; + Set : Maps.Character_Set; + Test : Strings.Membership := Strings.Inside; + Going : Strings.Direction := Strings.Forward) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Index (SR.Data (1 .. SR.Last), Set, Test, Going); + end Index; + + function Index + (Source : Unbounded_String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Index + (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Index + (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_String; + Set : Maps.Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Index (SR.Data (1 .. SR.Last), Set, From, Test, Going); + end Index; + + --------------------- + -- Index_Non_Blank -- + --------------------- + + function Index_Non_Blank + (Source : Unbounded_String; + Going : Strings.Direction := Strings.Forward) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Index_Non_Blank (SR.Data (1 .. SR.Last), Going); + end Index_Non_Blank; + + function Index_Non_Blank + (Source : Unbounded_String; + From : Positive; + Going : Direction := Forward) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Index_Non_Blank (SR.Data (1 .. SR.Last), From, Going); + end Index_Non_Blank; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Object : in out Unbounded_String) is + begin + Reference (Object.Reference); + end Initialize; + + ------------ + -- Insert -- + ------------ + + function Insert + (Source : Unbounded_String; + Before : Positive; + New_Item : String) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_String_Access; + + begin + -- Check index first + + if Before > SR.Last + 1 then + raise Index_Error; + end if; + + -- Result is empty, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Inserted string is empty, reuse source shared string + + elsif New_Item'Length = 0 then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL + DL /Growth_Factor); + DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); + DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + DR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Insert; + + procedure Insert + (Source : in out Unbounded_String; + Before : Positive; + New_Item : String) + is + SR : constant Shared_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_String_Access; + + begin + -- Check bounds + + if Before > SR.Last + 1 then + raise Index_Error; + end if; + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + Source.Reference := Empty_Shared_String'Access; + Unreference (SR); + + -- Inserted string is empty, nothing to do + + elsif New_Item'Length = 0 then + null; + + -- Try to reuse existing shared string first + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + SR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + SR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); + DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + DR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Insert; + + ------------ + -- Length -- + ------------ + + function Length (Source : Unbounded_String) return Natural is + begin + return Source.Reference.Last; + end Length; + + --------------- + -- Overwrite -- + --------------- + + function Overwrite + (Source : Unbounded_String; + Position : Positive; + New_Item : String) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + + begin + -- Check bounds + + if Position > SR.Last + 1 then + raise Index_Error; + end if; + + DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Result is same as source string, reuse source shared string + + elsif New_Item'Length = 0 then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); + DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + DR.Data (Position + New_Item'Length .. DL) := + SR.Data (Position + New_Item'Length .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Overwrite; + + procedure Overwrite + (Source : in out Unbounded_String; + Position : Positive; + New_Item : String) + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + + begin + -- Bounds check + + if Position > SR.Last + 1 then + raise Index_Error; + end if; + + DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + Source.Reference := Empty_Shared_String'Access; + Unreference (SR); + + -- String unchanged, nothing to do + + elsif New_Item'Length = 0 then + null; + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + SR.Last := DL; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); + DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + DR.Data (Position + New_Item'Length .. DL) := + SR.Data (Position + New_Item'Length .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Overwrite; + + --------------- + -- Reference -- + --------------- + + procedure Reference (Item : not null Shared_String_Access) is + begin + Sync_Add_And_Fetch (Item.Counter'Access, 1); + end Reference; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Source : in out Unbounded_String; + Index : Positive; + By : Character) + is + SR : constant Shared_String_Access := Source.Reference; + DR : Shared_String_Access; + + begin + -- Bounds check. + + if Index <= SR.Last then + + -- Try to reuse existing shared string + + if Can_Be_Reused (SR, SR.Last) then + SR.Data (Index) := By; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (Index) := By; + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + + else + raise Index_Error; + end if; + end Replace_Element; + + ------------------- + -- Replace_Slice -- + ------------------- + + function Replace_Slice + (Source : Unbounded_String; + Low : Positive; + High : Natural; + By : String) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 then + raise Index_Error; + end if; + + -- Do replace operation when removed slice is not empty + + if High >= Low then + DL := By'Length + SR.Last + Low - High - 1; + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); + DR.Data (Low .. Low + By'Length - 1) := By; + DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + + -- Otherwise just insert string + + else + return Insert (Source, Low, By); + end if; + end Replace_Slice; + + procedure Replace_Slice + (Source : in out Unbounded_String; + Low : Positive; + High : Natural; + By : String) + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + + begin + -- Bounds check + + if Low > SR.Last + 1 then + raise Index_Error; + end if; + + -- Do replace operation only when replaced slice is not empty + + if High >= Low then + DL := By'Length + SR.Last + Low - High - 1; + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + Source.Reference := Empty_Shared_String'Access; + Unreference (SR); + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + SR.Data (Low .. Low + By'Length - 1) := By; + SR.Last := DL; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); + DR.Data (Low .. Low + By'Length - 1) := By; + DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + + -- Otherwise just insert item + + else + Insert (Source, Low, By); + end if; + end Replace_Slice; + + -------------------------- + -- Set_Unbounded_String -- + -------------------------- + + procedure Set_Unbounded_String + (Target : out Unbounded_String; + Source : String) + is + TR : constant Shared_String_Access := Target.Reference; + DR : Shared_String_Access; + + begin + -- In case of empty string, reuse empty shared string + + if Source'Length = 0 then + Reference (Empty_Shared_String'Access); + Target.Reference := Empty_Shared_String'Access; + + else + -- Try to reuse existing shared string + + if Can_Be_Reused (TR, Source'Length) then + Reference (TR); + DR := TR; + + -- Otherwise allocate new shared string + + else + DR := Allocate (Source'Length); + Target.Reference := DR; + end if; + + DR.Data (1 .. Source'Length) := Source; + DR.Last := Source'Length; + end if; + + Unreference (TR); + end Set_Unbounded_String; + + ----------- + -- Slice -- + ----------- + + function Slice + (Source : Unbounded_String; + Low : Positive; + High : Natural) return String + is + SR : constant Shared_String_Access := Source.Reference; + + begin + -- Note: test of High > Length is in accordance with AI95-00128 + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + else + return SR.Data (Low .. High); + end if; + end Slice; + + ---------- + -- Tail -- + ---------- + + function Tail + (Source : Unbounded_String; + Count : Natural; + Pad : Character := Space) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DR : Shared_String_Access; + + begin + -- For empty result reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Result is whole source string, reuse source shared string + + elsif Count = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (Count); + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); + + else + for J in 1 .. Count - SR.Last loop + DR.Data (J) := Pad; + end loop; + + DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); + end if; + + DR.Last := Count; + end if; + + return (AF.Controlled with Reference => DR); + end Tail; + + procedure Tail + (Source : in out Unbounded_String; + Count : Natural; + Pad : Character := Space) + is + SR : constant Shared_String_Access := Source.Reference; + DR : Shared_String_Access; + + procedure Common + (SR : Shared_String_Access; + DR : Shared_String_Access; + Count : Natural); + -- Common code of tail computation. SR/DR can point to the same object + + ------------ + -- Common -- + ------------ + + procedure Common + (SR : Shared_String_Access; + DR : Shared_String_Access; + Count : Natural) is + begin + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); + + else + DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); + + for J in 1 .. Count - SR.Last loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + end Common; + + begin + -- Result is empty string, reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_String'Access); + Source.Reference := Empty_Shared_String'Access; + Unreference (SR); + + -- Length of the result is the same as length of the source string, + -- reuse source shared string. + + elsif Count = SR.Last then + null; + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, Count) then + Common (SR, SR, Count); + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (Count); + Common (SR, DR, Count); + Source.Reference := DR; + Unreference (SR); + end if; + end Tail; + + --------------- + -- To_String -- + --------------- + + function To_String (Source : Unbounded_String) return String is + begin + return Source.Reference.Data (1 .. Source.Reference.Last); + end To_String; + + ------------------------- + -- To_Unbounded_String -- + ------------------------- + + function To_Unbounded_String (Source : String) return Unbounded_String is + DR : constant Shared_String_Access := Allocate (Source'Length); + begin + DR.Data (1 .. Source'Length) := Source; + DR.Last := Source'Length; + return (AF.Controlled with Reference => DR); + end To_Unbounded_String; + + function To_Unbounded_String (Length : Natural) return Unbounded_String is + DR : constant Shared_String_Access := Allocate (Length); + begin + DR.Last := Length; + return (AF.Controlled with Reference => DR); + end To_Unbounded_String; + + --------------- + -- Translate -- + --------------- + + function Translate + (Source : Unbounded_String; + Mapping : Maps.Character_Mapping) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DR : Shared_String_Access; + + begin + -- Nothing to translate, reuse empty shared string + + if SR.Last = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + DR.Last := SR.Last; + end if; + + return (AF.Controlled with Reference => DR); + end Translate; + + procedure Translate + (Source : in out Unbounded_String; + Mapping : Maps.Character_Mapping) + is + SR : constant Shared_String_Access := Source.Reference; + DR : Shared_String_Access; + + begin + -- Nothing to translate + + if SR.Last = 0 then + null; + + -- Try to reuse shared string + + elsif Can_Be_Reused (SR, SR.Last) then + for J in 1 .. SR.Last loop + SR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + end Translate; + + function Translate + (Source : Unbounded_String; + Mapping : Maps.Character_Mapping_Function) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DR : Shared_String_Access; + + begin + -- Nothing to translate, reuse empty shared string + + if SR.Last = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + DR.Last := SR.Last; + end if; + + return (AF.Controlled with Reference => DR); + + exception + when others => + Unreference (DR); + + raise; + end Translate; + + procedure Translate + (Source : in out Unbounded_String; + Mapping : Maps.Character_Mapping_Function) + is + SR : constant Shared_String_Access := Source.Reference; + DR : Shared_String_Access; + + begin + -- Nothing to translate + + if SR.Last = 0 then + null; + + -- Try to reuse shared string + + elsif Can_Be_Reused (SR, SR.Last) then + for J in 1 .. SR.Last loop + SR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + + exception + when others => + if DR /= null then + Unreference (DR); + end if; + + raise; + end Translate; + + ---------- + -- Trim -- + ---------- + + function Trim + (Source : Unbounded_String; + Side : Trim_End) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index_Non_Blank (Source, Forward); + + -- All blanks, reuse empty shared string + + if Low = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + else + case Side is + when Left => + High := SR.Last; + DL := SR.Last - Low + 1; + + when Right => + Low := 1; + High := Index_Non_Blank (Source, Backward); + DL := High; + + when Both => + High := Index_Non_Blank (Source, Backward); + DL := High - Low + 1; + end case; + + -- Length of the result is the same as length of the source string, + -- reuse source shared string. + + if DL = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Trim; + + procedure Trim + (Source : in out Unbounded_String; + Side : Trim_End) + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index_Non_Blank (Source, Forward); + + -- All blanks, reuse empty shared string + + if Low = 0 then + Reference (Empty_Shared_String'Access); + Source.Reference := Empty_Shared_String'Access; + Unreference (SR); + + else + case Side is + when Left => + High := SR.Last; + DL := SR.Last - Low + 1; + + when Right => + Low := 1; + High := Index_Non_Blank (Source, Backward); + DL := High; + + when Both => + High := Index_Non_Blank (Source, Backward); + DL := High - Low + 1; + end case; + + -- Length of the result is the same as length of the source string, + -- nothing to do. + + if DL = SR.Last then + null; + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (1 .. DL) := SR.Data (Low .. High); + SR.Last := DL; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Trim; + + function Trim + (Source : Unbounded_String; + Left : Maps.Character_Set; + Right : Maps.Character_Set) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index (Source, Left, Outside, Forward); + + -- Source includes only characters from Left set, reuse empty shared + -- string. + + if Low = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + else + High := Index (Source, Right, Outside, Backward); + DL := Integer'Max (0, High - Low + 1); + + -- Source includes only characters from Right set or result string + -- is empty, reuse empty shared string. + + if High = 0 or else DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Trim; + + procedure Trim + (Source : in out Unbounded_String; + Left : Maps.Character_Set; + Right : Maps.Character_Set) + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index (Source, Left, Outside, Forward); + + -- Source includes only characters from Left set, reuse empty shared + -- string. + + if Low = 0 then + Reference (Empty_Shared_String'Access); + Source.Reference := Empty_Shared_String'Access; + Unreference (SR); + + else + High := Index (Source, Right, Outside, Backward); + DL := Integer'Max (0, High - Low + 1); + + -- Source includes only characters from Right set or result string + -- is empty, reuse empty shared string. + + if High = 0 or else DL = 0 then + Reference (Empty_Shared_String'Access); + Source.Reference := Empty_Shared_String'Access; + Unreference (SR); + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (1 .. DL) := SR.Data (Low .. High); + SR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Trim; + + --------------------- + -- Unbounded_Slice -- + --------------------- + + function Unbounded_Slice + (Source : Unbounded_String; + Low : Positive; + High : Natural) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + -- Result is empty slice, reuse empty shared string + + elsif Low > High then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DL := High - Low + 1; + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Unbounded_Slice; + + procedure Unbounded_Slice + (Source : Unbounded_String; + Target : out Unbounded_String; + Low : Positive; + High : Natural) + is + SR : constant Shared_String_Access := Source.Reference; + TR : constant Shared_String_Access := Target.Reference; + DL : Natural; + DR : Shared_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + -- Result is empty slice, reuse empty shared string + + elsif Low > High then + Reference (Empty_Shared_String'Access); + Target.Reference := Empty_Shared_String'Access; + Unreference (TR); + + else + DL := High - Low + 1; + + -- Try to reuse existing shared string + + if Can_Be_Reused (TR, DL) then + TR.Data (1 .. DL) := SR.Data (Low .. High); + TR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Target.Reference := DR; + Unreference (TR); + end if; + end if; + end Unbounded_Slice; + + ----------------- + -- Unreference -- + ----------------- + + procedure Unreference (Item : not null Shared_String_Access) is + use Interfaces; + + procedure Free is + new Ada.Unchecked_Deallocation (Shared_String, Shared_String_Access); + + Aux : Shared_String_Access := Item; + + begin + if Sync_Sub_And_Fetch (Aux.Counter'Access, 1) = 0 then + + -- Reference counter of Empty_Shared_String must never reach zero + + pragma Assert (Aux /= Empty_Shared_String'Access); + + Free (Aux); + end if; + end Unreference; + +end Ada.Strings.Unbounded; diff --git a/gcc/ada/a-strunb-shared.ads b/gcc/ada/a-strunb-shared.ads new file mode 100644 index 00000000000..b4b7c622759 --- /dev/null +++ b/gcc/ada/a-strunb-shared.ads @@ -0,0 +1,481 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . U N B O U N D E D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT 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 distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an implementation of Ada.Strings.Unbounded that uses +-- reference counts to implement copy on modification (rather than copy on +-- assignment). This is significantly more efficient on many targets. + +-- This version is supported on: +-- - all Alpha platforms +-- - all ia64 platforms +-- - all PowerPC platforms +-- - all SPARC V9 platforms +-- - all x86_64 platforms + + -- This package uses several techniques to increase speed: + + -- - Implicit sharing or copy-on-write. An Unbounded_String contains only + -- the reference to the data which is shared between several instances. + -- The shared data is reallocated only when its value is changed and + -- the object mutation can't be used or it is unefficient to use it. + + -- - Object mutation. Shared data object can be reused without memory + -- reallocation when all of the following requirements are met: + -- - shared data object is no longer used by anyone else. + -- - the size is sufficient to store new value. + -- - the gap after reuse is less then a defined threashold. + + -- - Memory preallocation. Most of used memory allocation algorithms + -- allign allocated segments on the some boundary, thus some amount of + -- additional memory can be preallocated without any impact. Such + -- preallocated memory can used later by Append/Insert operations + -- without reallocation. + + -- Reference counting uses GCC builtin atomic operations, which allows to + -- safely share internal data between Ada tasks. Nevertheless, this not + -- make objects of Unbounded_String thread-safe, so each instance can't be + -- accessed by several tasks simulatenously. + +with Ada.Strings.Maps; +private with Ada.Finalization; +private with Interfaces; + +package Ada.Strings.Unbounded is + pragma Preelaborate; + + type Unbounded_String is private; + pragma Preelaborable_Initialization (Unbounded_String); + + Null_Unbounded_String : constant Unbounded_String; + + function Length (Source : Unbounded_String) return Natural; + + type String_Access is access all String; + + procedure Free (X : in out String_Access); + + -------------------------------------------------------- + -- Conversion, Concatenation, and Selection Functions -- + -------------------------------------------------------- + + function To_Unbounded_String + (Source : String) return Unbounded_String; + + function To_Unbounded_String + (Length : Natural) return Unbounded_String; + + function To_String (Source : Unbounded_String) return String; + + procedure Set_Unbounded_String + (Target : out Unbounded_String; + Source : String); + pragma Ada_05 (Set_Unbounded_String); + + procedure Append + (Source : in out Unbounded_String; + New_Item : Unbounded_String); + + procedure Append + (Source : in out Unbounded_String; + New_Item : String); + + procedure Append + (Source : in out Unbounded_String; + New_Item : Character); + + function "&" + (Left : Unbounded_String; + Right : Unbounded_String) return Unbounded_String; + + function "&" + (Left : Unbounded_String; + Right : String) return Unbounded_String; + + function "&" + (Left : String; + Right : Unbounded_String) return Unbounded_String; + + function "&" + (Left : Unbounded_String; + Right : Character) return Unbounded_String; + + function "&" + (Left : Character; + Right : Unbounded_String) return Unbounded_String; + + function Element + (Source : Unbounded_String; + Index : Positive) return Character; + + procedure Replace_Element + (Source : in out Unbounded_String; + Index : Positive; + By : Character); + + function Slice + (Source : Unbounded_String; + Low : Positive; + High : Natural) return String; + + function Unbounded_Slice + (Source : Unbounded_String; + Low : Positive; + High : Natural) return Unbounded_String; + pragma Ada_05 (Unbounded_Slice); + + procedure Unbounded_Slice + (Source : Unbounded_String; + Target : out Unbounded_String; + Low : Positive; + High : Natural); + pragma Ada_05 (Unbounded_Slice); + + function "=" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean; + + function "=" + (Left : Unbounded_String; + Right : String) return Boolean; + + function "=" + (Left : String; + Right : Unbounded_String) return Boolean; + + function "<" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean; + + function "<" + (Left : Unbounded_String; + Right : String) return Boolean; + + function "<" + (Left : String; + Right : Unbounded_String) return Boolean; + + function "<=" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean; + + function "<=" + (Left : Unbounded_String; + Right : String) return Boolean; + + function "<=" + (Left : String; + Right : Unbounded_String) return Boolean; + + function ">" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean; + + function ">" + (Left : Unbounded_String; + Right : String) return Boolean; + + function ">" + (Left : String; + Right : Unbounded_String) return Boolean; + + function ">=" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean; + + function ">=" + (Left : Unbounded_String; + Right : String) return Boolean; + + function ">=" + (Left : String; + Right : Unbounded_String) return Boolean; + + ------------------------ + -- Search Subprograms -- + ------------------------ + + function Index + (Source : Unbounded_String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + + function Index + (Source : Unbounded_String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural; + + function Index + (Source : Unbounded_String; + Set : Maps.Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index + (Source : Unbounded_String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Unbounded_String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Unbounded_String; + Set : Maps.Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index); + + function Index_Non_Blank + (Source : Unbounded_String; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : Unbounded_String; + From : Positive; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index_Non_Blank); + + function Count + (Source : Unbounded_String; + Pattern : String; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + + function Count + (Source : Unbounded_String; + Pattern : String; + Mapping : Maps.Character_Mapping_Function) return Natural; + + function Count + (Source : Unbounded_String; + Set : Maps.Character_Set) return Natural; + + procedure Find_Token + (Source : Unbounded_String; + Set : Maps.Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + + ------------------------------------ + -- String Translation Subprograms -- + ------------------------------------ + + function Translate + (Source : Unbounded_String; + Mapping : Maps.Character_Mapping) return Unbounded_String; + + procedure Translate + (Source : in out Unbounded_String; + Mapping : Maps.Character_Mapping); + + function Translate + (Source : Unbounded_String; + Mapping : Maps.Character_Mapping_Function) return Unbounded_String; + + procedure Translate + (Source : in out Unbounded_String; + Mapping : Maps.Character_Mapping_Function); + + --------------------------------------- + -- String Transformation Subprograms -- + --------------------------------------- + + function Replace_Slice + (Source : Unbounded_String; + Low : Positive; + High : Natural; + By : String) return Unbounded_String; + + procedure Replace_Slice + (Source : in out Unbounded_String; + Low : Positive; + High : Natural; + By : String); + + function Insert + (Source : Unbounded_String; + Before : Positive; + New_Item : String) return Unbounded_String; + + procedure Insert + (Source : in out Unbounded_String; + Before : Positive; + New_Item : String); + + function Overwrite + (Source : Unbounded_String; + Position : Positive; + New_Item : String) return Unbounded_String; + + procedure Overwrite + (Source : in out Unbounded_String; + Position : Positive; + New_Item : String); + + function Delete + (Source : Unbounded_String; + From : Positive; + Through : Natural) return Unbounded_String; + + procedure Delete + (Source : in out Unbounded_String; + From : Positive; + Through : Natural); + + function Trim + (Source : Unbounded_String; + Side : Trim_End) return Unbounded_String; + + procedure Trim + (Source : in out Unbounded_String; + Side : Trim_End); + + function Trim + (Source : Unbounded_String; + Left : Maps.Character_Set; + Right : Maps.Character_Set) return Unbounded_String; + + procedure Trim + (Source : in out Unbounded_String; + Left : Maps.Character_Set; + Right : Maps.Character_Set); + + function Head + (Source : Unbounded_String; + Count : Natural; + Pad : Character := Space) return Unbounded_String; + + procedure Head + (Source : in out Unbounded_String; + Count : Natural; + Pad : Character := Space); + + function Tail + (Source : Unbounded_String; + Count : Natural; + Pad : Character := Space) return Unbounded_String; + + procedure Tail + (Source : in out Unbounded_String; + Count : Natural; + Pad : Character := Space); + + function "*" + (Left : Natural; + Right : Character) return Unbounded_String; + + function "*" + (Left : Natural; + Right : String) return Unbounded_String; + + function "*" + (Left : Natural; + Right : Unbounded_String) return Unbounded_String; + +private + pragma Inline (Length); + + package AF renames Ada.Finalization; + + type Shared_String (Max_Length : Natural) is limited record + Counter : aliased Interfaces.Unsigned_32 := 1; + -- Reference counter + + Last : Natural := 0; + Data : String (1 .. Max_Length); + -- Last is the index of last significant element of the Data. All + -- elements with larger indexes are currently insignificant. + end record; + + type Shared_String_Access is access all Shared_String; + + procedure Reference (Item : not null Shared_String_Access); + -- Increment reference counter + + procedure Unreference (Item : not null Shared_String_Access); + -- Decrement reference counter, deallocate Item when counter goes to zero + + function Can_Be_Reused + (Item : Shared_String_Access; + Length : Natural) return Boolean; + -- Returns True if Shared_String can be reused. There are two criteria when + -- Shared_String can be reused: its reference counter must be one (thus + -- Shared_String is owned exclusively) and its size is sufficient to + -- store string with specified length effectively. + + function Allocate (Max_Length : Natural) return Shared_String_Access; + -- Allocates new Shared_String with at least specified maximum length. + -- Actual maximum length of the allocated Shared_String can be sligtly + -- greater. Returns reference to Empty_Shared_String when requested length + -- is zero. + + Empty_Shared_String : aliased Shared_String (0); + + function To_Unbounded (S : String) return Unbounded_String + renames To_Unbounded_String; + -- This renames are here only to be used in the pragma Stream_Convert + + type Unbounded_String is new AF.Controlled with record + Reference : Shared_String_Access := Empty_Shared_String'Access; + end record; + + pragma Stream_Convert (Unbounded_String, To_Unbounded, To_String); + -- Provide stream routines without dragging in Ada.Streams + + pragma Finalize_Storage_Only (Unbounded_String); + -- Finalization is required only for freeing storage + + overriding procedure Initialize (Object : in out Unbounded_String); + overriding procedure Adjust (Object : in out Unbounded_String); + overriding procedure Finalize (Object : in out Unbounded_String); + + Null_Unbounded_String : constant Unbounded_String := + (AF.Controlled with + Reference => Empty_Shared_String'Access); + +end Ada.Strings.Unbounded; diff --git a/gcc/ada/a-strunb.adb b/gcc/ada/a-strunb.adb index 7634e65f6d2..cc5b92bfc43 100644 --- a/gcc/ada/a-strunb.adb +++ b/gcc/ada/a-strunb.adb @@ -914,9 +914,14 @@ package body Ada.Strings.Unbounded is function To_Unbounded_String (Source : String) return Unbounded_String is Result : Unbounded_String; begin - Result.Last := Source'Length; - Result.Reference := new String (1 .. Source'Length); - Result.Reference.all := Source; + -- Do not allocate an empty string: keep the default + + if Source'Length > 0 then + Result.Last := Source'Length; + Result.Reference := new String (1 .. Source'Length); + Result.Reference.all := Source; + end if; + return Result; end To_Unbounded_String; @@ -924,9 +929,15 @@ package body Ada.Strings.Unbounded is (Length : Natural) return Unbounded_String is Result : Unbounded_String; + begin - Result.Last := Length; - Result.Reference := new String (1 .. Length); + -- Do not allocate an empty string: keep the default + + if Length > 0 then + Result.Last := Length; + Result.Reference := new String (1 .. Length); + end if; + return Result; end To_Unbounded_String; diff --git a/gcc/ada/a-stunau-shared.adb b/gcc/ada/a-stunau-shared.adb new file mode 100644 index 00000000000..6ca416243b7 --- /dev/null +++ b/gcc/ada/a-stunau-shared.adb @@ -0,0 +1,62 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . U N B O U N D E D . A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.Unbounded.Aux is + + ---------------- + -- Get_String -- + ---------------- + + procedure Get_String + (U : Unbounded_String; + S : out Big_String_Access; + L : out Natural) + is + X : aliased Big_String; + for X'Address use U.Reference.Data'Address; + begin + S := X'Unchecked_Access; + L := U.Reference.Last; + end Get_String; + + ---------------- + -- Set_String -- + ---------------- + + procedure Set_String (UP : in out Unbounded_String; S : String_Access) is + X : String_Access := S; + + begin + Set_Unbounded_String (UP, S.all); + Free (X); + end Set_String; + +end Ada.Strings.Unbounded.Aux; diff --git a/gcc/ada/a-stunau.adb b/gcc/ada/a-stunau.adb index e77f71c12b1..c6d2bc43ac3 100644 --- a/gcc/ada/a-stunau.adb +++ b/gcc/ada/a-stunau.adb @@ -37,11 +37,14 @@ package body Ada.Strings.Unbounded.Aux is procedure Get_String (U : Unbounded_String; - S : out String_Access; + S : out Big_String_Access; L : out Natural) is + X : aliased Big_String; + for X'Address use U.Reference.all'Address; + begin - S := U.Reference; + S := X'Unchecked_Access; L := U.Last; end Get_String; @@ -49,17 +52,6 @@ package body Ada.Strings.Unbounded.Aux is -- Set_String -- ---------------- - procedure Set_String (UP : in out Unbounded_String; S : String) is - begin - if S'Length > UP.Last then - Finalize (UP); - UP.Reference := new String (1 .. S'Length); - end if; - - UP.Reference (1 .. S'Length) := S; - UP.Last := S'Length; - end Set_String; - procedure Set_String (UP : in out Unbounded_String; S : String_Access) is begin Finalize (UP); diff --git a/gcc/ada/a-stunau.ads b/gcc/ada/a-stunau.ads index c2d0ec855c0..8cff44f7151 100644 --- a/gcc/ada/a-stunau.ads +++ b/gcc/ada/a-stunau.ads @@ -37,9 +37,12 @@ package Ada.Strings.Unbounded.Aux is pragma Preelaborate; + subtype Big_String is String (1 .. Positive'Last); + type Big_String_Access is access all Big_String; + procedure Get_String (U : Unbounded_String; - S : out String_Access; + S : out Big_String_Access; L : out Natural); pragma Inline (Get_String); -- This procedure returns the internal string pointer used in the @@ -54,18 +57,16 @@ package Ada.Strings.Unbounded.Aux is -- referenced string returned by this call is always one, so the actual -- string data is always accessible as S (1 .. L). - procedure Set_String (UP : in out Unbounded_String; S : String); - pragma Inline (Set_String); - -- This function sets the string contents of the referenced unbounded - -- string to the given string value. It is significantly more efficient - -- than the use of To_Unbounded_String with an assignment, since it - -- avoids the necessity of messing with finalization chains. The lower - -- bound of the string S is not required to be one. + procedure Set_String (UP : out Unbounded_String; S : String) + renames Set_Unbounded_String; + -- This function is simply a renaming of the new Ada 2005 function as shown + -- above. It is provided for historical reasons, but should be removed at + -- this stage??? procedure Set_String (UP : in out Unbounded_String; S : String_Access); pragma Inline (Set_String); - -- This version of Set_String takes a string access value, rather than a - -- string. The lower bound of the string value is required to be one, and - -- this requirement is not checked. + -- This version of Set_Unbounded_String takes a string access value, rather + -- than a string. The lower bound of the string value is required to be + -- one, and this requirement is not checked. end Ada.Strings.Unbounded.Aux; diff --git a/gcc/ada/a-stuten.adb b/gcc/ada/a-stuten.adb new file mode 100644 index 00000000000..fc669b56ee4 --- /dev/null +++ b/gcc/ada/a-stuten.adb @@ -0,0 +1,209 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . U T F _ E N C O D I N G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.UTF_Encoding is + use Interfaces; + + -------------- + -- Encoding -- + -------------- + + function Encoding + (Item : UTF_String; + Default : Encoding_Scheme := UTF_8) return Encoding_Scheme + is + begin + if Item'Length >= 2 then + if Item (Item'First .. Item'First + 1) = BOM_16BE then + return UTF_16BE; + + elsif Item (Item'First .. Item'First + 1) = BOM_16LE then + return UTF_16LE; + + elsif Item'Length >= 3 + and then Item (Item'First .. Item'First + 2) = BOM_8 + then + return UTF_8; + end if; + end if; + + return Default; + end Encoding; + + ----------------- + -- From_UTF_16 -- + ----------------- + + function From_UTF_16 + (Item : UTF_16_Wide_String; + Output_Scheme : UTF_XE_Encoding; + Output_BOM : Boolean := False) return UTF_String + is + BSpace : constant Natural := 2 * Boolean'Pos (Output_BOM); + Result : UTF_String (1 .. 2 * Item'Length + BSpace); + Len : Natural; + C : Unsigned_16; + Iptr : Natural; + + begin + if Output_BOM then + Result (1 .. 2) := + (if Output_Scheme = UTF_16BE then BOM_16BE else BOM_16LE); + Len := 2; + else + Len := 0; + end if; + + -- Skip input BOM + + Iptr := Item'First; + + if Iptr <= Item'Last and then Item (Iptr) = BOM_16 (1) then + Iptr := Iptr + 1; + end if; + + -- UTF-16BE case + + if Output_Scheme = UTF_16BE then + while Iptr <= Item'Last loop + C := To_Unsigned_16 (Item (Iptr)); + Result (Len + 1) := Character'Val (Shift_Right (C, 8)); + Result (Len + 2) := Character'Val (C and 16#00_FF#); + Len := Len + 2; + Iptr := Iptr + 1; + end loop; + + -- UTF-16LE case + + else + while Iptr <= Item'Last loop + C := To_Unsigned_16 (Item (Iptr)); + Result (Len + 1) := Character'Val (C and 16#00_FF#); + Result (Len + 2) := Character'Val (Shift_Right (C, 8)); + Len := Len + 2; + Iptr := Iptr + 1; + end loop; + end if; + + return Result (1 .. Len); + end From_UTF_16; + + -------------------------- + -- Raise_Encoding_Error -- + -------------------------- + + procedure Raise_Encoding_Error (Index : Natural) is + Val : constant String := Index'Img; + begin + raise Encoding_Error with + "bad input at Item (" & Val (Val'First + 1 .. Val'Last) & ')'; + end Raise_Encoding_Error; + + --------------- + -- To_UTF_16 -- + --------------- + + function To_UTF_16 + (Item : UTF_String; + Input_Scheme : UTF_XE_Encoding; + Output_BOM : Boolean := False) return UTF_16_Wide_String + is + Result : UTF_16_Wide_String (1 .. Item'Length / 2 + 1); + Len : Natural; + Iptr : Natural; + + begin + if Item'Length mod 2 /= 0 then + raise Encoding_Error with "UTF-16BE/LE string has odd length"; + end if; + + -- Deal with input BOM, skip if OK, error if bad BOM + + Iptr := Item'First; + + if Item'Length >= 2 then + if Item (Iptr .. Iptr + 1) = BOM_16BE then + if Input_Scheme = UTF_16BE then + Iptr := Iptr + 2; + else + Raise_Encoding_Error (Iptr); + end if; + + elsif Item (Iptr .. Iptr + 1) = BOM_16LE then + if Input_Scheme = UTF_16LE then + Iptr := Iptr + 2; + else + Raise_Encoding_Error (Iptr); + end if; + + elsif Item'Length >= 3 and then Item (Iptr .. Iptr + 2) = BOM_8 then + Raise_Encoding_Error (Iptr); + end if; + end if; + + -- Output BOM if specified + + if Output_BOM then + Result (1) := BOM_16 (1); + Len := 1; + else + Len := 0; + end if; + + -- UTF-16BE case + + if Input_Scheme = UTF_16BE then + while Iptr < Item'Last loop + Len := Len + 1; + Result (Len) := + Wide_Character'Val + (Character'Pos (Item (Iptr)) * 256 + + Character'Pos (Item (Iptr + 1))); + Iptr := Iptr + 2; + end loop; + + -- UTF-16LE case + + else + while Iptr < Item'Last loop + Len := Len + 1; + Result (Len) := + Wide_Character'Val + (Character'Pos (Item (Iptr)) + + Character'Pos (Item (Iptr + 1)) * 256); + Iptr := Iptr + 2; + end loop; + end if; + + return Result (1 .. Len); + end To_UTF_16; + +end Ada.Strings.UTF_Encoding; diff --git a/gcc/ada/a-stuten.ads b/gcc/ada/a-stuten.ads new file mode 100644 index 00000000000..5299c6f88e2 --- /dev/null +++ b/gcc/ada/a-stuten.ads @@ -0,0 +1,146 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . U T F _ E N C O D I N G -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT 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 distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is one of the Ada 2012 package defined in AI05-0137-1. It is a parent +-- package that contains declarations used in the child packages for handling +-- UTF encoded strings. Note: this package is consistent with Ada 95, and may +-- be used in Ada 95 or Ada 2005 mode. + +with Interfaces; +with Unchecked_Conversion; + +package Ada.Strings.UTF_Encoding is + pragma Pure (UTF_Encoding); + + subtype UTF_String is String; + -- Used to represent a string of 8-bit values containing a sequence of + -- values encoded in one of three ways (UTF-8, UTF-16BE, or UTF-16LE). + -- Typically used in connection with a Scheme parameter indicating which + -- of the encodings applies. This is not strictly a String value in the + -- sense defined in the Ada RM, but in practice type String accomodates + -- all possible 256 codes, and can be used to hold any sequence of 8-bit + -- codes. We use String directly rather than create a new type so that + -- all existing facilities for manipulating type String (e.g. the child + -- packages of Ada.Strings) are available for manipulation of UTF_Strings. + + type Encoding_Scheme is (UTF_8, UTF_16BE, UTF_16LE); + -- Used to specify which of three possible encodings apply to a UTF_String + + subtype UTF_8_String is String; + -- Similar to UTF_String but specifically represents a UTF-8 encoded string + + subtype UTF_16_Wide_String is Wide_String; + -- This is similar to UTF_8_String but is used to represent a Wide_String + -- value which is a sequence of 16-bit values encoded using UTF-16. Again + -- this is not strictly a Wide_String in the sense of the Ada RM, but the + -- type Wide_String can be used to represent a sequence of arbitrary 16-bit + -- values, and it is more convenient to use Wide_String than a new type. + + Encoding_Error : exception; + -- This exception is raised in the following situations: + -- a) A UTF encoded string contains an invalid encoding sequence + -- b) A UTF-16BE or UTF-16LE input string has an odd length + -- c) An incorrect character value is present in the Input string + -- d) The result for a Wide_Character output exceeds 16#FFFF# + -- The exception message has the index value where the error occurred. + + -- The BOM (BYTE_ORDER_MARK) values defined here are used at the start of + -- a string to indicate the encoding. The convention in this package is + -- that on input a correct BOM is ignored and an incorrect BOM causes an + -- Encoding_Error exception. On output, the output string may or may not + -- include a BOM depending on the setting of Output_BOM. + + BOM_8 : constant UTF_8_String := + Character'Val (16#EF#) & + Character'Val (16#BB#) & + Character'Val (16#BF#); + + BOM_16BE : constant UTF_String := + Character'Val (16#FE#) & + Character'Val (16#FF#); + + BOM_16LE : constant UTF_String := + Character'Val (16#FF#) & + Character'Val (16#FE#); + + BOM_16 : constant UTF_16_Wide_String := + (1 => Wide_Character'Val (16#FEFF#)); + + function Encoding + (Item : UTF_String; + Default : Encoding_Scheme := UTF_8) return Encoding_Scheme; + -- This function inspects a UTF_String value to determine whether it + -- starts with a BOM for UTF-8, UTF-16BE, or UTF_16LE. If so, the result + -- is the scheme corresponding to the BOM. If no valid BOM is present + -- then the result is the specified Default value. + +private + function To_Unsigned_8 is new + Unchecked_Conversion (Character, Interfaces.Unsigned_8); + + function To_Unsigned_16 is new + Unchecked_Conversion (Wide_Character, Interfaces.Unsigned_16); + + function To_Unsigned_32 is new + Unchecked_Conversion (Wide_Wide_Character, Interfaces.Unsigned_32); + + subtype UTF_XE_Encoding is Encoding_Scheme range UTF_16BE .. UTF_16LE; + -- Subtype containing only UTF_16BE and UTF_16LE entries + + -- Utility routines for converting between UTF-16 and UTF-16LE/BE + + function From_UTF_16 + (Item : UTF_16_Wide_String; + Output_Scheme : UTF_XE_Encoding; + Output_BOM : Boolean := False) return UTF_String; + -- The input string Item is encoded in UTF-16. The output is encoded using + -- Output_Scheme (which is either UTF-16LE or UTF-16BE). There are no error + -- cases. The output starts with BOM_16BE/LE if Output_BOM is True. + + function To_UTF_16 + (Item : UTF_String; + Input_Scheme : UTF_XE_Encoding; + Output_BOM : Boolean := False) return UTF_16_Wide_String; + -- The input string Item is encoded using Input_Scheme which is either + -- UTF-16LE or UTF-16BE. The output is the corresponding UTF_16 wide + -- string. Encoding error is raised if the length of the input is odd. + -- The output starts with BOM_16 if Output_BOM is True. + + procedure Raise_Encoding_Error (Index : Natural); + pragma No_Return (Raise_Encoding_Error); + -- Raise Encoding_Error exception for bad encoding in input item. The + -- parameter Index is the index of the location in Item for the error. + +end Ada.Strings.UTF_Encoding; diff --git a/gcc/ada/a-stwiun-shared.adb b/gcc/ada/a-stwiun-shared.adb new file mode 100644 index 00000000000..0f61c7130e6 --- /dev/null +++ b/gcc/ada/a-stwiun-shared.adb @@ -0,0 +1,2104 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ U N B O U N D E D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Wide_Search; +with Ada.Unchecked_Deallocation; + +package body Ada.Strings.Wide_Unbounded is + + use Ada.Strings.Wide_Maps; + + Growth_Factor : constant := 32; + -- The growth factor controls how much extra space is allocated when + -- we have to increase the size of an allocated unbounded string. By + -- allocating extra space, we avoid the need to reallocate on every + -- append, particularly important when a string is built up by repeated + -- append operations of small pieces. This is expressed as a factor so + -- 32 means add 1/32 of the length of the string as growth space. + + Min_Mul_Alloc : constant := Standard'Maximum_Alignment; + -- Allocation will be done by a multiple of Min_Mul_Alloc. This causes + -- no memory loss as most (all?) malloc implementations are obliged to + -- align the returned memory on the maximum alignment as malloc does not + -- know the target alignment. + + procedure Sync_Add_And_Fetch + (Ptr : access Interfaces.Unsigned_32; + Value : Interfaces.Unsigned_32); + pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_4"); + + function Sync_Sub_And_Fetch + (Ptr : access Interfaces.Unsigned_32; + Value : Interfaces.Unsigned_32) return Interfaces.Unsigned_32; + pragma Import (Intrinsic, Sync_Sub_And_Fetch, "__sync_sub_and_fetch_4"); + + function Aligned_Max_Length (Max_Length : Natural) return Natural; + -- Returns recommended length of the shared string which is greater or + -- equal to specified length. Calculation take in sense alignment of + -- the allocated memory segments to use memory effectively by + -- Append/Insert/etc operations. + + --------- + -- "&" -- + --------- + + function "&" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Unbounded_Wide_String + is + LR : constant Shared_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_String_Access := Right.Reference; + DL : constant Natural := LR.Last + RR.Last; + DR : Shared_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared empty string. + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Left string is empty, return Rigth string. + + elsif LR.Last = 0 then + Reference (RR); + DR := RR; + + -- Right string is empty, return Left string. + + elsif RR.Last = 0 then + Reference (LR); + DR := LR; + + -- Overwise, allocate new shared string and fill data. + + else + DR := Allocate (LR.Last + RR.Last); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (LR.Last + 1 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Unbounded_Wide_String + is + LR : constant Shared_Wide_String_Access := Left.Reference; + DL : constant Natural := LR.Last + Right'Length; + DR : Shared_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared empty string. + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Right is an empty string, return Left string. + + elsif Right'Length = 0 then + Reference (LR); + DR := LR; + + -- Otherwise, allocate new shared string and fill it. + + else + DR := Allocate (DL); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (LR.Last + 1 .. DL) := Right; + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Unbounded_Wide_String + is + RR : constant Shared_Wide_String_Access := Right.Reference; + DL : constant Natural := Left'Length + RR.Last; + DR : Shared_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared one. + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Left is empty string, return Right string. + + elsif Left'Length = 0 then + Reference (RR); + DR := RR; + + -- Otherwise, allocate new shared string and fill it. + + else + DR := Allocate (DL); + DR.Data (1 .. Left'Length) := Left; + DR.Data (Left'Length + 1 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Unbounded_Wide_String; + Right : Wide_Character) return Unbounded_Wide_String + is + LR : constant Shared_Wide_String_Access := Left.Reference; + DL : constant Natural := LR.Last + 1; + DR : Shared_Wide_String_Access; + + begin + DR := Allocate (DL); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (DL) := Right; + DR.Last := DL; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Wide_Character; + Right : Unbounded_Wide_String) return Unbounded_Wide_String + is + RR : constant Shared_Wide_String_Access := Right.Reference; + DL : constant Natural := 1 + RR.Last; + DR : Shared_Wide_String_Access; + + begin + DR := Allocate (DL); + DR.Data (1) := Left; + DR.Data (2 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + + return (AF.Controlled with Reference => DR); + end "&"; + + --------- + -- "*" -- + --------- + + function "*" + (Left : Natural; + Right : Wide_Character) return Unbounded_Wide_String + is + DR : Shared_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared empty string. + + if Left = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it. + + else + DR := Allocate (Left); + + for J in 1 .. Left loop + DR.Data (J) := Right; + end loop; + + DR.Last := Left; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + function "*" + (Left : Natural; + Right : Wide_String) return Unbounded_Wide_String + is + DL : constant Natural := Left * Right'Length; + DR : Shared_Wide_String_Access; + K : Positive; + + begin + -- Result is an empty string, reuse shared empty string. + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it. + + else + DR := Allocate (DL); + K := 1; + + for J in 1 .. Left loop + DR.Data (K .. K + Right'Length - 1) := Right; + K := K + Right'Length; + end loop; + + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + function "*" + (Left : Natural; + Right : Unbounded_Wide_String) return Unbounded_Wide_String + is + RR : constant Shared_Wide_String_Access := Right.Reference; + DL : constant Natural := Left * RR.Last; + DR : Shared_Wide_String_Access; + K : Positive; + + begin + -- Result is an empty string, reuse shared empty string. + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Coefficient is one, just return string itself. + + elsif Left = 1 then + Reference (RR); + DR := RR; + + -- Otherwise, allocate new shared string and fill it. + + else + DR := Allocate (DL); + K := 1; + + for J in 1 .. Left loop + DR.Data (K .. K + RR.Last - 1) := RR.Data (1 .. RR.Last); + K := K + RR.Last; + end loop; + + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + --------- + -- "<" -- + --------- + + function "<" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_String_Access := Right.Reference; + begin + return LR.Data (1 .. LR.Last) < RR.Data (1 .. RR.Last); + end "<"; + + function "<" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) < Right; + end "<"; + + function "<" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + RR : constant Shared_Wide_String_Access := Right.Reference; + begin + return Left < RR.Data (1 .. RR.Last); + end "<"; + + ---------- + -- "<=" -- + ---------- + + function "<=" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_String_Access := Right.Reference; + + begin + -- LR = RR means two strings shares shared string, thus they are equal + + return LR = RR or else LR.Data (1 .. LR.Last) <= RR.Data (1 .. RR.Last); + end "<="; + + function "<=" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) <= Right; + end "<="; + + function "<=" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + RR : constant Shared_Wide_String_Access := Right.Reference; + begin + return Left <= RR.Data (1 .. RR.Last); + end "<="; + + --------- + -- "=" -- + --------- + + function "=" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_String_Access := Right.Reference; + + begin + return LR = RR or else LR.Data (1 .. LR.Last) = RR.Data (1 .. RR.Last); + -- LR = RR means two strings shares shared string, thus they are equal. + end "="; + + function "=" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) = Right; + end "="; + + function "=" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + RR : constant Shared_Wide_String_Access := Right.Reference; + begin + return Left = RR.Data (1 .. RR.Last); + end "="; + + --------- + -- ">" -- + --------- + + function ">" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_String_Access := Right.Reference; + begin + return LR.Data (1 .. LR.Last) > RR.Data (1 .. RR.Last); + end ">"; + + function ">" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) > Right; + end ">"; + + function ">" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + RR : constant Shared_Wide_String_Access := Right.Reference; + begin + return Left > RR.Data (1 .. RR.Last); + end ">"; + + ---------- + -- ">=" -- + ---------- + + function ">=" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_String_Access := Right.Reference; + + begin + -- LR = RR means two strings shares shared string, thus they are equal + + return LR = RR or else LR.Data (1 .. LR.Last) >= RR.Data (1 .. RR.Last); + end ">="; + + function ">=" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) >= Right; + end ">="; + + function ">=" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + RR : constant Shared_Wide_String_Access := Right.Reference; + begin + return Left >= RR.Data (1 .. RR.Last); + end ">="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Object : in out Unbounded_Wide_String) is + begin + Reference (Object.Reference); + end Adjust; + + ------------------------ + -- Aligned_Max_Length -- + ------------------------ + + function Aligned_Max_Length (Max_Length : Natural) return Natural is + Static_Size : constant Natural := + Empty_Shared_Wide_String'Size / Standard'Storage_Unit; + -- Total size of all static components + + Element_Size : constant Natural := + Wide_Character'Size / Standard'Storage_Unit; + + begin + return + (((Static_Size + Max_Length * Element_Size - 1) / Min_Mul_Alloc + 2) + * Min_Mul_Alloc - Static_Size) / Element_Size; + end Aligned_Max_Length; + + -------------- + -- Allocate -- + -------------- + + function Allocate (Max_Length : Natural) return Shared_Wide_String_Access is + begin + -- Empty string requested, return shared empty string + + if Max_Length = 0 then + Reference (Empty_Shared_Wide_String'Access); + return Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate requested space (and probably some more room) + + else + return new Shared_Wide_String (Aligned_Max_Length (Max_Length)); + end if; + end Allocate; + + ------------ + -- Append -- + ------------ + + procedure Append + (Source : in out Unbounded_Wide_String; + New_Item : Unbounded_Wide_String) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + NR : constant Shared_Wide_String_Access := New_Item.Reference; + DL : constant Natural := SR.Last + NR.Last; + DR : Shared_Wide_String_Access; + + begin + -- Source is an empty string, reuse New_Item data + + if SR.Last = 0 then + Reference (NR); + Source.Reference := NR; + Unreference (SR); + + -- New_Item is empty string, nothing to do + + elsif NR.Last = 0 then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); + SR.Last := DL; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + procedure Append + (Source : in out Unbounded_Wide_String; + New_Item : Wide_String) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_Wide_String_Access; + + begin + -- New_Item is an empty string, nothing to do + + if New_Item'Length = 0 then + null; + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (SR.Last + 1 .. DL) := New_Item; + SR.Last := DL; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (SR.Last + 1 .. DL) := New_Item; + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + procedure Append + (Source : in out Unbounded_Wide_String; + New_Item : Wide_Character) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + 1; + DR : Shared_Wide_String_Access; + + begin + -- Try to reuse existing shared string + + if Can_Be_Reused (SR, SR.Last + 1) then + SR.Data (SR.Last + 1) := New_Item; + SR.Last := SR.Last + 1; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (DL) := New_Item; + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + ------------------- + -- Can_Be_Reused -- + ------------------- + + function Can_Be_Reused + (Item : Shared_Wide_String_Access; + Length : Natural) return Boolean + is + use Interfaces; + begin + return + Item.Counter = 1 + and then Item.Max_Length >= Length + and then Item.Max_Length <= + Aligned_Max_Length (Length + Length / Growth_Factor); + end Can_Be_Reused; + + ----------- + -- Count -- + ----------- + + function Count + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); + end Count; + + function Count + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); + end Count; + + function Count + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Count (SR.Data (1 .. SR.Last), Set); + end Count; + + ------------ + -- Delete -- + ------------ + + function Delete + (Source : Unbounded_Wide_String; + From : Positive; + Through : Natural) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Empty slice is deleted, use the same shared string + + if From > Through then + Reference (SR); + DR := SR; + + -- Index is out of range + + elsif Through > SR.Last then + raise Index_Error; + + -- Compute size of the result + + else + DL := SR.Last - (Through - From + 1); + + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); + DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Delete; + + procedure Delete + (Source : in out Unbounded_Wide_String; + From : Positive; + Through : Natural) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Nothing changed, return + + if From > Through then + null; + + -- Through is outside of the range + + elsif Through > SR.Last then + raise Index_Error; + + else + DL := SR.Last - (Through - From + 1); + + -- Result is empty, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + SR.Last := DL; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); + DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Delete; + + ------------- + -- Element -- + ------------- + + function Element + (Source : Unbounded_Wide_String; + Index : Positive) return Wide_Character + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + if Index <= SR.Last then + return SR.Data (Index); + else + raise Index_Error; + end if; + end Element; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Unbounded_Wide_String) is + SR : constant Shared_Wide_String_Access := Object.Reference; + + begin + if SR /= null then + + -- The same controlled object can be finalized several times for + -- some reason. As per 7.6.1(24) this should have no ill effect, + -- so we need to add a guard for the case of finalizing the same + -- object twice. + + Object.Reference := null; + Unreference (SR); + end if; + end Finalize; + + ---------------- + -- Find_Token -- + ---------------- + + procedure Find_Token + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Strings.Membership; + First : out Positive; + Last : out Natural) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + Wide_Search.Find_Token (SR.Data (1 .. SR.Last), Set, Test, First, Last); + end Find_Token; + + ---------- + -- Free -- + ---------- + + procedure Free (X : in out Wide_String_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (Wide_String, Wide_String_Access); + begin + Deallocate (X); + end Free; + + ---------- + -- Head -- + ---------- + + function Head + (Source : Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- Result is empty, reuse shared empty string + + if Count = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Length of the string is the same as requested, reuse source shared + -- string. + + elsif Count = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (Count); + + -- Length of the source string is more than requested, copy + -- corresponding slice. + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (1 .. Count); + + -- Length of the source string is less then requested, copy all + -- contents and fill others by Pad character. + + else + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + + for J in SR.Last + 1 .. Count loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + end if; + + return (AF.Controlled with Reference => DR); + end Head; + + procedure Head + (Source : in out Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- Result is empty, reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + -- Result is same with source string, reuse source shared string + + elsif Count = SR.Last then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, Count) then + if Count > SR.Last then + for J in SR.Last + 1 .. Count loop + SR.Data (J) := Pad; + end loop; + end if; + + SR.Last := Count; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (Count); + + -- Length of the source string is greater then requested, copy + -- corresponding slice. + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (1 .. Count); + + -- Length of the source string is less the requested, copy all + -- exists data and fill others by Pad character. + + else + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + + for J in SR.Last + 1 .. Count loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + Source.Reference := DR; + Unreference (SR); + end if; + end Head; + + ----------- + -- Index -- + ----------- + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Going : Strings.Direction := Strings.Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Strings.Membership := Strings.Inside; + Going : Strings.Direction := Strings.Forward) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index (SR.Data (1 .. SR.Last), Set, Test, Going); + end Index; + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index + (SR.Data (1 .. SR.Last), Set, From, Test, Going); + end Index; + + --------------------- + -- Index_Non_Blank -- + --------------------- + + function Index_Non_Blank + (Source : Unbounded_Wide_String; + Going : Strings.Direction := Strings.Forward) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index_Non_Blank (SR.Data (1 .. SR.Last), Going); + end Index_Non_Blank; + + function Index_Non_Blank + (Source : Unbounded_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index_Non_Blank + (SR.Data (1 .. SR.Last), From, Going); + end Index_Non_Blank; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Object : in out Unbounded_Wide_String) is + begin + Reference (Object.Reference); + end Initialize; + + ------------ + -- Insert -- + ------------ + + function Insert + (Source : Unbounded_Wide_String; + Before : Positive; + New_Item : Wide_String) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_Wide_String_Access; + + begin + -- Check index first + + if Before > SR.Last + 1 then + raise Index_Error; + end if; + + -- Result is empty, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Inserted string is empty, reuse source shared string + + elsif New_Item'Length = 0 then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); + DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + DR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Insert; + + procedure Insert + (Source : in out Unbounded_Wide_String; + Before : Positive; + New_Item : Wide_String) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_Wide_String_Access; + + begin + -- Check bounds + + if Before > SR.Last + 1 then + raise Index_Error; + end if; + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + -- Inserted string is empty, nothing to do + + elsif New_Item'Length = 0 then + null; + + -- Try to reuse existent shared string first + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + SR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + SR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); + DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + DR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Insert; + + ------------ + -- Length -- + ------------ + + function Length (Source : Unbounded_Wide_String) return Natural is + begin + return Source.Reference.Last; + end Length; + + --------------- + -- Overwrite -- + --------------- + + function Overwrite + (Source : Unbounded_Wide_String; + Position : Positive; + New_Item : Wide_String) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Check bounds + + if Position > SR.Last + 1 then + raise Index_Error; + end if; + + DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Result is same with source string, reuse source shared string + + elsif New_Item'Length = 0 then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); + DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + DR.Data (Position + New_Item'Length .. DL) := + SR.Data (Position + New_Item'Length .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Overwrite; + + procedure Overwrite + (Source : in out Unbounded_Wide_String; + Position : Positive; + New_Item : Wide_String) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Bounds check + + if Position > SR.Last + 1 then + raise Index_Error; + end if; + + DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + -- String unchanged, nothing to do + + elsif New_Item'Length = 0 then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + SR.Last := DL; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); + DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + DR.Data (Position + New_Item'Length .. DL) := + SR.Data (Position + New_Item'Length .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Overwrite; + + --------------- + -- Reference -- + --------------- + + procedure Reference (Item : not null Shared_Wide_String_Access) is + begin + Sync_Add_And_Fetch (Item.Counter'Access, 1); + end Reference; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Source : in out Unbounded_Wide_String; + Index : Positive; + By : Wide_Character) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- Bounds check. + + if Index <= SR.Last then + + -- Try to reuse existent shared string + + if Can_Be_Reused (SR, SR.Last) then + SR.Data (Index) := By; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (Index) := By; + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + + else + raise Index_Error; + end if; + end Replace_Element; + + ------------------- + -- Replace_Slice -- + ------------------- + + function Replace_Slice + (Source : Unbounded_Wide_String; + Low : Positive; + High : Natural; + By : Wide_String) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 then + raise Index_Error; + end if; + + -- Do replace operation when removed slice is not empty + + if High >= Low then + DL := By'Length + SR.Last + Low - High - 1; + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); + DR.Data (Low .. Low + By'Length - 1) := By; + DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + + -- Otherwise just insert string + + else + return Insert (Source, Low, By); + end if; + end Replace_Slice; + + procedure Replace_Slice + (Source : in out Unbounded_Wide_String; + Low : Positive; + High : Natural; + By : Wide_String) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Bounds check + + if Low > SR.Last + 1 then + raise Index_Error; + end if; + + -- Do replace operation only when replaced slice is not empty + + if High >= Low then + DL := By'Length + SR.Last + Low - High - 1; + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + SR.Data (Low .. Low + By'Length - 1) := By; + SR.Last := DL; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); + DR.Data (Low .. Low + By'Length - 1) := By; + DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + + -- Otherwise just insert item + + else + Insert (Source, Low, By); + end if; + end Replace_Slice; + + ------------------------------- + -- Set_Unbounded_Wide_String -- + ------------------------------- + + procedure Set_Unbounded_Wide_String + (Target : out Unbounded_Wide_String; + Source : Wide_String) + is + TR : constant Shared_Wide_String_Access := Target.Reference; + DR : Shared_Wide_String_Access; + + begin + -- In case of empty string, reuse empty shared string + + if Source'Length = 0 then + Reference (Empty_Shared_Wide_String'Access); + Target.Reference := Empty_Shared_Wide_String'Access; + + else + -- Try to reuse existent shared string + + if Can_Be_Reused (TR, Source'Length) then + Reference (TR); + DR := TR; + + -- Otherwise allocate new shared string + + else + DR := Allocate (Source'Length); + Target.Reference := DR; + end if; + + DR.Data (1 .. Source'Length) := Source; + DR.Last := Source'Length; + end if; + + Unreference (TR); + end Set_Unbounded_Wide_String; + + ----------- + -- Slice -- + ----------- + + function Slice + (Source : Unbounded_Wide_String; + Low : Positive; + High : Natural) return Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + + begin + -- Note: test of High > Length is in accordance with AI95-00128 + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + else + return SR.Data (Low .. High); + end if; + end Slice; + + ---------- + -- Tail -- + ---------- + + function Tail + (Source : Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- For empty result reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Result is hole source string, reuse source shared string + + elsif Count = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (Count); + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); + + else + for J in 1 .. Count - SR.Last loop + DR.Data (J) := Pad; + end loop; + + DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); + end if; + + DR.Last := Count; + end if; + + return (AF.Controlled with Reference => DR); + end Tail; + + procedure Tail + (Source : in out Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + procedure Common + (SR : Shared_Wide_String_Access; + DR : Shared_Wide_String_Access; + Count : Natural); + -- Common code of tail computation. SR/DR can point to the same object + + ------------ + -- Common -- + ------------ + + procedure Common + (SR : Shared_Wide_String_Access; + DR : Shared_Wide_String_Access; + Count : Natural) is + begin + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); + + else + DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); + + for J in 1 .. Count - SR.Last loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + end Common; + + begin + -- Result is empty string, reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + -- Length of the result is the same with length of the source string, + -- reuse source shared string. + + elsif Count = SR.Last then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, Count) then + Common (SR, SR, Count); + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (Count); + Common (SR, DR, Count); + Source.Reference := DR; + Unreference (SR); + end if; + end Tail; + + -------------------- + -- To_Wide_String -- + -------------------- + + function To_Wide_String + (Source : Unbounded_Wide_String) return Wide_String is + begin + return Source.Reference.Data (1 .. Source.Reference.Last); + end To_Wide_String; + + ------------------------------ + -- To_Unbounded_Wide_String -- + ------------------------------ + + function To_Unbounded_Wide_String + (Source : Wide_String) return Unbounded_Wide_String + is + DR : constant Shared_Wide_String_Access := Allocate (Source'Length); + begin + DR.Data (1 .. Source'Length) := Source; + DR.Last := Source'Length; + return (AF.Controlled with Reference => DR); + end To_Unbounded_Wide_String; + + function To_Unbounded_Wide_String + (Length : Natural) return Unbounded_Wide_String + is + DR : constant Shared_Wide_String_Access := Allocate (Length); + begin + DR.Last := Length; + return (AF.Controlled with Reference => DR); + end To_Unbounded_Wide_String; + + --------------- + -- Translate -- + --------------- + + function Translate + (Source : Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- Nothing to translate, reuse empty shared string + + if SR.Last = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + DR.Last := SR.Last; + end if; + + return (AF.Controlled with Reference => DR); + end Translate; + + procedure Translate + (Source : in out Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- Nothing to translate + + if SR.Last = 0 then + null; + + -- Try to reuse shared string + + elsif Can_Be_Reused (SR, SR.Last) then + for J in 1 .. SR.Last loop + SR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + end Translate; + + function Translate + (Source : Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) + return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- Nothing to translate, reuse empty shared string + + if SR.Last = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + DR.Last := SR.Last; + end if; + + return (AF.Controlled with Reference => DR); + + exception + when others => + Unreference (DR); + + raise; + end Translate; + + procedure Translate + (Source : in out Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- Nothing to translate + + if SR.Last = 0 then + null; + + -- Try to reuse shared string + + elsif Can_Be_Reused (SR, SR.Last) then + for J in 1 .. SR.Last loop + SR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + + exception + when others => + if DR /= null then + Unreference (DR); + end if; + + raise; + end Translate; + + ---------- + -- Trim -- + ---------- + + function Trim + (Source : Unbounded_Wide_String; + Side : Trim_End) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index_Non_Blank (Source, Forward); + + -- All blanks, reuse empty shared string + + if Low = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + else + case Side is + when Left => + High := SR.Last; + DL := SR.Last - Low + 1; + + when Right => + Low := 1; + High := Index_Non_Blank (Source, Backward); + DL := High; + + when Both => + High := Index_Non_Blank (Source, Backward); + DL := High - Low + 1; + end case; + + -- Length of the result is the same as length of the source string, + -- reuse source shared string. + + if DL = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Trim; + + procedure Trim + (Source : in out Unbounded_Wide_String; + Side : Trim_End) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index_Non_Blank (Source, Forward); + + -- All blanks, reuse empty shared string + + if Low = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + else + case Side is + when Left => + High := SR.Last; + DL := SR.Last - Low + 1; + + when Right => + Low := 1; + High := Index_Non_Blank (Source, Backward); + DL := High; + + when Both => + High := Index_Non_Blank (Source, Backward); + DL := High - Low + 1; + end case; + + -- Length of the result is the same as length of the source string, + -- nothing to do. + + if DL = SR.Last then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (1 .. DL) := SR.Data (Low .. High); + SR.Last := DL; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Trim; + + function Trim + (Source : Unbounded_Wide_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index (Source, Left, Outside, Forward); + + -- Source includes only characters from Left set, reuse empty shared + -- string. + + if Low = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + else + High := Index (Source, Right, Outside, Backward); + DL := Integer'Max (0, High - Low + 1); + + -- Source includes only characters from Right set or result string + -- is empty, reuse empty shared string. + + if High = 0 or else DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Trim; + + procedure Trim + (Source : in out Unbounded_Wide_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index (Source, Left, Outside, Forward); + + -- Source includes only characters from Left set, reuse empty shared + -- string. + + if Low = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + else + High := Index (Source, Right, Outside, Backward); + DL := Integer'Max (0, High - Low + 1); + + -- Source includes only characters from Right set or result string + -- is empty, reuse empty shared string. + + if High = 0 or else DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (1 .. DL) := SR.Data (Low .. High); + SR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Trim; + + --------------------- + -- Unbounded_Slice -- + --------------------- + + function Unbounded_Slice + (Source : Unbounded_Wide_String; + Low : Positive; + High : Natural) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + -- Result is empty slice, reuse empty shared string + + elsif Low > High then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DL := High - Low + 1; + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Unbounded_Slice; + + procedure Unbounded_Slice + (Source : Unbounded_Wide_String; + Target : out Unbounded_Wide_String; + Low : Positive; + High : Natural) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + TR : constant Shared_Wide_String_Access := Target.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + -- Result is empty slice, reuse empty shared string + + elsif Low > High then + Reference (Empty_Shared_Wide_String'Access); + Target.Reference := Empty_Shared_Wide_String'Access; + Unreference (TR); + + else + DL := High - Low + 1; + + -- Try to reuse existent shared string + + if Can_Be_Reused (TR, DL) then + TR.Data (1 .. DL) := SR.Data (Low .. High); + TR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Target.Reference := DR; + Unreference (TR); + end if; + end if; + end Unbounded_Slice; + + ----------------- + -- Unreference -- + ----------------- + + procedure Unreference (Item : not null Shared_Wide_String_Access) is + use Interfaces; + + procedure Free is + new Ada.Unchecked_Deallocation + (Shared_Wide_String, Shared_Wide_String_Access); + + Aux : Shared_Wide_String_Access := Item; + + begin + if Sync_Sub_And_Fetch (Aux.Counter'Access, 1) = 0 then + + -- Reference counter of Empty_Shared_Wide_String must never reach + -- zero. + + pragma Assert (Aux /= Empty_Shared_Wide_String'Access); + + Free (Aux); + end if; + end Unreference; + +end Ada.Strings.Wide_Unbounded; diff --git a/gcc/ada/a-stwiun-shared.ads b/gcc/ada/a-stwiun-shared.ads new file mode 100644 index 00000000000..a438258c908 --- /dev/null +++ b/gcc/ada/a-stwiun-shared.ads @@ -0,0 +1,483 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ U N B O U N D E D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT 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 distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version is supported on: +-- - all Alpha platforms +-- - all ia64 platforms +-- - all PowerPC platforms +-- - all SPARC V9 platforms +-- - all x86_64 platforms + +with Ada.Strings.Wide_Maps; +private with Ada.Finalization; +private with Interfaces; + +package Ada.Strings.Wide_Unbounded is + pragma Preelaborate; + + type Unbounded_Wide_String is private; + pragma Preelaborable_Initialization (Unbounded_Wide_String); + + Null_Unbounded_Wide_String : constant Unbounded_Wide_String; + + function Length (Source : Unbounded_Wide_String) return Natural; + + type Wide_String_Access is access all Wide_String; + + procedure Free (X : in out Wide_String_Access); + + -------------------------------------------------------- + -- Conversion, Concatenation, and Selection Functions -- + -------------------------------------------------------- + + function To_Unbounded_Wide_String + (Source : Wide_String) return Unbounded_Wide_String; + + function To_Unbounded_Wide_String + (Length : Natural) return Unbounded_Wide_String; + + function To_Wide_String + (Source : Unbounded_Wide_String) return Wide_String; + + procedure Set_Unbounded_Wide_String + (Target : out Unbounded_Wide_String; + Source : Wide_String); + pragma Ada_05 (Set_Unbounded_Wide_String); + + procedure Append + (Source : in out Unbounded_Wide_String; + New_Item : Unbounded_Wide_String); + + procedure Append + (Source : in out Unbounded_Wide_String; + New_Item : Wide_String); + + procedure Append + (Source : in out Unbounded_Wide_String; + New_Item : Wide_Character); + + function "&" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Unbounded_Wide_String; + + function "&" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Unbounded_Wide_String; + + function "&" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Unbounded_Wide_String; + + function "&" + (Left : Unbounded_Wide_String; + Right : Wide_Character) return Unbounded_Wide_String; + + function "&" + (Left : Wide_Character; + Right : Unbounded_Wide_String) return Unbounded_Wide_String; + + function Element + (Source : Unbounded_Wide_String; + Index : Positive) return Wide_Character; + + procedure Replace_Element + (Source : in out Unbounded_Wide_String; + Index : Positive; + By : Wide_Character); + + function Slice + (Source : Unbounded_Wide_String; + Low : Positive; + High : Natural) return Wide_String; + + function Unbounded_Slice + (Source : Unbounded_Wide_String; + Low : Positive; + High : Natural) return Unbounded_Wide_String; + pragma Ada_05 (Unbounded_Slice); + + procedure Unbounded_Slice + (Source : Unbounded_Wide_String; + Target : out Unbounded_Wide_String; + Low : Positive; + High : Natural); + pragma Ada_05 (Unbounded_Slice); + + function "=" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function "=" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean; + + function "=" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function "<" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function "<" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean; + + function "<" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function "<=" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function "<=" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean; + + function "<=" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function ">" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function ">" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean; + + function ">" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function ">=" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function ">=" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean; + + function ">=" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + ------------------------ + -- Search Subprograms -- + ------------------------ + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural; + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; + + function Index + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index); + + function Index_Non_Blank + (Source : Unbounded_Wide_String; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : Unbounded_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index_Non_Blank); + + function Count + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural; + + function Count + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; + + function Count + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set) return Natural; + + procedure Find_Token + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + + ------------------------------------ + -- String Translation Subprograms -- + ------------------------------------ + + function Translate + (Source : Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping) + return Unbounded_Wide_String; + + procedure Translate + (Source : in out Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping); + + function Translate + (Source : Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) + return Unbounded_Wide_String; + + procedure Translate + (Source : in out Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function); + + --------------------------------------- + -- String Transformation Subprograms -- + --------------------------------------- + + function Replace_Slice + (Source : Unbounded_Wide_String; + Low : Positive; + High : Natural; + By : Wide_String) return Unbounded_Wide_String; + + procedure Replace_Slice + (Source : in out Unbounded_Wide_String; + Low : Positive; + High : Natural; + By : Wide_String); + + function Insert + (Source : Unbounded_Wide_String; + Before : Positive; + New_Item : Wide_String) return Unbounded_Wide_String; + + procedure Insert + (Source : in out Unbounded_Wide_String; + Before : Positive; + New_Item : Wide_String); + + function Overwrite + (Source : Unbounded_Wide_String; + Position : Positive; + New_Item : Wide_String) return Unbounded_Wide_String; + + procedure Overwrite + (Source : in out Unbounded_Wide_String; + Position : Positive; + New_Item : Wide_String); + + function Delete + (Source : Unbounded_Wide_String; + From : Positive; + Through : Natural) return Unbounded_Wide_String; + + procedure Delete + (Source : in out Unbounded_Wide_String; + From : Positive; + Through : Natural); + + function Trim + (Source : Unbounded_Wide_String; + Side : Trim_End) return Unbounded_Wide_String; + + procedure Trim + (Source : in out Unbounded_Wide_String; + Side : Trim_End); + + function Trim + (Source : Unbounded_Wide_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set) return Unbounded_Wide_String; + + procedure Trim + (Source : in out Unbounded_Wide_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set); + + function Head + (Source : Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String; + + procedure Head + (Source : in out Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space); + + function Tail + (Source : Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String; + + procedure Tail + (Source : in out Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space); + + function "*" + (Left : Natural; + Right : Wide_Character) return Unbounded_Wide_String; + + function "*" + (Left : Natural; + Right : Wide_String) return Unbounded_Wide_String; + + function "*" + (Left : Natural; + Right : Unbounded_Wide_String) return Unbounded_Wide_String; + +private + pragma Inline (Length); + + package AF renames Ada.Finalization; + + type Shared_Wide_String (Max_Length : Natural) is limited record + Counter : aliased Interfaces.Unsigned_32 := 1; + -- Reference counter. + + Last : Natural := 0; + Data : Wide_String (1 .. Max_Length); + -- Last is the index of last significant element of the Data. All + -- elements with larger indecies are just an extra room. + end record; + + type Shared_Wide_String_Access is access all Shared_Wide_String; + + procedure Reference (Item : not null Shared_Wide_String_Access); + -- Increment reference counter. + + procedure Unreference (Item : not null Shared_Wide_String_Access); + -- Decrement reference counter. Deallocate Item when reference counter is + -- zero. + + function Can_Be_Reused + (Item : Shared_Wide_String_Access; + Length : Natural) return Boolean; + -- Returns True if Shared_Wide_String can be reused. There are two criteria + -- when Shared_Wide_String can be reused: its reference counter must be one + -- (thus Shared_Wide_String is owned exclusively) and its size is + -- sufficient to store string with specified length effectively. + + function Allocate (Max_Length : Natural) return Shared_Wide_String_Access; + -- Allocates new Shared_Wide_String with at least specified maximum length. + -- Actual maximum length of the allocated Shared_Wide_String can be sligtly + -- greater. Returns reference to Empty_Shared_Wide_String when requested + -- length is zero. + + Empty_Shared_Wide_String : aliased Shared_Wide_String (0); + + function To_Unbounded (S : Wide_String) return Unbounded_Wide_String + renames To_Unbounded_Wide_String; + -- This renames are here only to be used in the pragma Stream_Convert. + + type Unbounded_Wide_String is new AF.Controlled with record + Reference : Shared_Wide_String_Access := Empty_Shared_Wide_String'Access; + end record; + + -- The Unbounded_Wide_String uses several techniques to increasy speed of + -- the application: + -- - implicit sharing or copy-on-write. Unbounded_Wide_String contains + -- only the reference to the data which is shared between several + -- instances. The shared data is reallocated only when its value is + -- changed and the object mutation can't be used or it is unefficient to + -- use it; + -- - object mutation. Shared data object can be reused without memory + -- reallocation when all of the following requirements are meat: + -- - shared data object don't used anywhere longer; + -- - its size is sufficient to store new value; + -- - the gap after reuse is less then some threashold. + -- - memory preallocation. Most of used memory allocation algorithms + -- alligns allocated segment on the some boundary, thus some amount of + -- additional memory can be preallocated without any impact. Such + -- preallocated memory can used later by Append/Insert operations + -- without reallocation. + -- + -- Reference counting uses GCC builtin atomic operations, which allows to + -- safely share internal data between Ada tasks. Nevertheless, this not + -- make objects of Unbounded_Wide_String thread-safe, so each instance + -- can't be accessed by several tasks simulatenously. + + pragma Stream_Convert (Unbounded_Wide_String, To_Unbounded, To_Wide_String); + -- Provide stream routines without dragging in Ada.Streams + + pragma Finalize_Storage_Only (Unbounded_Wide_String); + -- Finalization is required only for freeing storage + + overriding procedure Initialize (Object : in out Unbounded_Wide_String); + overriding procedure Adjust (Object : in out Unbounded_Wide_String); + overriding procedure Finalize (Object : in out Unbounded_Wide_String); + + Null_Unbounded_Wide_String : constant Unbounded_Wide_String := + (AF.Controlled with + Reference => Empty_Shared_Wide_String'Access); + +end Ada.Strings.Wide_Unbounded; diff --git a/gcc/ada/a-stzunb-shared.adb b/gcc/ada/a-stzunb-shared.adb new file mode 100644 index 00000000000..e20cd98e8a0 --- /dev/null +++ b/gcc/ada/a-stzunb-shared.adb @@ -0,0 +1,2118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Wide_Wide_Search; +with Ada.Unchecked_Deallocation; + +package body Ada.Strings.Wide_Wide_Unbounded is + + use Ada.Strings.Wide_Wide_Maps; + + Growth_Factor : constant := 32; + -- The growth factor controls how much extra space is allocated when + -- we have to increase the size of an allocated unbounded string. By + -- allocating extra space, we avoid the need to reallocate on every + -- append, particularly important when a string is built up by repeated + -- append operations of small pieces. This is expressed as a factor so + -- 32 means add 1/32 of the length of the string as growth space. + + Min_Mul_Alloc : constant := Standard'Maximum_Alignment; + -- Allocation will be done by a multiple of Min_Mul_Alloc. This causes + -- no memory loss as most (all?) malloc implementations are obliged to + -- align the returned memory on the maximum alignment as malloc does not + -- know the target alignment. + + procedure Sync_Add_And_Fetch + (Ptr : access Interfaces.Unsigned_32; + Value : Interfaces.Unsigned_32); + pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_4"); + + function Sync_Sub_And_Fetch + (Ptr : access Interfaces.Unsigned_32; + Value : Interfaces.Unsigned_32) return Interfaces.Unsigned_32; + pragma Import (Intrinsic, Sync_Sub_And_Fetch, "__sync_sub_and_fetch_4"); + + function Aligned_Max_Length (Max_Length : Natural) return Natural; + -- Returns recommended length of the shared string which is greater or + -- equal to specified length. Calculation take in sense alignment of + -- the allocated memory segments to use memory effectively by + -- Append/Insert/etc operations. + + --------- + -- "&" -- + --------- + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + DL : constant Natural := LR.Last + RR.Last; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared empty string. + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Left string is empty, return Rigth string. + + elsif LR.Last = 0 then + Reference (RR); + DR := RR; + + -- Right string is empty, return Left string. + + elsif RR.Last = 0 then + Reference (LR); + DR := LR; + + -- Overwise, allocate new shared string and fill data. + + else + DR := Allocate (LR.Last + RR.Last); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (LR.Last + 1 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + DL : constant Natural := LR.Last + Right'Length; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared empty string. + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Right is an empty string, return Left string. + + elsif Right'Length = 0 then + Reference (LR); + DR := LR; + + -- Otherwise, allocate new shared string and fill it. + + else + DR := Allocate (DL); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (LR.Last + 1 .. DL) := Right; + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + DL : constant Natural := Left'Length + RR.Last; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared one. + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Left is empty string, return Right string. + + elsif Left'Length = 0 then + Reference (RR); + DR := RR; + + -- Otherwise, allocate new shared string and fill it. + + else + DR := Allocate (DL); + DR.Data (1 .. Left'Length) := Left; + DR.Data (Left'Length + 1 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + DL : constant Natural := LR.Last + 1; + DR : Shared_Wide_Wide_String_Access; + + begin + DR := Allocate (DL); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (DL) := Right; + DR.Last := DL; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Wide_Wide_Character; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + DL : constant Natural := 1 + RR.Last; + DR : Shared_Wide_Wide_String_Access; + + begin + DR := Allocate (DL); + DR.Data (1) := Left; + DR.Data (2 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + + return (AF.Controlled with Reference => DR); + end "&"; + + --------- + -- "*" -- + --------- + + function "*" + (Left : Natural; + Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String + is + DR : Shared_Wide_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared empty string. + + if Left = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it. + + else + DR := Allocate (Left); + + for J in 1 .. Left loop + DR.Data (J) := Right; + end loop; + + DR.Last := Left; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + function "*" + (Left : Natural; + Right : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + DL : constant Natural := Left * Right'Length; + DR : Shared_Wide_Wide_String_Access; + K : Positive; + + begin + -- Result is an empty string, reuse shared empty string. + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it. + + else + DR := Allocate (DL); + K := 1; + + for J in 1 .. Left loop + DR.Data (K .. K + Right'Length - 1) := Right; + K := K + Right'Length; + end loop; + + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + function "*" + (Left : Natural; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + DL : constant Natural := Left * RR.Last; + DR : Shared_Wide_Wide_String_Access; + K : Positive; + + begin + -- Result is an empty string, reuse shared empty string. + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Coefficient is one, just return string itself. + + elsif Left = 1 then + Reference (RR); + DR := RR; + + -- Otherwise, allocate new shared string and fill it. + + else + DR := Allocate (DL); + K := 1; + + for J in 1 .. Left loop + DR.Data (K .. K + RR.Last - 1) := RR.Data (1 .. RR.Last); + K := K + RR.Last; + end loop; + + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + --------- + -- "<" -- + --------- + + function "<" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + begin + return LR.Data (1 .. LR.Last) < RR.Data (1 .. RR.Last); + end "<"; + + function "<" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) < Right; + end "<"; + + function "<" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + begin + return Left < RR.Data (1 .. RR.Last); + end "<"; + + ---------- + -- "<=" -- + ---------- + + function "<=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + + begin + -- LR = RR means two strings shares shared string, thus they are equal + + return LR = RR or else LR.Data (1 .. LR.Last) <= RR.Data (1 .. RR.Last); + end "<="; + + function "<=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) <= Right; + end "<="; + + function "<=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + begin + return Left <= RR.Data (1 .. RR.Last); + end "<="; + + --------- + -- "=" -- + --------- + + function "=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + + begin + return LR = RR or else LR.Data (1 .. LR.Last) = RR.Data (1 .. RR.Last); + -- LR = RR means two strings shares shared string, thus they are equal. + end "="; + + function "=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) = Right; + end "="; + + function "=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + begin + return Left = RR.Data (1 .. RR.Last); + end "="; + + --------- + -- ">" -- + --------- + + function ">" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + begin + return LR.Data (1 .. LR.Last) > RR.Data (1 .. RR.Last); + end ">"; + + function ">" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) > Right; + end ">"; + + function ">" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + begin + return Left > RR.Data (1 .. RR.Last); + end ">"; + + ---------- + -- ">=" -- + ---------- + + function ">=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + + begin + -- LR = RR means two strings shares shared string, thus they are equal + + return LR = RR or else LR.Data (1 .. LR.Last) >= RR.Data (1 .. RR.Last); + end ">="; + + function ">=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) >= Right; + end ">="; + + function ">=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + begin + return Left >= RR.Data (1 .. RR.Last); + end ">="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Object : in out Unbounded_Wide_Wide_String) is + begin + Reference (Object.Reference); + end Adjust; + + ------------------------ + -- Aligned_Max_Length -- + ------------------------ + + function Aligned_Max_Length (Max_Length : Natural) return Natural is + Static_Size : constant Natural := + Empty_Shared_Wide_Wide_String'Size + / Standard'Storage_Unit; + -- Total size of all static components + + Element_Size : constant Natural := + Wide_Wide_Character'Size / Standard'Storage_Unit; + + begin + return + (((Static_Size + Max_Length * Element_Size - 1) / Min_Mul_Alloc + 2) + * Min_Mul_Alloc - Static_Size) / Element_Size; + end Aligned_Max_Length; + + -------------- + -- Allocate -- + -------------- + + function Allocate + (Max_Length : Natural) return Shared_Wide_Wide_String_Access is + begin + -- Empty string requested, return shared empty string + + if Max_Length = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + return Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate requested space (and probably some more room) + + else + return new Shared_Wide_Wide_String (Aligned_Max_Length (Max_Length)); + end if; + end Allocate; + + ------------ + -- Append -- + ------------ + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Unbounded_Wide_Wide_String) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + NR : constant Shared_Wide_Wide_String_Access := New_Item.Reference; + DL : constant Natural := SR.Last + NR.Last; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Source is an empty string, reuse New_Item data + + if SR.Last = 0 then + Reference (NR); + Source.Reference := NR; + Unreference (SR); + + -- New_Item is empty string, nothing to do + + elsif NR.Last = 0 then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); + SR.Last := DL; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Wide_Wide_String) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_Wide_Wide_String_Access; + + begin + -- New_Item is an empty string, nothing to do + + if New_Item'Length = 0 then + null; + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (SR.Last + 1 .. DL) := New_Item; + SR.Last := DL; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (SR.Last + 1 .. DL) := New_Item; + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Wide_Wide_Character) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + 1; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Try to reuse existing shared string + + if Can_Be_Reused (SR, SR.Last + 1) then + SR.Data (SR.Last + 1) := New_Item; + SR.Last := SR.Last + 1; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (DL) := New_Item; + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + ------------------- + -- Can_Be_Reused -- + ------------------- + + function Can_Be_Reused + (Item : Shared_Wide_Wide_String_Access; + Length : Natural) return Boolean + is + use Interfaces; + begin + return + Item.Counter = 1 + and then Item.Max_Length >= Length + and then Item.Max_Length <= + Aligned_Max_Length (Length + Length / Growth_Factor); + end Can_Be_Reused; + + ----------- + -- Count -- + ----------- + + function Count + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); + end Count; + + function Count + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); + end Count; + + function Count + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Count (SR.Data (1 .. SR.Last), Set); + end Count; + + ------------ + -- Delete -- + ------------ + + function Delete + (Source : Unbounded_Wide_Wide_String; + From : Positive; + Through : Natural) return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Empty slice is deleted, use the same shared string + + if From > Through then + Reference (SR); + DR := SR; + + -- Index is out of range + + elsif Through > SR.Last then + raise Index_Error; + + -- Compute size of the result + + else + DL := SR.Last - (Through - From + 1); + + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); + DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Delete; + + procedure Delete + (Source : in out Unbounded_Wide_Wide_String; + From : Positive; + Through : Natural) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Nothing changed, return + + if From > Through then + null; + + -- Through is outside of the range + + elsif Through > SR.Last then + raise Index_Error; + + else + DL := SR.Last - (Through - From + 1); + + -- Result is empty, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + SR.Last := DL; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); + DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Delete; + + ------------- + -- Element -- + ------------- + + function Element + (Source : Unbounded_Wide_Wide_String; + Index : Positive) return Wide_Wide_Character + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + if Index <= SR.Last then + return SR.Data (Index); + else + raise Index_Error; + end if; + end Element; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Unbounded_Wide_Wide_String) is + SR : constant Shared_Wide_Wide_String_Access := Object.Reference; + + begin + if SR /= null then + + -- The same controlled object can be finalized several times for + -- some reason. As per 7.6.1(24) this should have no ill effect, + -- so we need to add a guard for the case of finalizing the same + -- object twice. + + Object.Reference := null; + Unreference (SR); + end if; + end Finalize; + + ---------------- + -- Find_Token -- + ---------------- + + procedure Find_Token + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Strings.Membership; + First : out Positive; + Last : out Natural) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + Wide_Wide_Search.Find_Token + (SR.Data (1 .. SR.Last), Set, Test, First, Last); + end Find_Token; + + ---------- + -- Free -- + ---------- + + procedure Free (X : in out Wide_Wide_String_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation + (Wide_Wide_String, Wide_Wide_String_Access); + begin + Deallocate (X); + end Free; + + ---------- + -- Head -- + ---------- + + function Head + (Source : Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Result is empty, reuse shared empty string + + if Count = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Length of the string is the same as requested, reuse source shared + -- string. + + elsif Count = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (Count); + + -- Length of the source string is more than requested, copy + -- corresponding slice. + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (1 .. Count); + + -- Length of the source string is less then requested, copy all + -- contents and fill others by Pad character. + + else + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + + for J in SR.Last + 1 .. Count loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + end if; + + return (AF.Controlled with Reference => DR); + end Head; + + procedure Head + (Source : in out Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Result is empty, reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + -- Result is same with source string, reuse source shared string + + elsif Count = SR.Last then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, Count) then + if Count > SR.Last then + for J in SR.Last + 1 .. Count loop + SR.Data (J) := Pad; + end loop; + end if; + + SR.Last := Count; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (Count); + + -- Length of the source string is greater then requested, copy + -- corresponding slice. + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (1 .. Count); + + -- Length of the source string is less the requested, copy all + -- exists data and fill others by Pad character. + + else + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + + for J in SR.Last + 1 .. Count loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + Source.Reference := DR; + Unreference (SR); + end if; + end Head; + + ----------- + -- Index -- + ----------- + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Strings.Direction := Strings.Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Strings.Membership := Strings.Inside; + Going : Strings.Direction := Strings.Forward) return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index (SR.Data (1 .. SR.Last), Set, Test, Going); + end Index; + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index + (SR.Data (1 .. SR.Last), Set, From, Test, Going); + end Index; + + --------------------- + -- Index_Non_Blank -- + --------------------- + + function Index_Non_Blank + (Source : Unbounded_Wide_Wide_String; + Going : Strings.Direction := Strings.Forward) return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index_Non_Blank (SR.Data (1 .. SR.Last), Going); + end Index_Non_Blank; + + function Index_Non_Blank + (Source : Unbounded_Wide_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index_Non_Blank + (SR.Data (1 .. SR.Last), From, Going); + end Index_Non_Blank; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Object : in out Unbounded_Wide_Wide_String) is + begin + Reference (Object.Reference); + end Initialize; + + ------------ + -- Insert -- + ------------ + + function Insert + (Source : Unbounded_Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Check index first + + if Before > SR.Last + 1 then + raise Index_Error; + end if; + + -- Result is empty, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Inserted string is empty, reuse source shared string + + elsif New_Item'Length = 0 then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); + DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + DR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Insert; + + procedure Insert + (Source : in out Unbounded_Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Check bounds + + if Before > SR.Last + 1 then + raise Index_Error; + end if; + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + -- Inserted string is empty, nothing to do + + elsif New_Item'Length = 0 then + null; + + -- Try to reuse existent shared string first + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + SR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + SR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); + DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + DR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Insert; + + ------------ + -- Length -- + ------------ + + function Length (Source : Unbounded_Wide_Wide_String) return Natural is + begin + return Source.Reference.Last; + end Length; + + --------------- + -- Overwrite -- + --------------- + + function Overwrite + (Source : Unbounded_Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Check bounds + + if Position > SR.Last + 1 then + raise Index_Error; + end if; + + DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Result is same with source string, reuse source shared string + + elsif New_Item'Length = 0 then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); + DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + DR.Data (Position + New_Item'Length .. DL) := + SR.Data (Position + New_Item'Length .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Overwrite; + + procedure Overwrite + (Source : in out Unbounded_Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Bounds check + + if Position > SR.Last + 1 then + raise Index_Error; + end if; + + DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + -- String unchanged, nothing to do + + elsif New_Item'Length = 0 then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + SR.Last := DL; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); + DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + DR.Data (Position + New_Item'Length .. DL) := + SR.Data (Position + New_Item'Length .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Overwrite; + + --------------- + -- Reference -- + --------------- + + procedure Reference (Item : not null Shared_Wide_Wide_String_Access) is + begin + Sync_Add_And_Fetch (Item.Counter'Access, 1); + end Reference; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Source : in out Unbounded_Wide_Wide_String; + Index : Positive; + By : Wide_Wide_Character) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Bounds check. + + if Index <= SR.Last then + + -- Try to reuse existent shared string + + if Can_Be_Reused (SR, SR.Last) then + SR.Data (Index) := By; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (Index) := By; + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + + else + raise Index_Error; + end if; + end Replace_Element; + + ------------------- + -- Replace_Slice -- + ------------------- + + function Replace_Slice + (Source : Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 then + raise Index_Error; + end if; + + -- Do replace operation when removed slice is not empty + + if High >= Low then + DL := By'Length + SR.Last + Low - High - 1; + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); + DR.Data (Low .. Low + By'Length - 1) := By; + DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + + -- Otherwise just insert string + + else + return Insert (Source, Low, By); + end if; + end Replace_Slice; + + procedure Replace_Slice + (Source : in out Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Bounds check + + if Low > SR.Last + 1 then + raise Index_Error; + end if; + + -- Do replace operation only when replaced slice is not empty + + if High >= Low then + DL := By'Length + SR.Last + Low - High - 1; + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + SR.Data (Low .. Low + By'Length - 1) := By; + SR.Last := DL; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); + DR.Data (Low .. Low + By'Length - 1) := By; + DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + + -- Otherwise just insert item + + else + Insert (Source, Low, By); + end if; + end Replace_Slice; + + ------------------------------- + -- Set_Unbounded_Wide_Wide_String -- + ------------------------------- + + procedure Set_Unbounded_Wide_Wide_String + (Target : out Unbounded_Wide_Wide_String; + Source : Wide_Wide_String) + is + TR : constant Shared_Wide_Wide_String_Access := Target.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- In case of empty string, reuse empty shared string + + if Source'Length = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Target.Reference := Empty_Shared_Wide_Wide_String'Access; + + else + -- Try to reuse existent shared string + + if Can_Be_Reused (TR, Source'Length) then + Reference (TR); + DR := TR; + + -- Otherwise allocate new shared string + + else + DR := Allocate (Source'Length); + Target.Reference := DR; + end if; + + DR.Data (1 .. Source'Length) := Source; + DR.Last := Source'Length; + end if; + + Unreference (TR); + end Set_Unbounded_Wide_Wide_String; + + ----------- + -- Slice -- + ----------- + + function Slice + (Source : Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural) return Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + + begin + -- Note: test of High > Length is in accordance with AI95-00128 + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + else + return SR.Data (Low .. High); + end if; + end Slice; + + ---------- + -- Tail -- + ---------- + + function Tail + (Source : Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- For empty result reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Result is hole source string, reuse source shared string + + elsif Count = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (Count); + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); + + else + for J in 1 .. Count - SR.Last loop + DR.Data (J) := Pad; + end loop; + + DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); + end if; + + DR.Last := Count; + end if; + + return (AF.Controlled with Reference => DR); + end Tail; + + procedure Tail + (Source : in out Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + procedure Common + (SR : Shared_Wide_Wide_String_Access; + DR : Shared_Wide_Wide_String_Access; + Count : Natural); + -- Common code of tail computation. SR/DR can point to the same object + + ------------ + -- Common -- + ------------ + + procedure Common + (SR : Shared_Wide_Wide_String_Access; + DR : Shared_Wide_Wide_String_Access; + Count : Natural) is + begin + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); + + else + DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); + + for J in 1 .. Count - SR.Last loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + end Common; + + begin + -- Result is empty string, reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + -- Length of the result is the same with length of the source string, + -- reuse source shared string. + + elsif Count = SR.Last then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, Count) then + Common (SR, SR, Count); + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (Count); + Common (SR, DR, Count); + Source.Reference := DR; + Unreference (SR); + end if; + end Tail; + + -------------------- + -- To_Wide_Wide_String -- + -------------------- + + function To_Wide_Wide_String + (Source : Unbounded_Wide_Wide_String) return Wide_Wide_String is + begin + return Source.Reference.Data (1 .. Source.Reference.Last); + end To_Wide_Wide_String; + + ------------------------------ + -- To_Unbounded_Wide_Wide_String -- + ------------------------------ + + function To_Unbounded_Wide_Wide_String + (Source : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + DR : constant Shared_Wide_Wide_String_Access := Allocate (Source'Length); + begin + DR.Data (1 .. Source'Length) := Source; + DR.Last := Source'Length; + return (AF.Controlled with Reference => DR); + end To_Unbounded_Wide_Wide_String; + + function To_Unbounded_Wide_Wide_String + (Length : Natural) return Unbounded_Wide_Wide_String + is + DR : constant Shared_Wide_Wide_String_Access := Allocate (Length); + begin + DR.Last := Length; + return (AF.Controlled with Reference => DR); + end To_Unbounded_Wide_Wide_String; + + --------------- + -- Translate -- + --------------- + + function Translate + (Source : Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Nothing to translate, reuse empty shared string + + if SR.Last = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + DR.Last := SR.Last; + end if; + + return (AF.Controlled with Reference => DR); + end Translate; + + procedure Translate + (Source : in out Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Nothing to translate + + if SR.Last = 0 then + null; + + -- Try to reuse shared string + + elsif Can_Be_Reused (SR, SR.Last) then + for J in 1 .. SR.Last loop + SR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + end Translate; + + function Translate + (Source : Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Nothing to translate, reuse empty shared string + + if SR.Last = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + DR.Last := SR.Last; + end if; + + return (AF.Controlled with Reference => DR); + + exception + when others => + Unreference (DR); + + raise; + end Translate; + + procedure Translate + (Source : in out Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Nothing to translate + + if SR.Last = 0 then + null; + + -- Try to reuse shared string + + elsif Can_Be_Reused (SR, SR.Last) then + for J in 1 .. SR.Last loop + SR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + + exception + when others => + if DR /= null then + Unreference (DR); + end if; + + raise; + end Translate; + + ---------- + -- Trim -- + ---------- + + function Trim + (Source : Unbounded_Wide_Wide_String; + Side : Trim_End) return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index_Non_Blank (Source, Forward); + + -- All blanks, reuse empty shared string + + if Low = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + else + case Side is + when Left => + High := SR.Last; + DL := SR.Last - Low + 1; + + when Right => + Low := 1; + High := Index_Non_Blank (Source, Backward); + DL := High; + + when Both => + High := Index_Non_Blank (Source, Backward); + DL := High - Low + 1; + end case; + + -- Length of the result is the same as length of the source string, + -- reuse source shared string. + + if DL = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Trim; + + procedure Trim + (Source : in out Unbounded_Wide_Wide_String; + Side : Trim_End) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index_Non_Blank (Source, Forward); + + -- All blanks, reuse empty shared string + + if Low = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + else + case Side is + when Left => + High := SR.Last; + DL := SR.Last - Low + 1; + + when Right => + Low := 1; + High := Index_Non_Blank (Source, Backward); + DL := High; + + when Both => + High := Index_Non_Blank (Source, Backward); + DL := High - Low + 1; + end case; + + -- Length of the result is the same as length of the source string, + -- nothing to do. + + if DL = SR.Last then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (1 .. DL) := SR.Data (Low .. High); + SR.Last := DL; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Trim; + + function Trim + (Source : Unbounded_Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set) + return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index (Source, Left, Outside, Forward); + + -- Source includes only characters from Left set, reuse empty shared + -- string. + + if Low = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + else + High := Index (Source, Right, Outside, Backward); + DL := Integer'Max (0, High - Low + 1); + + -- Source includes only characters from Right set or result string + -- is empty, reuse empty shared string. + + if High = 0 or else DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Trim; + + procedure Trim + (Source : in out Unbounded_Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index (Source, Left, Outside, Forward); + + -- Source includes only characters from Left set, reuse empty shared + -- string. + + if Low = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + else + High := Index (Source, Right, Outside, Backward); + DL := Integer'Max (0, High - Low + 1); + + -- Source includes only characters from Right set or result string + -- is empty, reuse empty shared string. + + if High = 0 or else DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (1 .. DL) := SR.Data (Low .. High); + SR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Trim; + + --------------------- + -- Unbounded_Slice -- + --------------------- + + function Unbounded_Slice + (Source : Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural) return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + -- Result is empty slice, reuse empty shared string + + elsif Low > High then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DL := High - Low + 1; + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Unbounded_Slice; + + procedure Unbounded_Slice + (Source : Unbounded_Wide_Wide_String; + Target : out Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + TR : constant Shared_Wide_Wide_String_Access := Target.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + -- Result is empty slice, reuse empty shared string + + elsif Low > High then + Reference (Empty_Shared_Wide_Wide_String'Access); + Target.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (TR); + + else + DL := High - Low + 1; + + -- Try to reuse existent shared string + + if Can_Be_Reused (TR, DL) then + TR.Data (1 .. DL) := SR.Data (Low .. High); + TR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Target.Reference := DR; + Unreference (TR); + end if; + end if; + end Unbounded_Slice; + + ----------------- + -- Unreference -- + ----------------- + + procedure Unreference (Item : not null Shared_Wide_Wide_String_Access) is + use Interfaces; + + procedure Free is + new Ada.Unchecked_Deallocation + (Shared_Wide_Wide_String, Shared_Wide_Wide_String_Access); + + Aux : Shared_Wide_Wide_String_Access := Item; + + begin + if Sync_Sub_And_Fetch (Aux.Counter'Access, 1) = 0 then + + -- Reference counter of Empty_Shared_Wide_Wide_String must never + -- reach zero. + + pragma Assert (Aux /= Empty_Shared_Wide_Wide_String'Access); + + Free (Aux); + end if; + end Unreference; + +end Ada.Strings.Wide_Wide_Unbounded; diff --git a/gcc/ada/a-stzunb-shared.ads b/gcc/ada/a-stzunb-shared.ads new file mode 100644 index 00000000000..4617f56fdc2 --- /dev/null +++ b/gcc/ada/a-stzunb-shared.ads @@ -0,0 +1,501 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT 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 distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version is supported on: +-- - all Alpha platforms +-- - all ia64 platforms +-- - all PowerPC platforms +-- - all SPARC V9 platforms +-- - all x86_64 platforms + +with Ada.Strings.Wide_Wide_Maps; +private with Ada.Finalization; +private with Interfaces; + +package Ada.Strings.Wide_Wide_Unbounded is + pragma Preelaborate; + + type Unbounded_Wide_Wide_String is private; + pragma Preelaborable_Initialization (Unbounded_Wide_Wide_String); + + Null_Unbounded_Wide_Wide_String : constant Unbounded_Wide_Wide_String; + + function Length (Source : Unbounded_Wide_Wide_String) return Natural; + + type Wide_Wide_String_Access is access all Wide_Wide_String; + + procedure Free (X : in out Wide_Wide_String_Access); + + -------------------------------------------------------- + -- Conversion, Concatenation, and Selection Functions -- + -------------------------------------------------------- + + function To_Unbounded_Wide_Wide_String + (Source : Wide_Wide_String) return Unbounded_Wide_Wide_String; + + function To_Unbounded_Wide_Wide_String + (Length : Natural) return Unbounded_Wide_Wide_String; + + function To_Wide_Wide_String + (Source : Unbounded_Wide_Wide_String) return Wide_Wide_String; + + procedure Set_Unbounded_Wide_Wide_String + (Target : out Unbounded_Wide_Wide_String; + Source : Wide_Wide_String); + pragma Ada_05 (Set_Unbounded_Wide_Wide_String); + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Unbounded_Wide_Wide_String); + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Wide_Wide_String); + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Wide_Wide_Character); + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String; + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Unbounded_Wide_Wide_String; + + function "&" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String; + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String; + + function "&" + (Left : Wide_Wide_Character; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String; + + function Element + (Source : Unbounded_Wide_Wide_String; + Index : Positive) return Wide_Wide_Character; + + procedure Replace_Element + (Source : in out Unbounded_Wide_Wide_String; + Index : Positive; + By : Wide_Wide_Character); + + function Slice + (Source : Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural) return Wide_Wide_String; + + function Unbounded_Slice + (Source : Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural) return Unbounded_Wide_Wide_String; + pragma Ada_05 (Unbounded_Slice); + + procedure Unbounded_Slice + (Source : Unbounded_Wide_Wide_String; + Target : out Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural); + pragma Ada_05 (Unbounded_Slice); + + function "=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function "=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function "=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function "<" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function "<" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function "<" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function "<=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function "<=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function "<=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function ">" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function ">" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function ">" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function ">=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function ">=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function ">=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + ------------------------ + -- Search Subprograms -- + ------------------------ + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + + function Index + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index); + + function Index_Non_Blank + (Source : Unbounded_Wide_Wide_String; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : Unbounded_Wide_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index_Non_Blank); + + function Count + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + + function Count + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + + function Count + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural; + + procedure Find_Token + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + + ------------------------------------ + -- String Translation Subprograms -- + ------------------------------------ + + function Translate + (Source : Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + return Unbounded_Wide_Wide_String; + + procedure Translate + (Source : in out Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping); + + function Translate + (Source : Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Unbounded_Wide_Wide_String; + + procedure Translate + (Source : in out Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function); + + --------------------------------------- + -- String Transformation Subprograms -- + --------------------------------------- + + function Replace_Slice + (Source : Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String) return Unbounded_Wide_Wide_String; + + procedure Replace_Slice + (Source : in out Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String); + + function Insert + (Source : Unbounded_Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String; + + procedure Insert + (Source : in out Unbounded_Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String); + + function Overwrite + (Source : Unbounded_Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String; + + procedure Overwrite + (Source : in out Unbounded_Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String); + + function Delete + (Source : Unbounded_Wide_Wide_String; + From : Positive; + Through : Natural) return Unbounded_Wide_Wide_String; + + procedure Delete + (Source : in out Unbounded_Wide_Wide_String; + From : Positive; + Through : Natural); + + function Trim + (Source : Unbounded_Wide_Wide_String; + Side : Trim_End) return Unbounded_Wide_Wide_String; + + procedure Trim + (Source : in out Unbounded_Wide_Wide_String; + Side : Trim_End); + + function Trim + (Source : Unbounded_Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set) + return Unbounded_Wide_Wide_String; + + procedure Trim + (Source : in out Unbounded_Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set); + + function Head + (Source : Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + return Unbounded_Wide_Wide_String; + + procedure Head + (Source : in out Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space); + + function Tail + (Source : Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + return Unbounded_Wide_Wide_String; + + procedure Tail + (Source : in out Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space); + + function "*" + (Left : Natural; + Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String; + + function "*" + (Left : Natural; + Right : Wide_Wide_String) return Unbounded_Wide_Wide_String; + + function "*" + (Left : Natural; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String; + +private + pragma Inline (Length); + + package AF renames Ada.Finalization; + + type Shared_Wide_Wide_String (Max_Length : Natural) is limited record + Counter : aliased Interfaces.Unsigned_32 := 1; + -- Reference counter. + + Last : Natural := 0; + Data : Wide_Wide_String (1 .. Max_Length); + -- Last is the index of last significant element of the Data. All + -- elements with larger indecies are just an extra room. + end record; + + type Shared_Wide_Wide_String_Access is access all Shared_Wide_Wide_String; + + procedure Reference (Item : not null Shared_Wide_Wide_String_Access); + -- Increment reference counter. + + procedure Unreference (Item : not null Shared_Wide_Wide_String_Access); + -- Decrement reference counter. Deallocate Item when reference counter is + -- zero. + + function Can_Be_Reused + (Item : Shared_Wide_Wide_String_Access; + Length : Natural) return Boolean; + -- Returns True if Shared_Wide_Wide_String can be reused. There are two + -- criteria when Shared_Wide_Wide_String can be reused: its reference + -- counter must be one (thus Shared_Wide_Wide_String is owned exclusively) + -- and its size is sufficient to store string with specified length + -- effectively. + + function Allocate + (Max_Length : Natural) return Shared_Wide_Wide_String_Access; + -- Allocates new Shared_Wide_Wide_String with at least specified maximum + -- length. Actual maximum length of the allocated Shared_Wide_Wide_String + -- can be sligtly greater. Returns reference to + -- Empty_Shared_Wide_Wide_String when requested length is zero. + + Empty_Shared_Wide_Wide_String : aliased Shared_Wide_Wide_String (0); + + function To_Unbounded + (S : Wide_Wide_String) return Unbounded_Wide_Wide_String + renames To_Unbounded_Wide_Wide_String; + -- This renames are here only to be used in the pragma Stream_Convert. + + type Unbounded_Wide_Wide_String is new AF.Controlled with record + Reference : Shared_Wide_Wide_String_Access := + Empty_Shared_Wide_Wide_String'Access; + end record; + + -- The Unbounded_Wide_Wide_String uses several techniques to increasy speed + -- of the application: + -- - implicit sharing or copy-on-write. Unbounded_Wide_Wide_String + -- contains only the reference to the data which is shared between + -- several instances. The shared data is reallocated only when its value + -- is changed and the object mutation can't be used or it is unefficient + -- to use it; + -- - object mutation. Shared data object can be reused without memory + -- reallocation when all of the following requirements are meat: + -- - shared data object don't used anywhere longer; + -- - its size is sufficient to store new value; + -- - the gap after reuse is less then some threashold. + -- - memory preallocation. Most of used memory allocation algorithms + -- alligns allocated segment on the some boundary, thus some amount of + -- additional memory can be preallocated without any impact. Such + -- preallocated memory can used later by Append/Insert operations + -- without reallocation. + -- + -- Reference counting uses GCC builtin atomic operations, which allows to + -- safely share internal data between Ada tasks. Nevertheless, this not + -- make objects of Unbounded_Wide_Wide_String thread-safe, so each instance + -- can't be accessed by several tasks simulatenously. + + pragma Stream_Convert + (Unbounded_Wide_Wide_String, To_Unbounded, To_Wide_Wide_String); + -- Provide stream routines without dragging in Ada.Streams + + pragma Finalize_Storage_Only (Unbounded_Wide_Wide_String); + -- Finalization is required only for freeing storage + + overriding procedure Initialize + (Object : in out Unbounded_Wide_Wide_String); + overriding procedure Adjust + (Object : in out Unbounded_Wide_Wide_String); + overriding procedure Finalize + (Object : in out Unbounded_Wide_Wide_String); + + Null_Unbounded_Wide_Wide_String : constant Unbounded_Wide_Wide_String := + (AF.Controlled with + Reference => + Empty_Shared_Wide_Wide_String'Access); + +end Ada.Strings.Wide_Wide_Unbounded; diff --git a/gcc/ada/a-suenco.adb b/gcc/ada/a-suenco.adb new file mode 100755 index 00000000000..42b7f719a5b --- /dev/null +++ b/gcc/ada/a-suenco.adb @@ -0,0 +1,390 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.UTF_ENCODING.CONVERSIONS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT 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 distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.UTF_Encoding.Conversions is + use Interfaces; + + -- Version convertion from UTF-8/UTF-16BE/LE to UTF-8/UTF-16BE/LE + + function Convert + (Item : UTF_String; + Input_Scheme : Encoding_Scheme; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String + is + begin + -- Nothing to do if identical schemes + + if Input_Scheme = Output_Scheme then + return Item; + + -- For remaining cases, one or other of the operands is UTF-16BE/LE + -- encoded, so go through UTF-16 intermediate. + + else + return Convert (UTF_16_Wide_String'(Convert (Item, Input_Scheme)), + Output_Scheme, Output_BOM); + end if; + end Convert; + + -- Version converting UTF-8/UTF-16BE/LE to UTF-16 + + function Convert + (Item : UTF_String; + Input_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_16_Wide_String + is + begin + if Input_Scheme = UTF_8 then + return Convert (Item, Output_BOM); + else + return To_UTF_16 (Item, Input_Scheme, Output_BOM); + end if; + end Convert; + + -- Version converting UTF-8 to UTF-16 + + function Convert + (Item : UTF_8_String; + Output_BOM : Boolean := False) return UTF_16_Wide_String + is + Result : UTF_16_Wide_String (1 .. Item'Length + 1); + -- Maximum length of result, including possible BOM + + Len : Natural := 0; + -- Number of characters stored so far in Result + + Iptr : Natural; + -- Next character to process in Item + + C : Unsigned_8; + -- Input UTF-8 code + + R : Unsigned_16; + -- Output UTF-16 code + + procedure Get_Continuation; + -- Reads a continuation byte of the form 10xxxxxx, shifts R left + -- by 6 bits, and or's in the xxxxxx to the low order 6 bits. On + -- return Ptr is incremented. Raises exceptioon if continuation + -- byte does not exist or is invalid. + + ---------------------- + -- Get_Continuation -- + ---------------------- + + procedure Get_Continuation is + begin + if Iptr > Item'Last then + Raise_Encoding_Error (Iptr - 1); + + else + C := To_Unsigned_8 (Item (Iptr)); + Iptr := Iptr + 1; + + if C < 2#10_000000# or else C > 2#10_111111# then + Raise_Encoding_Error (Iptr - 1); + + else + R := Shift_Left (R, 6) or + Unsigned_16 (C and 2#00_111111#); + end if; + end if; + end Get_Continuation; + + -- Start of processing for Convert + + begin + -- Output BOM if required + + if Output_BOM then + Len := Len + 1; + Result (Len) := BOM_16 (1); + end if; + + -- Skip OK BOM + + Iptr := Item'First; + + if Item'Length >= 3 and then Item (Iptr .. Iptr + 2) = BOM_8 then + Iptr := Iptr + 3; + + -- Error if bad BOM + + elsif Item'Length >= 2 + and then (Item (Iptr .. Iptr + 1) = BOM_16BE + or else + Item (Iptr .. Iptr + 1) = BOM_16LE) + then + Raise_Encoding_Error (Iptr); + + -- No BOM present + + else + Iptr := Item'First; + end if; + + while Iptr <= Item'Last loop + C := To_Unsigned_8 (Item (Iptr)); + Iptr := Iptr + 1; + + -- Codes in the range 16#00# - 16#7F# + -- UTF-8: 0xxxxxxx + -- UTF-16: 00000000_0xxxxxxx + + if C <= 16#7F# then + Len := Len + 1; + Result (Len) := Wide_Character'Val (C); + + -- No initial code can be of the form 10xxxxxx. Such codes are used + -- only for continuations. + + elsif C <= 2#10_111111# then + Raise_Encoding_Error (Iptr - 1); + + -- Codes in the range 16#80# - 16#7FF# + -- UTF-8: 110yyyxx 10xxxxxx + -- UTF-16: 00000yyy_xxxxxxxx + + elsif C <= 2#110_11111# then + R := Unsigned_16 (C and 2#000_11111#); + Get_Continuation; + Len := Len + 1; + Result (Len) := Wide_Character'Val (R); + + -- Codes in the range 16#800# - 16#FFFF# + -- UTF-8: 1110yyyy 10yyyyxx 10xxxxxx + -- UTF-16: yyyyyyyy_xxxxxxxx + + elsif C <= 2#1110_1111# then + R := Unsigned_16 (C and 2#0000_1111#); + Get_Continuation; + Get_Continuation; + Len := Len + 1; + Result (Len) := Wide_Character'Val (R); + + -- Make sure that we don't have a result in the forbidden range + -- reserved for UTF-16 surrogate characters. + + if R in 16#D800# .. 16#DF00# then + Raise_Encoding_Error (Iptr - 3); + end if; + + -- Codes in the range 16#10000# - 16#10FFFF# + -- UTF-8: 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx + -- UTF-16: 110110zz_zzyyyyyy 110111yy_xxxxxxxx + -- Note: zzzz in the output is input zzzzz - 1 + + elsif C <= 2#11110_111# then + R := Unsigned_16 (C and 2#00000_111#); + Get_Continuation; + + -- R now has zzzzzyyyy + + R := R - 2#0000_1_0000#; + + -- R now has zzzzyyyy (zzzz minus one for the output) + + Get_Continuation; + + -- R now has zzzzyyyyyyyyxx + + Len := Len + 1; + Result (Len) := + Wide_Character'Val + (2#110110_00_0000_0000# or Shift_Right (R, 4)); + + R := R and 2#1111#; + Get_Continuation; + Len := Len + 1; + Result (Len) := + Wide_Character'Val (2#110111_00_0000_0000# or R); + + -- Any other code is an error + + else + Raise_Encoding_Error (Iptr - 1); + end if; + end loop; + + return Result (1 .. Len); + end Convert; + + -- Convert from UTF-16 to UTF-8/UTF-16-BE/LE + + function Convert + (Item : UTF_16_Wide_String; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String + is + begin + if Output_Scheme = UTF_8 then + return Convert (Item, Output_BOM); + else + return From_UTF_16 (Item, Output_Scheme, Output_BOM); + end if; + end Convert; + + -- Convert from UTF-16 to UTF-8 + + function Convert + (Item : UTF_16_Wide_String; + Output_BOM : Boolean := False) return UTF_8_String + is + Result : UTF_8_String (1 .. 3 * Item'Length + 3); + -- Worst case is 3 output codes for each input code + BOM space + + Len : Natural; + -- Number of result codes stored + + Iptr : Natural; + -- Pointer to next input character + + C1, C2 : Unsigned_16; + + zzzzz : Unsigned_16; + yyyyyyyy : Unsigned_16; + xxxxxxxx : Unsigned_16; + -- Components of double length case + + begin + Iptr := Item'First; + + -- Skip BOM at start of input + + if Item'Length > 0 and then Item (Iptr) = BOM_16 (1) then + Iptr := Iptr + 1; + end if; + + -- Generate output BOM if required + + if Output_BOM then + Result (1 .. 3) := BOM_8; + Len := 3; + else + Len := 0; + end if; + + -- Loop through input + + while Iptr <= Item'Last loop + C1 := To_Unsigned_16 (Item (Iptr)); + Iptr := Iptr + 1; + + -- Codes in the range 16#0000# - 16#007F# + -- UTF-16: 000000000xxxxxxx + -- UTF-8: 0xxxxxxx + + if C1 <= 16#007F# then + Result (Len + 1) := Character'Val (C1); + Len := Len + 1; + + -- Codes in the range 16#80# - 16#7FF# + -- UTF-16: 00000yyyxxxxxxxx + -- UTF-8: 110yyyxx 10xxxxxx + + elsif C1 <= 16#07FF# then + Result (Len + 1) := + Character'Val + (2#110_000000# or Shift_Right (C1, 6)); + Result (Len + 2) := + Character'Val + (2#10_000000# or (C1 and 2#00_111111#)); + Len := Len + 2; + + -- Codes in the range 16#800# - 16#D7FF# or 16#E000# - 16#FFFF# + -- UTF-16: yyyyyyyyxxxxxxxx + -- UTF-8: 1110yyyy 10yyyyxx 10xxxxxx + + elsif C1 <= 16#D7FF# or else C1 >= 16#E000# then + Result (Len + 1) := + Character'Val + (2#1110_0000# or Shift_Right (C1, 12)); + Result (Len + 2) := + Character'Val + (2#10_000000# or (Shift_Right (C1, 6) and 2#00_111111#)); + Result (Len + 3) := + Character'Val + (2#10_000000# or (C1 and 2#00_111111#)); + Len := Len + 3; + + -- Codes in the range 16#10000# - 16#10FFFF# + -- UTF-16: 110110zzzzyyyyyy 110111yyxxxxxxxx + -- UTF-8: 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx + -- Note: zzzzz in the output is input zzzz + 1 + + elsif C1 <= 2#110110_11_11111111# then + if Iptr > Item'Last then + Raise_Encoding_Error (Iptr - 1); + else + C2 := To_Unsigned_16 (Item (Iptr)); + Iptr := Iptr + 1; + end if; + + if (C2 and 2#111111_00_00000000#) /= 2#110111_00_00000000# then + Raise_Encoding_Error (Iptr - 1); + end if; + + zzzzz := (Shift_Right (C1, 6) and 2#1111#) + 1; + yyyyyyyy := ((Shift_Left (C1, 2) and 2#111111_00#) + or + (Shift_Right (C2, 8) and 2#000000_11#)); + xxxxxxxx := C2 and 2#11111111#; + + Result (Len + 1) := + Character'Val + (2#11110_000# or (Shift_Right (zzzzz, 2))); + Result (Len + 2) := + Character'Val + (2#10_000000# or Shift_Left (zzzzz and 2#11#, 4) + or Shift_Right (yyyyyyyy, 4)); + Result (Len + 3) := + Character'Val + (2#10_000000# or Shift_Left (yyyyyyyy and 2#1111#, 4) + or Shift_Right (xxxxxxxx, 6)); + Result (Len + 4) := + Character'Val + (2#10_000000# or (xxxxxxxx and 2#00_111111#)); + Len := Len + 4; + + -- Error if input in 16#DC00# - 16#DFFF# (2nd surrogate with no 1st) + + else + Raise_Encoding_Error (Iptr - 2); + end if; + end loop; + + return Result (1 .. Len); + end Convert; + +end Ada.Strings.UTF_Encoding.Conversions; diff --git a/gcc/ada/a-suenco.ads b/gcc/ada/a-suenco.ads new file mode 100755 index 00000000000..0aa4f88b20f --- /dev/null +++ b/gcc/ada/a-suenco.ads @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.UTF_ENCODING.CONVERSIONS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- This is an Ada 2012 package defined in AI05-0137-1. It provides conversions +-- from one UTF encoding method to another. Note: this package is consistent +-- with Ada 95, and may be used in Ada 95 or Ada 2005 mode. + +package Ada.Strings.UTF_Encoding.Conversions is + pragma Pure (Conversions); + + -- In the following conversion routines, a BOM in the input that matches + -- the encoding scheme is ignored, an incorrect BOM causes Encoding_Error + -- to be raised. A BOM is present in the output if the Output_BOM parameter + -- is set to True. + + function Convert + (Item : UTF_String; + Input_Scheme : Encoding_Scheme; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String; + -- Convert from input encoded in UTF-8, UTF-16LE, or UTF-16BE as specified + -- by the Input_Scheme argument, and generate an output encoded in one of + -- these three schemes as specified by the Output_Scheme argument. + + function Convert + (Item : UTF_String; + Input_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_16_Wide_String; + -- Convert from input encoded in UTF-8, UTF-16LE, or UTF-16BE as specified + -- by the Input_Scheme argument, and generate an output encoded in UTF-16. + + function Convert + (Item : UTF_8_String; + Output_BOM : Boolean := False) return UTF_16_Wide_String; + -- Convert from UTF-8 to UTF-16 + + function Convert + (Item : UTF_16_Wide_String; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String; + -- Convert from UTF-16 to UTF-8, UTF-16LE, or UTF-16BE as specified by + -- the Output_Scheme argument. + + function Convert + (Item : UTF_16_Wide_String; + Output_BOM : Boolean := False) return UTF_8_String; + -- Convert from UTF-16 to UTF-8 + +end Ada.Strings.UTF_Encoding.Conversions; diff --git a/gcc/ada/a-suewen.adb b/gcc/ada/a-suewen.adb new file mode 100755 index 00000000000..3cbebc83d3a --- /dev/null +++ b/gcc/ada/a-suewen.adb @@ -0,0 +1,371 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.UTF_ENCODING.WIDE_ENCODING -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT 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 distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.UTF_Encoding.Wide_Encoding is + use Interfaces; + + ------------ + -- Decode -- + ------------ + + -- Version to decode UTF-8/UTF-16BE/UTF-16LE input to Wide_String + + function Decode + (Item : UTF_String; + Input_Scheme : Encoding_Scheme) return Wide_String + is + begin + if Input_Scheme = UTF_8 then + return Decode (Item); + else + return Decode (To_UTF_16 (Item, Input_Scheme)); + end if; + end Decode; + + -- Decode UTF-8 input to Wide_String + + function Decode (Item : UTF_8_String) return Wide_String is + Result : Wide_String (1 .. Item'Length); + -- Result string (worst case is same length as input) + + Len : Natural := 0; + -- Length of result stored so far + + Iptr : Natural; + -- Input Item pointer + + C : Unsigned_8; + R : Unsigned_16; + + procedure Get_Continuation; + -- Reads a continuation byte of the form 10xxxxxx, shifts R left + -- by 6 bits, and or's in the xxxxxx to the low order 6 bits. On + -- return Ptr is incremented. Raises exceptioon if continuation + -- byte does not exist or is invalid. + + ---------------------- + -- Get_Continuation -- + ---------------------- + + procedure Get_Continuation is + begin + if Iptr > Item'Last then + Raise_Encoding_Error (Iptr - 1); + + else + C := To_Unsigned_8 (Item (Iptr)); + Iptr := Iptr + 1; + + if C not in 2#10_000000# .. 2#10_111111# then + Raise_Encoding_Error (Iptr - 1); + else + R := Shift_Left (R, 6) or Unsigned_16 (C and 2#00_111111#); + end if; + end if; + end Get_Continuation; + + -- Start of processing for Decode + + begin + Iptr := Item'First; + + -- Skip BOM at start + + if Item'Length >= 3 + and then Item (Iptr .. Iptr + 2) = BOM_8 + then + Iptr := Iptr + 3; + + -- Error if bad BOM + + elsif Item'Length >= 2 + and then (Item (Iptr .. Iptr + 1) = BOM_16BE + or else + Item (Iptr .. Iptr + 1) = BOM_16LE) + then + Raise_Encoding_Error (Iptr); + end if; + + while Iptr <= Item'Last loop + C := To_Unsigned_8 (Item (Iptr)); + Iptr := Iptr + 1; + + -- Codes in the range 16#00# - 16#7F# are represented as + -- 0xxxxxxx + + if C <= 16#7F# then + R := Unsigned_16 (C); + + -- No initial code can be of the form 10xxxxxx. Such codes are used + -- only for continuations. + + elsif C <= 2#10_111111# then + Raise_Encoding_Error (Iptr - 1); + + -- Codes in the range 16#80# - 16#7FF# are represented as + -- 110yyyxx 10xxxxxx + + elsif C <= 2#110_11111# then + R := Unsigned_16 (C and 2#000_11111#); + Get_Continuation; + + -- Codes in the range 16#800# - 16#FFFF# are represented as + -- 1110yyyy 10yyyyxx 10xxxxxx + + elsif C <= 2#1110_1111# then + R := Unsigned_16 (C and 2#0000_1111#); + Get_Continuation; + Get_Continuation; + + -- Codes in the range 16#10000# - 16#10FFFF# are represented as + -- 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx + + -- Such codes are out of range for Wide_String output + + else + Raise_Encoding_Error (Iptr - 1); + end if; + + Len := Len + 1; + Result (Len) := Wide_Character'Val (R); + end loop; + + return Result (1 .. Len); + end Decode; + + -- Decode UTF-16 input to Wide_String + + function Decode (Item : UTF_16_Wide_String) return Wide_String is + Result : Wide_String (1 .. Item'Length); + -- Result is same length as input (possibly minus 1 if BOM present) + + Len : Natural := 0; + -- Length of result + + Iptr : Natural; + -- Index of next Item element + + C : Unsigned_16; + + begin + -- Skip UTF-16 BOM at start + + Iptr := Item'First; + + if Item'Length > 0 and then Item (Iptr) = BOM_16 (1) then + Iptr := Iptr + 1; + end if; + + -- Loop through input characters + + while Iptr <= Item'Last loop + C := To_Unsigned_16 (Item (Iptr)); + Iptr := Iptr + 1; + + -- Codes in the range 16#0000#..16#D7FF# or 16#E000#..16#FFFD# + -- represent their own value. + + if C <= 16#D7FF# or else C in 16#E000# .. 16#FFFD# then + Len := Len + 1; + Result (Len) := Wide_Character'Val (C); + + -- Codes in the range 16#D800#..16#DBFF# represent the first of the + -- two surrogates used to encode the range 16#01_000#..16#10_FFFF". + -- Such codes are out of range for 16-bit output. + + -- The case of input in the range 16#DC00#..16#DFFF# must never + -- occur, since it means we have a second surrogate character with + -- no corresponding first surrogate. + + -- Codes in the range 16#FFFE# .. 16#FFFF# are also invalid since + -- they conflict with codes used for BOM values. + + -- Thus all remaining codes are invalid + + else + Raise_Encoding_Error (Iptr - 1); + end if; + end loop; + + return Result (1 .. Len); + end Decode; + + ------------ + -- Encode -- + ------------ + + -- Encode Wide_String in UTF-8, UTF-16BE or UTF-16LE + + function Encode + (Item : Wide_String; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String + is + begin + -- Case of UTF_8 + + if Output_Scheme = UTF_8 then + return Encode (Item, Output_BOM); + + -- Case of UTF_16LE or UTF_16BE, use UTF-16 intermediary + + else + return From_UTF_16 (UTF_16_Wide_String'(Encode (Item)), + Output_Scheme, Output_BOM); + end if; + end Encode; + + -- Encode Wide_String in UTF-8 + + function Encode + (Item : Wide_String; + Output_BOM : Boolean := False) return UTF_8_String + is + Result : UTF_8_String (1 .. 3 * Item'Length + 3); + -- Worst case is three bytes per input byte + space for BOM + + Len : Natural; + -- Number of output codes stored in Result + + C : Unsigned_16; + -- Single input character + + procedure Store (C : Unsigned_16); + pragma Inline (Store); + -- Store one output code, C is in the range 0 .. 255 + + ----------- + -- Store -- + ----------- + + procedure Store (C : Unsigned_16) is + begin + Len := Len + 1; + Result (Len) := Character'Val (C); + end Store; + + -- Start of processing for UTF8_Encode + + begin + -- Output BOM if required + + if Output_BOM then + Result (1 .. 3) := BOM_8; + Len := 3; + else + Len := 0; + end if; + + -- Loop through characters of input + + for J in Item'Range loop + C := To_Unsigned_16 (Item (J)); + + -- Codes in the range 16#00# - 16#7F# are represented as + -- 0xxxxxxx + + if C <= 16#7F# then + Store (C); + + -- Codes in the range 16#80# - 16#7FF# are represented as + -- 110yyyxx 10xxxxxx + + elsif C <= 16#7FF# then + Store (2#110_00000# or Shift_Right (C, 6)); + Store (2#10_000000# or (C and 2#00_111111#)); + + -- Codes in the range 16#800# - 16#FFFF# are represented as + -- 1110yyyy 10yyyyxx 10xxxxxx + + else + Store (2#1110_0000# or Shift_Right (C, 12)); + Store (2#10_000000# or + Shift_Right (C and 2#111111_000000#, 6)); + Store (2#10_000000# or (C and 2#00_111111#)); + end if; + end loop; + + return Result (1 .. Len); + end Encode; + + -- Encode Wide_String in UTF-16 + + function Encode + (Item : Wide_String; + Output_BOM : Boolean := False) return UTF_16_Wide_String + is + Result : Wide_String (1 .. Item'Length + Boolean'Pos (Output_BOM)); + -- Output is same length as input + possible BOM + + Len : Integer; + -- Length of output string + + C : Unsigned_16; + + begin + -- Output BOM if required + + if Output_BOM then + Result (1) := BOM_16 (1); + Len := 1; + else + Len := 0; + end if; + + -- Loop through input characters encoding them + + for Iptr in Item'Range loop + C := To_Unsigned_16 (Item (Iptr)); + + -- Codes in the range 16#0000#..16#D7FF# or 16#E000#..16#FFFD# are + -- output unchaned. + + if C <= 16#D7FF# or else C in 16#E000# .. 16#FFFD# then + Len := Len + 1; + Result (Len) := Wide_Character'Val (C); + + -- Codes in tne range 16#D800#..16#DFFF# should never appear in the + -- input, since no valid Unicode characters are in this range (which + -- would conflict with the UTF-16 surrogate encodings). Similarly + -- codes in the range 16#FFFE#..16#FFFF conflict with BOM codes. + -- Thus all remaining codes are illegal. + + else + Raise_Encoding_Error (Iptr); + end if; + end loop; + + return Result; + end Encode; + +end Ada.Strings.UTF_Encoding.Wide_Encoding; diff --git a/gcc/ada/a-suewen.ads b/gcc/ada/a-suewen.ads new file mode 100755 index 00000000000..bae9e148447 --- /dev/null +++ b/gcc/ada/a-suewen.ads @@ -0,0 +1,67 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.UTF_ENCODING.WIDE_ENCODING -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- This is an Ada 2012 package defined in AI05-0137-1. It is used for encoding +-- and decoding Wide_String values using UTF encodings. Note: this package is +-- consistent with Ada 95, and may be included in Ada 95 implementations. + +package Ada.Strings.UTF_Encoding.Wide_Encoding is + pragma Pure (Wide_Encoding); + + -- The encoding routines take a Wide_String as input and encode the result + -- using the specified UTF encoding method. The result includes a BOM if + -- the Output_BOM argument is set to True. Encoding_Error is raised if an + -- invalid character appears in the input. In particular the characters + -- in the range 16#D800# .. 16#DFFF# are invalid because they conflict + -- with UTF-16 surrogate encodings, and the characters 16#FFFE# and + -- 16#FFFF# are also invalid because they conflict with BOM codes. + + function Encode + (Item : Wide_String; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String; + -- Encode Wide_String using UTF-8, UTF-16LE or UTF-16BE encoding as + -- specified by the Output_Scheme parameter. + + function Encode + (Item : Wide_String; + Output_BOM : Boolean := False) return UTF_8_String; + -- Encode Wide_String using UTF-8 encoding + + function Encode + (Item : Wide_String; + Output_BOM : Boolean := False) return UTF_16_Wide_String; + -- Encode Wide_String using UTF_16 encoding + + -- The decoding routines take a UTF String as input, and return a decoded + -- Wide_String. If the UTF String starts with a BOM that matches the + -- encoding method, it is ignored. An incorrect BOM raises Encoding_Error. + + function Decode + (Item : UTF_String; + Input_Scheme : Encoding_Scheme) return Wide_String; + -- The input is encoded in UTF_8, UTF_16LE or UTF_16BE as specified by the + -- Input_Scheme parameter. It is decoded and returned as a Wide_String + -- value. Note: a convenient form for scheme may be Encoding (UTF_String). + + function Decode + (Item : UTF_8_String) return Wide_String; + -- The input is encoded in UTF-8 and returned as a Wide_String value + + function Decode + (Item : UTF_16_Wide_String) return Wide_String; + -- The input is encoded in UTF-16 and returned as a Wide_String value + +end Ada.Strings.UTF_Encoding.Wide_Encoding; diff --git a/gcc/ada/a-suezen.adb b/gcc/ada/a-suezen.adb new file mode 100755 index 00000000000..972fbf061e8 --- /dev/null +++ b/gcc/ada/a-suezen.adb @@ -0,0 +1,431 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.UTF_ENCODING.WIDE_WIDE_ENCODING -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT 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 distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.UTF_Encoding.Wide_Wide_Encoding is + use Interfaces; + + ------------ + -- Decode -- + ------------ + + -- Version to decode UTF-8/UTF-16BE/UTF-16LE input to Wide_Wide_String + + function Decode + (Item : UTF_String; + Input_Scheme : Encoding_Scheme) return Wide_Wide_String + is + begin + if Input_Scheme = UTF_8 then + return Decode (Item); + else + return Decode (To_UTF_16 (Item, Input_Scheme)); + end if; + end Decode; + + -- Decode UTF-8 input to Wide_Wide_String + + function Decode (Item : UTF_8_String) return Wide_Wide_String is + Result : Wide_Wide_String (1 .. Item'Length); + -- Result string (worst case is same length as input) + + Len : Natural := 0; + -- Length of result stored so far + + Iptr : Natural; + -- Input string pointer + + C : Unsigned_8; + R : Unsigned_32; + + procedure Get_Continuation; + -- Reads a continuation byte of the form 10xxxxxx, shifts R left + -- by 6 bits, and or's in the xxxxxx to the low order 6 bits. On + -- return Ptr is incremented. Raises exceptioon if continuation + -- byte does not exist or is invalid. + + ---------------------- + -- Get_Continuation -- + ---------------------- + + procedure Get_Continuation is + begin + if Iptr > Item'Last then + Raise_Encoding_Error (Iptr - 1); + + else + C := To_Unsigned_8 (Item (Iptr)); + Iptr := Iptr + 1; + + if C not in 2#10_000000# .. 2#10_111111# then + Raise_Encoding_Error (Iptr - 1); + else + R := Shift_Left (R, 6) or Unsigned_32 (C and 2#00_111111#); + end if; + end if; + end Get_Continuation; + + -- Start of processing for Decode + + begin + Iptr := Item'First; + + -- Skip BOM at start + + if Item'Length >= 3 + and then Item (Iptr .. Iptr + 2) = BOM_8 + then + Iptr := Iptr + 3; + + -- Error if bad BOM + + elsif Item'Length >= 2 + and then (Item (Iptr .. Iptr + 1) = BOM_16BE + or else + Item (Iptr .. Iptr + 1) = BOM_16LE) + then + Raise_Encoding_Error (Iptr); + end if; + + -- Loop through input characters + + while Iptr <= Item'Last loop + C := To_Unsigned_8 (Item (Iptr)); + Iptr := Iptr + 1; + + -- Codes in the range 16#00# - 16#7F# are represented as + -- 0xxxxxxx + + if C <= 16#7F# then + R := Unsigned_32 (C); + + -- No initial code can be of the form 10xxxxxx. Such codes are used + -- only for continuations. + + elsif C <= 2#10_111111# then + Raise_Encoding_Error (Iptr - 1); + + -- Codes in the range 16#80# - 16#7FF# are represented as + -- 110yyyxx 10xxxxxx + + elsif C <= 2#110_11111# then + R := Unsigned_32 (C and 2#000_11111#); + Get_Continuation; + + -- Codes in the range 16#800# - 16#FFFF# are represented as + -- 1110yyyy 10yyyyxx 10xxxxxx + + elsif C <= 2#1110_1111# then + R := Unsigned_32 (C and 2#0000_1111#); + Get_Continuation; + Get_Continuation; + + -- Codes in the range 16#10000# - 16#10FFFF# are represented as + -- 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx + + elsif C <= 2#11110_111# then + R := Unsigned_32 (C and 2#00000_111#); + Get_Continuation; + Get_Continuation; + Get_Continuation; + + -- Any other code is an error + + else + Raise_Encoding_Error (Iptr - 1); + end if; + + Len := Len + 1; + Result (Len) := Wide_Wide_Character'Val (R); + end loop; + + return Result (1 .. Len); + end Decode; + + -- Decode UTF-16 input to Wide_Wide_String + + function Decode (Item : UTF_16_Wide_String) return Wide_Wide_String is + Result : Wide_Wide_String (1 .. Item'Length); + -- Result cannot be longer than the input string + + Len : Natural := 0; + -- Length of result + + Iptr : Natural; + -- Pointer to next element in Item + + C : Unsigned_16; + R : Unsigned_32; + + begin + -- Skip UTF-16 BOM at start + + Iptr := Item'First; + + if Iptr <= Item'Last and then Item (Iptr) = BOM_16 (1) then + Iptr := Iptr + 1; + end if; + + -- Loop through input characters + + while Iptr <= Item'Last loop + C := To_Unsigned_16 (Item (Iptr)); + Iptr := Iptr + 1; + + -- Codes in the range 16#0000#..16#D7FF# or 16#E000#..16#FFFD# + -- represent their own value. + + if C <= 16#D7FF# or else C in 16#E000# .. 16#FFFD# then + Len := Len + 1; + Result (Len) := Wide_Wide_Character'Val (C); + + -- Codes in the range 16#D800#..16#DBFF# represent the first of the + -- two surrogates used to encode the range 16#01_000#..16#10_FFFF". + -- The first surrogate provides 10 high order bits of the result. + + elsif C <= 16#DBFF# then + R := Shift_Left ((Unsigned_32 (C) - 16#D800#), 10); + + -- Error if at end of string + + if Iptr > Item'Last then + Raise_Encoding_Error (Iptr - 1); + + -- Otherwise next character must be valid low order surrogate + -- which provides the low 10 order bits of the result. + + else + C := To_Unsigned_16 (Item (Iptr)); + Iptr := Iptr + 1; + + if C not in 16#DC00# .. 16#DFFF# then + Raise_Encoding_Error (Iptr - 1); + + else + R := R or (Unsigned_32 (C) mod 2 ** 10); + + -- The final adjustment is to add 16#01_0000 to get the + -- result back in the required 21 bit range. + + R := R + 16#01_0000#; + Len := Len + 1; + Result (Len) := Wide_Wide_Character'Val (R); + end if; + end if; + + -- Remaining codes are invalid + + else + Raise_Encoding_Error (Iptr - 1); + end if; + end loop; + + return Result (1 .. Len); + end Decode; + + ------------ + -- Encode -- + ------------ + + -- Encode Wide_Wide_String in UTF-8, UTF-16BE or UTF-16LE + + function Encode + (Item : Wide_Wide_String; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String + is + begin + if Output_Scheme = UTF_8 then + return Encode (Item, Output_BOM); + else + return From_UTF_16 (Encode (Item), Output_Scheme, Output_BOM); + end if; + end Encode; + + -- Encode Wide_Wide_String in UTF-8 + + function Encode + (Item : Wide_Wide_String; + Output_BOM : Boolean := False) return UTF_8_String + is + Result : String (1 .. 4 * Item'Length + 3); + -- Worst case is four bytes per input byte + space for BOM + + Len : Natural; + -- Number of output codes stored in Result + + C : Unsigned_32; + -- Single input character + + procedure Store (C : Unsigned_32); + pragma Inline (Store); + -- Store one output code (input is in range 0 .. 255) + + ----------- + -- Store -- + ----------- + + procedure Store (C : Unsigned_32) is + begin + Len := Len + 1; + Result (Len) := Character'Val (C); + end Store; + + -- Start of processing for Encode + + begin + -- Output BOM if required + + if Output_BOM then + Result (1 .. 3) := BOM_8; + Len := 3; + else + Len := 0; + end if; + + -- Loop through characters of input + + for Iptr in Item'Range loop + C := To_Unsigned_32 (Item (Iptr)); + + -- Codes in the range 16#00#..16#7F# are represented as + -- 0xxxxxxx + + if C <= 16#7F# then + Store (C); + + -- Codes in the range 16#80#..16#7FF# are represented as + -- 110yyyxx 10xxxxxx + + elsif C <= 16#7FF# then + Store (2#110_00000# or Shift_Right (C, 6)); + Store (2#10_000000# or (C and 2#00_111111#)); + + -- Codes in the range 16#800#..16#D7FF# or 16#E000#..16#FFFD# are + -- represented as + -- 1110yyyy 10yyyyxx 10xxxxxx + + elsif C <= 16#D7FF# or else C in 16#E000# .. 16#FFFD# then + Store (2#1110_0000# or Shift_Right (C, 12)); + Store (2#10_000000# or + Shift_Right (C and 2#111111_000000#, 6)); + Store (2#10_000000# or (C and 2#00_111111#)); + + -- Codes in the range 16#10000# - 16#10FFFF# are represented as + -- 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx + + elsif C in 16#1_0000# .. 16#10_FFFF# then + Store (2#11110_000# or + Shift_Right (C, 18)); + Store (2#10_000000# or + Shift_Right (C and 2#111111_000000_000000#, 12)); + Store (2#10_000000# or + Shift_Right (C and 2#111111_000000#, 6)); + Store (2#10_000000# or + (C and 2#00_111111#)); + + -- All other codes are invalid + + else + Raise_Encoding_Error (Iptr); + end if; + end loop; + + return Result (1 .. Len); + end Encode; + + -- Encode Wide_Wide_String in UTF-16 + + function Encode + (Item : Wide_Wide_String; + Output_BOM : Boolean := False) return UTF_16_Wide_String + is + Result : Wide_String (1 .. 2 * Item'Length + 1); + -- Worst case is each input character generates two output characters + -- plus one for possible BOM. + + Len : Integer; + -- Length of output string + + C : Unsigned_32; + + begin + -- Output BOM if needed + + if Output_BOM then + Result (1) := BOM_16 (1); + Len := 1; + else + Len := 0; + end if; + + -- Loop through input characters encoding them + + for Iptr in Item'Range loop + C := To_Unsigned_32 (Item (Iptr)); + + -- Codes in the range 16#00_0000#..16#00_D7FF# or 16#E000#..16#FFFD# + -- are output unchanged + + if C <= 16#00_D7FF# or else C in 16#E000# .. 16#FFFD# then + Len := Len + 1; + Result (Len) := Wide_Character'Val (C); + + -- Codes in the range 16#01_0000#..16#10_FFFF# are output using two + -- surrogate characters. First 16#1_0000# is subtracted from the code + -- point to give a 20-bit value. This is then split into two separate + -- 10-bit values each of which is represented as a surrogate with the + -- most significant half placed in the first surrogate. The ranges of + -- values used for the two surrogates are 16#D800#-16#DBFF# for the + -- first, most significant surrogate and 16#DC00#-16#DFFF# for the + -- second, least significant surrogate. + + elsif C in 16#1_0000# .. 16#10_FFFF# then + C := C - 16#1_0000#; + + Len := Len + 1; + Result (Len) := Wide_Character'Val (16#D800# + C / 2 ** 10); + + Len := Len + 1; + Result (Len) := Wide_Character'Val (16#DC00# + C mod 2 ** 10); + + -- All other codes are invalid + + else + Raise_Encoding_Error (Iptr); + end if; + end loop; + + return Result (1 .. Len); + end Encode; + +end Ada.Strings.UTF_Encoding.Wide_Wide_Encoding; diff --git a/gcc/ada/a-suezen.ads b/gcc/ada/a-suezen.ads new file mode 100755 index 00000000000..7d2a91d2b25 --- /dev/null +++ b/gcc/ada/a-suezen.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.UTF_ENCODING.WIDE_WIDE_ENCODING -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- This is an Ada 2012 package defined in AI05-0137-1. It is used for encoding +-- and decoding Wide_String values using UTF encodings. Note: this package is +-- consistent with Ada 2005, and may be used in Ada 2005 mode, but cannot be +-- used in Ada 95 mode, since Wide_Wide_Character is an Ada 2005 feature. + +package Ada.Strings.UTF_Encoding.Wide_Wide_Encoding is + pragma Pure (Wide_Wide_Encoding); + + -- The encoding routines take a Wide_Wide_String as input and encode the + -- result using the specified UTF encoding method. The result includes a + -- BOM if the Output_BOM parameter is set to True. + + function Encode + (Item : Wide_Wide_String; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String; + -- Encode Wide_Wide_String using UTF-8, UTF-16LE or UTF-16BE encoding as + -- specified by the Output_Scheme parameter. + + function Encode + (Item : Wide_Wide_String; + Output_BOM : Boolean := False) return UTF_8_String; + -- Encode Wide_Wide_String using UTF-8 encoding + + function Encode + (Item : Wide_Wide_String; + Output_BOM : Boolean := False) return UTF_16_Wide_String; + -- Encode Wide_Wide_String using UTF_16 encoding + + -- The decoding routines take a UTF String as input, and return a decoded + -- Wide_String. If the UTF String starts with a BOM that matches the + -- encoding method, it is ignored. An incorrect BOM raises Encoding_Error. + + function Decode + (Item : UTF_String; + Input_Scheme : Encoding_Scheme) return Wide_Wide_String; + -- The input is encoded in UTF_8, UTF_16LE or UTF_16BE as specified by the + -- Input_Scheme parameter. It is decoded and returned as a Wide_Wide_String + -- value. Note: a convenient form for Scheme may be Encoding (UTF_String). + + function Decode + (Item : UTF_8_String) return Wide_Wide_String; + -- The input is encoded in UTF-8 and returned as a Wide_Wide_String value + + function Decode + (Item : UTF_16_Wide_String) return Wide_Wide_String; + -- The input is encoded in UTF-16 and returned as a Wide_String value + +end Ada.Strings.UTF_Encoding.Wide_Wide_Encoding; diff --git a/gcc/ada/a-suteio-shared.adb b/gcc/ada/a-suteio-shared.adb new file mode 100644 index 00000000000..d50ed776775 --- /dev/null +++ b/gcc/ada/a-suteio-shared.adb @@ -0,0 +1,132 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . U N B O U N D E D . T E X T _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; use Ada.Text_IO; + +package body Ada.Strings.Unbounded.Text_IO is + + -------------- + -- Get_Line -- + -------------- + + function Get_Line return Unbounded_String is + Buffer : String (1 .. 1000); + Last : Natural; + Result : Unbounded_String; + + begin + Get_Line (Buffer, Last); + Set_Unbounded_String (Result, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (Buffer, Last); + Append (Result, Buffer (1 .. Last)); + end loop; + + return Result; + end Get_Line; + + function Get_Line (File : Ada.Text_IO.File_Type) return Unbounded_String is + Buffer : String (1 .. 1000); + Last : Natural; + Result : Unbounded_String; + + begin + Get_Line (File, Buffer, Last); + Set_Unbounded_String (Result, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Append (Result, Buffer (1 .. Last)); + end loop; + + return Result; + end Get_Line; + + procedure Get_Line (Item : out Unbounded_String) is + begin + Get_Line (Current_Input, Item); + end Get_Line; + + procedure Get_Line + (File : Ada.Text_IO.File_Type; + Item : out Unbounded_String) + is + Buffer : String (1 .. 1000); + Last : Natural; + + begin + Get_Line (File, Buffer, Last); + Set_Unbounded_String (Item, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Append (Item, Buffer (1 .. Last)); + end loop; + end Get_Line; + + --------- + -- Put -- + --------- + + procedure Put (U : Unbounded_String) is + UR : constant Shared_String_Access := U.Reference; + + begin + Put (UR.Data (1 .. UR.Last)); + end Put; + + procedure Put (File : File_Type; U : Unbounded_String) is + UR : constant Shared_String_Access := U.Reference; + + begin + Put (File, UR.Data (1 .. UR.Last)); + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (U : Unbounded_String) is + UR : constant Shared_String_Access := U.Reference; + + begin + Put_Line (UR.Data (1 .. UR.Last)); + end Put_Line; + + procedure Put_Line (File : File_Type; U : Unbounded_String) is + UR : constant Shared_String_Access := U.Reference; + + begin + Put_Line (File, UR.Data (1 .. UR.Last)); + end Put_Line; + +end Ada.Strings.Unbounded.Text_IO; diff --git a/gcc/ada/a-swunau-shared.adb b/gcc/ada/a-swunau-shared.adb new file mode 100644 index 00000000000..ad397b8c5b3 --- /dev/null +++ b/gcc/ada/a-swunau-shared.adb @@ -0,0 +1,65 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ U N B O U N D E D . A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.Wide_Unbounded.Aux is + + --------------------- + -- Get_Wide_String -- + --------------------- + + procedure Get_Wide_String + (U : Unbounded_Wide_String; + S : out Big_Wide_String_Access; + L : out Natural) + is + X : aliased Big_Wide_String; + for X'Address use U.Reference.Data'Address; + begin + S := X'Unchecked_Access; + L := U.Reference.Last; + end Get_Wide_String; + + --------------------- + -- Set_Wide_String -- + --------------------- + + procedure Set_Wide_String + (UP : in out Unbounded_Wide_String; + S : Wide_String_Access) + is + X : Wide_String_Access := S; + + begin + Set_Unbounded_Wide_String (UP, S.all); + Free (X); + end Set_Wide_String; + +end Ada.Strings.Wide_Unbounded.Aux; diff --git a/gcc/ada/a-swunau.adb b/gcc/ada/a-swunau.adb index 59eb3f6cf22..004a5d4ac1a 100644 --- a/gcc/ada/a-swunau.adb +++ b/gcc/ada/a-swunau.adb @@ -37,11 +37,14 @@ package body Ada.Strings.Wide_Unbounded.Aux is procedure Get_Wide_String (U : Unbounded_Wide_String; - S : out Wide_String_Access; + S : out Big_Wide_String_Access; L : out Natural) is + X : aliased Big_Wide_String; + for X'Address use U.Reference.all'Address; + begin - S := U.Reference; + S := X'Unchecked_Access; L := U.Last; end Get_Wide_String; @@ -49,20 +52,6 @@ package body Ada.Strings.Wide_Unbounded.Aux is -- Set_Wide_String -- --------------------- - procedure Set_Wide_String - (UP : in out Unbounded_Wide_String; - S : Wide_String) - is - begin - if S'Length > UP.Last then - Finalize (UP); - UP.Reference := new Wide_String (1 .. S'Length); - end if; - - UP.Reference (1 .. S'Length) := S; - UP.Last := S'Length; - end Set_Wide_String; - procedure Set_Wide_String (UP : in out Unbounded_Wide_String; S : Wide_String_Access) diff --git a/gcc/ada/a-swunau.ads b/gcc/ada/a-swunau.ads index 6df205c0293..78fa5dbb865 100644 --- a/gcc/ada/a-swunau.ads +++ b/gcc/ada/a-swunau.ads @@ -37,9 +37,12 @@ package Ada.Strings.Wide_Unbounded.Aux is pragma Preelaborate; + subtype Big_Wide_String is Wide_String (Positive'Range); + type Big_Wide_String_Access is access all Big_Wide_String; + procedure Get_Wide_String (U : Unbounded_Wide_String; - S : out Wide_String_Access; + S : out Big_Wide_String_Access; L : out Natural); pragma Inline (Get_Wide_String); -- This procedure returns the internal string pointer used in the @@ -54,10 +57,8 @@ package Ada.Strings.Wide_Unbounded.Aux is -- referenced string returned by this call is always one, so the actual -- string data is always accessible as S (1 .. L). - procedure Set_Wide_String - (UP : in out Unbounded_Wide_String; - S : Wide_String); - pragma Inline (Set_Wide_String); + procedure Set_Wide_String (UP : out Unbounded_Wide_String; S : Wide_String) + renames Set_Unbounded_Wide_String; -- This function sets the string contents of the referenced unbounded -- string to the given string value. It is significantly more efficient -- than the use of To_Unbounded_Wide_String with an assignment, since it diff --git a/gcc/ada/a-swuwti-shared.adb b/gcc/ada/a-swuwti-shared.adb new file mode 100644 index 00000000000..9cf7c0ad559 --- /dev/null +++ b/gcc/ada/a-swuwti-shared.adb @@ -0,0 +1,134 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.WIDE_UNBOUNDED.WIDE_TEXT_IO -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO; use Ada.Wide_Text_IO; + +package body Ada.Strings.Wide_Unbounded.Wide_Text_IO is + + -------------- + -- Get_Line -- + -------------- + + function Get_Line return Unbounded_Wide_String is + Buffer : Wide_String (1 .. 1000); + Last : Natural; + Result : Unbounded_Wide_String; + + begin + Get_Line (Buffer, Last); + Set_Unbounded_Wide_String (Result, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (Buffer, Last); + Append (Result, Buffer (1 .. Last)); + end loop; + + return Result; + end Get_Line; + + function Get_Line + (File : Ada.Wide_Text_IO.File_Type) return Unbounded_Wide_String + is + Buffer : Wide_String (1 .. 1000); + Last : Natural; + Result : Unbounded_Wide_String; + + begin + Get_Line (File, Buffer, Last); + Set_Unbounded_Wide_String (Result, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Append (Result, Buffer (1 .. Last)); + end loop; + + return Result; + end Get_Line; + + procedure Get_Line (Item : out Unbounded_Wide_String) is + begin + Get_Line (Current_Input, Item); + end Get_Line; + + procedure Get_Line + (File : Ada.Wide_Text_IO.File_Type; + Item : out Unbounded_Wide_String) + is + Buffer : Wide_String (1 .. 1000); + Last : Natural; + + begin + Get_Line (File, Buffer, Last); + Set_Unbounded_Wide_String (Item, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Append (Item, Buffer (1 .. Last)); + end loop; + end Get_Line; + + --------- + -- Put -- + --------- + + procedure Put (U : Unbounded_Wide_String) is + UR : constant Shared_Wide_String_Access := U.Reference; + + begin + Put (UR.Data (1 .. UR.Last)); + end Put; + + procedure Put (File : File_Type; U : Unbounded_Wide_String) is + UR : constant Shared_Wide_String_Access := U.Reference; + + begin + Put (File, UR.Data (1 .. UR.Last)); + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (U : Unbounded_Wide_String) is + UR : constant Shared_Wide_String_Access := U.Reference; + + begin + Put_Line (UR.Data (1 .. UR.Last)); + end Put_Line; + + procedure Put_Line (File : File_Type; U : Unbounded_Wide_String) is + UR : constant Shared_Wide_String_Access := U.Reference; + + begin + Put_Line (File, UR.Data (1 .. UR.Last)); + end Put_Line; + +end Ada.Strings.Wide_Unbounded.Wide_Text_IO; diff --git a/gcc/ada/a-szunau-shared.adb b/gcc/ada/a-szunau-shared.adb new file mode 100644 index 00000000000..87b2cb40d15 --- /dev/null +++ b/gcc/ada/a-szunau-shared.adb @@ -0,0 +1,65 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D . A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.Wide_Wide_Unbounded.Aux is + + -------------------------- + -- Get_Wide_Wide_String -- + -------------------------- + + procedure Get_Wide_Wide_String + (U : Unbounded_Wide_Wide_String; + S : out Big_Wide_Wide_String_Access; + L : out Natural) + is + X : aliased Big_Wide_Wide_String; + for X'Address use U.Reference.Data'Address; + begin + S := X'Unchecked_Access; + L := U.Reference.Last; + end Get_Wide_Wide_String; + + -------------------------- + -- Set_Wide_Wide_String -- + -------------------------- + + procedure Set_Wide_Wide_String + (UP : in out Unbounded_Wide_Wide_String; + S : Wide_Wide_String_Access) + is + X : Wide_Wide_String_Access := S; + + begin + Set_Unbounded_Wide_Wide_String (UP, S.all); + Free (X); + end Set_Wide_Wide_String; + +end Ada.Strings.Wide_Wide_Unbounded.Aux; diff --git a/gcc/ada/a-szunau.adb b/gcc/ada/a-szunau.adb index 64e52507ce7..7ab9cc5acd4 100644 --- a/gcc/ada/a-szunau.adb +++ b/gcc/ada/a-szunau.adb @@ -31,37 +31,26 @@ package body Ada.Strings.Wide_Wide_Unbounded.Aux is - -------------------- + -------------------------- -- Get_Wide_Wide_String -- - --------------------- + -------------------------- procedure Get_Wide_Wide_String (U : Unbounded_Wide_Wide_String; - S : out Wide_Wide_String_Access; + S : out Big_Wide_Wide_String_Access; L : out Natural) is + X : aliased Big_Wide_Wide_String; + for X'Address use U.Reference.all'Address; + begin - S := U.Reference; + S := X'Unchecked_Access; L := U.Last; end Get_Wide_Wide_String; - --------------------- + -------------------------- -- Set_Wide_Wide_String -- - --------------------- - - procedure Set_Wide_Wide_String - (UP : in out Unbounded_Wide_Wide_String; - S : Wide_Wide_String) - is - begin - if S'Length > UP.Last then - Finalize (UP); - UP.Reference := new Wide_Wide_String (1 .. S'Length); - end if; - - UP.Reference (1 .. S'Length) := S; - UP.Last := S'Length; - end Set_Wide_Wide_String; + -------------------------- procedure Set_Wide_Wide_String (UP : in out Unbounded_Wide_Wide_String; diff --git a/gcc/ada/a-szunau.ads b/gcc/ada/a-szunau.ads index 913c0e136d7..6115330d94b 100644 --- a/gcc/ada/a-szunau.ads +++ b/gcc/ada/a-szunau.ads @@ -37,9 +37,12 @@ package Ada.Strings.Wide_Wide_Unbounded.Aux is pragma Preelaborate; + subtype Big_Wide_Wide_String is Wide_Wide_String (Positive); + type Big_Wide_Wide_String_Access is access all Big_Wide_Wide_String; + procedure Get_Wide_Wide_String (U : Unbounded_Wide_Wide_String; - S : out Wide_Wide_String_Access; + S : out Big_Wide_Wide_String_Access; L : out Natural); pragma Inline (Get_Wide_Wide_String); -- This procedure returns the internal string pointer used in the @@ -55,9 +58,9 @@ package Ada.Strings.Wide_Wide_Unbounded.Aux is -- string data is always accessible as S (1 .. L). procedure Set_Wide_Wide_String - (UP : in out Unbounded_Wide_Wide_String; - S : Wide_Wide_String); - pragma Inline (Set_Wide_Wide_String); + (UP : out Unbounded_Wide_Wide_String; + S : Wide_Wide_String) + renames Set_Unbounded_Wide_Wide_String; -- This function sets the string contents of the referenced unbounded -- string to the given string value. It is significantly more efficient -- than the use of To_Unbounded_Wide_Wide_String with an assignment, since diff --git a/gcc/ada/a-szuzti-shared.adb b/gcc/ada/a-szuzti-shared.adb new file mode 100644 index 00000000000..247ccb2bcd5 --- /dev/null +++ b/gcc/ada/a-szuzti-shared.adb @@ -0,0 +1,135 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.WIDE_UNBOUNDED.WIDE_TEXT_IO -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO; use Ada.Wide_Wide_Text_IO; + +package body Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO is + + -------------- + -- Get_Line -- + -------------- + + function Get_Line return Unbounded_Wide_Wide_String is + Buffer : Wide_Wide_String (1 .. 1000); + Last : Natural; + Result : Unbounded_Wide_Wide_String; + + begin + Get_Line (Buffer, Last); + Set_Unbounded_Wide_Wide_String (Result, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (Buffer, Last); + Append (Result, Buffer (1 .. Last)); + end loop; + + return Result; + end Get_Line; + + function Get_Line + (File : Ada.Wide_Wide_Text_IO.File_Type) + return Unbounded_Wide_Wide_String + is + Buffer : Wide_Wide_String (1 .. 1000); + Last : Natural; + Result : Unbounded_Wide_Wide_String; + + begin + Get_Line (File, Buffer, Last); + Set_Unbounded_Wide_Wide_String (Result, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Append (Result, Buffer (1 .. Last)); + end loop; + + return Result; + end Get_Line; + + procedure Get_Line (Item : out Unbounded_Wide_Wide_String) is + begin + Get_Line (Current_Input, Item); + end Get_Line; + + procedure Get_Line + (File : Ada.Wide_Wide_Text_IO.File_Type; + Item : out Unbounded_Wide_Wide_String) + is + Buffer : Wide_Wide_String (1 .. 1000); + Last : Natural; + + begin + Get_Line (File, Buffer, Last); + Set_Unbounded_Wide_Wide_String (Item, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Append (Item, Buffer (1 .. Last)); + end loop; + end Get_Line; + + --------- + -- Put -- + --------- + + procedure Put (U : Unbounded_Wide_Wide_String) is + UR : constant Shared_Wide_Wide_String_Access := U.Reference; + + begin + Put (UR.Data (1 .. UR.Last)); + end Put; + + procedure Put (File : File_Type; U : Unbounded_Wide_Wide_String) is + UR : constant Shared_Wide_Wide_String_Access := U.Reference; + + begin + Put (File, UR.Data (1 .. UR.Last)); + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (U : Unbounded_Wide_Wide_String) is + UR : constant Shared_Wide_Wide_String_Access := U.Reference; + + begin + Put_Line (UR.Data (1 .. UR.Last)); + end Put_Line; + + procedure Put_Line (File : File_Type; U : Unbounded_Wide_Wide_String) is + UR : constant Shared_Wide_Wide_String_Access := U.Reference; + + begin + Put_Line (File, UR.Data (1 .. UR.Last)); + end Put_Line; + +end Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO; diff --git a/gcc/ada/a-tags.ads b/gcc/ada/a-tags.ads index 63d694e87a6..7ef214bf83c 100644 --- a/gcc/ada/a-tags.ads +++ b/gcc/ada/a-tags.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -101,7 +101,7 @@ private -- +-------------------+ -- | hash table link | -- +-------------------+ - -- | remotely callable | + -- | transportable | -- +-------------------+ -- | rec ctrler offset | -- +-------------------+ diff --git a/gcc/ada/a-tifiio.adb b/gcc/ada/a-tifiio.adb index 73ebc006251..82aeb8a83e6 100644 --- a/gcc/ada/a-tifiio.adb +++ b/gcc/ada/a-tifiio.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -301,10 +301,14 @@ package body Ada.Text_IO.Fixed_IO is (To : out String; Last : out Natural; Item : Num; - Fore : Field; + Fore : Integer; Aft : Field; Exp : Field); - -- Actual output function, used internally by all other Put routines + -- Actual output function, used internally by all other Put routines. + -- The formal Fore is an Integer, not a Field, because the routine is + -- also called from the version of Put that performs I/O to a string, + -- where the starting position depends on the size of the String, and + -- bears no relation to the bounds of Field. --------- -- Get -- @@ -392,7 +396,7 @@ package body Ada.Text_IO.Fixed_IO is Last : Natural; begin - if Fore - Boolean'Pos (Item < 0.0) < 1 or else Fore > Field'Last then + if Fore - Boolean'Pos (Item < 0.0) < 1 then raise Layout_Error; end if; @@ -407,7 +411,7 @@ package body Ada.Text_IO.Fixed_IO is (To : out String; Last : out Natural; Item : Num; - Fore : Field; + Fore : Integer; Aft : Field; Exp : Field) is diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 54b32232bb8..9b814e945d0 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 1992-2009, Free Software Foundation, Inc. * + * Copyright (C) 1992-2010, Free Software Foundation, Inc. * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * @@ -132,7 +132,7 @@ UINT CurrentCodePage; #include #endif -#if defined (__EMX__) || defined (MSDOS) || defined (_WIN32) +#if defined (_WIN32) #elif defined (VMS) /* Header files and definitions for __gnat_set_file_time_name. */ @@ -183,7 +183,7 @@ struct vstring #include #endif -#if defined (__EMX__) || defined (MSDOS) || defined (_WIN32) +#if defined (_WIN32) #include #endif @@ -205,14 +205,6 @@ struct vstring external file mapped to LF in internal file), but in Unix-like systems, no text translation is required, so these flags have no effect. */ -#if defined (__EMX__) -#include -#endif - -#if defined (MSDOS) -#include -#endif - #ifndef O_BINARY #define O_BINARY 0 #endif @@ -275,9 +267,7 @@ char __gnat_path_separator = PATH_SEPARATOR; as well. This is only a temporary work-around for 3.11b. */ #ifndef GNAT_LIBRARY_TEMPLATE -#if defined (__EMX__) -#define GNAT_LIBRARY_TEMPLATE "*.a" -#elif defined (VMS) +#if defined (VMS) #define GNAT_LIBRARY_TEMPLATE "*.olb" #else #define GNAT_LIBRARY_TEMPLATE "lib*.a" @@ -294,10 +284,7 @@ const int __gnat_vmsp = 1; const int __gnat_vmsp = 0; #endif -#ifdef __EMX__ -#define GNAT_MAX_PATH_LEN MAX_PATH - -#elif defined (VMS) +#if defined (VMS) #define GNAT_MAX_PATH_LEN 256 /* PATH_MAX */ #elif defined (__vxworks) || defined (__OPENNT) || defined(__nucleus__) @@ -377,7 +364,7 @@ to_ptr32 (char **ptr64) #define MAYBE_TO_PTR32(argv) argv #endif -const char ATTR_UNSET = 127; +static const char ATTR_UNSET = 127; void __gnat_reset_attributes @@ -478,8 +465,8 @@ __gnat_readlink (char *path ATTRIBUTE_UNUSED, char *buf ATTRIBUTE_UNUSED, size_t bufsiz ATTRIBUTE_UNUSED) { -#if defined (MSDOS) || defined (_WIN32) || defined (__EMX__) \ - || defined (VMS) || defined(__vxworks) || defined (__nucleus__) +#if defined (_WIN32) || defined (VMS) \ + || defined(__vxworks) || defined (__nucleus__) return -1; #else return readlink (path, buf, bufsiz); @@ -494,8 +481,8 @@ int __gnat_symlink (char *oldpath ATTRIBUTE_UNUSED, char *newpath ATTRIBUTE_UNUSED) { -#if defined (MSDOS) || defined (_WIN32) || defined (__EMX__) \ - || defined (VMS) || defined(__vxworks) || defined (__nucleus__) +#if defined (_WIN32) || defined (VMS) \ + || defined(__vxworks) || defined (__nucleus__) return -1; #else return symlink (oldpath, newpath); @@ -504,8 +491,8 @@ __gnat_symlink (char *oldpath ATTRIBUTE_UNUSED, /* Try to lock a file, return 1 if success. */ -#if defined (__vxworks) || defined (__nucleus__) || defined (MSDOS) \ - || defined (_WIN32) || defined (__EMX__) || defined (VMS) +#if defined (__vxworks) || defined (__nucleus__) \ + || defined (_WIN32) || defined (VMS) /* Version that does not use link. */ @@ -577,9 +564,7 @@ __gnat_try_lock (char *dir, char *file) int __gnat_get_maximum_file_name_length (void) { -#if defined (MSDOS) - return 8; -#elif defined (VMS) +#if defined (VMS) if (getenv ("GNAT$EXTENDED_FILE_SPECIFICATIONS")) return -1; else @@ -594,7 +579,7 @@ __gnat_get_maximum_file_name_length (void) int __gnat_get_file_names_case_sensitive (void) { -#if defined (__EMX__) || defined (MSDOS) || defined (VMS) || defined (WINNT) +#if defined (VMS) || defined (WINNT) return 0; #else return 1; @@ -604,11 +589,7 @@ __gnat_get_file_names_case_sensitive (void) char __gnat_get_default_identifier_character_set (void) { -#if defined (__EMX__) || defined (MSDOS) - return 'p'; -#else return '1'; -#endif } /* Return the current working directory. */ @@ -675,12 +656,7 @@ __gnat_get_executable_suffix_ptr (int *len, const char **value) void __gnat_get_debuggable_suffix_ptr (int *len, const char **value) { -#ifndef MSDOS *value = HOST_EXECUTABLE_SUFFIX; -#else - /* On DOS, the extensionless COFF file is what gdb likes. */ - *value = ""; -#endif if (*value == 0) *len = 0; @@ -859,7 +835,7 @@ __gnat_open_read (char *path, int fmode) return fd < 0 ? -1 : fd; } -#if defined (__EMX__) || defined (__MINGW32__) +#if defined (__MINGW32__) #define PERM (S_IREAD | S_IWRITE) #elif defined (VMS) /* Excerpt from DECC C RTL Reference Manual: @@ -1101,7 +1077,7 @@ __gnat_stat_to_attr (int fd, char* name, struct file_attributes* attr) attr->executable = (!ret && (statbuf.st_mode & S_IXUSR)); #endif -#if !defined (__EMX__) && !defined (MSDOS) && (!defined (_WIN32) || defined (RTX)) +#if !defined (_WIN32) || defined (RTX) /* on Windows requires extra system call, see __gnat_file_time_name_attr */ if (ret != 0) { attr->timestamp = (OS_Time)-1; @@ -1342,13 +1318,7 @@ OS_Time __gnat_file_time_name_attr (char* name, struct file_attributes* attr) { if (attr->timestamp == (OS_Time)-2) { -#if defined (__EMX__) || defined (MSDOS) - int fd = open (name, O_RDONLY | O_BINARY); - time_t ret = __gnat_file_time_fd (fd); - close (fd); - attr->timestamp = (OS_Time)ret; - -#elif defined (_WIN32) && !defined (RTX) +#if defined (_WIN32) && !defined (RTX) time_t ret = -1; TCHAR wname[GNAT_MAX_PATH_LEN]; S2WSC (wname, name, GNAT_MAX_PATH_LEN); @@ -1383,74 +1353,7 @@ OS_Time __gnat_file_time_fd_attr (int fd, struct file_attributes* attr) { if (attr->timestamp == (OS_Time)-2) { - /* The following workaround code is due to the fact that under EMX and - DJGPP fstat attempts to convert time values to GMT rather than keep the - actual OS timestamp of the file. By using the OS2/DOS functions directly - the GNAT timestamp are independent of this behavior, which is desired to - facilitate the distribution of GNAT compiled libraries. */ - -#if defined (__EMX__) || defined (MSDOS) -#ifdef __EMX__ - - FILESTATUS fs; - int ret = DosQueryFileInfo (fd, 1, (unsigned char *) &fs, - sizeof (FILESTATUS)); - - unsigned file_year = fs.fdateLastWrite.year; - unsigned file_month = fs.fdateLastWrite.month; - unsigned file_day = fs.fdateLastWrite.day; - unsigned file_hour = fs.ftimeLastWrite.hours; - unsigned file_min = fs.ftimeLastWrite.minutes; - unsigned file_tsec = fs.ftimeLastWrite.twosecs; - -#else - struct ftime fs; - int ret = getftime (fd, &fs); - - unsigned file_year = fs.ft_year; - unsigned file_month = fs.ft_month; - unsigned file_day = fs.ft_day; - unsigned file_hour = fs.ft_hour; - unsigned file_min = fs.ft_min; - unsigned file_tsec = fs.ft_tsec; -#endif - - /* Calculate the seconds since epoch from the time components. First count - the whole days passed. The value for years returned by the DOS and OS2 - functions count years from 1980, so to compensate for the UNIX epoch which - begins in 1970 start with 10 years worth of days and add days for each - four year period since then. */ - - time_t tot_secs; - int cum_days[12] = {0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334}; - int days_passed = 3652 + (file_year / 4) * 1461; - int years_since_leap = file_year % 4; - - if (years_since_leap == 1) - days_passed += 366; - else if (years_since_leap == 2) - days_passed += 731; - else if (years_since_leap == 3) - days_passed += 1096; - - if (file_year > 20) - days_passed -= 1; - - days_passed += cum_days[file_month - 1]; - if (years_since_leap == 0 && file_year != 20 && file_month > 2) - days_passed++; - - days_passed += file_day - 1; - - /* OK - have whole days. Multiply -- then add in other parts. */ - - tot_secs = days_passed * 86400; - tot_secs += file_hour * 3600; - tot_secs += file_min * 60; - tot_secs += file_tsec * 2; - attr->timestamp = (OS_Time) tot_secs; - -#elif defined (_WIN32) && !defined (RTX) +#if defined (_WIN32) && !defined (RTX) HANDLE h = (HANDLE) _get_osfhandle (fd); time_t ret = win32_filetime (h); attr->timestamp = (OS_Time) ret; @@ -1476,7 +1379,7 @@ __gnat_file_time_fd (int fd) void __gnat_set_file_time_name (char *name, time_t time_stamp) { -#if defined (__EMX__) || defined (MSDOS) || defined (__vxworks) +#if defined (__vxworks) /* Code to implement __gnat_set_file_time_name for these systems. */ @@ -1857,7 +1760,7 @@ __gnat_is_absolute_path (char *name, int length) #else return (length != 0) && (*name == '/' || *name == DIR_SEPARATOR -#if defined (__EMX__) || defined (MSDOS) || defined (WINNT) +#if defined (WINNT) || (length > 1 && ISALPHA (name[0]) && name[1] == ':') #endif ); @@ -2358,7 +2261,7 @@ __gnat_portable_spawn (char *args[]) #if defined (__vxworks) || defined(__nucleus__) || defined(RTX) return -1; -#elif defined (MSDOS) || defined (_WIN32) +#elif defined (_WIN32) /* args[0] must be quotes as it could contain a full pathname with spaces */ char *args_0 = args[0]; args[0] = (char *)xmalloc (strlen (args_0) + 3); @@ -2379,12 +2282,6 @@ __gnat_portable_spawn (char *args[]) #else -#ifdef __EMX__ - pid = spawnvp (P_NOWAIT, args[0], args); - if (pid == -1) - return -1; - -#else pid = fork (); if (pid < 0) return -1; @@ -2399,7 +2296,6 @@ __gnat_portable_spawn (char *args[]) _exit (1); #endif } -#endif /* The parent. */ finished = waitpid (pid, &status, 0); @@ -2474,7 +2370,7 @@ static HANDLE *HANDLES_LIST = NULL; static int *PID_LIST = NULL, plist_length = 0, plist_max_length = 0; static void -add_handle (HANDLE h) +add_handle (HANDLE h, int pid) { /* -------------------- critical section -------------------- */ @@ -2490,7 +2386,7 @@ add_handle (HANDLE h) } HANDLES_LIST[plist_length] = h; - PID_LIST[plist_length] = GetProcessId (h); + PID_LIST[plist_length] = pid; ++plist_length; (*Unlock_Task) (); @@ -2521,8 +2417,8 @@ __gnat_win32_remove_handle (HANDLE h, int pid) /* -------------------- critical section -------------------- */ } -static HANDLE -win32_no_block_spawn (char *command, char *args[]) +static void +win32_no_block_spawn (char *command, char *args[], HANDLE *h, int *pid) { BOOL result; STARTUPINFO SI; @@ -2587,10 +2483,14 @@ win32_no_block_spawn (char *command, char *args[]) if (result == TRUE) { CloseHandle (PI.hThread); - return PI.hProcess; + *h = PI.hProcess; + *pid = PI.dwProcessId; } else - return NULL; + { + *h = NULL; + *pid = 0; + } } static int @@ -2627,7 +2527,7 @@ win32_wait (int *status) h = hl[res - WAIT_OBJECT_0]; GetExitCodeProcess (h, &exitcode); - pid = GetProcessId (h); + pid = PID_LIST [res - WAIT_OBJECT_0]; __gnat_win32_remove_handle (h, -1); free (hl); @@ -2645,28 +2545,16 @@ __gnat_portable_no_block_spawn (char *args[]) #if defined (__vxworks) || defined (__nucleus__) || defined (RTX) return -1; -#elif defined (__EMX__) || defined (MSDOS) - - /* ??? For PC machines I (Franco) don't know the system calls to implement - this routine. So I'll fake it as follows. This routine will behave - exactly like the blocking portable_spawn and will systematically return - a pid of 0 unless the spawned task did not complete successfully, in - which case we return a pid of -1. To synchronize with this the - portable_wait below systematically returns a pid of 0 and reports that - the subprocess terminated successfully. */ - - if (spawnvp (P_WAIT, args[0], args) != 0) - return -1; - #elif defined (_WIN32) HANDLE h = NULL; + int pid; - h = win32_no_block_spawn (args[0], args); + win32_no_block_spawn (args[0], args, &h, &pid); if (h != NULL) { - add_handle (h); - return GetProcessId (h); + add_handle (h, pid); + return pid; } else return -1; @@ -2698,16 +2586,12 @@ __gnat_portable_wait (int *process_status) int pid = 0; #if defined (__vxworks) || defined (__nucleus__) || defined (RTX) - /* Not sure what to do here, so do same as __EMX__ case, i.e., nothing but - return zero. */ + /* Not sure what to do here, so do nothing but return zero. */ #elif defined (_WIN32) pid = win32_wait (&status); -#elif defined (__EMX__) || defined (MSDOS) - /* ??? See corresponding comment in portable_no_block_spawn. */ - #else pid = waitpid (-1, &status, 0); @@ -2783,12 +2667,6 @@ __gnat_locate_regular_file (char *file_name, char *path_val) for (;;) { - for (; *path_val == PATH_SEPARATOR; path_val++) - ; - - if (*path_val == 0) - return 0; - /* Skip the starting quote */ if (*path_val == '"') @@ -2797,7 +2675,14 @@ __gnat_locate_regular_file (char *file_name, char *path_val) for (ptr = file_path; *path_val && *path_val != PATH_SEPARATOR; ) *ptr++ = *path_val++; - ptr--; + /* If directory is empty, it is the current directory*/ + + if (ptr == file_path) + { + *ptr = '.'; + } + else + ptr--; /* Skip the ending quote */ @@ -2811,6 +2696,13 @@ __gnat_locate_regular_file (char *file_name, char *path_val) if (__gnat_is_regular_file (file_path)) return xstrdup (file_path); + + if (*path_val == 0) + return 0; + + /* Skip path separator */ + + path_val++; } } @@ -3445,14 +3337,6 @@ __gnat_adjust_os_resource_limits (void) #endif -/* For EMX, we cannot include dummy in libgcc, since it is too difficult - to coordinate this with the EMX distribution. Consequently, we put the - definition of dummy which is used for exception handling, here. */ - -#if defined (__EMX__) -void __dummy () {} -#endif - #if defined (__mips_vxworks) int _flush_cache() diff --git a/gcc/ada/ali-util.adb b/gcc/ada/ali-util.adb index e996611c327..001d654ff1d 100644 --- a/gcc/ada/ali-util.adb +++ b/gcc/ada/ali-util.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -220,11 +220,11 @@ package body ALI.Util is null; end Post_Scan; - -------------- - -- Read_ALI -- - -------------- + ---------------------- + -- Read_Withed_ALIs -- + ---------------------- - procedure Read_ALI (Id : ALI_Id) is + procedure Read_Withed_ALIs (Id : ALI_Id) is Afile : File_Name_Type; Text : Text_Buffer_Ptr; Idread : ALI_Id; @@ -298,7 +298,7 @@ package body ALI.Util is else -- Otherwise, recurse to get new dependents - Read_ALI (Idread); + Read_Withed_ALIs (Idread); end if; -- If the ALI file has already been processed and is an interface, @@ -309,7 +309,7 @@ package body ALI.Util is end if; end loop; end loop; - end Read_ALI; + end Read_Withed_ALIs; ---------------------- -- Set_Source_Table -- @@ -481,6 +481,14 @@ package body ALI.Util is (Get_File_Checksum (Sdep.Table (D).Sfile), Source.Table (Src).Checksum) then + if Verbose_Mode then + Write_Str (" "); + Write_Str (Get_Name_String (Sdep.Table (D).Sfile)); + Write_Str (": up to date, different timestamps " & + "but same checksum"); + Write_Eol; + end if; + Sdep.Table (D).Stamp := Source.Table (Src).Stamp; end if; diff --git a/gcc/ada/ali-util.ads b/gcc/ada/ali-util.ads index d28ad40d54d..cbdb14f7075 100644 --- a/gcc/ada/ali-util.ads +++ b/gcc/ada/ali-util.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -32,9 +32,8 @@ package ALI.Util is -- Source File Table -- ----------------------- - -- A source file table entry is built for every source file that is - -- in the source dependency table of any of the ALI files that make - -- up the current program. + -- A table entry is built for every source file that is in the source + -- dependency table of any ALI file that is part of the current program. No_Source_Id : constant Source_Id := Source_Id'First; -- Special value indicating no Source table entry @@ -101,11 +100,11 @@ package ALI.Util is -- Subprograms for Manipulating ALI Information -- -------------------------------------------------- - procedure Read_ALI (Id : ALI_Id); - -- Process an ALI file which has been read and scanned by looping - -- through all withed units in the ALI file, checking if they have - -- been processed. Each unit that has not yet been processed will - -- be read, scanned, and processed recursively. + procedure Read_Withed_ALIs (Id : ALI_Id); + -- Process an ALI file which has been read and scanned by looping through + -- all withed units in the ALI file, checking if they have been processed. + -- Each unit that has not yet been processed will be read, scanned, and + -- processed recursively. procedure Set_Source_Table (A : ALI_Id); -- Build source table entry corresponding to the ALI file whose id is A diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index 20438cf66e6..eb45dcaca50 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -49,6 +49,7 @@ package body ALI is 'U' => True, -- unit 'W' => True, -- with 'L' => True, -- linker option + 'N' => True, -- notes 'E' => True, -- external 'D' => True, -- dependency 'X' => True, -- xref @@ -89,14 +90,16 @@ package body ALI is Withs.Init; Sdep.Init; Linker_Options.Init; + Notes.Init; Xref_Section.Init; Xref_Entity.Init; Xref.Init; Version_Ref.Reset; - -- Add dummy zero'th item in Linker_Options for the sort function + -- Add dummy zero'th item in Linker_Options and Notes for sort calls Linker_Options.Increment_Last; + Notes.Increment_Last; -- Initialize global variables recording cumulative options in all -- ALI files that are read for a given processing run in gnatbind. @@ -119,14 +122,15 @@ package body ALI is -------------- function Scan_ALI - (F : File_Name_Type; - T : Text_Buffer_Ptr; - Ignore_ED : Boolean; - Err : Boolean; - Read_Xref : Boolean := False; - Read_Lines : String := ""; - Ignore_Lines : String := "X"; - Ignore_Errors : Boolean := False) return ALI_Id + (F : File_Name_Type; + T : Text_Buffer_Ptr; + Ignore_ED : Boolean; + Err : Boolean; + Read_Xref : Boolean := False; + Read_Lines : String := ""; + Ignore_Lines : String := "X"; + Ignore_Errors : Boolean := False; + Directly_Scanned : Boolean := False) return ALI_Id is P : Text_Ptr := T'First; Line : Logical_Line_Number := 1; @@ -204,7 +208,7 @@ package body ALI is -- -- If Ignore_Special is False (normal case), the scan is terminated by -- a typeref bracket or an equal sign except for the special case of - -- an operator name starting with a double quite which is terminated + -- an operator name starting with a double quote which is terminated -- by another double quote. -- -- It is an error to set both Ignore_Spaces and Ignore_Special to True. @@ -1291,9 +1295,9 @@ package body ALI is else Skip_Space; No_Deps.Append ((Id, Get_Name)); + Skip_Eol; end if; - Skip_Eol; C := Getc; end loop; @@ -1415,6 +1419,7 @@ package body ALI is UL.First_Arg := First_Arg; UL.Elab_Position := 0; UL.SAL_Interface := ALIs.Table (Id).SAL_Interface; + UL.Directly_Scanned := Directly_Scanned; UL.Body_Needed_For_SAL := False; UL.Elaborate_Body_Desirable := False; UL.Optimize_Alignment := 'O'; @@ -1860,6 +1865,45 @@ package body ALI is Linker_Options.Table (Linker_Options.Last).Original_Pos := Linker_Options.Last; end if; + + -- If there are notes present, scan them + + Notes_Loop : loop + Check_Unknown_Line; + exit Notes_Loop when C /= 'N'; + + if Ignore ('N') then + Skip_Line; + + else + Checkc (' '); + + Notes.Increment_Last; + Notes.Table (Notes.Last).Pragma_Type := Getc; + Notes.Table (Notes.Last).Pragma_Line := Get_Nat; + Checkc (':'); + Notes.Table (Notes.Last).Pragma_Col := Get_Nat; + Notes.Table (Notes.Last).Unit := Units.Last; + + if At_Eol then + Notes.Table (Notes.Last).Pragma_Args := No_Name; + + else + Checkc (' '); + + Name_Len := 0; + while not At_Eol loop + Add_Char_To_Name_Buffer (Getc); + end loop; + + Notes.Table (Notes.Last).Pragma_Args := Name_Enter; + end if; + + Skip_Eol; + end if; + + C := Getc; + end loop Notes_Loop; end loop U_Loop; -- End loop through units for one ALI file @@ -2146,10 +2190,19 @@ package body ALI is -- Start of processing for Read_Refs_For_One_Entity begin - XE.Line := Get_Nat; - XE.Etype := Getc; - XE.Col := Get_Nat; - XE.Lib := (Getc = '*'); + XE.Line := Get_Nat; + XE.Etype := Getc; + XE.Col := Get_Nat; + + case Getc is + when '*' => + XE.Visibility := Global; + when '+' => + XE.Visibility := Static; + when others => + XE.Visibility := Other; + end case; + XE.Entity := Get_Name; -- Handle the information about generic instantiations diff --git a/gcc/ada/ali.ads b/gcc/ada/ali.ads index 9e8da30a22f..74aeaed026d 100644 --- a/gcc/ada/ali.ads +++ b/gcc/ada/ali.ads @@ -342,6 +342,9 @@ package ALI is SAL_Interface : Boolean; -- Set True when this is an interface to a standalone library + Directly_Scanned : Boolean; + -- True iff it is a unit from an ALI file specified to gnatbind + Body_Needed_For_SAL : Boolean; -- Indicates that the source for the body of the unit (subprogram, -- package, or generic unit) must be included in a standalone library. @@ -602,8 +605,6 @@ package ALI is -- table. end record; - -- Declare the Linker_Options Table - -- The indexes of active entries in this table range from 1 to the -- value of Linker_Options.Last. The zero'th element is for sort call. @@ -615,6 +616,44 @@ package ALI is Table_Increment => 400, Table_Name => "Linker_Options"); + ----------------- + -- Notes Table -- + ----------------- + + -- The notes table records entries from N lines + + type Notes_Record is record + Pragma_Type : Character; + -- 'A', 'C', 'I', 'S', 'T' for Annotate/Comment/Ident/Subtitle/Title + + Pragma_Line : Nat; + -- Line number of pragma + + Pragma_Col : Nat; + -- Column number of pragma + + Unit : Unit_Id; + -- Unit_Id for the entry + + Pragma_Args : Name_Id; + -- Pragma arguments. No_Name if no arguments, otherwise a single + -- name table entry consisting of all the characters on the notes + -- line from the first non-blank character following the source + -- location to the last character on the line. + end record; + + -- The indexes of active entries in this table range from 1 to the + -- value of Linker_Options.Last. The zero'th element is for convenience + -- if the table needs to be sorted. + + package Notes is new Table.Table ( + Table_Component_Type => Notes_Record, + Table_Index_Type => Integer, + Table_Low_Bound => 0, + Table_Initial => 200, + Table_Increment => 400, + Table_Name => "Notes"); + ------------------------------------------- -- External Version Reference Hash Table -- ------------------------------------------- @@ -772,6 +811,11 @@ package ALI is Tref_Derived, -- Derived type typeref (points to parent type) Tref_Type); -- All other cases + type Visibility_Kind is + (Global, -- Library level entity + Static, -- Static C/C++ entity + Other); -- Local and other entity + -- The following table records entities for which xrefs are recorded type Xref_Entity_Record is record @@ -785,8 +829,8 @@ package ALI is Col : Pos; -- Column number of definition - Lib : Boolean; - -- True if entity is library level entity + Visibility : Visibility_Kind; + -- Visiblity of entity Entity : Name_Id; -- Name of entity @@ -933,14 +977,15 @@ package ALI is -- Initialize the ALI tables. Also resets all switch values to defaults function Scan_ALI - (F : File_Name_Type; - T : Text_Buffer_Ptr; - Ignore_ED : Boolean; - Err : Boolean; - Read_Xref : Boolean := False; - Read_Lines : String := ""; - Ignore_Lines : String := "X"; - Ignore_Errors : Boolean := False) return ALI_Id; + (F : File_Name_Type; + T : Text_Buffer_Ptr; + Ignore_ED : Boolean; + Err : Boolean; + Read_Xref : Boolean := False; + Read_Lines : String := ""; + Ignore_Lines : String := "X"; + Ignore_Errors : Boolean := False; + Directly_Scanned : Boolean := False) return ALI_Id; -- Given the text, T, of an ALI file, F, scan and store the information -- from the file, and return the Id of the resulting entry in the ALI -- table. Switch settings may be modified as described above in the @@ -986,5 +1031,11 @@ package ALI is -- Scan_ALI was completely unable to process the file (e.g. it did not -- look like an ALI file at all). Ignore_Errors is intended to improve -- the downward compatibility of new compilers with old tools. + -- + -- Directly_Scanned is normally False. If it is set to True, then the + -- units (spec and/or body) corresponding to the ALI file are marked as + -- such. It is used to decide for what units gnatbind should generate + -- the symbols corresponding to 'Version or 'Body_Version in + -- Stand-Alone Libraries. end ALI; diff --git a/gcc/ada/alloc.ads b/gcc/ada/alloc.ads index fa6c9d123f5..c5cad729652 100644 --- a/gcc/ada/alloc.ads +++ b/gcc/ada/alloc.ads @@ -100,6 +100,9 @@ package Alloc is Nodes_Initial : constant := 50_000; -- Atree Nodes_Increment : constant := 100; + Notes_Initial : constant := 100; -- Lib + Notes_Increment : constant := 200; + Obsolescent_Warnings_Initial : constant := 50; -- Sem_Prag Obsolescent_Warnings_Increment : constant := 200; diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index b22732668a5..807527230af 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -44,6 +44,9 @@ with Tree_IO; use Tree_IO; package body Atree is + Reporting_Proc : Report_Proc := null; + -- Record argument to last call to Set_Reporting_Proc + --------------- -- Debugging -- --------------- @@ -63,13 +66,15 @@ package body Atree is -- Either way, gnat1 will stop when node 12345 is created - -- The second method is faster + -- The second method is much faster + + -- Similarly, rr and rrd allow breaking on rewriting of a given node ww : Node_Id'Base := Node_Id'First - 1; pragma Export (Ada, ww); -- trick the optimizer Watch_Node : Node_Id'Base renames ww; - -- Node to "watch"; that is, whenever a node is created, we check if it is - -- equal to Watch_Node, and if so, call New_Node_Breakpoint. You have + -- Node to "watch"; that is, whenever a node is created, we check if it + -- is equal to Watch_Node, and if so, call New_Node_Breakpoint. You have -- presumably set a breakpoint on New_Node_Breakpoint. Note that the -- initial value of Node_Id'First - 1 ensures that by default, no node -- will be equal to Watch_Node. @@ -89,6 +94,25 @@ package body Atree is -- If Node = Watch_Node, this prints out the new node and calls -- New_Node_Breakpoint. Otherwise, does nothing. + procedure rr; + pragma Export (Ada, rr); + procedure Rewrite_Breakpoint renames rr; + -- This doesn't do anything interesting; it's just for setting breakpoint + -- on as explained above. + + procedure rrd (Old_Node, New_Node : Node_Id); + pragma Export (Ada, rrd); + procedure Rewrite_Debugging_Output + (Old_Node, New_Node : Node_Id) renames rrd; + -- For debugging. If debugging is turned on, Rewrite calls this. If debug + -- flag N is turned on, this prints out the new node. + -- + -- If Old_Node = Watch_Node, this prints out the old and new nodes and + -- calls Rewrite_Breakpoint. Otherwise, does nothing. + + procedure Node_Debug_Output (Op : String; N : Node_Id); + -- Common code for nnd and rrd, writes Op followed by information about N + ----------------------------- -- Local Objects and Types -- ----------------------------- @@ -510,6 +534,13 @@ package body Atree is Orig_Nodes.Set_Last (Nodes.Last); Allocate_List_Tables (Nodes.Last); + + -- Invoke the reporting procedure (if available) + + if Reporting_Proc /= null then + Reporting_Proc.all (Target => New_Id, Source => Src); + end if; + return New_Id; end Allocate_Initialize_Node; @@ -766,6 +797,145 @@ package body Atree is return N_To_E (Nodes.Table (E + 1).Nkind); end Ekind; + -------------- + -- Ekind_In -- + -------------- + + function Ekind_In + (T : Entity_Kind; + V1 : Entity_Kind; + V2 : Entity_Kind) return Boolean + is + begin + return T = V1 or else + T = V2; + end Ekind_In; + + function Ekind_In + (T : Entity_Kind; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind) return Boolean + is + begin + return T = V1 or else + T = V2 or else + T = V3; + end Ekind_In; + + function Ekind_In + (T : Entity_Kind; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind) return Boolean + is + begin + return T = V1 or else + T = V2 or else + T = V3 or else + T = V4; + end Ekind_In; + + function Ekind_In + (T : Entity_Kind; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind; + V5 : Entity_Kind) return Boolean + is + begin + return T = V1 or else + T = V2 or else + T = V3 or else + T = V4 or else + T = V5; + end Ekind_In; + + function Ekind_In + (T : Entity_Kind; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind; + V5 : Entity_Kind; + V6 : Entity_Kind) return Boolean + is + begin + return T = V1 or else + T = V2 or else + T = V3 or else + T = V4 or else + T = V5 or else + T = V6; + end Ekind_In; + + function Ekind_In + (E : Entity_Id; + V1 : Entity_Kind; + V2 : Entity_Kind) return Boolean + is + begin + return Ekind_In (Ekind (E), V1, V2); + end Ekind_In; + + function Ekind_In + (E : Entity_Id; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind) return Boolean + is + begin + return Ekind_In (Ekind (E), V1, V2, V3); + end Ekind_In; + + function Ekind_In + (E : Entity_Id; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind) return Boolean + is + begin + return Ekind_In (Ekind (E), V1, V2, V3, V4); + end Ekind_In; + + function Ekind_In + (E : Entity_Id; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind; + V5 : Entity_Kind) return Boolean + is + begin + return Ekind_In (Ekind (E), V1, V2, V3, V4, V5); + end Ekind_In; + + function Ekind_In + (E : Entity_Id; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind; + V5 : Entity_Kind; + V6 : Entity_Kind) return Boolean + is + begin + return Ekind_In (Ekind (E), V1, V2, V3, V4, V5, V6); + end Ekind_In; + + ------------------------ + -- Set_Reporting_Proc -- + ------------------------ + + procedure Set_Reporting_Proc (P : Report_Proc) is + begin + pragma Assert (Reporting_Proc = null); + Reporting_Proc := P; + end Set_Reporting_Proc; + ------------------ -- Error_Posted -- ------------------ @@ -1108,21 +1278,7 @@ package body Atree is begin if Debug_Flag_N or else Node_Is_Watched then - Write_Str ("Allocate "); - - if Nkind (N) in N_Entity then - Write_Str ("entity"); - else - Write_Str ("node"); - end if; - - Write_Str (", Id = "); - Write_Int (Int (N)); - Write_Str (" "); - Write_Location (Sloc (N)); - Write_Str (" "); - Write_Str (Node_Kind'Image (Nkind (N))); - Write_Eol; + Node_Debug_Output ("Allocate", N); if Node_Is_Watched then New_Node_Breakpoint; @@ -1242,6 +1398,7 @@ package body Atree is begin return Nkind_In (Nkind (N), V1, V2, V3, V4, V5, V6, V7, V8, V9); end Nkind_In; + -------- -- No -- -------- @@ -1251,6 +1408,29 @@ package body Atree is return N = Empty; end No; + ----------------------- + -- Node_Debug_Output -- + ----------------------- + + procedure Node_Debug_Output (Op : String; N : Node_Id) is + begin + Write_Str (Op); + + if Nkind (N) in N_Entity then + Write_Str (" entity"); + else + Write_Str (" node"); + end if; + + Write_Str (" Id = "); + Write_Int (Int (N)); + Write_Str (" "); + Write_Location (Sloc (N)); + Write_Str (" "); + Write_Str (Node_Kind'Image (Nkind (N))); + Write_Eol; + end Node_Debug_Output; + ------------------- -- Nodes_Address -- ------------------- @@ -1410,6 +1590,12 @@ package body Atree is -- to Rewrite if there were an intention to save the original node. Orig_Nodes.Table (Old_Node) := Old_Node; + + -- Invoke the reporting procedure (if available) + + if Reporting_Proc /= null then + Reporting_Proc.all (Target => Old_Node, Source => New_Node); + end if; end Replace; ------------- @@ -1435,6 +1621,7 @@ package body Atree is (not Has_Extension (Old_Node) and not Has_Extension (New_Node) and not Nodes.Table (New_Node).In_List); + pragma Debug (Rewrite_Debugging_Output (Old_Node, New_Node)); if Nkind (Old_Node) in N_Subexpr then Old_Paren_Count := Paren_Count (Old_Node); @@ -1467,8 +1654,44 @@ package body Atree is end if; Fix_Parents (Ref_Node => New_Node, Fix_Node => Old_Node); + + -- Invoke the reporting procedure (if available) + + if Reporting_Proc /= null then + Reporting_Proc.all (Target => Old_Node, Source => New_Node); + end if; end Rewrite; + ------------------------- + -- Rewrite_Breakpoint -- + ------------------------- + + procedure rr is -- Rewrite_Breakpoint + begin + Write_Str ("Watched node "); + Write_Int (Int (Watch_Node)); + Write_Str (" rewritten"); + Write_Eol; + end rr; + + ------------------------------ + -- Rewrite_Debugging_Output -- + ------------------------------ + + procedure rrd (Old_Node, New_Node : Node_Id) is -- Rewrite_Debugging_Output + Node_Is_Watched : constant Boolean := Old_Node = Watch_Node; + + begin + if Debug_Flag_N or else Node_Is_Watched then + Node_Debug_Output ("Rewrite", Old_Node); + Node_Debug_Output ("into", New_Node); + + if Node_Is_Watched then + Rewrite_Breakpoint; + end if; + end if; + end rrd; + ------------------ -- Set_Analyzed -- ------------------ diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index da0b28874c6..11787bc116e 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -461,6 +461,12 @@ package Atree is -- function is used only by Sinfo.CN to change nodes into their -- corresponding entities. + type Report_Proc is access procedure (Target : Node_Id; Source : Node_Id); + + procedure Set_Reporting_Proc (P : Report_Proc); + -- Register a procedure that is invoked when a node is allocated, replaced + -- or rewritten. + type Traverse_Result is (Abandon, OK, OK_Orig, Skip); -- This is the type of the result returned by the Process function passed -- to Traverse_Func and Traverse_Proc. See below for details. @@ -543,8 +549,12 @@ package Atree is -- Tests given Id for inequality with the Empty node. This allows notations -- like "if Present (Statement)" as opposed to "if Statement /= Empty". - -- Node_Kind tests, like the functions in Sinfo, but the first argument is - -- a Node_Id, and the tested field is Nkind (N). + --------------------- + -- Node_Kind Tests -- + --------------------- + + -- These are like the functions in Sinfo, but the first argument is a + -- Node_Id, and the tested field is Nkind (N). function Nkind_In (N : Node_Id; @@ -617,6 +627,88 @@ package Atree is pragma Inline (Nkind_In); -- Inline all above functions + ----------------------- + -- Entity_Kind_Tests -- + ----------------------- + + -- Utility functions to test whether an Entity_Kind value, either given + -- directly as the first argument, or the Ekind field of an Entity give + -- as the first argument, matches any of the given list of Entity_Kind + -- values. Return True if any match, False if no match. + + function Ekind_In + (E : Entity_Id; + V1 : Entity_Kind; + V2 : Entity_Kind) return Boolean; + + function Ekind_In + (E : Entity_Id; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind) return Boolean; + + function Ekind_In + (E : Entity_Id; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind) return Boolean; + + function Ekind_In + (E : Entity_Id; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind; + V5 : Entity_Kind) return Boolean; + + function Ekind_In + (E : Entity_Id; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind; + V5 : Entity_Kind; + V6 : Entity_Kind) return Boolean; + + function Ekind_In + (T : Entity_Kind; + V1 : Entity_Kind; + V2 : Entity_Kind) return Boolean; + + function Ekind_In + (T : Entity_Kind; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind) return Boolean; + + function Ekind_In + (T : Entity_Kind; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind) return Boolean; + + function Ekind_In + (T : Entity_Kind; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind; + V5 : Entity_Kind) return Boolean; + + function Ekind_In + (T : Entity_Kind; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind; + V5 : Entity_Kind; + V6 : Entity_Kind) return Boolean; + + pragma Inline (Ekind_In); + -- Inline all above functions + ----------------------------- -- Entity Access Functions -- ----------------------------- diff --git a/gcc/ada/back_end.adb b/gcc/ada/back_end.adb index f23a320d1ae..ee93f140796 100644 --- a/gcc/ada/back_end.adb +++ b/gcc/ada/back_end.adb @@ -40,8 +40,29 @@ with Switch.C; use Switch.C; with System; use System; with Types; use Types; +with System.OS_Lib; use System.OS_Lib; + package body Back_End is + type Arg_Array is array (Nat) of Big_String_Ptr; + type Arg_Array_Ptr is access Arg_Array; + -- Types to access compiler arguments + + flag_stack_check : Int; + pragma Import (C, flag_stack_check); + -- Indicates if stack checking is enabled, imported from decl.c + + save_argc : Nat; + pragma Import (C, save_argc); + -- Saved value of argc (number of arguments), imported from misc.c + + save_argv : Arg_Array_Ptr; + pragma Import (C, save_argv); + -- Saved value of argv (argument pointers), imported from misc.c + + function Len_Arg (Arg : Pos) return Nat; + -- Determine length of argument number Arg on original gnat1 command line + ------------------- -- Call_Back_End -- ------------------- @@ -122,37 +143,33 @@ package body Back_End is gigi_operating_mode => Mode); end Call_Back_End; + ------------- + -- Len_Arg -- + ------------- + + function Len_Arg (Arg : Pos) return Nat is + begin + for J in 1 .. Nat'Last loop + if save_argv (Arg).all (Natural (J)) = ASCII.NUL then + return J - 1; + end if; + end loop; + + raise Program_Error; + end Len_Arg; + ----------------------------- -- Scan_Compiler_Arguments -- ----------------------------- procedure Scan_Compiler_Arguments is - Next_Arg : Pos := 1; - - type Arg_Array is array (Nat) of Big_String_Ptr; - type Arg_Array_Ptr is access Arg_Array; - flag_stack_check : Int; - pragma Import (C, flag_stack_check); - -- Import from toplev.c - - save_argc : Nat; - pragma Import (C, save_argc); - -- Import from toplev.c - - save_argv : Arg_Array_Ptr; - pragma Import (C, save_argv); - -- Import from toplev.c + Next_Arg : Positive; + -- Next argument to be scanned Output_File_Name_Seen : Boolean := False; -- Set to True after having scanned file_name for switch "-gnatO file" - -- Local functions - - function Len_Arg (Arg : Pos) return Nat; - -- Determine length of argument number Arg on the original command line - -- from gnat1. - procedure Scan_Back_End_Switches (Switch_Chars : String); -- Procedure to scan out switches stored in Switch_Chars. The first -- character is known to be a valid switch character, and there are no @@ -165,21 +182,6 @@ package body Back_End is -- switches must still be scanned to skip "-o" or internal GCC switches -- with their argument. - ------------- - -- Len_Arg -- - ------------- - - function Len_Arg (Arg : Pos) return Nat is - begin - for J in 1 .. Nat'Last loop - if save_argv (Arg).all (Natural (J)) = ASCII.NUL then - return J - 1; - end if; - end loop; - - raise Program_Error; - end Len_Arg; - ---------------------------- -- Scan_Back_End_Switches -- ---------------------------- @@ -222,6 +224,11 @@ package body Back_End is end if; end Scan_Back_End_Switches; + -- Local variables + + Arg_Count : constant Natural := Natural (save_argc - 1); + Args : Argument_List (1 .. Arg_Count); + -- Start of processing for Scan_Compiler_Arguments begin @@ -229,14 +236,25 @@ package body Back_End is Opt.Stack_Checking_Enabled := (flag_stack_check /= 0); - -- Loop through command line arguments, storing them for later access + -- Put the arguments in Args - while Next_Arg < save_argc loop - Look_At_Arg : declare - Argv_Ptr : constant Big_String_Ptr := save_argv (Next_Arg); - Argv_Len : constant Nat := Len_Arg (Next_Arg); + for Arg in Pos range 1 .. save_argc - 1 loop + declare + Argv_Ptr : constant Big_String_Ptr := save_argv (Arg); + Argv_Len : constant Nat := Len_Arg (Arg); Argv : constant String := Argv_Ptr (1 .. Natural (Argv_Len)); + begin + Args (Positive (Arg)) := new String'(Argv); + end; + end loop; + + -- Loop through command line arguments, storing them for later access + + Next_Arg := 1; + while Next_Arg <= Args'Last loop + Look_At_Arg : declare + Argv : constant String := Args (Next_Arg).all; begin -- If the previous switch has set the Output_File_Name_Present @@ -283,7 +301,7 @@ package body Back_End is Opt.No_Stdlib := True; elsif Is_Front_End_Switch (Argv) then - Scan_Front_End_Switches (Argv); + Scan_Front_End_Switches (Argv, Args, Next_Arg); -- All non-front-end switches are back-end switches @@ -295,5 +313,4 @@ package body Back_End is Next_Arg := Next_Arg + 1; end loop; end Scan_Compiler_Arguments; - end Back_End; diff --git a/gcc/ada/back_end.ads b/gcc/ada/back_end.ads index 19144a1128d..fb11939a064 100644 --- a/gcc/ada/back_end.ads +++ b/gcc/ada/back_end.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/binde.adb b/gcc/ada/binde.adb index 3a85ae85e11..f4681906df1 100644 --- a/gcc/ada/binde.adb +++ b/gcc/ada/binde.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -224,25 +224,25 @@ package body Binde is After : Unit_Id; R : Succ_Reason; Ea_Id : Elab_All_Id := No_Elab_All_Link); - -- Establish a successor link, Before must be elaborated before After, - -- and the reason for the link is R. Ea_Id is the contents to be placed - -- in the Elab_All_Link of the entry. + -- Establish a successor link, Before must be elaborated before After, and + -- the reason for the link is R. Ea_Id is the contents to be placed in the + -- Elab_All_Link of the entry. procedure Choose (Chosen : Unit_Id); - -- Chosen is the next entry chosen in the elaboration order. This - -- procedure updates all data structures appropriately. + -- Chosen is the next entry chosen in the elaboration order. This procedure + -- updates all data structures appropriately. function Corresponding_Body (U : Unit_Id) return Unit_Id; pragma Inline (Corresponding_Body); - -- Given a unit which is a spec for which there is a separate body, - -- return the unit id of the body. It is an error to call this routine - -- with a unit that is not a spec, or which does not have a separate body. + -- Given a unit which is a spec for which there is a separate body, return + -- the unit id of the body. It is an error to call this routine with a unit + -- that is not a spec, or which does not have a separate body. function Corresponding_Spec (U : Unit_Id) return Unit_Id; pragma Inline (Corresponding_Spec); - -- Given a unit which is a body for which there is a separate spec, - -- return the unit id of the spec. It is an error to call this routine - -- with a unit that is not a body, or which does not have a separate spec. + -- Given a unit which is a body for which there is a separate spec, return + -- the unit id of the spec. It is an error to call this routine with a unit + -- that is not a body, or which does not have a separate spec. procedure Diagnose_Elaboration_Problem; -- Called when no elaboration order can be found. Outputs an appropriate @@ -276,6 +276,10 @@ package body Binde is pragma Inline (Is_Body_Unit); -- Determines if given unit is a body + function Is_Pure_Or_Preelab_Unit (U : Unit_Id) return Boolean; + -- Returns True if corresponding unit is Pure or Preelaborate. Includes + -- dealing with testing flags on spec if it is given a body. + function Is_Waiting_Body (U : Unit_Id) return Boolean; pragma Inline (Is_Waiting_Body); -- Determines if U is a waiting body, defined as a body which has @@ -286,16 +290,16 @@ package body Binde is Link : Elab_All_Id) return Elab_All_Id; -- Make an Elab_All_Entries table entry with the given Unam and Link - function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id; - -- This function uses the Info field set in the names table to obtain - -- the unit Id of a unit, given its name id value. - - function Worse_Choice (U1, U2 : Unit_Id) return Boolean; + function Pessimistic_Better_Choice (U1, U2 : Unit_Id) return Boolean; -- This is like Better_Choice, and has the same interface, but returns - -- true if U1 is a worse choice than U2 in the sense of the -h (horrible + -- true if U1 is a worse choice than U2 in the sense of the -p (pessimistic -- elaboration order) switch. We still have to obey Ada rules, so it is -- not quite the direct inverse of Better_Choice. + function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id; + -- This function uses the Info field set in the names table to obtain + -- the unit Id of a unit, given its name id value. + procedure Write_Dependencies; -- Write out dependencies (called only if appropriate option is set) @@ -323,7 +327,7 @@ package body Binde is -- Note: the checks here are applied in sequence, and the ordering is -- significant (i.e. the more important criteria are applied first). - -- Prefer a waiting body to any other case + -- Prefer a waiting body to one that is not a waiting body if Is_Waiting_Body (U1) and then not Is_Waiting_Body (U2) then if Debug_Flag_B then @@ -370,6 +374,28 @@ package body Binde is return False; + -- Prefer a pure or preelaborable unit to one that is not + + elsif Is_Pure_Or_Preelab_Unit (U1) + and then not + Is_Pure_Or_Preelab_Unit (U2) + then + if Debug_Flag_B then + Write_Line (" True: u1 is pure/preelab, u2 is not"); + end if; + + return True; + + elsif Is_Pure_Or_Preelab_Unit (U2) + and then not + Is_Pure_Or_Preelab_Unit (U1) + then + if Debug_Flag_B then + Write_Line (" False: u2 is pure/preelab, u1 is not"); + end if; + + return False; + -- Prefer a body to a spec elsif Is_Body_Unit (U1) and then not Is_Body_Unit (U2) then @@ -1141,7 +1167,7 @@ package body Binde is or else ((not Pessimistic_Elab_Order) and then Better_Choice (U, Best_So_Far)) or else (Pessimistic_Elab_Order - and then Worse_Choice (U, Best_So_Far)) + and then Pessimistic_Better_Choice (U, Best_So_Far)) then if Debug_Flag_N then Write_Str (" tentatively chosen (best so far)"); @@ -1321,6 +1347,28 @@ package body Binde is or else Units.Table (U).Utype = Is_Body_Only; end Is_Body_Unit; + ----------------------------- + -- Is_Pure_Or_Preelab_Unit -- + ----------------------------- + + function Is_Pure_Or_Preelab_Unit (U : Unit_Id) return Boolean is + begin + -- If we have a body with separate spec, test flags on the spec + + if Units.Table (U).Utype = Is_Body then + return Units.Table (U + 1).Preelab + or else + Units.Table (U + 1).Pure; + + -- Otherwise we have a spec or body acting as spec, test flags on unit + + else + return Units.Table (U).Preelab + or else + Units.Table (U).Pure; + end if; + end Is_Pure_Or_Preelab_Unit; + --------------------- -- Is_Waiting_Body -- --------------------- @@ -1346,51 +1394,115 @@ package body Binde is return Elab_All_Entries.Last; end Make_Elab_Entry; - ---------------- - -- Unit_Id_Of -- - ---------------- - - function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id is - Info : constant Int := Get_Name_Table_Info (Uname); - begin - pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id); - return Unit_Id (Info); - end Unit_Id_Of; - - ------------------ - -- Worse_Choice -- - ------------------ + ------------------------------- + -- Pessimistic_Better_Choice -- + ------------------------------- - function Worse_Choice (U1, U2 : Unit_Id) return Boolean is + function Pessimistic_Better_Choice (U1, U2 : Unit_Id) return Boolean is UT1 : Unit_Record renames Units.Table (U1); UT2 : Unit_Record renames Units.Table (U2); begin + if Debug_Flag_B then + Write_Str ("Pessimistic_Better_Choice ("); + Write_Unit_Name (UT1.Uname); + Write_Str (", "); + Write_Unit_Name (UT2.Uname); + Write_Line (")"); + end if; + -- Note: the checks here are applied in sequence, and the ordering is -- significant (i.e. the more important criteria are applied first). - -- If either unit is internal, then use Better_Choice, since the - -- language requires that predefined units not mess up in the choice - -- of elaboration order, and for internal units, any problems are - -- ours and not the programmers. + -- If either unit is predefined or internal, then we use the normal + -- Better_Choice rule, since we don't want to disturb the elaboration + -- rules of the language with -p, same treatment for Pure/Preelab. + + -- Prefer a predefined unit to a non-predefined unit - if UT1.Internal or else UT2.Internal then - return Better_Choice (U1, U2); + if UT1.Predefined and then not UT2.Predefined then + if Debug_Flag_B then + Write_Line (" True: u1 is predefined, u2 is not"); + end if; - -- Prefer anything else to a waiting body (!) + return True; + + elsif UT2.Predefined and then not UT1.Predefined then + if Debug_Flag_B then + Write_Line (" False: u2 is predefined, u1 is not"); + end if; + + return False; + + -- Prefer an internal unit to a non-internal unit + + elsif UT1.Internal and then not UT2.Internal then + if Debug_Flag_B then + Write_Line (" True: u1 is internal, u2 is not"); + end if; + + return True; + + elsif UT2.Internal and then not UT1.Internal then + if Debug_Flag_B then + Write_Line (" False: u2 is internal, u1 is not"); + end if; + + return False; + + -- Prefer a pure or preelaborable unit to one that is not + + elsif Is_Pure_Or_Preelab_Unit (U1) + and then not + Is_Pure_Or_Preelab_Unit (U2) + then + if Debug_Flag_B then + Write_Line (" True: u1 is pure/preelab, u2 is not"); + end if; + + return True; + + elsif Is_Pure_Or_Preelab_Unit (U2) + and then not + Is_Pure_Or_Preelab_Unit (U1) + then + if Debug_Flag_B then + Write_Line (" False: u2 is pure/preelab, u1 is not"); + end if; + + return False; + + -- Prefer anything else to a waiting body. We want to make bodies wait + -- as long as possible, till we are forced to choose them! elsif Is_Waiting_Body (U1) and then not Is_Waiting_Body (U2) then + if Debug_Flag_B then + Write_Line (" False: u1 is waiting body, u2 is not"); + end if; + return False; elsif Is_Waiting_Body (U2) and then not Is_Waiting_Body (U1) then + if Debug_Flag_B then + Write_Line (" True: u2 is waiting body, u1 is not"); + end if; + return True; -- Prefer a spec to a body (!) elsif Is_Body_Unit (U1) and then not Is_Body_Unit (U2) then + if Debug_Flag_B then + Write_Line (" False: u1 is body, u2 is not"); + end if; + return False; elsif Is_Body_Unit (U2) and then not Is_Body_Unit (U1) then + if Debug_Flag_B then + Write_Line (" True: u2 is body, u1 is not"); + end if; + return True; -- If both are waiting bodies, then prefer the one whose spec is @@ -1404,12 +1516,24 @@ package body Binde is -- A before the spec of B if it could. Since it could not, there it -- must be the case that A depends on B. It is therefore a good idea -- to put the body of B last so that if there is an elaboration order - -- problem, we will find it (that's what horrible order is about) + -- problem, we will find it (that's what pssimistic order is about) elsif Is_Waiting_Body (U1) and then Is_Waiting_Body (U2) then - return - UNR.Table (Corresponding_Spec (U1)).Elab_Position < - UNR.Table (Corresponding_Spec (U2)).Elab_Position; + declare + Result : constant Boolean := + UNR.Table (Corresponding_Spec (U1)).Elab_Position < + UNR.Table (Corresponding_Spec (U2)).Elab_Position; + begin + if Debug_Flag_B then + if Result then + Write_Line (" True: based on waiting body elab positions"); + else + Write_Line (" False: based on waiting body elab positions"); + end if; + end if; + + return Result; + end; end if; -- Remaining choice rules are disabled by Debug flag -do @@ -1420,44 +1544,81 @@ package body Binde is -- as Elaborate_Body_Desirable. In the normal case, we generally want -- to delay the elaboration of these specs as long as possible, so -- that bodies have better chance of being elaborated closer to the - -- specs. Worse_Choice as usual wants to do the opposite and - -- elaborate such specs as early as possible. + -- specs. Pessimistic_Better_Choice as usual wants to do the opposite + -- and elaborate such specs as early as possible. -- If we have two units, one of which is a spec for which this flag -- is set, and the other is not, we normally prefer to delay the spec - -- for which the flag is set, and so Worse_Choice does the opposite. + -- for which the flag is set, so again Pessimistic_Better_Choice does + -- the opposite. if not UT1.Elaborate_Body_Desirable and then UT2.Elaborate_Body_Desirable then + if Debug_Flag_B then + Write_Line (" False: u1 is elab body desirable, u2 is not"); + end if; + return False; elsif not UT2.Elaborate_Body_Desirable and then UT1.Elaborate_Body_Desirable then + if Debug_Flag_B then + Write_Line (" True: u1 is elab body desirable, u2 is not"); + end if; + return True; -- If we have two specs that are both marked as Elaborate_Body -- desirable, we normally prefer the one whose body is nearer to -- being able to be elaborated, based on the Num_Pred count. This -- helps to ensure bodies are as close to specs as possible. As - -- usual, Worse_Choice does the opposite. + -- usual, Pessimistic_Better_Choice does the opposite. elsif UT1.Elaborate_Body_Desirable and then UT2.Elaborate_Body_Desirable then - return UNR.Table (Corresponding_Body (U1)).Num_Pred >= - UNR.Table (Corresponding_Body (U2)).Num_Pred; + declare + Result : constant Boolean := + UNR.Table (Corresponding_Body (U1)).Num_Pred >= + UNR.Table (Corresponding_Body (U2)).Num_Pred; + begin + if Debug_Flag_B then + if Result then + Write_Line (" True based on Num_Pred compare"); + else + Write_Line (" False based on Num_Pred compare"); + end if; + end if; + + return Result; + end; end if; end if; -- If we fall through, it means that no preference rule applies, so we -- use alphabetical order to at least give a deterministic result. Since - -- Worse_Choice is in the business of stirring up the order, we will - -- use reverse alphabetical ordering. + -- Pessimistic_Better_Choice is in the business of stirring up the + -- order, we will use reverse alphabetical ordering. + + if Debug_Flag_B then + Write_Line (" choose on reverse alpha order"); + end if; return Uname_Less (UT2.Uname, UT1.Uname); - end Worse_Choice; + end Pessimistic_Better_Choice; + + ---------------- + -- Unit_Id_Of -- + ---------------- + + function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id is + Info : constant Int := Get_Name_Table_Info (Uname); + begin + pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id); + return Unit_Id (Info); + end Unit_Id_Of; ------------------------ -- Write_Dependencies -- diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index 182586133ae..3d120161789 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -111,6 +111,7 @@ package body Bindgen is -- Main_Priority : Integer; -- Time_Slice_Value : Integer; + -- Heap_Size : Natural; -- WC_Encoding : Character; -- Locking_Policy : Character; -- Queuing_Policy : Character; @@ -136,6 +137,10 @@ package body Bindgen is -- A value of zero indicates that time slicing should be suppressed. If no -- pragma is present, and no -T switch was used, the value is -1. + -- Heap_Size is the heap to use for memory allocations set by use of a + -- -Hnn parameter for the binder or by the GNAT$NO_MALLOC_64 logical. + -- Valid values are 32 and 64. This switch is only available on VMS. + -- WC_Encoding shows the wide character encoding method used for the main -- program. This is one of the encoding letters defined in -- System.WCh_Con.WC_Encoding_Letters. @@ -615,6 +620,15 @@ package body Bindgen is WBI (" Features_Set : Integer;"); WBI (" pragma Import (C, Features_Set, " & """__gnat_features_set"");"); + + if Opt.Heap_Size /= 0 then + WBI (""); + WBI (" Heap_Size : Integer;"); + WBI (" pragma Import (C, Heap_Size, " & + """__gl_heap_size"");"); + + Write_Statement_Buffer; + end if; end if; -- Initialize stack limit variable of the environment task if the @@ -786,6 +800,16 @@ package body Bindgen is WBI (" if Features_Set = 0 then"); WBI (" Set_Features;"); WBI (" end if;"); + + -- Features_Set may twiddle the heap size according to a logical + -- name, but the binder switch must override. + + if Opt.Heap_Size /= 0 then + Set_String (" Heap_Size := "); + Set_Int (Opt.Heap_Size); + Set_Char (';'); + Write_Statement_Buffer; + end if; end if; end if; @@ -1936,10 +1960,14 @@ package body Bindgen is WBI (""); Write_Info_Ada_C ("-- ", "/* ", " BEGIN Object file/option list"); + if Object_List_Filename /= null then + Set_List_File (Object_List_Filename.all); + end if; + for E in Elab_Order.First .. Elab_Order.Last loop - -- If not spec that has an associated body, then generate a - -- comment giving the name of the corresponding object file. + -- If not spec that has an associated body, then generate a comment + -- giving the name of the corresponding object file. if (not Units.Table (Elab_Order.Table (E)).SAL_Interface) and then Units.Table (Elab_Order.Table (E)).Utype /= Is_Spec @@ -1948,8 +1976,8 @@ package body Bindgen is (ALIs.Table (Units.Table (Elab_Order.Table (E)).My_ALI).Ofile_Full_Name); - -- If the presence of an object file is necessary or if it - -- exists, then use it. + -- If the presence of an object file is necessary or if it exists, + -- then use it. if not Hostparm.Exclude_Missing_Objects or else @@ -1971,8 +1999,7 @@ package body Bindgen is (ALIs.Table (Units.Table (Elab_Order.Table (E)).My_ALI).Sfile) then - -- Special case for g-trasym.obj, which is not included - -- in libgnat. + -- Special case for g-trasym.obj (not included in libgnat) Get_Name_String (ALIs.Table (Units.Table (Elab_Order.Table (E)).My_ALI).Sfile); @@ -1985,6 +2012,10 @@ package body Bindgen is end if; end loop; + if Object_List_Filename /= null then + Close_List_File; + end if; + -- Add a "-Ldir" for each directory in the object path for J in 1 .. Nb_Dir_In_Obj_Search_Path loop @@ -2002,38 +2033,36 @@ package body Bindgen is -- This sort accomplishes two important purposes: - -- a) All application files are sorted to the front, and all - -- GNAT internal files are sorted to the end. This results - -- in a well defined dividing line between the two sets of - -- files, for the purpose of inserting certain standard - -- library references into the linker arguments list. - - -- b) Given two different units, we sort the linker options so - -- that those from a unit earlier in the elaboration order - -- comes later in the list. This is a heuristic designed - -- to create a more friendly order of linker options when - -- the operations appear in separate units. The idea is that - -- if unit A must be elaborated before unit B, then it is - -- more likely that B references libraries included by A, - -- than vice versa, so we want the libraries included by - -- A to come after the libraries included by B. - - -- These two criteria are implemented by function Lt_Linker_Option. - -- Note that a special case of b) is that specs are elaborated before - -- bodies, so linker options from specs come after linker options - -- for bodies, and again, the assumption is that libraries used by - -- the body are more likely to reference libraries used by the spec, - -- than vice versa. + -- a) All application files are sorted to the front, and all GNAT + -- internal files are sorted to the end. This results in a well + -- defined dividing line between the two sets of files, for the + -- purpose of inserting certain standard library references into + -- the linker arguments list. + + -- b) Given two different units, we sort the linker options so that + -- those from a unit earlier in the elaboration order comes later + -- in the list. This is a heuristic designed to create a more + -- friendly order of linker options when the operations appear in + -- separate units. The idea is that if unit A must be elaborated + -- before unit B, then it is more likely that B references + -- libraries included by A, than vice versa, so we want libraries + -- included by A to come after libraries included by B. + + -- These two criteria are implemented by function Lt_Linker_Option. Note + -- that a special case of b) is that specs are elaborated before bodies, + -- so linker options from specs come after linker options for bodies, + -- and again, the assumption is that libraries used by the body are more + -- likely to reference libraries used by the spec, than vice versa. Sort (Linker_Options.Last, Move_Linker_Option'Access, Lt_Linker_Option'Access); - -- Write user linker options, i.e. the set of linker options that - -- come from all files other than GNAT internal files, Lgnat is - -- left set to point to the first entry from a GNAT internal file, - -- or past the end of the entriers if there are no internal files. + -- Write user linker options, i.e. the set of linker options that come + -- from all files other than GNAT internal files, Lgnat is left set to + -- point to the first entry from a GNAT internal file, or past the end + -- of the entriers if there are no internal files. Lgnat := Linker_Options.Last + 1; @@ -2137,9 +2166,9 @@ package body Bindgen is Set_PSD_Pragma_Table; - -- Override Ada_Bind_File and Bind_Main_Program for VMs since - -- JGNAT only supports Ada code, and the main program is already - -- generated by the compiler. + -- Override Ada_Bind_File and Bind_Main_Program for VMs since JGNAT only + -- supports Ada code, and the main program is already generated by the + -- compiler. if VM_Target /= No_VM then Ada_Bind_File := True; @@ -2271,8 +2300,7 @@ package body Bindgen is WBI (" gnat_envp : System.Address;"); -- If the standard library is not suppressed, these variables - -- are in the runtime data area for easy access from the - -- runtime. + -- are in the run-time data area for easy run time access. if not Suppress_Standard_Library_On_Target then WBI (""); @@ -2467,8 +2495,8 @@ package body Bindgen is if not Cumulative_Restrictions.Set (No_Finalization) then - -- In the Java case, pragma Import C cannot be used, so the - -- standard Ada constructs will be used instead. + -- In the Java case, pragma Import C cannot be used, so the standard + -- Ada constructs will be used instead. if VM_Target = No_VM then WBI (""); @@ -2623,8 +2651,8 @@ package body Bindgen is WBI ("extern void __gnat_stack_usage_initialize (int size);"); end if; - -- Initialize stack limit for the environment task if the stack - -- check method is stack limit and stack check is enabled. + -- Initialize stack limit for the environment task if the stack check + -- method is stack limit and stack check is enabled. if Stack_Check_Limits_On_Target and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set) @@ -2658,8 +2686,8 @@ package body Bindgen is if Bind_Main_Program then - -- First deal with argc/argv/envp. In the normal case they - -- are in the run-time library. + -- First deal with argc/argv/envp. In the normal case they are in the + -- run-time library. if not Configurable_Run_Time_On_Target then WBI ("extern int gnat_argc;"); @@ -2672,8 +2700,8 @@ package body Bindgen is elsif not Command_Line_Args_On_Target then null; - -- Otherwise, in the configurable run-time case they are right in - -- the binder file. + -- Otherwise, in the configurable run-time case they are right in the + -- binder file. else WBI ("int gnat_argc;"); @@ -2686,8 +2714,8 @@ package body Bindgen is if not Configurable_Run_Time_On_Target then WBI ("extern int gnat_exit_status;"); - -- If configurable run time and no exit status on target, then - -- the generation of this variables is entirely suppressed. + -- If configurable run time and no exit status on target, then the + -- generation of this variables is entirely suppressed. elsif not Exit_Status_Supported_On_Target then null; @@ -2702,9 +2730,8 @@ package body Bindgen is WBI (""); end if; - -- When suppressing the standard library, the __gnat_break_start - -- routine (for the debugger to get initial control) is defined in - -- this file. + -- When suppressing the standard library, the __gnat_break_start routine + -- (for the debugger to get initial control) is defined in this file. if Suppress_Standard_Library_On_Target then WBI (""); @@ -2728,8 +2755,8 @@ package body Bindgen is Write_Statement_Buffer; end if; - -- Generate the adafinal routine. In no runtime mode, this is - -- not needed, since there is no finalization to do. + -- Generate the adafinal routine. In no runtime mode, this is not + -- needed, since there is no finalization to do. if not Cumulative_Restrictions.Set (No_Finalization) then Gen_Adafinal_C; @@ -2969,17 +2996,14 @@ package body Bindgen is -- Gen_Versions_Ada -- ---------------------- - -- This routine generates two sets of lines. The first set has the form: + -- This routine generates lines such as: -- unnnnn : constant Integer := 16#hhhhhhhh#; - - -- The second set has the form - -- pragma Export (C, unnnnn, unam); - -- for each unit, where unam is the unit name suffixed by either B or - -- S for body or spec, with dots replaced by double underscores, and - -- hhhhhhhh is the version number, and nnnnn is a 5-digits serial number. + -- for each unit, where unam is the unit name suffixed by either B or S for + -- body or spec, with dots replaced by double underscores, and hhhhhhhh is + -- the version number, and nnnnn is a 5-digits serial number. procedure Gen_Versions_Ada is Ubuf : String (1 .. 6) := "u00000"; @@ -2999,57 +3023,44 @@ package body Bindgen is -- Start of processing for Gen_Versions_Ada begin - if Bind_For_Library then - - -- When building libraries, the version number of each unit can - -- not be computed, since the binder does not know the full list - -- of units. Therefore, the 'Version and 'Body_Version - -- attributes cannot supported in this case. - - return; - end if; - WBI (""); WBI (" type Version_32 is mod 2 ** 32;"); for U in Units.First .. Units.Last loop - Increment_Ubuf; - WBI (" " & Ubuf & " : constant Version_32 := 16#" & - Units.Table (U).Version & "#;"); - end loop; - - WBI (""); - Ubuf := "u00000"; + if not Units.Table (U).SAL_Interface and then + ((not Bind_For_Library) or else Units.Table (U).Directly_Scanned) + then + Increment_Ubuf; + WBI (" " & Ubuf & " : constant Version_32 := 16#" & + Units.Table (U).Version & "#;"); + Set_String (" pragma Export (C, "); + Set_String (Ubuf); + Set_String (", """); - for U in Units.First .. Units.Last loop - Increment_Ubuf; - Set_String (" pragma Export (C, "); - Set_String (Ubuf); - Set_String (", """); + Get_Name_String (Units.Table (U).Uname); - Get_Name_String (Units.Table (U).Uname); + for K in 1 .. Name_Len loop + if Name_Buffer (K) = '.' then + Set_Char ('_'); + Set_Char ('_'); - for K in 1 .. Name_Len loop - if Name_Buffer (K) = '.' then - Set_Char ('_'); - Set_Char ('_'); + elsif Name_Buffer (K) = '%' then + exit; - elsif Name_Buffer (K) = '%' then - exit; + else + Set_Char (Name_Buffer (K)); + end if; + end loop; + if Name_Buffer (Name_Len) = 's' then + Set_Char ('S'); else - Set_Char (Name_Buffer (K)); + Set_Char ('B'); end if; - end loop; - if Name_Buffer (Name_Len) = 's' then - Set_Char ('S'); - else - Set_Char ('B'); + Set_String (""");"); + Write_Statement_Buffer; end if; - - Set_String (""");"); - Write_Statement_Buffer; end loop; end Gen_Versions_Ada; @@ -3062,48 +3073,42 @@ package body Bindgen is -- unsigned unam = 0xhhhhhhhh; - -- for each unit, where unam is the unit name suffixed by either B or - -- S for body or spec, with dots replaced by double underscores. + -- for each unit, where unam is the unit name suffixed by either B or S for + -- body or spec, with dots replaced by double underscores. procedure Gen_Versions_C is begin - if Bind_For_Library then - - -- When building libraries, the version number of each unit can - -- not be computed, since the binder does not know the full list - -- of units. Therefore, the 'Version and 'Body_Version - -- attributes cannot supported. - - return; - end if; - for U in Units.First .. Units.Last loop - Set_String ("unsigned "); + if not Units.Table (U).SAL_Interface and then + ((not Bind_For_Library) or else Units.Table (U).Directly_Scanned) + then + Set_String ("unsigned "); - Get_Name_String (Units.Table (U).Uname); + Get_Name_String (Units.Table (U).Uname); - for K in 1 .. Name_Len loop - if Name_Buffer (K) = '.' then - Set_String ("__"); + for K in 1 .. Name_Len loop + if Name_Buffer (K) = '.' then + Set_String ("__"); - elsif Name_Buffer (K) = '%' then - exit; + elsif Name_Buffer (K) = '%' then + exit; + else + Set_Char (Name_Buffer (K)); + end if; + end loop; + + if Name_Buffer (Name_Len) = 's' then + Set_Char ('S'); else - Set_Char (Name_Buffer (K)); + Set_Char ('B'); end if; - end loop; - if Name_Buffer (Name_Len) = 's' then - Set_Char ('S'); - else - Set_Char ('B'); + Set_String (" = 0x"); + Set_String (Units.Table (U).Version); + Set_Char (';'); + Write_Statement_Buffer; end if; - - Set_String (" = 0x"); - Set_String (Units.Table (U).Version); - Set_Char (';'); - Write_Statement_Buffer; end loop; end Gen_Versions_C; @@ -3207,9 +3212,9 @@ package body Bindgen is Get_Name_String (Units.Table (First_Unit_Entry).Uname); - -- If this is a child name, return only the name of the child, - -- since we can't have dots in a nested program name. Note that - -- we do not include the %b at the end of the unit name. + -- If this is a child name, return only the name of the child, since + -- we can't have dots in a nested program name. Note that we do not + -- include the %b at the end of the unit name. for J in reverse 1 .. Name_Len - 2 loop if J = 1 or else Name_Buffer (J - 1) = '.' then @@ -3241,12 +3246,12 @@ package body Bindgen is -- no better choice. If some other encoding is required when there is -- no main, it must be set explicitly using -Wx. - -- Note: if the ALI file always passed the wide character encoding - -- of every file, then we could use the encoding of the initial - -- specified file, but this information is passed only for potential - -- main programs. We could fix this sometime, but it is a very minor - -- point (wide character default encoding for [Wide_[Wide_]Text_IO - -- when there is no main program). + -- Note: if the ALI file always passed the wide character encoding of + -- every file, then we could use the encoding of the initial specified + -- file, but this information is passed only for potential main + -- programs. We could fix this sometime, but it is a very minor point + -- (wide character default encoding for [Wide_[Wide_]Text_IO when there + -- is no main program). elsif No_Main_Subprogram then return 'b'; @@ -3277,8 +3282,8 @@ package body Bindgen is Linker_Options.Table (Op2).Internal_File; -- If both internal or both non-internal, sort according to the - -- elaboration position. A unit that is elaborated later should - -- come earlier in the linker options list. + -- elaboration position. A unit that is elaborated later should come + -- earlier in the linker options list. else return Units.Table (Linker_Options.Table (Op1).Unit).Elab_Position @@ -3307,9 +3312,9 @@ package body Bindgen is Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname); -- This is not a perfect approach, but is the current protocol - -- between the run-time and the binder to indicate that tasking - -- is used: system.os_interface should always be used by any - -- tasking application. + -- between the run-time and the binder to indicate that tasking is + -- used: system.os_interface should always be used by any tasking + -- application. if Name_Buffer (1 .. 19) = "system.os_interface" then With_GNARL := True; diff --git a/gcc/ada/bindgen.ads b/gcc/ada/bindgen.ads index 1bce36d4bb2..96d2e306888 100644 --- a/gcc/ada/bindgen.ads +++ b/gcc/ada/bindgen.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -24,7 +24,7 @@ ------------------------------------------------------------------------------ -- This package contains the routines to output the binder file. This is --- a C program which contains the following: +-- an Ada or C program which contains the following: -- initialization for main program case -- sequence of calls to elaboration routines in appropriate order diff --git a/gcc/ada/bindusg.adb b/gcc/ada/bindusg.adb index 2529c351cf1..06fa354d414 100644 --- a/gcc/ada/bindusg.adb +++ b/gcc/ada/bindusg.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -73,9 +73,9 @@ package body Bindusg is Write_Line (" -a Automatically initialize elaboration " & "procedure"); - -- Line for A switch + -- Line for -A switch - Write_Line (" -A Generate binder program in Ada (default)"); + Write_Line (" -A Give list of ALI files in partition"); -- Line for -b switch @@ -87,10 +87,6 @@ package body Bindusg is Write_Line (" -c Check only, no generation of " & "binder output file"); - -- Line for C switch - - Write_Line (" -C Generate binder program in C"); - -- Line for -d switch Write_Line (" -dnn[k|m] Default primary stack " & @@ -120,6 +116,11 @@ package body Bindusg is Write_Line (" -h Output this usage (help) information"); + -- Line for -H switch + + Write_Line (" -Hnn Use nn bit heap where nn is 32 or 64 " & + "(VMS Only)"); + -- Lines for -I switch Write_Line (" -Idir Specify library and source files search path"); @@ -185,7 +186,7 @@ package body Bindusg is -- Line for -R switch Write_Line - (" -R List sources referenced in closure (implies -c)"); + (" -R List sources referenced in closure"); -- Line for -s switch diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index ff511665b73..59270e875a9 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1084,6 +1084,11 @@ package body Checks is Cond : Node_Id; T_Typ : Entity_Id; + function Denotes_Explicit_Dereference (Obj : Node_Id) return Boolean; + -- A heap object with an indefinite subtype is constrained by its + -- initial value, and assigning to it requires a constraint_check. + -- The target may be an explicit dereference, or a renaming of one. + function Is_Aliased_Unconstrained_Component return Boolean; -- It is possible for an aliased component to have a nominal -- unconstrained subtype (through instantiation). If this is a @@ -1091,6 +1096,21 @@ package body Checks is -- in an initialization, the check must be suppressed. This unusual -- situation requires a predicate of its own. + ---------------------------------- + -- Denotes_Explicit_Dereference -- + ---------------------------------- + + function Denotes_Explicit_Dereference (Obj : Node_Id) return Boolean is + begin + return + Nkind (Obj) = N_Explicit_Dereference + or else + (Is_Entity_Name (Obj) + and then Present (Renamed_Object (Entity (Obj))) + and then Nkind (Renamed_Object (Entity (Obj))) = + N_Explicit_Dereference); + end Denotes_Explicit_Dereference; + ---------------------------------------- -- Is_Aliased_Unconstrained_Component -- ---------------------------------------- @@ -1164,7 +1184,7 @@ package body Checks is -- Ada 2005 (AI-363): For Ada 2005, we limit the building of the actual -- subtype to the parameter and dereference cases, since other aliased -- objects are unconstrained (unless the nominal subtype is explicitly - -- constrained). (But we also need to test for renamings???) + -- constrained). if Present (Lhs) and then (Present (Param_Entity (Lhs)) @@ -1174,7 +1194,7 @@ package body Checks is and then not Is_Aliased_Unconstrained_Component) or else (Ada_Version >= Ada_05 and then not Is_Constrained (T_Typ) - and then Nkind (Lhs) = N_Explicit_Dereference + and then Denotes_Explicit_Dereference (Lhs) and then Nkind (Original_Node (Lhs)) /= N_Function_Call)) then @@ -1564,9 +1584,7 @@ package body Checks is pragma Assert (Target_Base /= Target_Typ); - Temp : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); + Temp : constant Entity_Id := Make_Temporary (Loc, 'T', Par); begin Apply_Float_Conversion_Check (Ck_Node, Target_Base); @@ -2723,9 +2741,11 @@ package body Checks is end case; if K = N_Op_And then - Error_Msg_N ("use `AND THEN` instead of AND?", P); + Error_Msg_N -- CODEFIX + ("use `AND THEN` instead of AND?", P); else - Error_Msg_N ("use `OR ELSE` instead of OR?", P); + Error_Msg_N -- CODEFIX + ("use `OR ELSE` instead of OR?", P); end if; -- If not short-circuited, we need the ckeck @@ -3331,6 +3351,14 @@ package body Checks is Indx := Next_Index (Indx); end loop; + -- If the index type is a formal type or derived from + -- one, the bounds are not static. + + if Is_Generic_Type (Root_Type (Etype (Indx))) then + OK := False; + return; + end if; + Determine_Range (Type_Low_Bound (Etype (Indx)), OK1, LL, LU, Assume_Valid); @@ -3350,8 +3378,8 @@ package body Checks is -- For constrained arrays, the minimum value for -- Length is taken from the actual value of the - -- bounds, since the index will be exactly of - -- this subtype. + -- bounds, since the index will be exactly of this + -- subtype. if Is_Constrained (Atyp) then Lor := UI_Max (Uint_0, UL - LU + 1); @@ -3367,7 +3395,7 @@ package body Checks is end; -- No special handling for other attributes - -- Probably more opportunities exist here ??? + -- Probably more opportunities exist here??? when others => OK1 := False; @@ -3388,33 +3416,31 @@ package body Checks is Hir := No_Uint; end case; - -- At this stage, if OK1 is true, then we know that the actual - -- result of the computed expression is in the range Lor .. Hir. - -- We can use this to restrict the possible range of results. + -- At this stage, if OK1 is true, then we know that the actual result of + -- the computed expression is in the range Lor .. Hir. We can use this + -- to restrict the possible range of results. if OK1 then - -- If the refined value of the low bound is greater than the - -- type high bound, then reset it to the more restrictive - -- value. However, we do NOT do this for the case of a modular - -- type where the possible upper bound on the value is above the - -- base type high bound, because that means the result could wrap. + -- If the refined value of the low bound is greater than the type + -- high bound, then reset it to the more restrictive value. However, + -- we do NOT do this for the case of a modular type where the + -- possible upper bound on the value is above the base type high + -- bound, because that means the result could wrap. if Lor > Lo - and then not (Is_Modular_Integer_Type (Typ) - and then Hir > Hbound) + and then not (Is_Modular_Integer_Type (Typ) and then Hir > Hbound) then Lo := Lor; end if; - -- Similarly, if the refined value of the high bound is less - -- than the value so far, then reset it to the more restrictive - -- value. Again, we do not do this if the refined low bound is - -- negative for a modular type, since this would wrap. + -- Similarly, if the refined value of the high bound is less than the + -- value so far, then reset it to the more restrictive value. Again, + -- we do not do this if the refined low bound is negative for a + -- modular type, since this would wrap. if Hir < Hi - and then not (Is_Modular_Integer_Type (Typ) - and then Lor < Uint_0) + and then not (Is_Modular_Integer_Type (Typ) and then Lor < Uint_0) then Hi := Hir; end if; @@ -3428,8 +3454,8 @@ package body Checks is Determine_Range_Cache_Hi (Cindex) := Hi; return; - -- If any exception occurs, it means that we have some bug in the compiler - -- possibly triggered by a previous error, or by some unforseen peculiar + -- If any exception occurs, it means that we have some bug in the compiler, + -- possibly triggered by a previous error, or by some unforeseen peculiar -- occurrence. However, this is only an optimization attempt, so there is -- really no point in crashing the compiler. Instead we just decide, too -- bad, we can't figure out a range in this case after all. @@ -4687,9 +4713,7 @@ package body Checks is -- Then the conversion itself is replaced by an occurrence of Tnn declare - Tnn : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); + Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N); begin Insert_Actions (N, New_List ( @@ -4840,9 +4864,7 @@ package body Checks is -- the value is non-negative declare - Tnn : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); + Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N); begin Insert_Actions (N, New_List ( @@ -5279,6 +5301,16 @@ package body Checks is return False; end if; + -- If we are in a case eexpression, and not part of the + -- expression, then we return False, since a particular + -- branch may not always be elaborated + + if Nkind (P) = N_Case_Expression + and then N /= Expression (P) + then + return False; + end if; + -- While traversing the parent chain, we find that N -- belongs to a statement, thus it may never appear in -- a declarative region. @@ -6223,11 +6255,18 @@ package body Checks is -- Expr > Typ'Last function Get_E_First_Or_Last - (E : Entity_Id; + (Loc : Source_Ptr; + E : Entity_Id; Indx : Nat; Nam : Name_Id) return Node_Id; - -- Returns expression to compute: + -- Returns an attribute reference -- E'First or E'Last + -- with a source location of Loc. + -- + -- Nam is Name_First or Name_Last, according to which attribute is + -- desired. If Indx is non-zero, it is passed as a literal in the + -- Expressions of the attribute reference (identifying the desired + -- array dimension). function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id; function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id; @@ -6294,7 +6333,7 @@ package body Checks is Duplicate_Subexpr_No_Checks (Expr)), Right_Opnd => Convert_To (Base_Type (Typ), - Get_E_First_Or_Last (Typ, 0, Name_First))), + Get_E_First_Or_Last (Loc, Typ, 0, Name_First))), Right_Opnd => Make_Op_Gt (Loc, @@ -6304,7 +6343,7 @@ package body Checks is Right_Opnd => Convert_To (Base_Type (Typ), - Get_E_First_Or_Last (Typ, 0, Name_Last)))); + Get_E_First_Or_Last (Loc, Typ, 0, Name_Last)))); end Discrete_Expr_Cond; ------------------------- @@ -6342,7 +6381,8 @@ package body Checks is Right_Opnd => Convert_To - (Base_Type (Typ), Get_E_First_Or_Last (Typ, 0, Name_First))); + (Base_Type (Typ), + Get_E_First_Or_Last (Loc, Typ, 0, Name_First))); if Base_Type (Typ) = Typ then return Left_Opnd; @@ -6377,7 +6417,7 @@ package body Checks is Right_Opnd => Convert_To (Base_Type (Typ), - Get_E_First_Or_Last (Typ, 0, Name_Last))); + Get_E_First_Or_Last (Loc, Typ, 0, Name_Last))); return Make_Or_Else (Loc, Left_Opnd, Right_Opnd); end Discrete_Range_Cond; @@ -6387,115 +6427,23 @@ package body Checks is ------------------------- function Get_E_First_Or_Last - (E : Entity_Id; + (Loc : Source_Ptr; + E : Entity_Id; Indx : Nat; Nam : Name_Id) return Node_Id is - N : Node_Id; - LB : Node_Id; - HB : Node_Id; - Bound : Node_Id; - + Exprs : List_Id; begin - if Is_Array_Type (E) then - N := First_Index (E); - - for J in 2 .. Indx loop - Next_Index (N); - end loop; - - else - N := Scalar_Range (E); - end if; - - if Nkind (N) = N_Subtype_Indication then - LB := Low_Bound (Range_Expression (Constraint (N))); - HB := High_Bound (Range_Expression (Constraint (N))); - - elsif Is_Entity_Name (N) then - LB := Type_Low_Bound (Etype (N)); - HB := Type_High_Bound (Etype (N)); - - else - LB := Low_Bound (N); - HB := High_Bound (N); - end if; - - if Nam = Name_First then - Bound := LB; + if Indx > 0 then + Exprs := New_List (Make_Integer_Literal (Loc, UI_From_Int (Indx))); else - Bound := HB; + Exprs := No_List; end if; - if Nkind (Bound) = N_Identifier - and then Ekind (Entity (Bound)) = E_Discriminant - then - -- If this is a task discriminant, and we are the body, we must - -- retrieve the corresponding body discriminal. This is another - -- consequence of the early creation of discriminals, and the - -- need to generate constraint checks before their declarations - -- are made visible. - - if Is_Concurrent_Record_Type (Scope (Entity (Bound))) then - declare - Tsk : constant Entity_Id := - Corresponding_Concurrent_Type - (Scope (Entity (Bound))); - Disc : Entity_Id; - - begin - if In_Open_Scopes (Tsk) - and then Has_Completion (Tsk) - then - -- Find discriminant of original task, and use its - -- current discriminal, which is the renaming within - -- the task body. - - Disc := First_Discriminant (Tsk); - while Present (Disc) loop - if Chars (Disc) = Chars (Entity (Bound)) then - Set_Scope (Discriminal (Disc), Tsk); - return New_Occurrence_Of (Discriminal (Disc), Loc); - end if; - - Next_Discriminant (Disc); - end loop; - - -- That loop should always succeed in finding a matching - -- entry and returning. Fatal error if not. - - raise Program_Error; - - else - return - New_Occurrence_Of (Discriminal (Entity (Bound)), Loc); - end if; - end; - else - return New_Occurrence_Of (Discriminal (Entity (Bound)), Loc); - end if; - - elsif Nkind (Bound) = N_Identifier - and then Ekind (Entity (Bound)) = E_In_Parameter - and then not Inside_Init_Proc - then - return Get_Discriminal (E, Bound); - - elsif Nkind (Bound) = N_Integer_Literal then - return Make_Integer_Literal (Loc, Intval (Bound)); - - -- Case of a bound rewritten to an N_Raise_Constraint_Error node - -- because it is an out-of-range value. Duplicate_Subexpr cannot be - -- called on this node because an N_Raise_Constraint_Error is not - -- side effect free, and we may not assume that we are in the proper - -- context to remove side effects on it at the point of reference. - - elsif Nkind (Bound) = N_Raise_Constraint_Error then - return New_Copy_Tree (Bound); - - else - return Duplicate_Subexpr_No_Checks (Bound); - end if; + return Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (E, Loc), + Attribute_Name => Nam, + Expressions => Exprs); end Get_E_First_Or_Last; ----------------- @@ -6542,13 +6490,17 @@ package body Checks is Make_Or_Else (Loc, Left_Opnd => Make_Op_Lt (Loc, - Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_First), - Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)), + Left_Opnd => + Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_First), + Right_Opnd => + Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)), Right_Opnd => Make_Op_Gt (Loc, - Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_Last), - Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last))); + Left_Opnd => + Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_Last), + Right_Opnd => + Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last))); end Range_E_Cond; ------------------------ @@ -6565,12 +6517,17 @@ package body Checks is Make_Or_Else (Loc, Left_Opnd => Make_Op_Ne (Loc, - Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_First), - Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)), + Left_Opnd => + Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_First), + Right_Opnd => + Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)), + Right_Opnd => Make_Op_Ne (Loc, - Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_Last), - Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last))); + Left_Opnd => + Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_Last), + Right_Opnd => + Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last))); end Range_Equal_E_Cond; ------------------ @@ -6587,13 +6544,17 @@ package body Checks is Make_Or_Else (Loc, Left_Opnd => Make_Op_Lt (Loc, - Left_Opnd => Get_N_First (Expr, Indx), - Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)), + Left_Opnd => + Get_N_First (Expr, Indx), + Right_Opnd => + Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)), Right_Opnd => Make_Op_Gt (Loc, - Left_Opnd => Get_N_Last (Expr, Indx), - Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last))); + Left_Opnd => + Get_N_Last (Expr, Indx), + Right_Opnd => + Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last))); end Range_N_Cond; -- Start of processing for Selected_Range_Checks diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb index 978a5e7006f..54497274f2d 100644 --- a/gcc/ada/clean.adb +++ b/gcc/ada/clean.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2003-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1677,6 +1677,9 @@ package body Clean is new String' (Arg (Subdirs_Option'Length + 1 .. Arg'Last)); + elsif Arg = Makeutl.Unchecked_Shared_Lib_Imports then + Opt.Unchecked_Shared_Lib_Imports := True; + else Bad_Argument; end if; @@ -1957,6 +1960,8 @@ package body Clean is New_Line; Put_Line (" --subdirs=dir real obj/lib/exec dirs are subdirs"); + Put_Line (" " & Makeutl.Unchecked_Shared_Lib_Imports); + Put_Line (" Allow shared libraries to import static libraries"); New_Line; Put_Line (" -c Only delete compiler generated files"); diff --git a/gcc/ada/csets.adb b/gcc/ada/csets.adb index cd3e0b55a3f..771affc3be0 100644 --- a/gcc/ada/csets.adb +++ b/gcc/ada/csets.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -618,9 +618,9 @@ package body Csets is -- Definitions for IBM PC (Code Page 437) -- -------------------------------------------- - -- Note: Code page 437 is the typical default in DOS, Windows and OS/2 - -- for PC's in the US, it corresponds to the original PC character set. - -- See also the definitions for code page 850. + -- Note: Code page 437 is the typical default in Windows for PC's in the + -- US, it corresponds to the original PC character set. See also the + -- definitions for code page 850. Fold_IBM_PC_437 : constant Translate_Table := Translate_Table'( @@ -752,10 +752,10 @@ package body Csets is -- Definitions for IBM PC (Code Page 850) -- -------------------------------------------- - -- Note: Code page 850 is the typical default in DOS, Windows and OS/2 - -- for PC's in Europe, it is an extension of the original PC character - -- set to include the additional characters defined in ISO Latin-1. - -- See also the definitions for code page 437. + -- Note: Code page 850 is the typical default in Windows for PC's in + -- Europe, it is an extension of the original PC character set to include + -- the additional characters defined in ISO Latin-1. See also the + -- definitions for code page 437. Fold_IBM_PC_850 : constant Translate_Table := Translate_Table'( diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb index d6f0ff09cea..9f9332b7241 100644 --- a/gcc/ada/cstand.adb +++ b/gcc/ada/cstand.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -287,11 +287,10 @@ package body CStand is Set_Etype (Last_Entity (Standard_Op_Concatw), Standard_Wide_String); Set_Etype (First_Entity (Standard_Op_Concatww), - Standard_Wide_Wide_String); + Standard_Wide_Wide_String); Set_Etype (Last_Entity (Standard_Op_Concatww), - Standard_Wide_Wide_String); - + Standard_Wide_Wide_String); end Create_Operators; --------------------- @@ -324,6 +323,10 @@ package body CStand is procedure Build_Exception (S : Standard_Entity_Type); -- Procedure to declare given entity as an exception + procedure Pack_String_Type (String_Type : Entity_Id); + -- Generate proper tree for pragma Pack that applies to given type, and + -- mark type as having the pragma. + --------------------- -- Build_Exception -- --------------------- @@ -341,6 +344,25 @@ package body CStand is Append (Decl, Decl_S); end Build_Exception; + ---------------------- + -- Pack_String_Type -- + ---------------------- + + procedure Pack_String_Type (String_Type : Entity_Id) is + Prag : constant Node_Id := + Make_Pragma (Stloc, + Chars => Name_Pack, + Pragma_Argument_Associations => + New_List ( + Make_Pragma_Argument_Association (Stloc, + Expression => + New_Occurrence_Of (String_Type, Stloc)))); + begin + Append (Prag, Decl_S); + Record_Rep_Item (String_Type, Prag); + Set_Has_Pragma_Pack (String_Type, True); + end Pack_String_Type; + -- Start of processing for Create_Standard begin @@ -688,12 +710,13 @@ package body CStand is Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node)); Set_Type_Definition (Parent (Standard_String), Tdef_Node); - Set_Ekind (Standard_String, E_String_Type); - Set_Etype (Standard_String, Standard_String); - Set_Component_Type (Standard_String, Standard_Character); - Set_Component_Size (Standard_String, Uint_8); - Init_Size_Align (Standard_String); - Set_Alignment (Standard_String, Uint_1); + Set_Ekind (Standard_String, E_String_Type); + Set_Etype (Standard_String, Standard_String); + Set_Component_Type (Standard_String, Standard_Character); + Set_Component_Size (Standard_String, Uint_8); + Init_Size_Align (Standard_String); + Set_Alignment (Standard_String, Uint_1); + Pack_String_Type (Standard_String); -- On targets where a storage unit is larger than a byte (such as AAMP), -- pragma Pack has a real effect on the representation of type String, @@ -731,11 +754,12 @@ package body CStand is Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node)); Set_Type_Definition (Parent (Standard_Wide_String), Tdef_Node); - Set_Ekind (Standard_Wide_String, E_String_Type); - Set_Etype (Standard_Wide_String, Standard_Wide_String); - Set_Component_Type (Standard_Wide_String, Standard_Wide_Character); - Set_Component_Size (Standard_Wide_String, Uint_16); - Init_Size_Align (Standard_Wide_String); + Set_Ekind (Standard_Wide_String, E_String_Type); + Set_Etype (Standard_Wide_String, Standard_Wide_String); + Set_Component_Type (Standard_Wide_String, Standard_Wide_Character); + Set_Component_Size (Standard_Wide_String, Uint_16); + Init_Size_Align (Standard_Wide_String); + Pack_String_Type (Standard_Wide_String); -- Set index type of Wide_String @@ -772,6 +796,7 @@ package body CStand is Set_Component_Size (Standard_Wide_Wide_String, Uint_32); Init_Size_Align (Standard_Wide_Wide_String); Set_Is_Ada_2005_Only (Standard_Wide_Wide_String); + Pack_String_Type (Standard_Wide_Wide_String); -- Set index type of Wide_Wide_String diff --git a/gcc/ada/cstreams.c b/gcc/ada/cstreams.c index d57b382a7fb..9dea9a4f13e 100644 --- a/gcc/ada/cstreams.c +++ b/gcc/ada/cstreams.c @@ -6,7 +6,7 @@ * * * Auxiliary C functions for Interfaces.C.Streams * * * - * Copyright (C) 1992-2009, Free Software Foundation, Inc. * + * Copyright (C) 1992-2010, Free Software Foundation, Inc. * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * @@ -98,15 +98,6 @@ __gnat_is_regular_file_fd (int fd) int ret; GNAT_STRUCT_STAT statbuf; -#ifdef __EMX__ - /* Programs using screen I/O may need to reset the FPU after - initialization of screen-handling related DLL's, so force - DLL initialization by doing a null-write and then reset the FPU */ - - DosWrite (0, &ret, 0, &ret); - __gnat_init_float(); -#endif - ret = GNAT_FSTAT (fd, &statbuf); return (!ret && S_ISREG (statbuf.st_mode)); } @@ -166,9 +157,9 @@ __gnat_full_name (char *nam, char *buffer) else buffer[0] = '\0'; -#elif defined(__EMX__) || defined (__MINGW32__) - /* If this is a device file return it as is; under Windows NT and - OS/2 a device file end with ":". */ +#elif defined (__MINGW32__) + /* If this is a device file return it as is; + under Windows NT a device file ends with ":". */ if (nam[strlen (nam) - 1] == ':') strcpy (buffer, nam); else @@ -182,9 +173,6 @@ __gnat_full_name (char *nam, char *buffer) *p = '\\'; } -#elif defined (MSDOS) - _fixpath (nam, buffer); - #elif defined (sgi) || defined (__FreeBSD__) /* Use realpath function which resolves links and references to . and .. diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index ca207b2e4d8..b7f750d506f 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -76,7 +76,7 @@ package body Debug is -- dJ Output debugging trace info for JGNAT (Java VM version of GNAT) -- dK Kill all error messages -- dL Output trace information on elaboration checking - -- dM Asssume all variables are modified (no current values) + -- dM Assume all variables are modified (no current values) -- dN No file name information in exception messages -- dO Output immediate error messages -- dP Do not check for controlled objects in preelaborable packages @@ -113,7 +113,7 @@ package body Debug is -- d.t Disable static allocation of library level dispatch tables -- d.u -- d.v Enable OK_To_Reorder_Components in variant records - -- d.w Do not check for infinite while loops + -- d.w Do not check for infinite loops -- d.x No exception handlers -- d.y -- d.z @@ -129,7 +129,7 @@ package body Debug is -- d.I SCIL generation mode -- d.J Parallel SCIL generation mode -- d.K - -- d.L + -- d.L Depend on back end for limited types in conditional expressions -- d.M -- d.N -- d.O Dump internal SCO tables @@ -141,9 +141,9 @@ package body Debug is -- d.U -- d.V -- d.W Print out debugging information for Walk_Library_Items - -- d.X - -- d.Y - -- d.Z + -- d.X Use Expression_With_Actions + -- d.Y Do not use Expression_With_Actions + -- d.Z Generate call-graph information -- d1 Error msgs have node numbers where possible -- d2 Eliminate error flags in verbose form error messages @@ -548,7 +548,7 @@ package body Debug is -- d.v Forces the flag OK_To_Reorder_Components to be set in all record -- base types that have at least one discriminant (v = variant). - -- d.w This flag turns off the scanning of while loops to detect possible + -- d.w This flag turns off the scanning of loops to detect possible -- infinite loops. -- d.x No exception handlers in generated code. This causes exception @@ -567,6 +567,11 @@ package body Debug is -- This means in particular not writing the same files under the -- same directory. + -- d.L Normally the front end generates special expansion for conditional + -- expressions of a limited type. This debug flag removes this special + -- case expansion, leaving it up to the back end to handle conditional + -- expressions correctly. + -- d.O Dump internal SCO tables. Before outputting the SCO information to -- the ALI file, the internal SCO tables (SCO_Table/SCO_Unit_Table) -- are dumped for debugging purposes. @@ -579,6 +584,24 @@ package body Debug is -- the order in which units are walked. This is primarily for SofCheck -- Inspector. + -- d.X By default, the compiler uses an elaborate rewriting framework for + -- short-circuited forms where the right hand condition generates + -- actions to be inserted. With the gcc backend, we now use the new + -- N_Expression_With_Actions node for this expansion, but we still use + -- the old method for other backends and in SCIL mode. This debug flag + -- forces use of the new N_Expression_With_Actions node in these other + -- cases and is intended for transitional use. + + -- d.Y Prevents the use of the N_Expression_With_Actions node even in the + -- case of the gcc back end. Provided as a back up in case the new + -- scheme has problems. + + -- d.Z This flag enables the frontend call-graph output associated with + -- dispatching calls. This is a temporary debug flag to be used during + -- development of this output. Once it works, it will always be output + -- (as part of the standard call-graph output) by default, and this + -- flag will be removed. + -- d1 Error messages have node numbers where possible. Normally error -- messages have only source locations. This option is useful when -- debugging errors caused by expanded code, where the source location diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index fdc9d276c6a..f1145a1ac07 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -79,6 +79,7 @@ package body Einfo is -- Normalized_First_Bit Uint8 -- Postcondition_Proc Node8 -- Return_Applies_To Node8 + -- First_Exit_Statement Node8 -- Class_Wide_Type Node9 -- Current_Value Node9 @@ -207,7 +208,6 @@ package body Einfo is -- Related_Expression Node24 -- Spec_PPC_List Node24 - -- Underlying_Record_View Node24 -- Interface_Alias Node25 -- Interfaces Elist25 @@ -227,6 +227,7 @@ package body Einfo is -- Wrapped_Entity Node27 -- Extra_Formals Node28 + -- Underlying_Record_View Node28 --------------------------------------------- -- Usage of Flags in Defining Entity Nodes -- @@ -454,9 +455,6 @@ package body Einfo is -- Is_Primitive_Wrapper Flag195 -- Was_Hidden Flag196 -- Is_Limited_Interface Flag197 - -- Is_Protected_Interface Flag198 - -- Is_Synchronized_Interface Flag199 - -- Is_Task_Interface Flag200 -- Has_Anon_Block_Suffix Flag201 -- Itype_Printed Flag202 @@ -510,6 +508,10 @@ package body Einfo is -- Is_Underlying_Record_View Flag246 -- OK_To_Rename Flag247 + -- (unused) Flag198 + -- (unused) Flag199 + -- (unused) Flag200 + ----------------------- -- Local subprograms -- ----------------------- @@ -558,9 +560,7 @@ package body Einfo is function Actual_Subtype (Id : E) return E is begin pragma Assert - (Ekind (Id) = E_Constant - or else Ekind (Id) = E_Variable - or else Ekind (Id) = E_Generic_In_Out_Parameter + (Ekind_In (Id, E_Constant, E_Variable, E_Generic_In_Out_Parameter) or else Is_Formal (Id)); return Node17 (Id); end Actual_Subtype; @@ -570,6 +570,18 @@ package body Einfo is return Flag104 (Id); end Address_Taken; + function Aft_Value (Id : E) return U is + Result : Nat := 1; + Delta_Val : Ureal := Delta_Value (Id); + begin + while Delta_Val < Ureal_Tenth loop + Delta_Val := Delta_Val * Ureal_10; + Result := Result + 1; + end loop; + + return UI_From_Int (Result); + end Aft_Value; + function Alias (Id : E) return E is begin pragma Assert @@ -581,10 +593,10 @@ package body Einfo is begin pragma Assert (Is_Type (Id) or else Is_Formal (Id) - or else Ekind (Id) = E_Loop_Parameter - or else Ekind (Id) = E_Constant - or else Ekind (Id) = E_Exception - or else Ekind (Id) = E_Variable); + or else Ekind_In (Id, E_Loop_Parameter, + E_Constant, + E_Exception, + E_Variable)); return Uint14 (Id); end Alignment; @@ -625,8 +637,7 @@ package body Einfo is function Body_Entity (Id : E) return E is begin - pragma Assert - (Ekind (Id) = E_Package or else Ekind (Id) = E_Generic_Package); + pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package)); return Node19 (Id); end Body_Entity; @@ -663,24 +674,19 @@ package body Einfo is function Cloned_Subtype (Id : E) return E is begin - pragma Assert - (Ekind (Id) = E_Record_Subtype - or else - Ekind (Id) = E_Class_Wide_Subtype); + pragma Assert (Ekind_In (Id, E_Record_Subtype, E_Class_Wide_Subtype)); return Node16 (Id); end Cloned_Subtype; function Component_Bit_Offset (Id : E) return U is begin - pragma Assert - (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant); + pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); return Uint11 (Id); end Component_Bit_Offset; function Component_Clause (Id : E) return N is begin - pragma Assert - (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant); + pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); return Node13 (Id); end Component_Clause; @@ -874,17 +880,14 @@ package body Einfo is function DT_Position (Id : E) return U is begin - pragma Assert - ((Ekind (Id) = E_Function - or else Ekind (Id) = E_Procedure) - and then Present (DTC_Entity (Id))); + pragma Assert (Ekind_In (Id, E_Function, E_Procedure) + and then Present (DTC_Entity (Id))); return Uint15 (Id); end DT_Position; function DTC_Entity (Id : E) return E is begin - pragma Assert - (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure); + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); return Node16 (Id); end DTC_Entity; @@ -985,11 +988,12 @@ package body Einfo is function Equivalent_Type (Id : E) return E is begin pragma Assert - (Ekind (Id) = E_Class_Wide_Subtype or else - Ekind (Id) = E_Access_Protected_Subprogram_Type or else - Ekind (Id) = E_Anonymous_Access_Protected_Subprogram_Type or else - Ekind (Id) = E_Access_Subprogram_Type or else - Ekind (Id) = E_Exception_Type); + (Ekind_In (Id, E_Class_Wide_Type, + E_Class_Wide_Subtype, + E_Access_Protected_Subprogram_Type, + E_Anonymous_Access_Protected_Subprogram_Type, + E_Access_Subprogram_Type, + E_Exception_Type)); return Node18 (Id); end Equivalent_Type; @@ -1025,9 +1029,9 @@ package body Einfo is begin pragma Assert (Is_Overloadable (Id) - or else Ekind (Id) = E_Entry_Family - or else Ekind (Id) = E_Subprogram_Body - or else Ekind (Id) = E_Subprogram_Type); + or else Ekind_In (Id, E_Entry_Family, + E_Subprogram_Body, + E_Subprogram_Type)); return Node28 (Id); end Extra_Formals; @@ -1053,6 +1057,12 @@ package body Einfo is return Node17 (Id); end First_Entity; + function First_Exit_Statement (Id : E) return N is + begin + pragma Assert (Ekind (Id) = E_Loop); + return Node8 (Id); + end First_Exit_Statement; + function First_Index (Id : E) return N is begin pragma Assert (Is_Array_Type (Id) or else Is_String_Type (Id)); @@ -1067,15 +1077,13 @@ package body Einfo is function First_Optional_Parameter (Id : E) return E is begin - pragma Assert - (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure); + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); return Node14 (Id); end First_Optional_Parameter; function First_Private_Entity (Id : E) return E is begin - pragma Assert (Ekind (Id) = E_Package - or else Ekind (Id) = E_Generic_Package + pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package) or else Ekind (Id) in Concurrent_Kind); return Node16 (Id); end First_Private_Entity; @@ -1271,8 +1279,7 @@ package body Einfo is function Has_Missing_Return (Id : E) return B is begin - pragma Assert - (Ekind (Id) = E_Function or else Ekind (Id) = E_Generic_Function); + pragma Assert (Ekind_In (Id, E_Function, E_Generic_Function)); return Flag142 (Id); end Has_Missing_Return; @@ -1492,9 +1499,7 @@ package body Einfo is function Has_Up_Level_Access (Id : E) return B is begin pragma Assert - (Ekind (Id) = E_Variable - or else Ekind (Id) = E_Constant - or else Ekind (Id) = E_Loop_Parameter); + (Ekind_In (Id, E_Variable, E_Constant, E_Loop_Parameter)); return Flag215 (Id); end Has_Up_Level_Access; @@ -1521,9 +1526,7 @@ package body Einfo is function Implemented_By_Entry (Id : E) return B is begin - pragma Assert - (Ekind (Id) = E_Function - or else Ekind (Id) = E_Procedure); + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); return Flag232 (Id); end Implemented_By_Entry; @@ -1608,8 +1611,7 @@ package body Einfo is function Is_Asynchronous (Id : E) return B is begin - pragma Assert - (Ekind (Id) = E_Procedure or else Is_Type (Id)); + pragma Assert (Ekind (Id) = E_Procedure or else Is_Type (Id)); return Flag81 (Id); end Is_Asynchronous; @@ -1625,8 +1627,7 @@ package body Einfo is function Is_Called (Id : E) return B is begin - pragma Assert - (Ekind (Id) = E_Procedure or else Ekind (Id) = E_Function); + pragma Assert (Ekind_In (Id, E_Procedure, E_Function)); return Flag102 (Id); end Is_Called; @@ -1737,10 +1738,7 @@ package body Einfo is function Is_For_Access_Subtype (Id : E) return B is begin - pragma Assert - (Ekind (Id) = E_Record_Subtype - or else - Ekind (Id) = E_Private_Subtype); + pragma Assert (Ekind_In (Id, E_Record_Subtype, E_Private_Subtype)); return Flag118 (Id); end Is_For_Access_Subtype; @@ -1930,15 +1928,13 @@ package body Einfo is begin pragma Assert (Is_Overloadable (Id) - or else Ekind (Id) = E_Generic_Function - or else Ekind (Id) = E_Generic_Procedure); + or else Ekind_In (Id, E_Generic_Function, E_Generic_Procedure)); return Flag218 (Id); end Is_Primitive; function Is_Primitive_Wrapper (Id : E) return B is begin - pragma Assert (Ekind (Id) = E_Function - or else Ekind (Id) = E_Procedure); + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); return Flag195 (Id); end Is_Primitive_Wrapper; @@ -1955,17 +1951,10 @@ package body Einfo is function Is_Private_Primitive (Id : E) return B is begin - pragma Assert (Ekind (Id) = E_Function - or else Ekind (Id) = E_Procedure); + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); return Flag245 (Id); end Is_Private_Primitive; - function Is_Protected_Interface (Id : E) return B is - begin - pragma Assert (Is_Interface (Id)); - return Flag198 (Id); - end Is_Protected_Interface; - function Is_Public (Id : E) return B is begin pragma Assert (Nkind (Id) in N_Entity); @@ -2025,12 +2014,6 @@ package body Einfo is return Flag28 (Id); end Is_Statically_Allocated; - function Is_Synchronized_Interface (Id : E) return B is - begin - pragma Assert (Is_Interface (Id)); - return Flag199 (Id); - end Is_Synchronized_Interface; - function Is_Tag (Id : E) return B is begin pragma Assert (Nkind (Id) in N_Entity); @@ -2042,12 +2025,6 @@ package body Einfo is return Flag55 (Id); end Is_Tagged_Type; - function Is_Task_Interface (Id : E) return B is - begin - pragma Assert (Is_Interface (Id)); - return Flag200 (Id); - end Is_Task_Interface; - function Is_Thunk (Id : E) return B is begin pragma Assert (Is_Subprogram (Id)); @@ -2224,8 +2201,7 @@ package body Einfo is begin pragma Assert (Is_Overloadable (Id) - or else Ekind (Id) = E_Subprogram_Type - or else Ekind (Id) = E_Entry_Family); + or else Ekind_In (Id, E_Subprogram_Type, E_Entry_Family)); return Flag22 (Id); end Needs_No_Actuals; @@ -2276,22 +2252,19 @@ package body Einfo is function Normalized_First_Bit (Id : E) return U is begin - pragma Assert - (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant); + pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); return Uint8 (Id); end Normalized_First_Bit; function Normalized_Position (Id : E) return U is begin - pragma Assert - (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant); + pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); return Uint14 (Id); end Normalized_Position; function Normalized_Position_Max (Id : E) return U is begin - pragma Assert - (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant); + pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); return Uint10 (Id); end Normalized_Position_Max; @@ -2310,18 +2283,14 @@ package body Einfo is function Optimize_Alignment_Space (Id : E) return B is begin pragma Assert - (Is_Type (Id) - or else Ekind (Id) = E_Constant - or else Ekind (Id) = E_Variable); + (Is_Type (Id) or else Ekind_In (Id, E_Constant, E_Variable)); return Flag241 (Id); end Optimize_Alignment_Space; function Optimize_Alignment_Time (Id : E) return B is begin pragma Assert - (Is_Type (Id) - or else Ekind (Id) = E_Constant - or else Ekind (Id) = E_Variable); + (Is_Type (Id) or else Ekind_In (Id, E_Constant, E_Variable)); return Flag242 (Id); end Optimize_Alignment_Time; @@ -2333,10 +2302,7 @@ package body Einfo is function Original_Record_Component (Id : E) return E is begin - pragma Assert - (Ekind (Id) = E_Void - or else Ekind (Id) = E_Component - or else Ekind (Id) = E_Discriminant); + pragma Assert (Ekind_In (Id, E_Void, E_Component, E_Discriminant)); return Node22 (Id); end Original_Record_Component; @@ -2352,10 +2318,7 @@ package body Einfo is function Package_Instantiation (Id : E) return N is begin - pragma Assert - (False - or else Ekind (Id) = E_Generic_Package - or else Ekind (Id) = E_Package); + pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package)); return Node26 (Id); end Package_Instantiation; @@ -2391,8 +2354,7 @@ package body Einfo is function Prival_Link (Id : E) return E is begin - pragma Assert (Ekind (Id) = E_Constant - or else Ekind (Id) = E_Variable); + pragma Assert (Ekind_In (Id, E_Constant, E_Variable)); return Node20 (Id); end Prival_Link; @@ -2422,10 +2384,8 @@ package body Einfo is function Protection_Object (Id : E) return E is begin - pragma Assert (Ekind (Id) = E_Entry - or else Ekind (Id) = E_Entry_Family - or else Ekind (Id) = E_Function - or else Ekind (Id) = E_Procedure); + pragma Assert + (Ekind_In (Id, E_Entry, E_Entry_Family, E_Function, E_Procedure)); return Node23 (Id); end Protection_Object; @@ -2469,21 +2429,20 @@ package body Einfo is function Related_Expression (Id : E) return N is begin - pragma Assert (Ekind (Id) = E_Constant or else Ekind (Id) = E_Variable); + pragma Assert (Ekind (Id) in Type_Kind + or else Ekind_In (Id, E_Constant, E_Variable)); return Node24 (Id); end Related_Expression; function Related_Instance (Id : E) return E is begin - pragma Assert - (Ekind (Id) = E_Package or else Ekind (Id) = E_Package_Body); + pragma Assert (Ekind_In (Id, E_Package, E_Package_Body)); return Node15 (Id); end Related_Instance; function Related_Type (Id : E) return E is begin - pragma Assert - (Ekind (Id) = E_Component or else Ekind (Id) = E_Constant); + pragma Assert (Ekind_In (Id, E_Component, E_Constant)); return Node26 (Id); end Related_Type; @@ -2569,8 +2528,7 @@ package body Einfo is function Shadow_Entities (Id : E) return S is begin - pragma Assert - (Ekind (Id) = E_Package or else Ekind (Id) = E_Generic_Package); + pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package)); return List14 (Id); end Shadow_Entities; @@ -2582,7 +2540,7 @@ package body Einfo is function Size_Check_Code (Id : E) return N is begin - pragma Assert (Ekind (Id) = E_Constant or else Ekind (Id) = E_Variable); + pragma Assert (Ekind_In (Id, E_Constant, E_Variable)); return Node19 (Id); end Size_Check_Code; @@ -2604,8 +2562,7 @@ package body Einfo is function Spec_Entity (Id : E) return E is begin - pragma Assert - (Ekind (Id) = E_Package_Body or else Is_Formal (Id)); + pragma Assert (Ekind (Id) = E_Package_Body or else Is_Formal (Id)); return Node19 (Id); end Spec_Entity; @@ -2695,7 +2652,7 @@ package body Einfo is function Underlying_Record_View (Id : E) return E is begin - return Node24 (Id); + return Node28 (Id); end Underlying_Record_View; function Universal_Aliasing (Id : E) return B is @@ -2746,9 +2703,8 @@ package body Einfo is function Wrapped_Entity (Id : E) return E is begin - pragma Assert ((Ekind (Id) = E_Function - or else Ekind (Id) = E_Procedure) - and then Is_Primitive_Wrapper (Id)); + pragma Assert (Ekind_In (Id, E_Function, E_Procedure) + and then Is_Primitive_Wrapper (Id)); return Node27 (Id); end Wrapped_Entity; @@ -2956,8 +2912,7 @@ package body Einfo is function Is_Signed_Integer_Type (Id : E) return B is begin - return Ekind (Id) in - Signed_Integer_Kind; + return Ekind (Id) in Signed_Integer_Kind; end Is_Signed_Integer_Type; function Is_Subprogram (Id : E) return B is @@ -2979,6 +2934,12 @@ package body Einfo is -- Attribute Set Procedures -- ------------------------------ + -- Note: in many of these set procedures an "obvious" assertion is missing. + -- The reason for this is that in many cases, a field is set before the + -- Ekind field is set, so that the field is set when Ekind = E_Void. It + -- it is possible to add assertions that specifically include the E_Void + -- possibility, but in some cases, we just omit the assertions. + procedure Set_Accept_Address (Id : E; V : L) is begin Set_Elist21 (Id, V); @@ -3015,9 +2976,7 @@ package body Einfo is procedure Set_Actual_Subtype (Id : E; V : E) is begin pragma Assert - (Ekind (Id) = E_Constant - or else Ekind (Id) = E_Variable - or else Ekind (Id) = E_Generic_In_Out_Parameter + (Ekind_In (Id, E_Constant, E_Variable, E_Generic_In_Out_Parameter) or else Is_Formal (Id)); Set_Node17 (Id, V); end Set_Actual_Subtype; @@ -3037,11 +2996,11 @@ package body Einfo is procedure Set_Alignment (Id : E; V : U) is begin pragma Assert (Is_Type (Id) - or else Is_Formal (Id) - or else Ekind (Id) = E_Loop_Parameter - or else Ekind (Id) = E_Constant - or else Ekind (Id) = E_Exception - or else Ekind (Id) = E_Variable); + or else Is_Formal (Id) + or else Ekind_In (Id, E_Loop_Parameter, + E_Constant, + E_Exception, + E_Variable)); Set_Uint14 (Id, V); end Set_Alignment; @@ -3059,8 +3018,7 @@ package body Einfo is procedure Set_Body_Entity (Id : E; V : E) is begin - pragma Assert - (Ekind (Id) = E_Package or else Ekind (Id) = E_Generic_Package); + pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package)); Set_Node19 (Id, V); end Set_Body_Entity; @@ -3068,8 +3026,8 @@ package body Einfo is begin pragma Assert (Ekind (Id) = E_Package - or else Is_Subprogram (Id) - or else Is_Generic_Unit (Id)); + or else Is_Subprogram (Id) + or else Is_Generic_Unit (Id)); Set_Flag40 (Id, V); end Set_Body_Needed_For_SAL; @@ -3097,23 +3055,19 @@ package body Einfo is procedure Set_Cloned_Subtype (Id : E; V : E) is begin - pragma Assert - (Ekind (Id) = E_Record_Subtype - or else Ekind (Id) = E_Class_Wide_Subtype); + pragma Assert (Ekind_In (Id, E_Record_Subtype, E_Class_Wide_Subtype)); Set_Node16 (Id, V); end Set_Cloned_Subtype; procedure Set_Component_Bit_Offset (Id : E; V : U) is begin - pragma Assert - (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant); + pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); Set_Uint11 (Id, V); end Set_Component_Bit_Offset; procedure Set_Component_Clause (Id : E; V : N) is begin - pragma Assert - (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant); + pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); Set_Node13 (Id, V); end Set_Component_Clause; @@ -3218,9 +3172,7 @@ package body Einfo is procedure Set_Delay_Subprogram_Descriptors (Id : E; V : B := True) is begin pragma Assert - (Is_Subprogram (Id) - or else Ekind (Id) = E_Package - or else Ekind (Id) = E_Package_Body); + (Is_Subprogram (Id) or else Ekind_In (Id, E_Package, E_Package_Body)); Set_Flag50 (Id, V); end Set_Delay_Subprogram_Descriptors; @@ -3313,14 +3265,13 @@ package body Einfo is procedure Set_DT_Position (Id : E; V : U) is begin - pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure); + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); Set_Uint15 (Id, V); end Set_DT_Position; procedure Set_DTC_Entity (Id : E; V : E) is begin - pragma Assert - (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure); + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); Set_Node16 (Id, V); end Set_DTC_Entity; @@ -3421,12 +3372,12 @@ package body Einfo is procedure Set_Equivalent_Type (Id : E; V : E) is begin pragma Assert - (Ekind (Id) = E_Class_Wide_Type or else - Ekind (Id) = E_Class_Wide_Subtype or else - Ekind (Id) = E_Access_Protected_Subprogram_Type or else - Ekind (Id) = E_Anonymous_Access_Protected_Subprogram_Type or else - Ekind (Id) = E_Access_Subprogram_Type or else - Ekind (Id) = E_Exception_Type); + (Ekind_In (Id, E_Class_Wide_Type, + E_Class_Wide_Subtype, + E_Access_Protected_Subprogram_Type, + E_Anonymous_Access_Protected_Subprogram_Type, + E_Access_Subprogram_Type, + E_Exception_Type)); Set_Node18 (Id, V); end Set_Equivalent_Type; @@ -3462,9 +3413,9 @@ package body Einfo is begin pragma Assert (Is_Overloadable (Id) - or else Ekind (Id) = E_Entry_Family - or else Ekind (Id) = E_Subprogram_Body - or else Ekind (Id) = E_Subprogram_Type); + or else Ekind_In (Id, E_Entry_Family, + E_Subprogram_Body, + E_Subprogram_Type)); Set_Node28 (Id, V); end Set_Extra_Formals; @@ -3492,6 +3443,12 @@ package body Einfo is Set_Node17 (Id, V); end Set_First_Entity; + procedure Set_First_Exit_Statement (Id : E; V : N) is + begin + pragma Assert (Ekind (Id) = E_Loop); + Set_Node8 (Id, V); + end Set_First_Exit_Statement; + procedure Set_First_Index (Id : E; V : N) is begin pragma Assert (Is_Array_Type (Id) or else Is_String_Type (Id)); @@ -3506,16 +3463,14 @@ package body Einfo is procedure Set_First_Optional_Parameter (Id : E; V : E) is begin - pragma Assert - (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure); + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); Set_Node14 (Id, V); end Set_First_Optional_Parameter; procedure Set_First_Private_Entity (Id : E; V : E) is begin - pragma Assert (Ekind (Id) = E_Package - or else Ekind (Id) = E_Generic_Package - or else Ekind (Id) in Concurrent_Kind); + pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package) + or else Ekind (Id) in Concurrent_Kind); Set_Node16 (Id, V); end Set_First_Private_Entity; @@ -3533,7 +3488,7 @@ package body Einfo is begin pragma Assert (Is_Type (Id) - or else Ekind (Id) = E_Package); + or else Ekind (Id) = E_Package); Set_Flag159 (Id, V); end Set_From_With_Type; @@ -3700,8 +3655,7 @@ package body Einfo is procedure Set_Has_Initial_Value (Id : E; V : B := True) is begin - pragma Assert - (Ekind (Id) = E_Variable or else Ekind (Id) = E_Out_Parameter); + pragma Assert (Ekind_In (Id, E_Variable, E_Out_Parameter)); Set_Flag219 (Id, V); end Set_Has_Initial_Value; @@ -3718,8 +3672,7 @@ package body Einfo is procedure Set_Has_Missing_Return (Id : E; V : B := True) is begin - pragma Assert - (Ekind (Id) = E_Function or else Ekind (Id) = E_Generic_Function); + pragma Assert (Ekind_In (Id, E_Function, E_Generic_Function)); Set_Flag142 (Id, V); end Set_Has_Missing_Return; @@ -3730,10 +3683,7 @@ package body Einfo is procedure Set_Has_Up_Level_Access (Id : E; V : B := True) is begin - pragma Assert - (Ekind (Id) = E_Variable - or else Ekind (Id) = E_Constant - or else Ekind (Id) = E_Loop_Parameter); + pragma Assert (Ekind_In (Id, E_Variable, E_Constant, E_Loop_Parameter)); Set_Flag215 (Id, V); end Set_Has_Up_Level_Access; @@ -3976,9 +3926,7 @@ package body Einfo is procedure Set_Implemented_By_Entry (Id : E; V : B := True) is begin - pragma Assert - (Ekind (Id) = E_Function - or else Ekind (Id) = E_Procedure); + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); Set_Flag232 (Id, V); end Set_Implemented_By_Entry; @@ -3993,8 +3941,7 @@ package body Einfo is pragma Assert (Is_Internal (Id) and then Is_Hidden (Id) - and then (Ekind (Id) = E_Procedure - or else Ekind (Id) = E_Function)); + and then (Ekind_In (Id, E_Procedure, E_Function))); Set_Node25 (Id, V); end Set_Interface_Alias; @@ -4087,8 +4034,7 @@ package body Einfo is procedure Set_Is_Called (Id : E; V : B := True) is begin - pragma Assert - (Ekind (Id) = E_Procedure or else Ekind (Id) = E_Function); + pragma Assert (Ekind_In (Id, E_Procedure, E_Function)); Set_Flag102 (Id, V); end Set_Is_Called; @@ -4211,10 +4157,7 @@ package body Einfo is procedure Set_Is_For_Access_Subtype (Id : E; V : B := True) is begin - pragma Assert - (Ekind (Id) = E_Record_Subtype - or else - Ekind (Id) = E_Private_Subtype); + pragma Assert (Ekind_In (Id, E_Record_Subtype, E_Private_Subtype)); Set_Flag118 (Id, V); end Set_Is_For_Access_Subtype; @@ -4275,12 +4218,12 @@ package body Einfo is procedure Set_Is_Interface (Id : E; V : B := True) is begin pragma Assert - (Ekind (Id) = E_Record_Type - or else Ekind (Id) = E_Record_Subtype - or else Ekind (Id) = E_Record_Type_With_Private - or else Ekind (Id) = E_Record_Subtype_With_Private - or else Ekind (Id) = E_Class_Wide_Type - or else Ekind (Id) = E_Class_Wide_Subtype); + (Ekind_In (Id, E_Record_Type, + E_Record_Subtype, + E_Record_Type_With_Private, + E_Record_Subtype_With_Private, + E_Class_Wide_Type, + E_Class_Wide_Subtype)); Set_Flag186 (Id, V); end Set_Is_Interface; @@ -4415,15 +4358,13 @@ package body Einfo is begin pragma Assert (Is_Overloadable (Id) - or else Ekind (Id) = E_Generic_Function - or else Ekind (Id) = E_Generic_Procedure); + or else Ekind_In (Id, E_Generic_Function, E_Generic_Procedure)); Set_Flag218 (Id, V); end Set_Is_Primitive; procedure Set_Is_Primitive_Wrapper (Id : E; V : B := True) is begin - pragma Assert (Ekind (Id) = E_Function - or else Ekind (Id) = E_Procedure); + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); Set_Flag195 (Id, V); end Set_Is_Primitive_Wrapper; @@ -4440,17 +4381,10 @@ package body Einfo is procedure Set_Is_Private_Primitive (Id : E; V : B := True) is begin - pragma Assert (Ekind (Id) = E_Function - or else Ekind (Id) = E_Procedure); + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); Set_Flag245 (Id, V); end Set_Is_Private_Primitive; - procedure Set_Is_Protected_Interface (Id : E; V : B := True) is - begin - pragma Assert (Is_Interface (Id)); - Set_Flag198 (Id, V); - end Set_Is_Protected_Interface; - procedure Set_Is_Public (Id : E; V : B := True) is begin pragma Assert (Nkind (Id) in N_Entity); @@ -4508,25 +4442,17 @@ package body Einfo is procedure Set_Is_Statically_Allocated (Id : E; V : B := True) is begin pragma Assert - (Ekind (Id) = E_Exception - or else Ekind (Id) = E_Variable - or else Ekind (Id) = E_Constant - or else Is_Type (Id) - or else Ekind (Id) = E_Void); + (Is_Type (Id) + or else Ekind_In (Id, E_Exception, + E_Variable, + E_Constant, + E_Void)); Set_Flag28 (Id, V); end Set_Is_Statically_Allocated; - procedure Set_Is_Synchronized_Interface (Id : E; V : B := True) is - begin - pragma Assert (Is_Interface (Id)); - Set_Flag199 (Id, V); - end Set_Is_Synchronized_Interface; - procedure Set_Is_Tag (Id : E; V : B := True) is begin - pragma Assert - (Ekind (Id) = E_Component - or else Ekind (Id) = E_Constant); + pragma Assert (Ekind_In (Id, E_Component, E_Constant)); Set_Flag78 (Id, V); end Set_Is_Tag; @@ -4535,12 +4461,6 @@ package body Einfo is Set_Flag55 (Id, V); end Set_Is_Tagged_Type; - procedure Set_Is_Task_Interface (Id : E; V : B := True) is - begin - pragma Assert (Is_Interface (Id)); - Set_Flag200 (Id, V); - end Set_Is_Task_Interface; - procedure Set_Is_Thunk (Id : E; V : B := True) is begin Set_Flag225 (Id, V); @@ -4715,8 +4635,7 @@ package body Einfo is begin pragma Assert (Is_Overloadable (Id) - or else Ekind (Id) = E_Subprogram_Type - or else Ekind (Id) = E_Entry_Family); + or else Ekind_In (Id, E_Subprogram_Type, E_Entry_Family)); Set_Flag22 (Id, V); end Set_Needs_No_Actuals; @@ -4739,9 +4658,7 @@ package body Einfo is procedure Set_No_Return (Id : E; V : B := True) is begin pragma Assert - (V = False - or else Ekind (Id) = E_Procedure - or else Ekind (Id) = E_Generic_Procedure); + (V = False or else Ekind_In (Id, E_Procedure, E_Generic_Procedure)); Set_Flag113 (Id, V); end Set_No_Return; @@ -4773,22 +4690,19 @@ package body Einfo is procedure Set_Normalized_First_Bit (Id : E; V : U) is begin - pragma Assert - (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant); + pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); Set_Uint8 (Id, V); end Set_Normalized_First_Bit; procedure Set_Normalized_Position (Id : E; V : U) is begin - pragma Assert - (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant); + pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); Set_Uint14 (Id, V); end Set_Normalized_Position; procedure Set_Normalized_Position_Max (Id : E; V : U) is begin - pragma Assert - (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant); + pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); Set_Uint10 (Id, V); end Set_Normalized_Position_Max; @@ -4808,18 +4722,14 @@ package body Einfo is procedure Set_Optimize_Alignment_Space (Id : E; V : B := True) is begin pragma Assert - (Is_Type (Id) - or else Ekind (Id) = E_Constant - or else Ekind (Id) = E_Variable); + (Is_Type (Id) or else Ekind_In (Id, E_Constant, E_Variable)); Set_Flag241 (Id, V); end Set_Optimize_Alignment_Space; procedure Set_Optimize_Alignment_Time (Id : E; V : B := True) is begin pragma Assert - (Is_Type (Id) - or else Ekind (Id) = E_Constant - or else Ekind (Id) = E_Variable); + (Is_Type (Id) or else Ekind_In (Id, E_Constant, E_Variable)); Set_Flag242 (Id, V); end Set_Optimize_Alignment_Time; @@ -4831,10 +4741,7 @@ package body Einfo is procedure Set_Original_Record_Component (Id : E; V : E) is begin - pragma Assert - (Ekind (Id) = E_Void - or else Ekind (Id) = E_Component - or else Ekind (Id) = E_Discriminant); + pragma Assert (Ekind_In (Id, E_Void, E_Component, E_Discriminant)); Set_Node22 (Id, V); end Set_Original_Record_Component; @@ -4850,10 +4757,7 @@ package body Einfo is procedure Set_Package_Instantiation (Id : E; V : N) is begin - pragma Assert - (Ekind (Id) = E_Void - or else Ekind (Id) = E_Generic_Package - or else Ekind (Id) = E_Package); + pragma Assert (Ekind_In (Id, E_Void, E_Generic_Package, E_Package)); Set_Node26 (Id, V); end Set_Package_Instantiation; @@ -4889,8 +4793,7 @@ package body Einfo is procedure Set_Prival_Link (Id : E; V : E) is begin - pragma Assert (Ekind (Id) = E_Constant - or else Ekind (Id) = E_Variable); + pragma Assert (Ekind_In (Id, E_Constant, E_Variable)); Set_Node20 (Id, V); end Set_Prival_Link; @@ -4920,10 +4823,10 @@ package body Einfo is procedure Set_Protection_Object (Id : E; V : E) is begin - pragma Assert (Ekind (Id) = E_Entry - or else Ekind (Id) = E_Entry_Family - or else Ekind (Id) = E_Function - or else Ekind (Id) = E_Procedure); + pragma Assert (Ekind_In (Id, E_Entry, + E_Entry_Family, + E_Function, + E_Procedure)); Set_Node23 (Id, V); end Set_Protection_Object; @@ -4967,20 +4870,20 @@ package body Einfo is procedure Set_Related_Expression (Id : E; V : N) is begin + pragma Assert (Ekind (Id) in Type_Kind + or else Ekind_In (Id, E_Constant, E_Variable, E_Void)); Set_Node24 (Id, V); end Set_Related_Expression; procedure Set_Related_Instance (Id : E; V : E) is begin - pragma Assert - (Ekind (Id) = E_Package or else Ekind (Id) = E_Package_Body); + pragma Assert (Ekind_In (Id, E_Package, E_Package_Body)); Set_Node15 (Id, V); end Set_Related_Instance; procedure Set_Related_Type (Id : E; V : E) is begin - pragma Assert - (Ekind (Id) = E_Component or else Ekind (Id) = E_Constant); + pragma Assert (Ekind_In (Id, E_Component, E_Constant)); Set_Node26 (Id, V); end Set_Related_Type; @@ -5068,8 +4971,7 @@ package body Einfo is procedure Set_Shadow_Entities (Id : E; V : S) is begin - pragma Assert - (Ekind (Id) = E_Package or else Ekind (Id) = E_Generic_Package); + pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package)); Set_List14 (Id, V); end Set_Shadow_Entities; @@ -5081,7 +4983,7 @@ package body Einfo is procedure Set_Size_Check_Code (Id : E; V : N) is begin - pragma Assert (Ekind (Id) = E_Constant or else Ekind (Id) = E_Variable); + pragma Assert (Ekind_In (Id, E_Constant, E_Variable)); Set_Node19 (Id, V); end Set_Size_Check_Code; @@ -5198,7 +5100,7 @@ package body Einfo is procedure Set_Underlying_Record_View (Id : E; V : E) is begin pragma Assert (Ekind (Id) = E_Record_Type); - Set_Node24 (Id, V); + Set_Node28 (Id, V); end Set_Underlying_Record_View; procedure Set_Universal_Aliasing (Id : E; V : B := True) is @@ -5255,9 +5157,8 @@ package body Einfo is procedure Set_Wrapped_Entity (Id : E; V : E) is begin - pragma Assert ((Ekind (Id) = E_Function - or else Ekind (Id) = E_Procedure) - and then Is_Primitive_Wrapper (Id)); + pragma Assert (Ekind_In (Id, E_Function, E_Procedure) + and then Is_Primitive_Wrapper (Id)); Set_Node27 (Id, V); end Set_Wrapped_Entity; @@ -5452,7 +5353,8 @@ package body Einfo is function Known_Static_Esize (E : Entity_Id) return B is begin - return Uint12 (E) > Uint_0; + return Uint12 (E) > Uint_0 + and then not Is_Generic_Type (E); end Known_Static_Esize; function Known_Static_Normalized_First_Bit (E : Entity_Id) return B is @@ -5475,9 +5377,10 @@ package body Einfo is function Known_Static_RM_Size (E : Entity_Id) return B is begin - return Uint13 (E) > Uint_0 - or else Is_Discrete_Type (E) - or else Is_Fixed_Point_Type (E); + return (Uint13 (E) > Uint_0 + or else Is_Discrete_Type (E) + or else Is_Fixed_Point_Type (E)) + and then not Is_Generic_Type (E); end Known_Static_RM_Size; function Unknown_Alignment (E : Entity_Id) return B is @@ -5752,9 +5655,9 @@ package body Einfo is begin pragma Assert (Is_Overloadable (Id) - or else Ekind (Id) = E_Entry_Family - or else Ekind (Id) = E_Subprogram_Body - or else Ekind (Id) = E_Subprogram_Type); + or else Ekind_In (Id, E_Entry_Family, + E_Subprogram_Body, + E_Subprogram_Type)); if Ekind (Id) = E_Enumeration_Literal then return Empty; @@ -5780,9 +5683,9 @@ package body Einfo is begin pragma Assert (Is_Overloadable (Id) - or else Ekind (Id) = E_Entry_Family - or else Ekind (Id) = E_Subprogram_Body - or else Ekind (Id) = E_Subprogram_Type); + or else Ekind_In (Id, E_Entry_Family, + E_Subprogram_Body, + E_Subprogram_Type)); if Ekind (Id) = E_Enumeration_Literal then return Empty; @@ -5829,9 +5732,7 @@ package body Einfo is function Get_Full_View (T : Entity_Id) return Entity_Id is begin - if Ekind (T) = E_Incomplete_Type - and then Present (Full_View (T)) - then + if Ekind (T) = E_Incomplete_Type and then Present (Full_View (T)) then return Full_View (T); elsif Is_Class_Wide_Type (T) @@ -5845,6 +5746,26 @@ package body Einfo is end if; end Get_Full_View; + -------------------------------------- + -- Get_Record_Representation_Clause -- + -------------------------------------- + + function Get_Record_Representation_Clause (E : Entity_Id) return Node_Id is + N : Node_Id; + + begin + N := First_Rep_Item (E); + while Present (N) loop + if Nkind (N) = N_Record_Representation_Clause then + return N; + end if; + + Next_Rep_Item (N); + end loop; + + return Empty; + end Get_Record_Representation_Clause; + -------------------- -- Get_Rep_Pragma -- -------------------- @@ -5929,7 +5850,13 @@ package body Einfo is function Has_Foreign_Convention (Id : E) return B is begin - return Convention (Id) in Foreign_Convention; + -- While regular Intrinsics such as the Standard operators fit in the + -- "Ada" convention, those with an Interface_Name materialize GCC + -- builtin imports for which Ada special treatments shouldn't apply. + + return Convention (Id) in Foreign_Convention + or else (Convention (Id) = Convention_Intrinsic + and then Present (Interface_Name (Id))); end Has_Foreign_Convention; --------------------------- @@ -6085,10 +6012,8 @@ package body Einfo is function Is_Discriminal (Id : E) return B is begin - return - (Ekind (Id) = E_Constant - or else Ekind (Id) = E_In_Parameter) - and then Present (Discriminal_Link (Id)); + return (Ekind_In (Id, E_Constant, E_In_Parameter) + and then Present (Discriminal_Link (Id))); end Is_Discriminal; ---------------------- @@ -6156,10 +6081,8 @@ package body Einfo is function Is_Prival (Id : E) return B is begin - return - (Ekind (Id) = E_Constant - or else Ekind (Id) = E_Variable) - and then Present (Prival_Link (Id)); + return (Ekind_In (Id, E_Constant, E_Variable) + and then Present (Prival_Link (Id))); end Is_Prival; ---------------------------- @@ -6172,6 +6095,22 @@ package body Einfo is and then Is_Protected_Type (Scope (Id)); end Is_Protected_Component; + ---------------------------- + -- Is_Protected_Interface -- + ---------------------------- + + function Is_Protected_Interface (Id : E) return B is + Typ : constant Entity_Id := Base_Type (Id); + begin + if not Is_Interface (Typ) then + return False; + elsif Is_Class_Wide_Type (Typ) then + return Is_Protected_Interface (Etype (Typ)); + else + return Protected_Present (Type_Definition (Parent (Typ))); + end if; + end Is_Protected_Interface; + ------------------------------ -- Is_Protected_Record_Type -- ------------------------------ @@ -6214,10 +6153,47 @@ package body Einfo is begin return Ekind (Id) in String_Kind or else (Is_Array_Type (Id) - and then Number_Dimensions (Id) = 1 - and then Is_Character_Type (Component_Type (Id))); + and then Number_Dimensions (Id) = 1 + and then Is_Character_Type (Component_Type (Id))); end Is_String_Type; + ------------------------------- + -- Is_Synchronized_Interface -- + ------------------------------- + + function Is_Synchronized_Interface (Id : E) return B is + Typ : constant Entity_Id := Base_Type (Id); + + begin + if not Is_Interface (Typ) then + return False; + + elsif Is_Class_Wide_Type (Typ) then + return Is_Synchronized_Interface (Etype (Typ)); + + else + return Protected_Present (Type_Definition (Parent (Typ))) + or else Synchronized_Present (Type_Definition (Parent (Typ))) + or else Task_Present (Type_Definition (Parent (Typ))); + end if; + end Is_Synchronized_Interface; + + ----------------------- + -- Is_Task_Interface -- + ----------------------- + + function Is_Task_Interface (Id : E) return B is + Typ : constant Entity_Id := Base_Type (Id); + begin + if not Is_Interface (Typ) then + return False; + elsif Is_Class_Wide_Type (Typ) then + return Is_Task_Interface (Etype (Typ)); + else + return Task_Present (Type_Definition (Parent (Typ))); + end if; + end Is_Task_Interface; + ------------------------- -- Is_Task_Record_Type -- ------------------------- @@ -6236,9 +6212,39 @@ package body Einfo is function Is_Wrapper_Package (Id : E) return B is begin return (Ekind (Id) = E_Package - and then Present (Related_Instance (Id))); + and then Present (Related_Instance (Id))); end Is_Wrapper_Package; + ----------------- + -- Last_Formal -- + ----------------- + + function Last_Formal (Id : E) return E is + Formal : E; + + begin + pragma Assert + (Is_Overloadable (Id) + or else Ekind_In (Id, E_Entry_Family, + E_Subprogram_Body, + E_Subprogram_Type)); + + if Ekind (Id) = E_Enumeration_Literal then + return Empty; + + else + Formal := First_Formal (Id); + + if Present (Formal) then + while Present (Next_Formal (Formal)) loop + Formal := Next_Formal (Formal); + end loop; + end if; + + return Formal; + end if; + end Last_Formal; + -------------------- -- Next_Component -- -------------------- @@ -6266,9 +6272,7 @@ package body Einfo is begin Comp_Id := Next_Entity (Id); while Present (Comp_Id) loop - exit when Ekind (Comp_Id) = E_Component - or else - Ekind (Comp_Id) = E_Discriminant; + exit when Ekind_In (Comp_Id, E_Component, E_Discriminant); Comp_Id := Next_Entity (Comp_Id); end loop; @@ -6305,7 +6309,7 @@ package body Einfo is D := Next_Entity (D); if No (D) or else (Ekind (D) /= E_Discriminant - and then not Is_Itype (D)) + and then not Is_Itype (D)) then return Empty; end if; @@ -6989,7 +6993,6 @@ package body Einfo is W ("Is_Private_Composite", Flag107 (Id)); W ("Is_Private_Descendant", Flag53 (Id)); W ("Is_Private_Primitive", Flag245 (Id)); - W ("Is_Protected_Interface", Flag198 (Id)); W ("Is_Public", Flag10 (Id)); W ("Is_Pure", Flag44 (Id)); W ("Is_Pure_Unit_Access_Type", Flag189 (Id)); @@ -7000,11 +7003,9 @@ package body Einfo is W ("Is_Renaming_Of_Object", Flag112 (Id)); W ("Is_Return_Object", Flag209 (Id)); W ("Is_Shared_Passive", Flag60 (Id)); - W ("Is_Synchronized_Interface", Flag199 (Id)); W ("Is_Statically_Allocated", Flag28 (Id)); W ("Is_Tag", Flag78 (Id)); W ("Is_Tagged_Type", Flag55 (Id)); - W ("Is_Task_Interface", Flag200 (Id)); W ("Is_Thunk", Flag225 (Id)); W ("Is_Trivial_Subprogram", Flag235 (Id)); W ("Is_True_Constant", Flag163 (Id)); @@ -7236,6 +7237,9 @@ package body Einfo is when Type_Kind => Write_Str ("Associated_Node_For_Itype"); + when E_Loop => + Write_Str ("First_Exit_Statement"); + when E_Package => Write_Str ("Dependent_Instances"); @@ -7960,14 +7964,11 @@ package body Einfo is when Subprogram_Kind => Write_Str ("Spec_PPC_List"); - when E_Record_Type => - Write_Str ("Underlying record view"); - - when E_Variable | E_Constant => - Write_Str ("Related expression"); + when E_Variable | E_Constant | Type_Kind => + Write_Str ("Related_Expression"); when others => - Write_Str ("???"); + Write_Str ("Field24???"); end case; end Write_Field24_Name; @@ -8071,6 +8072,9 @@ package body Einfo is when E_Procedure | E_Function | E_Entry => Write_Str ("Extra_Formals"); + when E_Record_Type => + Write_Str ("Underlying_Record_View"); + when others => Write_Str ("Field28??"); end case; @@ -8089,9 +8093,7 @@ package body Einfo is begin N := Next_Entity (N); while Present (N) loop - exit when Ekind (N) = E_Component - or else - Ekind (N) = E_Discriminant; + exit when Ekind_In (N, E_Component, E_Discriminant); N := Next_Entity (N); end loop; end Proc_Next_Component_Or_Discriminant; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index d4294728563..a3bff056113 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -350,6 +350,10 @@ package Einfo is -- make sure that the address can be meaningfully taken, and also in -- the case of subprograms to control output of certain warnings. +-- Aft_Value (synthesized) +-- Applies to fixed and decimal types. Computes a universal integer +-- that holds value of the Aft attribute for the type. + -- Alias (Node18) -- Present in overloaded entities (literals, subprograms, entries) and -- subprograms that cover a primitive operation of an abstract interface @@ -1116,6 +1120,13 @@ package Einfo is -- Points to a list of associated entities using the Next_Entity field -- as a chain pointer with Empty marking the end of the list. +-- First_Exit_Statement (Node8) +-- Present in E_Loop entity. The exit statements for a loop are chained +-- (in reverse order of appearence) using this field to point to the +-- first entry in the chain (last exit statement in the loop). The +-- entries are chained through the Next_Exit_Statement field of the +-- N_Exit_Statement node with Empty marking the end of the list. + -- First_Formal (synthesized) -- Applies to subprograms and subprogram types, and also in entries -- and entry families. Returns first formal of the subprogram or entry. @@ -2470,7 +2481,7 @@ package Einfo is -- Applicable to all entities, true if the entity denotes a private -- component of a protected type. --- Is_Protected_Interface (Flag198) +-- Is_Protected_Interface (synthesized) -- Present in types that are interfaces. True if interface is declared -- protected, or is derived from protected interfaces. @@ -2577,7 +2588,7 @@ package Einfo is -- Applies to all entities, true for function, procedure and operator -- entities. --- Is_Synchronized_Interface (Flag199) +-- Is_Synchronized_Interface (synthesized) -- Present in types that are interfaces. True if interface is declared -- synchronized, task, or protected, or is derived from a synchronized -- interface. @@ -2591,7 +2602,7 @@ package Einfo is -- Is_Tagged_Type (Flag55) -- Present in all entities. Set for an entity for a tagged type. --- Is_Task_Interface (Flag200) +-- Is_Task_Interface (synthesized) -- Present in types that are interfaces. True if interface is declared as -- a task interface, or if it is derived from task interfaces. @@ -2745,6 +2756,13 @@ package Einfo is -- Points to the last entry in the list of associated entities chained -- through the Next_Entity field. Empty if no entities are chained. +-- Last_Formal (synthesized) +-- Applies to subprograms and subprogram types, and also in entries +-- and entry families. Returns last formal of the subprogram or entry. +-- The formals are the first entities declared in a subprogram or in +-- a subprogram type (the designated type of an Access_To_Subprogram +-- definition) or in an entry. + -- Limited_View (Node23) -- Present in non-generic package entities that are not instances. Bona -- fide package with the limited-view list through the first_entity and @@ -3134,7 +3152,9 @@ package Einfo is -- types. Points to an element list of entities for primitive operations -- for the tagged type. Not present (and not set) in untagged types (it -- is an error to reference the primitive operations field of a type --- that is not tagged). +-- that is not tagged). In order to fulfill the C++ ABI, entities of +-- primitives that come from source must be stored in this list following +-- their order of occurrence in the sources. -- Prival (Node17) -- Present in private components of protected types. Refers to the entity @@ -3237,9 +3257,13 @@ package Einfo is -- only for type-related error messages. -- Related_Expression (Node24) --- Present in variables generated internally. Denotes the source --- expression whose elaboration created the variable declaration. --- Used for clearer messages from CodePeer. +-- Present in variables and types. Set only for internally generated +-- entities, where it may be used to denote the source expression whose +-- elaboration created the variable declaration. If set, it is used +-- for generating clearer messages from CodePeer. +-- +-- Shouldn't it also be used for the same purpose in errout? It seems +-- odd to have two mechanisms here??? -- Related_Instance (Node15) -- Present in the wrapper packages created for subprogram instances. @@ -3532,12 +3556,13 @@ package Einfo is -- value may be passed around, and if used, may clobber a local variable. -- Task_Body_Procedure (Node25) --- Present in task types and subtypes. Points to the entity for --- the task body procedure (as further described in Exp_Ch9, task --- bodies are expanded into procedures). A convenient function to --- retrieve this field is Sem_Util.Get_Task_Body_Procedure. --- The last sentence is odd ??? Why not have Task_Body_Procedure --- go to the Underlying_Type of the Root_Type??? +-- Present in task types and subtypes. Points to the entity for the task +-- task body procedure (as further described in Exp_Ch9, task bodies are +-- expanded into procedures). A convenient function to retrieve this +-- field is Sem_Util.Get_Task_Body_Procedure. +-- +-- The last sentence is odd??? Why not have Task_Body_Procedure go to the +-- Underlying_Type of the Root_Type??? -- Treat_As_Volatile (Flag41) -- Present in all type entities, and also in constants, components and @@ -3584,7 +3609,7 @@ package Einfo is -- private completion. If Td is already constrained, then its full view -- can serve directly as the full view of T. --- Underlying_Record_View (Node24) +-- Underlying_Record_View (Node28) -- Present in record types. Set for record types that are extensions of -- types with unknown discriminants, and also set for internally built -- underlying record views to reference its original record type. Record @@ -4592,6 +4617,7 @@ package Einfo is -- Esize (Uint12) -- RM_Size (Uint13) -- Alignment (Uint14) + -- Related_Expression (Node24) -- Depends_On_Private (Flag14) -- Discard_Names (Flag88) @@ -4628,10 +4654,7 @@ package Einfo is -- Is_Eliminated (Flag124) -- Is_Frozen (Flag4) -- Is_Generic_Actual_Type (Flag94) - -- Is_Protected_Interface (Flag198) -- Is_RACW_Stub_Type (Flag244) - -- Is_Synchronized_Interface (Flag199) - -- Is_Task_Interface (Flag200) -- Is_Non_Static_Subtype (Flag109) -- Is_Packed (Flag51) (base type only) -- Is_Private_Composite (Flag107) @@ -4822,6 +4845,7 @@ package Einfo is -- Small_Value (Ureal21) -- Has_Machine_Radix_Clause (Flag83) -- Machine_Radix_10 (Flag84) + -- Aft_Value (synth) -- Type_Low_Bound (synth) -- Type_High_Bound (synth) -- (plus type attributes) @@ -4866,9 +4890,10 @@ package Einfo is -- Sec_Stack_Needed_For_Return (Flag167) -- Uses_Sec_Stack (Flag95) -- Address_Clause (synth) + -- Entry_Index_Type (synth) -- First_Formal (synth) -- First_Formal_With_Extras (synth) - -- Entry_Index_Type (synth) + -- Last_Formal (synth) -- Number_Formals (synth) -- Scope_Depth (synth) @@ -4987,6 +5012,7 @@ package Einfo is -- Address_Clause (synth) -- First_Formal (synth) -- First_Formal_With_Extras (synth) + -- Last_Formal (synth) -- Number_Formals (synth) -- Scope_Depth (synth) @@ -5063,6 +5089,7 @@ package Einfo is -- (plus type attributes) -- E_Loop + -- First_Exit_Statement (Node8) -- Has_Exit (Flag47) -- Has_Master_Entity (Flag21) -- Has_Nested_Block_With_Handler (Flag101) @@ -5103,6 +5130,7 @@ package Einfo is -- Scalar_Range (Node20) -- Small_Value (Ureal21) -- Has_Small_Clause (Flag67) + -- Aft_Value (synth) -- Type_Low_Bound (synth) -- Type_High_Bound (synth) -- (plus type attributes) @@ -5201,7 +5229,7 @@ package Einfo is -- Spec_PPC_List (Node24) -- Interface_Alias (Node25) -- Static_Initialization (Node26) (init_proc only) - -- Overridden_Operation (Node26) + -- Overridden_Operation (Node26) (never for init proc) -- Wrapped_Entity (Node27) (non-generic case only) -- Extra_Formals (Node28) -- Body_Needed_For_SAL (Flag40) @@ -5244,6 +5272,7 @@ package Einfo is -- Address_Clause (synth) -- First_Formal (synth) -- First_Formal_With_Extras (synth) + -- Last_Formal (synth) -- Number_Formals (synth) -- E_Protected_Body @@ -5282,8 +5311,8 @@ package Einfo is -- Discriminant_Constraint (Elist21) -- Corresponding_Remote_Type (Node22) -- Stored_Constraint (Elist23) - -- Underlying_Record_View (Node24) (base type only) -- Interfaces (Elist25) + -- Underlying_Record_View (Node28) (base type only) -- Component_Alignment (special) (base type only) -- C_Pass_By_Copy (Flag125) (base type only) -- Has_Dispatch_Table (Flag220) (base tagged type only) @@ -5368,6 +5397,7 @@ package Einfo is -- Directly_Designated_Type (Node20) -- First_Formal (synth) -- First_Formal_With_Extras (synth) + -- Last_Formal (synth) -- Number_Formals (synth) -- (plus type attributes) @@ -5743,6 +5773,7 @@ package Einfo is function Finalization_Chain_Entity (Id : E) return E; function Finalize_Storage_Only (Id : E) return B; function First_Entity (Id : E) return E; + function First_Exit_Statement (Id : E) return N; function First_Index (Id : E) return N; function First_Literal (Id : E) return E; function First_Optional_Parameter (Id : E) return E; @@ -5900,7 +5931,6 @@ package Einfo is function Is_Private_Composite (Id : E) return B; function Is_Private_Descendant (Id : E) return B; function Is_Private_Primitive (Id : E) return B; - function Is_Protected_Interface (Id : E) return B; function Is_Public (Id : E) return B; function Is_Pure (Id : E) return B; function Is_Pure_Unit_Access_Type (Id : E) return B; @@ -5912,10 +5942,8 @@ package Einfo is function Is_Return_Object (Id : E) return B; function Is_Shared_Passive (Id : E) return B; function Is_Statically_Allocated (Id : E) return B; - function Is_Synchronized_Interface (Id : E) return B; function Is_Tag (Id : E) return B; function Is_Tagged_Type (Id : E) return B; - function Is_Task_Interface (Id : E) return B; function Is_Thunk (Id : E) return B; function Is_Trivial_Subprogram (Id : E) return B; function Is_True_Constant (Id : E) return B; @@ -6104,6 +6132,7 @@ package Einfo is -- so they do not correspond to defined fields in the entity itself. function Address_Clause (Id : E) return N; + function Aft_Value (Id : E) return U; function Alignment_Clause (Id : E) return N; function Base_Type (Id : E) return E; function Declaration_Node (Id : E) return N; @@ -6125,11 +6154,15 @@ package Einfo is function Is_Package_Or_Generic_Package (Id : E) return B; function Is_Prival (Id : E) return B; function Is_Protected_Component (Id : E) return B; + function Is_Protected_Interface (Id : E) return B; function Is_Protected_Record_Type (Id : E) return B; function Is_Standard_Character_Type (Id : E) return B; function Is_String_Type (Id : E) return B; + function Is_Synchronized_Interface (Id : E) return B; + function Is_Task_Interface (Id : E) return B; function Is_Task_Record_Type (Id : E) return B; function Is_Wrapper_Package (Id : E) return B; + function Last_Formal (Id : E) return E; function Next_Component (Id : E) return E; function Next_Component_Or_Discriminant (Id : E) return E; function Next_Discriminant (Id : E) return E; @@ -6179,6 +6212,13 @@ package Einfo is -- value is always known static for discrete types (and no other types can -- have an RM_Size value of zero). + -- In two cases, Known_Static_Esize and Known_Static_RM_Size, there is one + -- more consideration, which is that we always return False for generic + -- types. Within a template, the size can look known, because of the fake + -- size values we put in template types, but they are not really known and + -- anyone testing if they are known within the template should get False as + -- a result to prevent incorrect assumptions. + function Known_Alignment (E : Entity_Id) return B; function Known_Component_Bit_Offset (E : Entity_Id) return B; function Known_Component_Size (E : Entity_Id) return B; @@ -6291,6 +6331,7 @@ package Einfo is procedure Set_Finalization_Chain_Entity (Id : E; V : E); procedure Set_Finalize_Storage_Only (Id : E; V : B := True); procedure Set_First_Entity (Id : E; V : E); + procedure Set_First_Exit_Statement (Id : E; V : N); procedure Set_First_Index (Id : E; V : N); procedure Set_First_Literal (Id : E; V : E); procedure Set_First_Optional_Parameter (Id : E; V : E); @@ -6455,7 +6496,6 @@ package Einfo is procedure Set_Is_Private_Composite (Id : E; V : B := True); procedure Set_Is_Private_Descendant (Id : E; V : B := True); procedure Set_Is_Private_Primitive (Id : E; V : B := True); - procedure Set_Is_Protected_Interface (Id : E; V : B := True); procedure Set_Is_Public (Id : E; V : B := True); procedure Set_Is_Pure (Id : E; V : B := True); procedure Set_Is_Pure_Unit_Access_Type (Id : E; V : B := True); @@ -6467,10 +6507,8 @@ package Einfo is procedure Set_Is_Return_Object (Id : E; V : B := True); procedure Set_Is_Shared_Passive (Id : E; V : B := True); procedure Set_Is_Statically_Allocated (Id : E; V : B := True); - procedure Set_Is_Synchronized_Interface (Id : E; V : B := True); procedure Set_Is_Tag (Id : E; V : B := True); procedure Set_Is_Tagged_Type (Id : E; V : B := True); - procedure Set_Is_Task_Interface (Id : E; V : B := True); procedure Set_Is_Thunk (Id : E; V : B := True); procedure Set_Is_Trivial_Subprogram (Id : E; V : B := True); procedure Set_Is_True_Constant (Id : E; V : B := True); @@ -6757,6 +6795,11 @@ package Einfo is -- value returned is the N_Attribute_Definition_Clause node, otherwise -- Empty is returned. + function Get_Record_Representation_Clause (E : Entity_Id) return Node_Id; + -- Searches the Rep_Item chain for a given entyt E, for a record + -- representation clause, and if found, returns it. Returns Empty + -- if no such clause is found. + function Get_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Node_Id; -- Searches the Rep_Item chain for the given entity E, for an instance -- a representation pragma with the given name Nam. If found then the @@ -6793,9 +6836,9 @@ package Einfo is -- Add an entity to the list of entities declared in the scope V function Get_Full_View (T : Entity_Id) return Entity_Id; - -- If T is an incomplete type and the full declaration has been - -- seen, or is the name of a class_wide type whose root is incomplete. - -- return the corresponding full declaration. + -- If T is an incomplete type and the full declaration has been seen, or + -- is the name of a class_wide type whose root is incomplete, return the + -- corresponding full declaration, else return T itself. function Is_Entity_Name (N : Node_Id) return Boolean; -- Test if the node N is the name of an entity (i.e. is an identifier, @@ -6945,6 +6988,7 @@ package Einfo is pragma Inline (Can_Use_Internal_Rep); pragma Inline (Finalization_Chain_Entity); pragma Inline (First_Entity); + pragma Inline (First_Exit_Statement); pragma Inline (First_Index); pragma Inline (First_Literal); pragma Inline (First_Optional_Parameter); @@ -7141,7 +7185,6 @@ package Einfo is pragma Inline (Is_Private_Descendant); pragma Inline (Is_Private_Primitive); pragma Inline (Is_Private_Type); - pragma Inline (Is_Protected_Interface); pragma Inline (Is_Protected_Type); pragma Inline (Is_Public); pragma Inline (Is_Pure); @@ -7159,10 +7202,8 @@ package Einfo is pragma Inline (Is_Signed_Integer_Type); pragma Inline (Is_Statically_Allocated); pragma Inline (Is_Subprogram); - pragma Inline (Is_Synchronized_Interface); pragma Inline (Is_Tag); pragma Inline (Is_Tagged_Type); - pragma Inline (Is_Task_Interface); pragma Inline (Is_True_Constant); pragma Inline (Is_Task_Type); pragma Inline (Is_Thunk); @@ -7376,6 +7417,7 @@ package Einfo is pragma Inline (Set_Can_Use_Internal_Rep); pragma Inline (Set_Finalization_Chain_Entity); pragma Inline (Set_First_Entity); + pragma Inline (Set_First_Exit_Statement); pragma Inline (Set_First_Index); pragma Inline (Set_First_Literal); pragma Inline (Set_First_Optional_Parameter); @@ -7540,7 +7582,6 @@ package Einfo is pragma Inline (Set_Is_Private_Composite); pragma Inline (Set_Is_Private_Descendant); pragma Inline (Set_Is_Private_Primitive); - pragma Inline (Set_Is_Protected_Interface); pragma Inline (Set_Is_Public); pragma Inline (Set_Is_Pure); pragma Inline (Set_Is_Pure_Unit_Access_Type); @@ -7552,10 +7593,8 @@ package Einfo is pragma Inline (Set_Is_Return_Object); pragma Inline (Set_Is_Shared_Passive); pragma Inline (Set_Is_Statically_Allocated); - pragma Inline (Set_Is_Synchronized_Interface); pragma Inline (Set_Is_Tag); pragma Inline (Set_Is_Tagged_Type); - pragma Inline (Set_Is_Task_Interface); pragma Inline (Set_Is_Thunk); pragma Inline (Set_Is_Trivial_Subprogram); pragma Inline (Set_Is_True_Constant); diff --git a/gcc/ada/env.c b/gcc/ada/env.c index c8b49ebe122..c53678ab831 100644 --- a/gcc/ada/env.c +++ b/gcc/ada/env.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 2005-2009, Free Software Foundation, Inc. * + * Copyright (C) 2005-2010, Free Software Foundation, Inc. * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * @@ -107,9 +107,7 @@ typedef struct _ile3 void __gnat_setenv (char *name, char *value) { -#ifdef MSDOS - -#elif defined (VMS) +#if defined (VMS) struct descriptor_s name_desc; /* Put in JOB table for now, so that the project stuff at least works. */ struct descriptor_s table_desc = {7, 0, "LNM$JOB"}; diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 651b43d1122..e307ce7e44d 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -43,6 +43,7 @@ with Opt; use Opt; with Nlists; use Nlists; with Output; use Output; with Scans; use Scans; +with Sem_Aux; use Sem_Aux; with Sinput; use Sinput; with Sinfo; use Sinfo; with Snames; use Snames; @@ -176,25 +177,24 @@ package body Errout is -- If the message should be generated (the normal case) False is returned. procedure Unwind_Internal_Type (Ent : in out Entity_Id); - -- This procedure is given an entity id for an internal type, i.e. - -- a type with an internal name. It unwinds the type to try to get - -- to something reasonably printable, generating prefixes like - -- "subtype of", "access to", etc along the way in the buffer. The - -- value in Ent on return is the final name to be printed. Hopefully - -- this is not an internal name, but in some internal name cases, it - -- is an internal name, and has to be printed anyway (although in this - -- case the message has been killed if possible). The global variable - -- Class_Flag is set to True if the resulting entity should have - -- 'Class appended to its name (see Add_Class procedure), and is - -- otherwise unchanged. + -- This procedure is given an entity id for an internal type, i.e. a type + -- with an internal name. It unwinds the type to try to get to something + -- reasonably printable, generating prefixes like "subtype of", "access + -- to", etc along the way in the buffer. The value in Ent on return is the + -- final name to be printed. Hopefully this is not an internal name, but in + -- some internal name cases, it is an internal name, and has to be printed + -- anyway (although in this case the message has been killed if possible). + -- The global variable Class_Flag is set to True if the resulting entity + -- should have 'Class appended to its name (see Add_Class procedure), and + -- is otherwise unchanged. procedure VMS_Convert; - -- This procedure has no effect if called when the host is not OpenVMS. - -- If the host is indeed OpenVMS, then the error message stored in - -- Msg_Buffer is scanned for appearances of switch names which need - -- converting to corresponding VMS qualifier names. See Gnames/Vnames - -- table in Errout spec for precise definition of the conversion that - -- is performed by this routine in OpenVMS mode. + -- This procedure has no effect if called when the host is not OpenVMS. If + -- the host is indeed OpenVMS, then the error message stored in Msg_Buffer + -- is scanned for appearances of switch names which need converting to + -- corresponding VMS qualifier names. See Gnames/Vnames table in Errout + -- spec for precise definition of the conversion that is performed by this + -- routine in OpenVMS mode. ----------------------- -- Change_Error_Text -- @@ -242,10 +242,10 @@ package body Errout is --------------- -- Error_Msg posts a flag at the given location, except that if the - -- Flag_Location points within a generic template and corresponds - -- to an instantiation of this generic template, then the actual - -- message will be posted on the generic instantiation, along with - -- additional messages referencing the generic declaration. + -- Flag_Location points within a generic template and corresponds to an + -- instantiation of this generic template, then the actual message will be + -- posted on the generic instantiation, along with additional messages + -- referencing the generic declaration. procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is Sindex : Source_File_Index; @@ -256,8 +256,8 @@ package body Errout is -- template in instantiation case, otherwise unchanged). begin - -- It is a fatal error to issue an error message when scanning from - -- the internal source buffer (see Sinput for further documentation) + -- It is a fatal error to issue an error message when scanning from the + -- internal source buffer (see Sinput for further documentation) pragma Assert (Sinput.Source /= Internal_Source_Ptr); @@ -267,8 +267,8 @@ package body Errout is return; end if; - -- If we already have messages, and we are trying to place a message - -- at No_Location or in package Standard, then just ignore the attempt + -- If we already have messages, and we are trying to place a message at + -- No_Location or in package Standard, then just ignore the attempt -- since we assume that what is happening is some cascaded junk. Note -- that this is safe in the sense that proceeding will surely bomb. @@ -284,24 +284,23 @@ package body Errout is Test_Style_Warning_Serious_Msg (Msg); Orig_Loc := Original_Location (Flag_Location); - -- If the current location is in an instantiation, the issue arises - -- of whether to post the message on the template or the instantiation. + -- If the current location is in an instantiation, the issue arises of + -- whether to post the message on the template or the instantiation. - -- The way we decide is to see if we have posted the same message - -- on the template when we compiled the template (the template is - -- always compiled before any instantiations). For this purpose, - -- we use a separate table of messages. The reason we do this is - -- twofold: + -- The way we decide is to see if we have posted the same message on + -- the template when we compiled the template (the template is always + -- compiled before any instantiations). For this purpose, we use a + -- separate table of messages. The reason we do this is twofold: -- First, the messages can get changed by various processing -- including the insertion of tokens etc, making it hard to -- do the comparison. - -- Second, we will suppress a warning on a template if it is - -- not in the current extended source unit. That's reasonable - -- and means we don't want the warning on the instantiation - -- here either, but it does mean that the main error table - -- would not in any case include the message. + -- Second, we will suppress a warning on a template if it is not in + -- the current extended source unit. That's reasonable and means we + -- don't want the warning on the instantiation here either, but it + -- does mean that the main error table would not in any case include + -- the message. if Flag_Location = Orig_Loc then Non_Instance_Msgs.Append ((new String'(Msg), Flag_Location)); @@ -310,8 +309,8 @@ package body Errout is -- Here we have an instance message else - -- Delete if debug flag off, and this message duplicates a - -- message already posted on the corresponding template + -- Delete if debug flag off, and this message duplicates a message + -- already posted on the corresponding template if not Debug_Flag_GG then for J in Non_Instance_Msgs.First .. Non_Instance_Msgs.Last loop @@ -373,9 +372,9 @@ package body Errout is -- instantiation error message can be repeated, pointing to each -- of the relevant instantiations. - -- Note: the instantiation mechanism is also shared for inlining - -- of subprogram bodies when front end inlining is done. In this - -- case the messages have the form: + -- Note: the instantiation mechanism is also shared for inlining of + -- subprogram bodies when front end inlining is done. In this case the + -- messages have the form: -- in inlined body at ... -- original error message @@ -385,9 +384,8 @@ package body Errout is -- warning: in inlined body at -- warning: original warning message - -- OK, this is the case where we have an instantiation error, and - -- we need to generate the error on the instantiation, rather than - -- on the template. + -- OK, here we have an instantiation error, and we need to generate the + -- error on the instantiation, rather than on the template. declare Actual_Error_Loc : Source_Ptr; @@ -396,9 +394,9 @@ package body Errout is -- location where all error messages will actually be posted. Save_Error_Msg_Sloc : constant Source_Ptr := Error_Msg_Sloc; - -- Save possible location set for caller's message. We need to - -- use Error_Msg_Sloc for the location of the instantiation error - -- but we have to preserve a possible original value. + -- Save possible location set for caller's message. We need to use + -- Error_Msg_Sloc for the location of the instantiation error but we + -- have to preserve a possible original value. X : Source_File_Index; @@ -417,10 +415,9 @@ package body Errout is exit when Instantiation (X) = No_Location; end loop; - -- Since we are generating the messages at the instantiation - -- point in any case, we do not want the references to the - -- bad lines in the instance to be annotated with the location - -- of the instantiation. + -- Since we are generating the messages at the instantiation point in + -- any case, we do not want the references to the bad lines in the + -- instance to be annotated with the location of the instantiation. Suppress_Instance_Location := True; Msg_Cont_Status := False; @@ -679,10 +676,10 @@ package body Errout is Expander_Active := False; end if; - -- Set the fatal error flag in the unit table unless we are - -- in Try_Semantics mode. This stops the semantics from being - -- performed if we find a serious error. This is skipped if we - -- are currently dealing with the configuration pragma file. + -- Set the fatal error flag in the unit table unless we are in + -- Try_Semantics mode. This stops the semantics from being performed + -- if we find a serious error. This is skipped if we are currently + -- dealing with the configuration pragma file. if not Try_Semantics and then Current_Source_Unit /= No_Unit then Set_Fatal_Error (Get_Source_Unit (Sptr)); @@ -722,10 +719,10 @@ package body Errout is return; end if; - -- Return without doing anything if message is killed and this - -- is not the first error message. The philosophy is that if we - -- get a weird error message and we already have had a message, - -- then we hope the weird message is a junk cascaded message + -- Return without doing anything if message is killed and this is not + -- the first error message. The philosophy is that if we get a weird + -- error message and we already have had a message, then we hope the + -- weird message is a junk cascaded message if Kill_Message and then not All_Errors_Mode @@ -749,15 +746,15 @@ package body Errout is return; end if; - -- If the flag location is in the main extended source unit - -- then for sure we want the warning since it definitely belongs + -- If the flag location is in the main extended source unit then for + -- sure we want the warning since it definitely belongs if In_Extended_Main_Source_Unit (Sptr) then null; - -- If the flag location is not in the main extended source unit, - -- then we want to eliminate the warning, unless it is in the - -- extended main code unit and we want warnings on the instance. + -- If the flag location is not in the main extended source unit, then + -- we want to eliminate the warning, unless it is in the extended + -- main code unit and we want warnings on the instance. elsif In_Extended_Main_Code_Unit (Sptr) and then Warn_On_Instance then null; @@ -884,6 +881,7 @@ package body Errout is Errors.Append ((Text => new String'(Msg_Buffer (1 .. Msglen)), Next => No_Error_Msg, + Prev => No_Error_Msg, Sptr => Sptr, Optr => Optr, Sfile => Get_Source_File_Index (Sptr), @@ -1217,7 +1215,34 @@ package body Errout is Nxt : Error_Msg_Id; F : Error_Msg_Id; + procedure Delete_Warning (E : Error_Msg_Id); + -- Delete a message if not already deleted and adjust warning count + + -------------------- + -- Delete_Warning -- + -------------------- + + procedure Delete_Warning (E : Error_Msg_Id) is + begin + if not Errors.Table (E).Deleted then + Errors.Table (E).Deleted := True; + Warnings_Detected := Warnings_Detected - 1; + end if; + end Delete_Warning; + + -- Start of message for Finalize + begin + -- Set Prev pointers + + Cur := First_Error_Msg; + while Cur /= No_Error_Msg loop + Nxt := Errors.Table (Cur).Next; + exit when Nxt = No_Error_Msg; + Errors.Table (Nxt).Prev := Cur; + Cur := Nxt; + end loop; + -- Eliminate any duplicated error messages from the list. This is -- done after the fact to avoid problems with Change_Error_Text. @@ -1242,11 +1267,27 @@ package body Errout is while Cur /= No_Error_Msg loop if not Errors.Table (Cur).Deleted and then Warning_Specifically_Suppressed - (Errors.Table (Cur).Sptr, - Errors.Table (Cur).Text) + (Errors.Table (Cur).Sptr, Errors.Table (Cur).Text) then - Errors.Table (Cur).Deleted := True; - Warnings_Detected := Warnings_Detected - 1; + Delete_Warning (Cur); + + -- If this is a continuation, delete previous messages + + F := Cur; + while Errors.Table (F).Msg_Cont loop + F := Errors.Table (F).Prev; + Delete_Warning (F); + end loop; + + -- Delete any following continuations + + F := Cur; + loop + F := Errors.Table (F).Next; + exit when F = No_Error_Msg; + exit when not Errors.Table (F).Msg_Cont; + Delete_Warning (F); + end loop; end if; Cur := Errors.Table (Cur).Next; @@ -1325,13 +1366,12 @@ package body Errout is S := Sloc (F); -- The following circuit is a bit subtle. When we have parenthesized - -- expressions, then the Sloc will not record the location of the - -- paren, but we would like to post the flag on the paren. So what - -- we do is to crawl up the tree from the First_Node, adjusting the - -- Sloc value for any parentheses we know are present. Yes, we know - -- this circuit is not 100% reliable (e.g. because we don't record - -- all possible paren level values), but this is only for an error - -- message so it is good enough. + -- expressions, then the Sloc will not record the location of the paren, + -- but we would like to post the flag on the paren. So what we do is to + -- crawl up the tree from the First_Node, adjusting the Sloc value for + -- any parentheses we know are present. Yes, we know this circuit is not + -- 100% reliable (e.g. because we don't record all possible paren level + -- values), but this is only for an error message so it is good enough. Node_Loop : loop Paren_Loop : for J in 1 .. Paren_Count (F) loop @@ -1378,8 +1418,8 @@ package body Errout is Cur_Msg := No_Error_Msg; List_Pragmas.Init; - -- Initialize warnings table, if all warnings are suppressed, supply - -- an initial dummy entry covering all possible source locations. + -- Initialize warnings table, if all warnings are suppressed, supply an + -- initial dummy entry covering all possible source locations. Warnings.Init; Specific_Warnings.Init; @@ -2100,12 +2140,12 @@ package body Errout is Flen := Flen + 1; end loop; - -- Loop through file names to find matching one. This is a bit slow, - -- but we only do it in error situations so it is not so terrible. - -- Note that if the loop does not exit, then the desired case will - -- be left set to Mixed_Case, this can happen if the name was not - -- in canonical form, and gets canonicalized on VMS. Possibly we - -- could fix this by unconditinally canonicalizing these names ??? + -- Loop through file names to find matching one. This is a bit slow, but + -- we only do it in error situations so it is not so terrible. Note that + -- if the loop does not exit, then the desired case will be left set to + -- Mixed_Case, this can happen if the name was not in canonical form, + -- and gets canonicalized on VMS. Possibly we could fix this by + -- unconditinally canonicalizing these names ??? for J in 1 .. Last_Source_File loop Get_Name_String (Full_Debug_Name (J)); @@ -2185,9 +2225,9 @@ package body Errout is K := Nkind (Error_Msg_Node_1); -- If we have operator case, skip quotes since name of operator - -- itself will supply the required quotations. An operator can be - -- an applied use in an expression or an explicit operator symbol, - -- or an identifier whose name indicates it is an operator. + -- itself will supply the required quotations. An operator can be an + -- applied use in an expression or an explicit operator symbol, or an + -- identifier whose name indicates it is an operator. if K in N_Op or else K = N_Operator_Symbol @@ -2333,8 +2373,8 @@ package body Errout is Set_Msg_Node (Ent); Add_Class; - -- If Ent is an anonymous subprogram type, there is no name - -- to print, so remove enclosing quotes. + -- If Ent is an anonymous subprogram type, there is no name to print, + -- so remove enclosing quotes. if Buffer_Ends_With ("""") then Buffer_Remove (""""); @@ -2343,8 +2383,8 @@ package body Errout is end if; end if; - -- If the original type did not come from a predefined - -- file, add the location where the type was defined. + -- If the original type did not come from a predefined file, add the + -- location where the type was defined. if Sloc (Error_Msg_Node_1) > Standard_Location and then @@ -2504,7 +2544,7 @@ package body Errout is -- in case, which is the case when we can copy from the source. declare - Src_Loc : constant Source_Ptr := Sloc (Error_Msg_Node_1); + Src_Loc : constant Source_Ptr := Sloc (Node); Sbuffer : Source_Buffer_Ptr; Ref_Ptr : Integer; Src_Ptr : Source_Ptr; @@ -2521,9 +2561,9 @@ package body Errout is Set_Casing (Mixed_Case); else - -- Determine if the reference we are dealing with corresponds - -- to text at the point of the error reference. This will often - -- be the case for simple identifier references, and is the case + -- Determine if the reference we are dealing with corresponds to + -- text at the point of the error reference. This will often be + -- the case for simple identifier references, and is the case -- where we can copy the spelling from the source. Sbuffer := Source_Text (Get_Source_File_Index (Src_Loc)); @@ -2536,8 +2576,8 @@ package body Errout is Src_Ptr := Src_Ptr + 1; end loop; - -- If we get through the loop without a mismatch, then output - -- the name the way it is spelled in the source program + -- If we get through the loop without a mismatch, then output the + -- name the way it is spelled in the source program if Ref_Ptr > Name_Len then Src_Ptr := Src_Loc; @@ -2572,8 +2612,8 @@ package body Errout is Is_Unconditional_Msg := False; Msglen := 0; Flag_Source := Get_Source_File_Index (Flag); - P := Text'First; + P := Text'First; while P <= Text'Last loop C := Text (P); P := P + 1; @@ -2829,7 +2869,7 @@ package body Errout is -- "type derived from" message more than once in the case where we climb -- up multiple levels. - loop + Find : loop Old_Ent := Ent; -- Implicit access type, use directly designated type In Ada 2005, @@ -2877,7 +2917,7 @@ package body Errout is Set_Msg_Str ("access to procedure "); end if; - exit; + exit Find; -- Type is access to object, named or anonymous @@ -2915,51 +2955,54 @@ package body Errout is -- itself an internal name. This avoids the obvious loop (subtype -> -- basetype -> subtype) which would otherwise occur!) - elsif Present (Freeze_Node (Ent)) - and then Present (First_Subtype_Link (Freeze_Node (Ent))) - and then - not Is_Internal_Name - (Chars (First_Subtype_Link (Freeze_Node (Ent)))) - then - Ent := First_Subtype_Link (Freeze_Node (Ent)); + else + declare + FST : constant Entity_Id := First_Subtype (Ent); - -- Otherwise use root type + begin + if not Is_Internal_Name (Chars (FST)) then + Ent := FST; + exit Find; - else - if not Derived then - Buffer_Remove ("type "); + -- Otherwise use root type - -- Test for "subtype of type derived from" which seems - -- excessive and is replaced by simply "type derived from" + else + if not Derived then + Buffer_Remove ("type "); - Buffer_Remove ("subtype of"); + -- Test for "subtype of type derived from" which seems + -- excessive and is replaced by "type derived from". - -- Avoid duplication "type derived from type derived from" + Buffer_Remove ("subtype of"); - if not Buffer_Ends_With ("type derived from ") then - Set_Msg_Str ("type derived from "); - end if; + -- Avoid duplicated "type derived from type derived from" - Derived := True; - end if; + if not Buffer_Ends_With ("type derived from ") then + Set_Msg_Str ("type derived from "); + end if; + + Derived := True; + end if; + end if; + end; Ent := Etype (Ent); end if; -- If we are stuck in a loop, get out and settle for the internal - -- name after all. In this case we set to kill the message if it - -- is not the first error message (we really try hard not to show - -- the dirty laundry of the implementation to the poor user!) + -- name after all. In this case we set to kill the message if it is + -- not the first error message (we really try hard not to show the + -- dirty laundry of the implementation to the poor user!) if Ent = Old_Ent then Kill_Message := True; - exit; + exit Find; end if; -- Get out if we finally found a non-internal name to use - exit when not Is_Internal_Name (Chars (Ent)); - end loop; + exit Find when not Is_Internal_Name (Chars (Ent)); + end loop Find; if Mchar = '"' then Set_Msg_Char ('"'); diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index e4d8a62e6dc..8251126f341 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -376,6 +376,9 @@ package Errout is Gname5 : aliased constant String := "gnat05"; Vname5 : aliased constant String := "05"; + Gname6 : aliased constant String := "gnat12"; + Vname6 : aliased constant String := "12"; + type Cstring_Ptr is access constant String; Gnames : array (Nat range <>) of Cstring_Ptr := @@ -383,14 +386,16 @@ package Errout is Gname2'Access, Gname3'Access, Gname4'Access, - Gname5'Access); + Gname5'Access, + Gname6'Access); Vnames : array (Nat range <>) of Cstring_Ptr := (Vname1'Access, Vname2'Access, Vname3'Access, Vname4'Access, - Vname5'Access); + Vname5'Access, + Vname6'Access); ----------------------------------------------------- -- Global Values Used for Error Message Insertions -- @@ -601,13 +606,6 @@ package Errout is -- without appropriate coordination. If new messages are added which may -- be susceptible to automatic codefix action, they are marked using: - -- Error_Msg -- CODEFIX??? - -- (parameters) - - -- And subsequently either the appropriate code is added to codefix and the - -- ??? are removed, or it is determined that this is not an appropriate - -- case for codefix action, and the comment is removed. - ------------------------------ -- Error Output Subprograms -- ------------------------------ diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads index f2127deaa39..d7628ed01ca 100644 --- a/gcc/ada/erroutc.ads +++ b/gcc/ada/erroutc.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -147,6 +147,11 @@ package Erroutc is -- Pointer to next message in error chain. A value of No_Error_Msg -- indicates the end of the chain. + Prev : Error_Msg_Id; + -- Pointer to previous message in error chain. Only set during the + -- Finalize procedure. A value of No_Error_Msg indicates the first + -- message in the chain. + Sfile : Source_File_Index; -- Source table index of source file. In the case of an error that -- refers to a template, always references the original template diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 6e3edc192b9..36045190d53 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -93,7 +93,7 @@ package body Exp_Aggr is function Has_Default_Init_Comps (N : Node_Id) return Boolean; -- N is an aggregate (record or array). Checks the presence of default - -- initialization (<>) in any component (Ada 2005: AI-287) + -- initialization (<>) in any component (Ada 2005: AI-287). function Is_Static_Dispatch_Table_Aggregate (N : Node_Id) return Boolean; -- Returns true if N is an aggregate used to initialize the components @@ -173,14 +173,15 @@ package body Exp_Aggr is ----------------------------------------------------- function Aggr_Size_OK (N : Node_Id; Typ : Entity_Id) return Boolean; - -- Very large static aggregates present problems to the back-end, and - -- are transformed into assignments and loops. This function verifies - -- that the total number of components of an aggregate is acceptable - -- for transformation into a purely positional static form. It is called - -- prior to calling Flatten. - -- This function also detects and warns about one-component aggregates - -- that appear in a non-static context. Even if the component value is - -- static, such an aggregate must be expanded into an assignment. + -- Very large static aggregates present problems to the back-end, and are + -- transformed into assignments and loops. This function verifies that the + -- total number of components of an aggregate is acceptable for rewriting + -- into a purely positional static form. Aggr_Size_OK must be called before + -- calling Flatten. + -- + -- This function also detects and warns about one-component aggregates that + -- appear in a non-static context. Even if the component value is static, + -- such an aggregate must be expanded into an assignment. procedure Convert_Array_Aggr_In_Allocator (Decl : Node_Id; @@ -1347,7 +1348,7 @@ package body Exp_Aggr is -- Otherwise construct the loop, starting with the loop index L_J - L_J := Make_Defining_Identifier (Loc, New_Internal_Name ('J')); + L_J := Make_Temporary (Loc, 'J', L); -- Construct "L .. H" in Index_Base. We use a qualified expression -- for the bound to convert to the index base, but we don't need @@ -1455,7 +1456,7 @@ package body Exp_Aggr is -- Build the decl of W_J - W_J := Make_Defining_Identifier (Loc, New_Internal_Name ('J')); + W_J := Make_Temporary (Loc, 'J', L); W_Decl := Make_Object_Declaration (Loc, @@ -2426,14 +2427,16 @@ package body Exp_Aggr is function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result is begin - if Nkind (Expr) = N_Identifier + if Is_Entity_Name (Expr) and then Present (Entity (Expr)) and then Ekind (Entity (Expr)) = E_In_Parameter and then Present (Discriminal_Link (Entity (Expr))) + and then Scope (Discriminal_Link (Entity (Expr))) + = Base_Type (Etype (N)) then Rewrite (Expr, Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Obj, Loc), + Prefix => New_Copy_Tree (Lhs), Selector_Name => Make_Identifier (Loc, Chars (Expr)))); end if; return OK; @@ -2860,14 +2863,14 @@ package body Exp_Aggr is if Is_CPP_Constructor_Call (Expression (Comp)) then Append_List_To (L, Build_Initialization_Call (Loc, - Id_Ref => Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Target), - Selector_Name => New_Occurrence_Of (Selector, - Loc)), - Typ => Etype (Selector), - Enclos_Type => Typ, + Id_Ref => Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => + New_Occurrence_Of (Selector, Loc)), + Typ => Etype (Selector), + Enclos_Type => Typ, With_Default_Init => True, - Constructor_Ref => Expression (Comp))); + Constructor_Ref => Expression (Comp))); -- Ada 2005 (AI-287): For each default-initialized component generate -- a call to the corresponding IP subprogram if available. @@ -2886,8 +2889,8 @@ package body Exp_Aggr is declare Ctype : constant Entity_Id := Etype (Selector); - Inside_Allocator : Boolean := False; - P : Node_Id := Parent (N); + Inside_Allocator : Boolean := False; + P : Node_Id := Parent (N); begin if Is_Task_Type (Ctype) or else Has_Task (Ctype) then @@ -2908,12 +2911,12 @@ package body Exp_Aggr is Append_List_To (L, Build_Initialization_Call (Loc, - Id_Ref => Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Target), - Selector_Name => New_Occurrence_Of (Selector, - Loc)), - Typ => Etype (Selector), - Enclos_Type => Typ, + Id_Ref => Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => + New_Occurrence_Of (Selector, Loc)), + Typ => Etype (Selector), + Enclos_Type => Typ, With_Default_Init => True)); -- Prepare for component assignment @@ -3008,9 +3011,7 @@ package body Exp_Aggr is -- the corresponding aggregate. declare - SubE : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); + SubE : constant Entity_Id := Make_Temporary (Loc, 'T'); SubD : constant Node_Id := Make_Subtype_Declaration (Loc, @@ -3784,10 +3785,11 @@ package body Exp_Aggr is Rep_Count : Nat; -- Used to validate Max_Others_Replicate limit - Elmt : Node_Id; - Num : Int := UI_To_Int (Lov); - Choice : Node_Id; - Lo, Hi : Node_Id; + Elmt : Node_Id; + Num : Int := UI_To_Int (Lov); + Choice_Index : Int; + Choice : Node_Id; + Lo, Hi : Node_Id; begin if Present (Expressions (N)) then @@ -3913,9 +3915,18 @@ package body Exp_Aggr is return False; else - Vals (UI_To_Int (Expr_Value (Choice))) := - New_Copy_Tree (Expression (Elmt)); - goto Continue; + Choice_Index := UI_To_Int (Expr_Value (Choice)); + if Choice_Index in Vals'Range then + Vals (Choice_Index) := + New_Copy_Tree (Expression (Elmt)); + goto Continue; + + else + -- Choice is statically out-of-range, will be + -- rewritten to raise Constraint_Error. + + return False; + end if; end if; end if; @@ -4122,12 +4133,6 @@ package body Exp_Aggr is -- array sub-aggregate we start the computation from. Dim is the -- dimension corresponding to the sub-aggregate. - function Has_Address_Clause (D : Node_Id) return Boolean; - -- If the aggregate is the expression in an object declaration, it - -- cannot be expanded in place. This function does a lookahead in the - -- current declarative part to find an address clause for the object - -- being declared. - function In_Place_Assign_OK return Boolean; -- Simple predicate to determine whether an aggregate assignment can -- be done in place, because none of the new values can depend on the @@ -4145,7 +4150,7 @@ package body Exp_Aggr is procedure Build_Constrained_Type (Positional : Boolean) is Loc : constant Source_Ptr := Sloc (N); - Agg_Type : Entity_Id; + Agg_Type : constant Entity_Id := Make_Temporary (Loc, 'A'); Comp : Node_Id; Decl : Node_Id; Typ : constant Entity_Id := Etype (N); @@ -4154,10 +4159,6 @@ package body Exp_Aggr is Sub_Agg : Node_Id; begin - Agg_Type := - Make_Defining_Identifier ( - Loc, New_Internal_Name ('A')); - -- If the aggregate is purely positional, all its subaggregates -- have the same size. We collect the dimensions from the first -- subaggregate at each level. @@ -4175,19 +4176,16 @@ package body Exp_Aggr is Next (Comp); end loop; - Append ( + Append_To (Indices, Make_Range (Loc, - Low_Bound => Make_Integer_Literal (Loc, 1), - High_Bound => - Make_Integer_Literal (Loc, Num)), - Indices); + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => Make_Integer_Literal (Loc, Num))); end loop; else -- We know the aggregate type is unconstrained and the aggregate -- is not processable by the back end, therefore not necessarily -- positional. Retrieve each dimension bounds (computed earlier). - -- earlier. for D in 1 .. Number_Dimensions (Typ) loop Append ( @@ -4434,35 +4432,6 @@ package body Exp_Aggr is end if; end Compute_Others_Present; - ------------------------ - -- Has_Address_Clause -- - ------------------------ - - function Has_Address_Clause (D : Node_Id) return Boolean is - Id : constant Entity_Id := Defining_Identifier (D); - Decl : Node_Id; - - begin - Decl := Next (D); - while Present (Decl) loop - if Nkind (Decl) = N_At_Clause - and then Chars (Identifier (Decl)) = Chars (Id) - then - return True; - - elsif Nkind (Decl) = N_Attribute_Definition_Clause - and then Chars (Decl) = Name_Address - and then Chars (Name (Decl)) = Chars (Id) - then - return True; - end if; - - Next (Decl); - end loop; - - return False; - end Has_Address_Clause; - ------------------------ -- In_Place_Assign_OK -- ------------------------ @@ -5162,6 +5131,8 @@ package body Exp_Aggr is Build_Activation_Chain_Entity (N); end if; + -- Should document these individual tests ??? + if not Has_Default_Init_Comps (N) and then Comes_From_Source (Parent (N)) and then Nkind (Parent (N)) = N_Object_Declaration @@ -5170,7 +5141,13 @@ package body Exp_Aggr is and then N = Expression (Parent (N)) and then not Is_Bit_Packed_Array (Typ) and then not Has_Controlled_Component (Typ) - and then not Has_Address_Clause (Parent (N)) + + -- If the aggregate is the expression in an object declaration, it + -- cannot be expanded in place. Lookahead in the current declarative + -- part to find an address clause for the object being declared. If + -- one is present, we cannot build in place. Unclear comment??? + + and then not Has_Following_Address_Clause (Parent (N)) then Tmp := Defining_Identifier (Parent (N)); Set_No_Initialization (Parent (N)); @@ -5720,9 +5697,7 @@ package body Exp_Aggr is Decl := Make_Subtype_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - New_Internal_Name ('T')), + Defining_Identifier => Make_Temporary (Loc, 'T'), Subtype_Indication => Make_Subtype_Indication (Loc, Subtype_Mark => @@ -6411,9 +6386,8 @@ package body Exp_Aggr is and then Nkind (First (Choices (First (Component_Associations (N))))) = N_Others_Choice then - Expr := - Expression (First (Component_Associations (N))); - L_J := Make_Defining_Identifier (Loc, New_Internal_Name ('J')); + Expr := Expression (First (Component_Associations (N))); + L_J := Make_Temporary (Loc, 'J'); L_Iter := Make_Iteration_Scheme (Loc, diff --git a/gcc/ada/exp_atag.adb b/gcc/ada/exp_atag.adb index d5cdf0b79b7..23a9202c372 100644 --- a/gcc/ada/exp_atag.adb +++ b/gcc/ada/exp_atag.adb @@ -150,14 +150,10 @@ package body Exp_Atag is Related_Nod : Node_Id; New_Node : out Node_Id) is - Tag_Addr : constant Entity_Id := Make_Defining_Identifier (Loc, - New_Internal_Name ('D')); - Obj_TSD : constant Entity_Id := Make_Defining_Identifier (Loc, - New_Internal_Name ('D')); - Typ_TSD : constant Entity_Id := Make_Defining_Identifier (Loc, - New_Internal_Name ('D')); - Index : constant Entity_Id := Make_Defining_Identifier (Loc, - New_Internal_Name ('D')); + Tag_Addr : constant Entity_Id := Make_Temporary (Loc, 'D', Obj_Tag_Node); + Obj_TSD : constant Entity_Id := Make_Temporary (Loc, 'D'); + Typ_TSD : constant Entity_Id := Make_Temporary (Loc, 'D'); + Index : constant Entity_Id := Make_Temporary (Loc, 'D'); begin -- Generate: diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 48bd566b38b..5126e5a1730 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -280,16 +280,14 @@ package body Exp_Attr is -- Start of processing for Expand_Access_To_Protected_Op begin - -- Within the body of the protected type, the prefix - -- designates a local operation, and the object is the first - -- parameter of the corresponding protected body of the - -- current enclosing operation. + -- Within the body of the protected type, the prefix designates a local + -- operation, and the object is the first parameter of the corresponding + -- protected body of the current enclosing operation. if Is_Entity_Name (Pref) then if May_Be_External_Call then Sub := - New_Occurrence_Of - (External_Subprogram (Entity (Pref)), Loc); + New_Occurrence_Of (External_Subprogram (Entity (Pref)), Loc); else Sub := New_Occurrence_Of @@ -372,6 +370,7 @@ package body Exp_Attr is Make_Aggregate (Loc, Expressions => New_List (Obj_Ref, Sub_Ref)); + Freeze_Before (N, Entity (Sub)); Rewrite (N, Agg); Analyze_And_Resolve (N, E_T); @@ -530,9 +529,7 @@ package body Exp_Attr is and then Is_Written then declare - Temp : constant Entity_Id := - Make_Defining_Identifier - (Loc, New_Internal_Name ('V')); + Temp : constant Entity_Id := Make_Temporary (Loc, 'V'); Decl : Node_Id; Assn : Node_Id; @@ -1208,6 +1205,20 @@ package body Exp_Attr is Analyze_And_Resolve (N, RTE (RE_AST_Handler)); end AST_Entry; + --------- + -- Bit -- + --------- + + -- We compute this if a packed array reference was present, otherwise we + -- leave the computation up to the back end. + + when Attribute_Bit => + if Involves_Packed_Array_Reference (Pref) then + Expand_Packed_Bit_Reference (N); + else + Apply_Universal_Integer_Attribute_Checks (N); + end if; + ------------------ -- Bit_Position -- ------------------ @@ -1220,8 +1231,7 @@ package body Exp_Attr is -- in generated code (i.e. the prefix is an identifier that -- references the component or discriminant entity). - when Attribute_Bit_Position => Bit_Position : - declare + when Attribute_Bit_Position => Bit_Position : declare CE : Entity_Id; begin @@ -1259,12 +1269,11 @@ package body Exp_Attr is -- subprogram spec or package. This sequence of code references the -- the unsigned constant created in the main program by the binder. - -- A special exception occurs for Standard, where the string - -- returned is a copy of the library string in gnatvsn.ads. + -- A special exception occurs for Standard, where the string returned + -- is a copy of the library string in gnatvsn.ads. when Attribute_Body_Version | Attribute_Version => Version : declare - E : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('V')); + E : constant Entity_Id := Make_Temporary (Loc, 'V'); Pent : Entity_Id; S : String_Id; @@ -1777,9 +1786,7 @@ package body Exp_Attr is Attribute_Elab_Spec => Elab_Body : declare - Ent : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('E')); + Ent : constant Entity_Id := Make_Temporary (Loc, 'E'); Str : String_Id; Lang : Node_Id; @@ -2389,13 +2396,14 @@ package body Exp_Attr is Rtyp : constant Entity_Id := Root_Type (P_Type); Dnn : Entity_Id; Decl : Node_Id; + Expr : Node_Id; begin -- Read the internal tag (RM 13.13.2(34)) and use it to -- initialize a dummy tag object: - -- Dnn : Ada.Tags.Tag - -- := Descendant_Tag (String'Input (Strm), P_Type); + -- Dnn : Ada.Tags.Tag := + -- Descendant_Tag (String'Input (Strm), P_Type); -- This dummy object is used only to provide a controlling -- argument for the eventual _Input call. Descendant_Tag is @@ -2406,30 +2414,28 @@ package body Exp_Attr is -- required for Ada 2005 because tagged types can be -- extended in nested scopes (AI-344). - Dnn := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('D')); + Expr := + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Descendant_Tag), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Standard_String, Loc), + Attribute_Name => Name_Input, + Expressions => New_List ( + Relocate_Node (Duplicate_Subexpr (Strm)))), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (P_Type, Loc), + Attribute_Name => Name_Tag))); + + Dnn := Make_Temporary (Loc, 'D', Expr); Decl := Make_Object_Declaration (Loc, Defining_Identifier => Dnn, - Object_Definition => + Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc), - Expression => - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Descendant_Tag), Loc), - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Standard_String, Loc), - Attribute_Name => Name_Input, - Expressions => New_List ( - Relocate_Node - (Duplicate_Subexpr (Strm)))), - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (P_Type, Loc), - Attribute_Name => Name_Tag)))); + Expression => Expr); Insert_Action (N, Decl); @@ -2440,8 +2446,9 @@ package body Exp_Attr is -- tagged object). Fname := Find_Prim_Op (Rtyp, TSS_Stream_Input); - Cntrl := Unchecked_Convert_To (P_Type, - New_Occurrence_Of (Dnn, Loc)); + Cntrl := + Unchecked_Convert_To (P_Type, + New_Occurrence_Of (Dnn, Loc)); Set_Etype (Cntrl, P_Type); Set_Parent (Cntrl, N); end; @@ -2987,9 +2994,7 @@ package body Exp_Attr is --------- when Attribute_Old => Old : declare - Tnn : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); + Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', Pref); Subp : Node_Id; Asn_Stm : Node_Id; @@ -3239,9 +3244,9 @@ package body Exp_Attr is -- For enumeration types with a standard representation, Pos is -- handled by the back end. - -- For enumeration types, with a non-standard representation we - -- generate a call to the _Rep_To_Pos function created when the - -- type was frozen. The call has the form + -- For enumeration types, with a non-standard representation we generate + -- a call to the _Rep_To_Pos function created when the type was frozen. + -- The call has the form -- _rep_to_pos (expr, flag) @@ -3548,6 +3553,7 @@ package body Exp_Attr is ------------------ when Attribute_Range_Length => Range_Length : begin + -- The only special processing required is for the case where -- Range_Length is applied to an enumeration type with holes. -- In this case we transform @@ -3586,8 +3592,7 @@ package body Exp_Attr is Attribute_Name => Name_First, Prefix => New_Occurrence_Of (Ptyp, Loc))))), - Right_Opnd => - Make_Integer_Literal (Loc, 1))); + Right_Opnd => Make_Integer_Literal (Loc, 1))); Analyze_And_Resolve (N, Typ); @@ -3707,7 +3712,7 @@ package body Exp_Attr is Rewrite (N, Make_Assignment_Statement (Loc, - Name => Lhs, + Name => Lhs, Expression => Rhs)); Analyze (N); @@ -3785,9 +3790,7 @@ package body Exp_Attr is -- the context of a _Postcondition function with a _Result parameter. when Attribute_Result => - Rewrite (N, - Make_Identifier (Loc, - Chars => Name_uResult)); + Rewrite (N, Make_Identifier (Loc, Chars => Name_uResult)); Analyze_And_Resolve (N, Typ); ----------- @@ -4267,8 +4270,7 @@ package body Exp_Attr is -- 2. For floating-point, generate call to attribute function -- 3. For other cases, deal with constraint checking - when Attribute_Succ => Succ : - declare + when Attribute_Succ => Succ : declare Etyp : constant Entity_Id := Base_Type (Ptyp); begin @@ -4360,8 +4362,7 @@ package body Exp_Attr is -- Transforms X'Tag into a direct reference to the tag of X - when Attribute_Tag => Tag : - declare + when Attribute_Tag => Tag : declare Ttyp : Entity_Id; Prefix_Is_Type : Boolean; @@ -4555,8 +4556,7 @@ package body Exp_Attr is ----------------- when Attribute_UET_Address => UET_Address : declare - Ent : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('T')); + Ent : constant Entity_Id := Make_Temporary (Loc, 'T'); begin Insert_Action (N, @@ -4609,8 +4609,7 @@ package body Exp_Attr is -- with a non-standard representation we use the _Pos_To_Rep array that -- was created when the type was frozen. - when Attribute_Val => Val : - declare + when Attribute_Val => Val : declare Etyp : constant Entity_Id := Base_Type (Entity (Pref)); begin @@ -4673,8 +4672,7 @@ package body Exp_Attr is -- The code for valid is dependent on the particular types involved. -- See separate sections below for the generated code in each case. - when Attribute_Valid => Valid : - declare + when Attribute_Valid => Valid : declare Btyp : Entity_Id := Base_Type (Ptyp); Tst : Node_Id; @@ -4734,6 +4732,13 @@ package body Exp_Attr is -- Start of processing for Attribute_Valid begin + -- Do not expand sourced code 'Valid reference in CodePeer mode, + -- will be handled by the back-end directly. + + if CodePeer_Mode and then Comes_From_Source (N) then + return; + end if; + -- Turn off validity checks. We do not want any implicit validity -- checks to intefere with the explicit check from the attribute @@ -5278,7 +5283,6 @@ package body Exp_Attr is -- that the result is in range. when Attribute_Aft | - Attribute_Bit | Attribute_Max_Size_In_Storage_Elements => Apply_Universal_Integer_Attribute_Checks (N); diff --git a/gcc/ada/exp_cg.adb b/gcc/ada/exp_cg.adb new file mode 100644 index 00000000000..e7decc8f1e7 --- /dev/null +++ b/gcc/ada/exp_cg.adb @@ -0,0 +1,602 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT 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 distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Debug; use Debug; +with Einfo; use Einfo; +with Elists; use Elists; +with Exp_Disp; use Exp_Disp; +with Exp_Dbug; use Exp_Dbug; +with Exp_Tss; use Exp_Tss; +with Lib; use Lib; +with Namet; use Namet; +with Opt; use Opt; +with Output; use Output; +with Sem_Aux; use Sem_Aux; +with Sem_Disp; use Sem_Disp; +with Sem_Type; use Sem_Type; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Snames; use Snames; +with System; use System; +with Table; +with Uintp; use Uintp; + +package body Exp_CG is + + -- We duplicate here some declarations from packages Interfaces.C and + -- Interfaces.C_Streams because adding their dependence to the frontend + -- causes bootstrapping problems with old versions of the compiler. + + subtype FILEs is System.Address; + -- Corresponds to the C type FILE* + + subtype C_chars is System.Address; + -- Pointer to null-terminated array of characters + + function fputs (Strng : C_chars; Stream : FILEs) return Integer; + pragma Import (C, fputs, "fputs"); + + -- Import the file stream associated with the "ci" output file. Done to + -- generate the output in the file created and left opened by routine + -- toplev.c before calling gnat1drv. + + Callgraph_Info_File : FILEs; + pragma Import (C, Callgraph_Info_File); + + package Call_Graph_Nodes is new Table.Table ( + Table_Component_Type => Node_Id, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 50, + Table_Increment => 100, + Table_Name => "Call_Graph_Nodes"); + -- This table records nodes associated with dispatching calls and tagged + -- type declarations found in the main compilation unit. Used as an + -- auxiliary storage because the call-graph output requires fully qualified + -- names and they are not available until the backend is called. + + function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean; + -- Determines if E is a predefined primitive operation. + -- Note: This routine should replace the routine with the same name that is + -- currently available in exp_disp because it extends its functionality to + -- handle fully qualified names ??? + + function Slot_Number (Prim : Entity_Id) return Uint; + -- Returns the slot number associated with Prim. For predefined primitives + -- the slot is returned as a negative number. + + procedure Write_Output (Str : String); + -- Used to print a line in the output file (this is used as the + -- argument for a call to Set_Special_Output in package Output). + + procedure Write_Call_Info (Call : Node_Id); + -- Subsidiary of Generate_CG_Output that generates the output associated + -- with a dispatching call. + + procedure Write_Type_Info (Typ : Entity_Id); + -- Subsidiary of Generate_CG_Output that generates the output associated + -- with a tagged type declaration. + + ------------------------ + -- Generate_CG_Output -- + ------------------------ + + procedure Generate_CG_Output is + N : Node_Id; + + begin + -- No output if the "ci" output file has not been previously opened + -- by toplev.c. Temporarily the output is also disabled with -gnatd.Z + + if Callgraph_Info_File = Null_Address + or else not Debug_Flag_Dot_ZZ + then + return; + end if; + + -- Setup write routine, create the output file and generate the output + + Set_Special_Output (Write_Output'Access); + + for J in Call_Graph_Nodes.First .. Call_Graph_Nodes.Last loop + N := Call_Graph_Nodes.Table (J); + + if Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call) then + Write_Call_Info (N); + + else pragma Assert (Nkind (N) = N_Defining_Identifier); + pragma Assert (Is_Tagged_Type (N)); + + Write_Type_Info (N); + end if; + end loop; + + Set_Special_Output (null); + end Generate_CG_Output; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Call_Graph_Nodes.Init; + end Initialize; + + ----------------------------------------- + -- Is_Predefined_Dispatching_Operation -- + ----------------------------------------- + + function Is_Predefined_Dispatching_Operation + (E : Entity_Id) return Boolean + is + function Homonym_Suffix_Length (E : Entity_Id) return Natural; + -- Returns the length of the homonym suffix corresponding to E. + -- Note: This routine relies on the functionality provided by routines + -- of Exp_Dbug. Further work needed here to decide if it should be + -- located in that package??? + + --------------------------- + -- Homonym_Suffix_Length -- + --------------------------- + + function Homonym_Suffix_Length (E : Entity_Id) return Natural is + Prefix_Length : constant := 2; -- Length of prefix "__" + + H : Entity_Id; + Nr : Nat := 1; + + begin + if not Has_Homonym (E) then + return 0; + + else + H := Homonym (E); + while Present (H) loop + if Scope (H) = Scope (E) then + Nr := Nr + 1; + end if; + + H := Homonym (H); + end loop; + + if Nr = 1 then + return 0; + + -- Prefix "__" followed by number + + else + declare + Result : Natural := Prefix_Length + 1; + begin + while Nr > 10 loop + Result := Result + 1; + Nr := Nr / 10; + end loop; + return Result; + end; + end if; + end if; + end Homonym_Suffix_Length; + + -- Local variables + + Full_Name : constant String := Get_Name_String (Chars (E)); + TSS_Name : TSS_Name_Type; + + -- Start of processing for Is_Predefined_Dispatching_Operation + + begin + if not Is_Dispatching_Operation (E) then + return False; + end if; + + -- Most predefined primitives have internally generated names. Equality + -- must be treated differently; the predefined operation is recognized + -- as a homogeneous binary operator that returns Boolean. + + if Full_Name'Length > TSS_Name_Type'Length then + TSS_Name := + TSS_Name_Type (Full_Name (Full_Name'Last - TSS_Name'Length + 1 + .. Full_Name'Last)); + + if TSS_Name = TSS_Stream_Read + or else TSS_Name = TSS_Stream_Write + or else TSS_Name = TSS_Stream_Input + or else TSS_Name = TSS_Stream_Output + or else TSS_Name = TSS_Deep_Adjust + or else TSS_Name = TSS_Deep_Finalize + then + return True; + + elsif not Has_Fully_Qualified_Name (E) then + if Chars (E) = Name_uSize + or else Chars (E) = Name_uAlignment + or else + (Chars (E) = Name_Op_Eq + and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) + or else Chars (E) = Name_uAssign + or else Is_Predefined_Interface_Primitive (E) + then + return True; + end if; + + -- Handle fully qualified names + + else + declare + type Names_Table is array (Positive range <>) of Name_Id; + + Predef_Names_95 : constant Names_Table := + (Name_uSize, + Name_uAlignment, + Name_Op_Eq, + Name_uAssign); + + Predef_Names_05 : constant Names_Table := + (Name_uDisp_Asynchronous_Select, + Name_uDisp_Conditional_Select, + Name_uDisp_Get_Prim_Op_Kind, + Name_uDisp_Get_Task_Id, + Name_uDisp_Requeue, + Name_uDisp_Timed_Select); + + Suffix_Length : constant Natural := Homonym_Suffix_Length (E); + + begin + for J in Predef_Names_95'Range loop + Get_Name_String (Predef_Names_95 (J)); + + if Full_Name'Last - Suffix_Length > Name_Len + and then + Full_Name + (Full_Name'Last - Name_Len - Suffix_Length + 1 + .. Full_Name'Last - Suffix_Length) = + Name_Buffer (1 .. Name_Len) + then + -- For the equality operator the type of the two operands + -- must also match. + + return Predef_Names_95 (J) /= Name_Op_Eq + or else + Etype (First_Formal (E)) = Etype (Last_Formal (E)); + end if; + end loop; + + if Ada_Version >= Ada_05 then + for J in Predef_Names_05'Range loop + Get_Name_String (Predef_Names_05 (J)); + + if Full_Name'Last - Suffix_Length > Name_Len + and then + Full_Name + (Full_Name'Last - Name_Len - Suffix_Length + 1 + .. Full_Name'Last - Suffix_Length) = + Name_Buffer (1 .. Name_Len) + then + return True; + end if; + end loop; + end if; + end; + end if; + end if; + + return False; + end Is_Predefined_Dispatching_Operation; + + ---------------------- + -- Register_CG_Node -- + ---------------------- + + procedure Register_CG_Node (N : Node_Id) is + begin + if Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call) then + if Current_Scope = Main_Unit_Entity + or else Entity_Is_In_Main_Unit (Current_Scope) + then + -- Register a copy of the dispatching call node. Needed since the + -- node containing a dispatching call is rewriten by the expander. + + declare + Copy : constant Node_Id := New_Copy (N); + + begin + -- Copy the link to the parent to allow climbing up the tree + -- when the call-graph information is generated + + Set_Parent (Copy, Parent (N)); + Call_Graph_Nodes.Append (Copy); + end; + end if; + + else pragma Assert (Nkind (N) = N_Defining_Identifier); + if Entity_Is_In_Main_Unit (N) then + Call_Graph_Nodes.Append (N); + end if; + end if; + end Register_CG_Node; + + ----------------- + -- Slot_Number -- + ----------------- + + function Slot_Number (Prim : Entity_Id) return Uint is + begin + if Is_Predefined_Dispatching_Operation (Prim) then + return -DT_Position (Prim); + else + return DT_Position (Prim); + end if; + end Slot_Number; + + ------------------ + -- Write_Output -- + ------------------ + + procedure Write_Output (Str : String) is + Nul : constant Character := Character'First; + Line : String (Str'First .. Str'Last + 1); + Errno : Integer; + begin + -- Add the null character to the string as required by fputs + + Line := Str & Nul; + Errno := fputs (Line'Address, Callgraph_Info_File); + pragma Assert (Errno >= 0); + end Write_Output; + + --------------------- + -- Write_Call_Info -- + --------------------- + + procedure Write_Call_Info (Call : Node_Id) is + Ctrl_Arg : constant Node_Id := Controlling_Argument (Call); + Ctrl_Typ : constant Entity_Id := Base_Type (Etype (Ctrl_Arg)); + Prim : constant Entity_Id := Entity (Sinfo.Name (Call)); + P : Node_Id; + + begin + -- Locate the enclosing context: a subprogram (if available) or the + -- enclosing library-level package + + P := Parent (Call); + while Nkind (P) /= N_Subprogram_Body + and then Nkind (Parent (P)) /= N_Compilation_Unit + loop + P := Parent (P); + pragma Assert (Present (P)); + end loop; + + Write_Str ("edge: { sourcename: "); + Write_Char ('"'); + Get_External_Name (Defining_Entity (P), Has_Suffix => False); + Write_Str (Name_Buffer (1 .. Name_Len)); + + if Nkind (P) = N_Package_Declaration then + Write_Str ("___elabs"); + + elsif Nkind (P) = N_Package_Body then + Write_Str ("___elabb"); + end if; + + Write_Char ('"'); + Write_Eol; + + -- The targetname is a triple: + -- N: the index in a vtable used for dispatch + -- V: the type who's vtable is used + -- S: the static type of the expression + + Write_Str (" targetname: "); + Write_Char ('"'); + + pragma Assert (No (Interface_Alias (Prim))); + + -- The check on Is_Ancestor is done here to avoid problems with + -- renamings of primitives. For example: + + -- type Root is tagged ... + -- procedure Base (Obj : Root); + -- procedure Base2 (Obj : Root) renames Base; + + if Present (Alias (Prim)) + and then + Is_Ancestor + (Find_Dispatching_Type (Ultimate_Alias (Prim)), + Root_Type (Ctrl_Typ)) + then + Write_Int (UI_To_Int (Slot_Number (Ultimate_Alias (Prim)))); + Write_Char (':'); + Write_Name + (Chars (Find_Dispatching_Type (Ultimate_Alias (Prim)))); + else + Write_Int (UI_To_Int (Slot_Number (Prim))); + Write_Char (':'); + Write_Name (Chars (Root_Type (Ctrl_Typ))); + end if; + + Write_Char (','); + Write_Name (Chars (Root_Type (Ctrl_Typ))); + + Write_Char ('"'); + Write_Eol; + + Write_Str (" label: "); + Write_Char ('"'); + Write_Location (Sloc (Call)); + Write_Char ('"'); + Write_Eol; + + Write_Char ('}'); + Write_Eol; + end Write_Call_Info; + + --------------------- + -- Write_Type_Info -- + --------------------- + + procedure Write_Type_Info (Typ : Entity_Id) is + Elmt : Elmt_Id; + Prim : Node_Id; + + Parent_Typ : Entity_Id; + Separator_Needed : Boolean := False; + + begin + -- Initialize Parent_Typ handling private types + + Parent_Typ := Etype (Typ); + + if Present (Full_View (Parent_Typ)) then + Parent_Typ := Full_View (Parent_Typ); + end if; + + Write_Str ("class {"); + Write_Eol; + + Write_Str (" classname: "); + Write_Char ('"'); + Write_Name (Chars (Typ)); + Write_Char ('"'); + Write_Eol; + + Write_Str (" label: "); + Write_Char ('"'); + Write_Name (Chars (Typ)); + Write_Char ('\'); + Write_Location (Sloc (Typ)); + Write_Char ('"'); + Write_Eol; + + if Parent_Typ /= Typ then + Write_Str (" parent: "); + Write_Char ('"'); + Write_Name (Chars (Parent_Typ)); + + -- Note: Einfo prefix not needed if this routine is moved to + -- exp_disp??? + + if Present (Einfo.Interfaces (Typ)) + and then not Is_Empty_Elmt_List (Einfo.Interfaces (Typ)) + then + Elmt := First_Elmt (Einfo.Interfaces (Typ)); + while Present (Elmt) loop + Write_Str (", "); + Write_Name (Chars (Node (Elmt))); + Next_Elmt (Elmt); + end loop; + end if; + + Write_Char ('"'); + Write_Eol; + end if; + + Write_Str (" virtuals: "); + Write_Char ('"'); + + Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Elmt) loop + Prim := Node (Elmt); + + -- Display only primitives overriden or defined + + if Present (Alias (Prim)) then + goto Continue; + end if; + + -- Do not generate separator for output of first primitive + + if Separator_Needed then + Write_Str ("\n"); + Write_Eol; + Write_Str (" "); + else + Separator_Needed := True; + end if; + + Write_Int (UI_To_Int (Slot_Number (Prim))); + Write_Char (':'); + Write_Name (Chars (Prim)); + + -- Display overriding of parent primitives + + if Present (Overridden_Operation (Prim)) + and then + Is_Ancestor + (Find_Dispatching_Type (Overridden_Operation (Prim)), Typ) + then + Write_Char (','); + Write_Int + (UI_To_Int (Slot_Number (Overridden_Operation (Prim)))); + Write_Char (':'); + Write_Name + (Chars (Find_Dispatching_Type (Overridden_Operation (Prim)))); + end if; + + -- Display overriding of interface primitives + + if Has_Interfaces (Typ) then + declare + Prim_Elmt : Elmt_Id; + Prim_Op : Node_Id; + Int_Alias : Entity_Id; + + begin + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Prim_Op := Node (Prim_Elmt); + Int_Alias := Interface_Alias (Prim_Op); + + if Present (Int_Alias) + and then not Is_Ancestor + (Find_Dispatching_Type (Int_Alias), Typ) + and then (Alias (Prim_Op)) = Prim + then + Write_Char (','); + Write_Int (UI_To_Int (Slot_Number (Int_Alias))); + Write_Char (':'); + Write_Name (Chars (Find_Dispatching_Type (Int_Alias))); + end if; + + Next_Elmt (Prim_Elmt); + end loop; + end; + end if; + + <> + Next_Elmt (Elmt); + end loop; + + Write_Char ('"'); + Write_Eol; + + Write_Char ('}'); + Write_Eol; + end Write_Type_Info; + +end Exp_CG; diff --git a/gcc/ada/exp_cg.ads b/gcc/ada/exp_cg.ads new file mode 100644 index 00000000000..5c2458d8408 --- /dev/null +++ b/gcc/ada/exp_cg.ads @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT 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 distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains routines used to store and handle nodes required +-- to generate call graph information of dispatching calls. + +with Types; use Types; + +package Exp_CG is + + procedure Generate_CG_Output; + -- Generate in the standard output the information associated with tagged + -- types declaration and dispatching calls + + procedure Initialize; + -- Called at the start of compilation to initialize the table that stores + -- the tree nodes used by Generate_Output. This table is required because + -- the format of the output requires fully qualified names (and hence the + -- output must be generated after the source program has been compiled). + + procedure Register_CG_Node (N : Node_Id); + -- Register a dispatching call node or the defining entity of a tagged + -- type declaration + +end Exp_CG; diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index 21f878b579a..111bc182fe7 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -469,9 +469,7 @@ package body Exp_Ch11 is Local_Expansion_Required := True; declare - L : constant Entity_Id := - Make_Defining_Identifier (Sloc (H), - Chars => New_Internal_Name ('L')); + L : constant Entity_Id := Make_Temporary (Sloc (H), 'L'); begin Set_Exception_Label (H, L); Add_Label_Declaration (L); @@ -646,9 +644,7 @@ package body Exp_Ch11 is declare -- L3 is the label to exit the HSS - L3_Dent : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('L')); + L3_Dent : constant Entity_Id := Make_Temporary (Loc, 'L'); Labl_L3 : constant Node_Id := Make_Label (Loc, @@ -670,7 +666,8 @@ package body Exp_Ch11 is Rewrite (HSS, Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Blk_Stm))); + Statements => New_List (Blk_Stm), + End_Label => Relocate_Node (End_Label (HSS)))); -- Set block statement as analyzed, we don't want to actually call -- Analyze on this block, it would cause a recursion in exception @@ -745,13 +742,12 @@ package body Exp_Ch11 is Relmt := First_Elmt (Local_Raise_Statements (Handler)); while Present (Relmt) loop declare - Raise_S : constant Node_Id := Node (Relmt); - + Raise_S : constant Node_Id := Node (Relmt); + RLoc : constant Source_Ptr := Sloc (Raise_S); Name_L1 : constant Node_Id := New_Occurrence_Of (L1_Dent, Loc); - Goto_L1 : constant Node_Id := - Make_Goto_Statement (Loc, + Make_Goto_Statement (RLoc, Name => Name_L1); begin @@ -1516,15 +1512,6 @@ package body Exp_Ch11 is -- Remaining processing is for the case where no string expression -- is present. - -- There is no expansion needed for statement "raise ;" when - -- compiling for the JVM since the JVM has a built-in exception - -- mechanism. However we need to keep the expansion for "raise;" - -- statements. See 4jexcept.ads for details. - - if Present (Name (N)) and then VM_Target /= No_VM then - return; - end if; - -- Don't expand a raise statement that does not come from source -- if we have already had configurable run-time violations, since -- most likely it will be junk cascaded nonsense. @@ -1686,7 +1673,7 @@ package body Exp_Ch11 is -- be referencing this entity by normal visibility methods. if No (Choice_Parameter (Ehand)) then - E := Make_Defining_Identifier (Loc, New_Internal_Name ('E')); + E := Make_Temporary (Loc, 'E'); Set_Choice_Parameter (Ehand, E); Set_Ekind (E, E_Variable); Set_Etype (E, RTE (RE_Exception_Occurrence)); diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index 3b682cf04ae..d0004f473a0 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -46,6 +46,7 @@ with Snames; use Snames; with Stand; use Stand; with Tbuild; use Tbuild; with Uintp; use Uintp; +with Validsw; use Validsw; package body Exp_Ch13 is @@ -346,6 +347,23 @@ package body Exp_Ch13 is Analyze (Decl, Suppress => All_Checks); Pop_Scope; + -- We treat generated equality specially, if validity checks are + -- enabled, in order to detect components default-initialized + -- with invalid values. + + elsif Nkind (Decl) = N_Subprogram_Body + and then Chars (Defining_Entity (Decl)) = Name_Op_Eq + and then Validity_Checks_On + and then Initialize_Scalars + then + declare + Save_Force : constant Boolean := Force_Validity_Checks; + begin + Force_Validity_Checks := True; + Analyze (Decl); + Force_Validity_Checks := Save_Force; + end; + else Analyze (Decl, Suppress => All_Checks); end if; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 9420558b9fd..e2263f3ab8f 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -504,7 +504,7 @@ package body Exp_Ch3 is -- And insert this declaration into the tree. The type of the -- discriminant is then reset to this more restricted subtype. - Tnn := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); + Tnn := Make_Temporary (Loc, 'T'); Insert_Action (Declaration_Node (Rtype), Make_Subtype_Declaration (Loc, @@ -593,7 +593,7 @@ package body Exp_Ch3 is ------------------------ function Init_One_Dimension (N : Int) return List_Id is - Index : Entity_Id; + Index : Entity_Id; begin -- If the component does not need initializing, then there is nothing @@ -1465,8 +1465,8 @@ package body Exp_Ch3 is if Has_Task (Full_Type) then if Restriction_Active (No_Task_Hierarchy) then - -- See comments in System.Tasking.Initialization.Init_RTS - -- for the value 3 (should be rtsfindable constant ???) + -- 3 is System.Tasking.Library_Task_Level + -- (should be rtsfindable constant ???) Append_To (Args, Make_Integer_Literal (Loc, 3)); @@ -2020,8 +2020,7 @@ package body Exp_Ch3 is if Has_Task (Rec_Type) then if Restriction_Active (No_Task_Hierarchy) then - -- See comments in System.Tasking.Initialization.Init_RTS - -- for the value 3. + -- 3 is System.Tasking.Library_Task_Level Append_To (Args, Make_Integer_Literal (Loc, 3)); else @@ -2115,10 +2114,7 @@ package body Exp_Ch3 is Spec_Node : Node_Id; begin - Func_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('F')); - + Func_Id := Make_Temporary (Loc, 'F'); Set_DT_Offset_To_Top_Func (Iface_Comp, Func_Id); -- Generate @@ -2246,9 +2242,7 @@ package body Exp_Ch3 is if Is_Tagged_Type (Rec_Type) and then not Is_CPP_Class (Rec_Type) then - Set_Tag := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('P')); + Set_Tag := Make_Temporary (Loc, 'P'); Append_To (Parameters, Make_Parameter_Specification (Loc, @@ -2336,22 +2330,6 @@ package body Exp_Ch3 is New_Reference_To (Node (First_Elmt (Access_Disp_Table (Rec_Type))), Loc))); - -- Generate the SCIL node associated with the initialization of - -- the tag component. - - if Generate_SCIL then - declare - New_Node : Node_Id; - - begin - New_Node := - Make_SCIL_Tag_Init (Sloc (First (Init_Tags_List))); - Set_SCIL_Related_Node (New_Node, First (Init_Tags_List)); - Set_SCIL_Entity (New_Node, Rec_Type); - Prepend_To (Init_Tags_List, New_Node); - end; - end if; - -- Ada 2005 (AI-251): Initialize the secondary tags components -- located at fixed positions (tags whose position depends on -- variable size components are initialized later ---see below). @@ -3404,37 +3382,21 @@ package body Exp_Ch3 is Loc : constant Source_Ptr := Sloc (Typ); Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ))); - -- Build formal parameters of procedure - - Larray : constant Entity_Id := - Make_Defining_Identifier - (Loc, Chars => New_Internal_Name ('A')); - Rarray : constant Entity_Id := - Make_Defining_Identifier - (Loc, Chars => New_Internal_Name ('R')); - Left_Lo : constant Entity_Id := - Make_Defining_Identifier - (Loc, Chars => New_Internal_Name ('L')); - Left_Hi : constant Entity_Id := - Make_Defining_Identifier - (Loc, Chars => New_Internal_Name ('L')); - Right_Lo : constant Entity_Id := - Make_Defining_Identifier - (Loc, Chars => New_Internal_Name ('R')); - Right_Hi : constant Entity_Id := - Make_Defining_Identifier - (Loc, Chars => New_Internal_Name ('R')); - Rev : constant Entity_Id := - Make_Defining_Identifier - (Loc, Chars => New_Internal_Name ('D')); + Larray : constant Entity_Id := Make_Temporary (Loc, 'A'); + Rarray : constant Entity_Id := Make_Temporary (Loc, 'R'); + Left_Lo : constant Entity_Id := Make_Temporary (Loc, 'L'); + Left_Hi : constant Entity_Id := Make_Temporary (Loc, 'L'); + Right_Lo : constant Entity_Id := Make_Temporary (Loc, 'R'); + Right_Hi : constant Entity_Id := Make_Temporary (Loc, 'R'); + Rev : constant Entity_Id := Make_Temporary (Loc, 'D'); + -- Formal parameters of procedure + Proc_Name : constant Entity_Id := Make_Defining_Identifier (Loc, Chars => Make_TSS_Name (Typ, TSS_Slice_Assign)); - Lnn : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('L')); - Rnn : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Lnn : constant Entity_Id := Make_Temporary (Loc, 'L'); + Rnn : constant Entity_Id := Make_Temporary (Loc, 'R'); -- Subscripts for left and right sides Decls : List_Id; @@ -4466,7 +4428,10 @@ package body Exp_Ch3 is -- it will be assigned subsequently. In particular, there is no point -- in applying Initialize_Scalars to such a temporary. - elsif Needs_Simple_Initialization (Typ) + elsif Needs_Simple_Initialization + (Typ, + Initialize_Scalars + and then not Has_Following_Address_Clause (N)) and then not Is_Internal (Def_Id) and then not Has_Init_Expression (N) then @@ -4617,8 +4582,7 @@ package body Exp_Ch3 is Decl_1 := Make_Object_Declaration (Loc, Defining_Identifier => - Make_Defining_Identifier (Loc, - New_Internal_Name ('D')), + Make_Temporary (Loc, 'D', Expr_N), Object_Definition => New_Occurrence_Of (Expr_Typ, Loc), Expression => @@ -4630,12 +4594,9 @@ package body Exp_Ch3 is Decl_2 := Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - New_Internal_Name ('D')), - Subtype_Mark => - New_Occurrence_Of (Typ, Loc), - Name => + Defining_Identifier => Make_Temporary (Loc, 'D'), + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Name => Unchecked_Convert_To (Typ, Make_Selected_Component (Loc, Prefix => @@ -4679,23 +4640,19 @@ package body Exp_Ch3 is Decl_1 := Make_Object_Declaration (Loc, Defining_Identifier => - Make_Defining_Identifier (Loc, - New_Internal_Name ('D')), - Object_Definition => + Make_Temporary (Loc, 'D', New_Expr), + Object_Definition => New_Occurrence_Of (Etype (Object_Definition (N)), Loc), - Expression => + Expression => Unchecked_Convert_To (Etype (Object_Definition (N)), New_Expr)); Decl_2 := Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - New_Internal_Name ('D')), - Subtype_Mark => - New_Occurrence_Of (Typ, Loc), - Name => + Defining_Identifier => Make_Temporary (Loc, 'D'), + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Name => Unchecked_Convert_To (Typ, Make_Explicit_Dereference (Loc, Unchecked_Convert_To (RTE (RE_Tag_Ptr), @@ -5969,8 +5926,8 @@ package body Exp_Ch3 is and then Has_Discriminants (Def_Id) then declare - Ctyp : constant Entity_Id := - Corresponding_Concurrent_Type (Def_Id); + Ctyp : constant Entity_Id := + Corresponding_Concurrent_Type (Def_Id); Conc_Discr : Entity_Id; Rec_Discr : Entity_Id; Temp : Entity_Id; @@ -5978,7 +5935,6 @@ package body Exp_Ch3 is begin Conc_Discr := First_Discriminant (Ctyp); Rec_Discr := First_Discriminant (Def_Id); - while Present (Conc_Discr) loop Temp := Discriminal (Conc_Discr); Set_Discriminal (Conc_Discr, Discriminal (Rec_Discr)); @@ -6247,9 +6203,7 @@ package body Exp_Ch3 is -- See GNAT Pool packages in the Run-Time for more details - elsif Ekind (Def_Id) = E_Access_Type - or else Ekind (Def_Id) = E_General_Access_Type - then + elsif Ekind_In (Def_Id, E_Access_Type, E_General_Access_Type) then declare Loc : constant Source_Ptr := Sloc (N); Desig_Type : constant Entity_Id := Designated_Type (Def_Id); @@ -7865,12 +7819,11 @@ package body Exp_Ch3 is -- If a primitive is encountered that renames the predefined -- equality operator before reaching any explicit equality - -- primitive, then we still need to create a predefined - -- equality function, because calls to it can occur via - -- the renaming. A new name is created for the equality - -- to avoid conflicting with any user-defined equality. - -- (Note that this doesn't account for renamings of - -- equality nested within subpackages???) + -- primitive, then we still need to create a predefined equality + -- function, because calls to it can occur via the renaming. A new + -- name is created for the equality to avoid conflicting with any + -- user-defined equality. (Note that this doesn't account for + -- renamings of equality nested within subpackages???) if Is_Predefined_Eq_Renaming (Node (Prim)) then Eq_Name := New_External_Name (Chars (Node (Prim)), 'E'); @@ -8145,7 +8098,14 @@ package body Exp_Ch3 is -- Needs_Simple_Initialization -- --------------------------------- - function Needs_Simple_Initialization (T : Entity_Id) return Boolean is + function Needs_Simple_Initialization + (T : Entity_Id; + Consider_IS : Boolean := True) return Boolean + is + Consider_IS_NS : constant Boolean := + Normalize_Scalars + or (Initialize_Scalars and Consider_IS); + begin -- Check for private type, in which case test applies to the underlying -- type of the private type. @@ -8167,7 +8127,7 @@ package body Exp_Ch3 is -- types. elsif Is_Access_Type (T) - or else (Init_Or_Norm_Scalars and then (Is_Scalar_Type (T))) + or else (Consider_IS_NS and then (Is_Scalar_Type (T))) then return True; @@ -8176,7 +8136,7 @@ package body Exp_Ch3 is -- expanding an aggregate (since in the latter case they will be -- filled with appropriate initializing values before they are used). - elsif Init_Or_Norm_Scalars + elsif Consider_IS_NS and then (Root_Type (T) = Standard_String or else Root_Type (T) = Standard_Wide_String diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads index 6738ae958f9..9b838b0b652 100644 --- a/gcc/ada/exp_ch3.ads +++ b/gcc/ada/exp_ch3.ads @@ -126,14 +126,18 @@ package Exp_Ch3 is -- then tags components located at variable positions of Target are -- initialized. - function Needs_Simple_Initialization (T : Entity_Id) return Boolean; + function Needs_Simple_Initialization + (T : Entity_Id; + Consider_IS : Boolean := True) return Boolean; -- Certain types need initialization even though there is no specific -- initialization routine. In this category are access types (which need -- initializing to null), packed array types whose implementation is a -- modular type, and all scalar types if Normalize_Scalars is set, as well -- as private types whose underlying type is present and meets any of these -- criteria. Finally, descendants of String and Wide_String also need - -- initialization in Initialize/Normalize_Scalars mode. + -- initialization in Initialize/Normalize_Scalars mode. Consider_IS is + -- normally True. If it is False, the Initialize_Scalars is not considered + -- in determining whether simple initialization is needed. function Get_Simple_Init_Val (T : Entity_Id; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 096abbde9c9..7588ae3cc03 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -47,6 +47,7 @@ with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; +with Par_SCO; use Par_SCO; with Restrict; use Restrict; with Rident; use Rident; with Rtsfind; use Rtsfind; @@ -58,13 +59,13 @@ with Sem_Ch8; use Sem_Ch8; with Sem_Ch13; use Sem_Ch13; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; -with Sem_SCIL; use Sem_SCIL; with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Sem_Warn; use Sem_Warn; with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; +with SCIL_LL; use SCIL_LL; with Targparm; use Targparm; with Tbuild; use Tbuild; with Ttypes; use Ttypes; @@ -127,6 +128,9 @@ package body Exp_Ch4 is -- Common expansion processing for Boolean operators (And, Or, Xor) for the -- case of array type arguments. + procedure Expand_Short_Circuit_Operator (N : Node_Id); + -- Common expansion processing for short-circuit boolean operators + function Expand_Composite_Equality (Nod : Node_Id; Typ : Entity_Id; @@ -319,10 +323,8 @@ package body Exp_Ch4 is if Nkind (Op1) = N_Op_Not then if Kind = N_Op_And then Proc_Name := RTE (RE_Vector_Nor); - elsif Kind = N_Op_Or then Proc_Name := RTE (RE_Vector_Nand); - else Proc_Name := RTE (RE_Vector_Xor); end if; @@ -330,14 +332,11 @@ package body Exp_Ch4 is else if Kind = N_Op_And then Proc_Name := RTE (RE_Vector_And); - elsif Kind = N_Op_Or then Proc_Name := RTE (RE_Vector_Or); - elsif Nkind (Op2) = N_Op_Not then Proc_Name := RTE (RE_Vector_Nxor); Arg2 := Right_Opnd (Op2); - else Proc_Name := RTE (RE_Vector_Xor); end if; @@ -348,15 +347,15 @@ package body Exp_Ch4 is Name => New_Occurrence_Of (Proc_Name, Loc), Parameter_Associations => New_List ( Target, - Make_Attribute_Reference (Loc, - Prefix => Arg1, - Attribute_Name => Name_Address), - Make_Attribute_Reference (Loc, - Prefix => Arg2, - Attribute_Name => Name_Address), - Make_Attribute_Reference (Loc, - Prefix => Op1, - Attribute_Name => Name_Length))); + Make_Attribute_Reference (Loc, + Prefix => Arg1, + Attribute_Name => Name_Address), + Make_Attribute_Reference (Loc, + Prefix => Arg2, + Attribute_Name => Name_Address), + Make_Attribute_Reference (Loc, + Prefix => Op1, + Attribute_Name => Name_Length))); end if; Rewrite (N, Call_Node); @@ -591,7 +590,7 @@ package body Exp_Ch4 is Set_Analyzed (Node); - Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Temp := Make_Temporary (Loc, 'P', N); Insert_Action (N, Make_Object_Declaration (Loc, @@ -660,8 +659,7 @@ package body Exp_Ch4 is Remove_Side_Effects (Exp); end if; - Temp := - Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Temp := Make_Temporary (Loc, 'P', N); -- For a class wide allocation generate the following code: @@ -751,9 +749,7 @@ package body Exp_Ch4 is else declare - Def_Id : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('T')); + Def_Id : constant Entity_Id := Make_Temporary (Loc, 'T'); New_Decl : Node_Id; begin @@ -830,8 +826,7 @@ package body Exp_Ch4 is New_Decl := Make_Object_Declaration (Loc, - Defining_Identifier => Make_Defining_Identifier (Loc, - New_Internal_Name ('P')), + Defining_Identifier => Make_Temporary (Loc, 'P'), Object_Definition => New_Reference_To (PtrT, Loc), Expression => Unchecked_Convert_To (PtrT, New_Reference_To (Temp, Loc))); @@ -912,16 +907,13 @@ package body Exp_Ch4 is if Is_RTE (Apool, RE_SS_Pool) then declare - F : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('F')); + F : constant Entity_Id := Make_Temporary (Loc, 'F'); begin Insert_Action (N, Make_Object_Declaration (Loc, Defining_Identifier => F, - Object_Definition => New_Reference_To (RTE - (RE_Finalizable_Ptr), Loc))); - + Object_Definition => + New_Reference_To (RTE (RE_Finalizable_Ptr), Loc))); Flist := New_Reference_To (F, Loc); Attach := Make_Integer_Literal (Loc, 1); end; @@ -987,8 +979,7 @@ package body Exp_Ch4 is end if; elsif Aggr_In_Place then - Temp := - Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Temp := Make_Temporary (Loc, 'P', N); Tmp_Node := Make_Object_Declaration (Loc, Defining_Identifier => Temp, @@ -1072,9 +1063,7 @@ package body Exp_Ch4 is and then Is_Packed (T) then declare - ConstrT : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('A')); + ConstrT : constant Entity_Id := Make_Temporary (Loc, 'A'); Internal_Exp : constant Node_Id := Relocate_Node (Exp); begin Insert_Action (Exp, @@ -1594,8 +1583,7 @@ package body Exp_Ch4 is -- constrained types, then we can use the same index for both -- of the arrays. - An : constant Entity_Id := Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('A')); + An : constant Entity_Id := Make_Temporary (Loc, 'A'); Bn : Entity_Id; Index_T : Entity_Id; @@ -1612,9 +1600,7 @@ package body Exp_Ch4 is Index_T := Base_Type (Etype (Index)); if Need_Separate_Indexes then - Bn := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('B')); + Bn := Make_Temporary (Loc, 'B'); else Bn := An; end if; @@ -1801,7 +1787,7 @@ package body Exp_Ch4 is Defining_Identifier => B, Parameter_Type => New_Reference_To (Rtyp, Loc))); - Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('E')); + Func_Name := Make_Temporary (Loc, 'E'); -- Build statement sequence for function @@ -2621,9 +2607,7 @@ package body Exp_Ch4 is Operands (NN) := Opnd; Is_Fixed_Length (NN) := False; - Var_Length (NN) := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('L')); + Var_Length (NN) := Make_Temporary (Loc, 'L'); Append_To (Actions, Make_Object_Declaration (Loc, @@ -2670,9 +2654,7 @@ package body Exp_Ch4 is -- create an entity initialized to this length. else - Ent := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('L')); + Ent := Make_Temporary (Loc, 'L'); if Is_Fixed_Length (NN) then Clen := Make_Integer_Literal (Loc, Fixed_Length (NN)); @@ -2790,8 +2772,7 @@ package body Exp_Ch4 is end Get_Known_Bound; begin - Ent := - Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('L')); + Ent := Make_Temporary (Loc, 'L'); Append_To (Actions, Make_Object_Declaration (Loc, @@ -2845,11 +2826,12 @@ package body Exp_Ch4 is Insert_Actions (Cnode, Actions, Suppress => All_Checks); - -- Now we construct an array object with appropriate bounds + -- Now we construct an array object with appropriate bounds. We mark + -- the target as internal to prevent useless initialization when + -- Initialize_Scalars is enabled. - Ent := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); + Ent := Make_Temporary (Loc, 'S'); + Set_Is_Internal (Ent); -- If the bound is statically known to be out of range, we do not want -- to abort, we want a warning and a runtime constraint error. Note that @@ -3173,9 +3155,10 @@ package body Exp_Ch4 is declare Decl : Node_Id; Outer_S : Entity_Id; - S : Entity_Id := Current_Scope; + S : Entity_Id; begin + S := Current_Scope; while Present (S) and then S /= Standard_Standard loop if Ekind (S) = E_Function then Outer_S := Scope (S); @@ -3273,9 +3256,7 @@ package body Exp_Ch4 is ------------------------- procedure Rewrite_Coextension (N : Node_Id) is - Temp : constant Node_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('C')); + Temp : constant Node_Id := Make_Temporary (Loc, 'C'); -- Generate: -- Cnn : aliased Etyp; @@ -3428,9 +3409,7 @@ package body Exp_Ch4 is -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is -- marked as requiring static allocation. - Temp := - Make_Defining_Identifier (Loc, New_Internal_Name ('T')); - + Temp := Make_Temporary (Loc, 'T', Expression (Expression (N))); Desig := Subtype_Mark (Expression (N)); -- If context is constrained, use constrained subtype directly, @@ -3593,7 +3572,7 @@ package body Exp_Ch4 is if not Restriction_Active (No_Default_Initialization) then Init := Base_Init_Proc (T); Nod := N; - Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Temp := Make_Temporary (Loc, 'P'); -- Construct argument list for the initialization routine call @@ -3665,9 +3644,11 @@ package body Exp_Ch4 is -- The designated type was an incomplete type, and the -- access type did not get expanded. Salvage it now. - pragma Assert (Present (Parent (Base_Type (PtrT)))); - Expand_N_Full_Type_Declaration - (Parent (Base_Type (PtrT))); + if not Restriction_Active (No_Task_Hierarchy) then + pragma Assert (Present (Parent (Base_Type (PtrT)))); + Expand_N_Full_Type_Declaration + (Parent (Base_Type (PtrT))); + end if; end if; -- If the context of the allocator is a declaration or an @@ -3710,16 +3691,22 @@ package body Exp_Ch4 is Decls := Build_Task_Image_Decls (Loc, T, T); end if; - Append_To (Args, - New_Reference_To - (Master_Id (Base_Type (Root_Type (PtrT))), Loc)); + if Restriction_Active (No_Task_Hierarchy) then + -- 3 is System.Tasking.Library_Task_Level + Append_To (Args, Make_Integer_Literal (Loc, 3)); + else + Append_To (Args, + New_Reference_To + (Master_Id (Base_Type (Root_Type (PtrT))), Loc)); + end if; + Append_To (Args, Make_Identifier (Loc, Name_uChain)); Decl := Last (Decls); Append_To (Args, New_Occurrence_Of (Defining_Identifier (Decl), Loc)); - -- Has_Task is false, Decls not used + -- Has_Task is false, Decls not used else Decls := No_List; @@ -3900,119 +3887,145 @@ package body Exp_Ch4 is -- Expand_N_And_Then -- ----------------------- - -- Expand into conditional expression if Actions present, and also deal - -- with optimizing case of arguments being True or False. + procedure Expand_N_And_Then (N : Node_Id) + renames Expand_Short_Circuit_Operator; + + ------------------------------ + -- Expand_N_Case_Expression -- + ------------------------------ - procedure Expand_N_And_Then (N : Node_Id) is + procedure Expand_N_Case_Expression (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Typ : constant Entity_Id := Etype (N); - Left : constant Node_Id := Left_Opnd (N); - Right : constant Node_Id := Right_Opnd (N); - Actlist : List_Id; + Cstmt : Node_Id; + Tnn : Entity_Id; + Pnn : Entity_Id; + Actions : List_Id; + Ttyp : Entity_Id; + Alt : Node_Id; + Fexp : Node_Id; begin - -- Deal with non-standard booleans + -- We expand + + -- case X is when A => AX, when B => BX ... + + -- to + + -- do + -- Tnn : typ; + -- case X is + -- when A => + -- Tnn := AX; + -- when B => + -- Tnn := BX; + -- ... + -- end case; + -- in Tnn end; + + -- However, this expansion is wrong for limited types, and also + -- wrong for unconstrained types (since the bounds may not be the + -- same in all branches). Furthermore it involves an extra copy + -- for large objects. So we take care of this by using the following + -- modified expansion for non-scalar types: + + -- do + -- type Pnn is access all typ; + -- Tnn : Pnn; + -- case X is + -- when A => + -- T := AX'Unrestricted_Access; + -- when B => + -- T := BX'Unrestricted_Access; + -- ... + -- end case; + -- in Tnn.all end; + + Cstmt := + Make_Case_Statement (Loc, + Expression => Expression (N), + Alternatives => New_List); + + Actions := New_List; + + -- Scalar case + + if Is_Scalar_Type (Typ) then + Ttyp := Typ; - if Is_Boolean_Type (Typ) then - Adjust_Condition (Left); - Adjust_Condition (Right); - Set_Etype (N, Standard_Boolean); + else + Pnn := Make_Temporary (Loc, 'P'); + Append_To (Actions, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Pnn, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => + New_Reference_To (Typ, Loc)))); + Ttyp := Pnn; end if; - -- Check for cases where left argument is known to be True or False + Tnn := Make_Temporary (Loc, 'T'); + Append_To (Actions, + Make_Object_Declaration (Loc, + Defining_Identifier => Tnn, + Object_Definition => New_Occurrence_Of (Ttyp, Loc))); - if Compile_Time_Known_Value (Left) then + -- Now process the alternatives - -- If left argument is True, change (True and then Right) to Right. - -- Any actions associated with Right will be executed unconditionally - -- and can thus be inserted into the tree unconditionally. + Alt := First (Alternatives (N)); + while Present (Alt) loop + declare + Aexp : Node_Id := Expression (Alt); + Aloc : constant Source_Ptr := Sloc (Aexp); - if Expr_Value_E (Left) = Standard_True then - if Present (Actions (N)) then - Insert_Actions (N, Actions (N)); + begin + if not Is_Scalar_Type (Typ) then + Aexp := + Make_Attribute_Reference (Aloc, + Prefix => Relocate_Node (Aexp), + Attribute_Name => Name_Unrestricted_Access); end if; - Rewrite (N, Right); - - -- If left argument is False, change (False and then Right) to False. - -- In this case we can forget the actions associated with Right, - -- since they will never be executed. - - else pragma Assert (Expr_Value_E (Left) = Standard_False); - Kill_Dead_Code (Right); - Kill_Dead_Code (Actions (N)); - Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); - end if; - - Adjust_Result_Type (N, Typ); - return; - end if; - - -- If Actions are present, we expand - - -- left and then right - - -- into + Append_To + (Alternatives (Cstmt), + Make_Case_Statement_Alternative (Sloc (Alt), + Discrete_Choices => Discrete_Choices (Alt), + Statements => New_List ( + Make_Assignment_Statement (Aloc, + Name => New_Occurrence_Of (Tnn, Loc), + Expression => Aexp)))); + end; - -- if left then right else false end + Next (Alt); + end loop; - -- with the actions becoming the Then_Actions of the conditional - -- expression. This conditional expression is then further expanded - -- (and will eventually disappear) + Append_To (Actions, Cstmt); - if Present (Actions (N)) then - Actlist := Actions (N); - Rewrite (N, - Make_Conditional_Expression (Loc, - Expressions => New_List ( - Left, - Right, - New_Occurrence_Of (Standard_False, Loc)))); - - -- If the right part of the expression is a function call then it can - -- be part of the expansion of the predefined equality operator of a - -- tagged type and we may need to adjust its SCIL dispatching node. - - if Generate_SCIL - and then Nkind (Right) = N_Function_Call - then - Adjust_SCIL_Node (N, Right); - end if; + -- Construct and return final expression with actions - Set_Then_Actions (N, Actlist); - Analyze_And_Resolve (N, Standard_Boolean); - Adjust_Result_Type (N, Typ); - return; + if Is_Scalar_Type (Typ) then + Fexp := New_Occurrence_Of (Tnn, Loc); + else + Fexp := + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Tnn, Loc)); end if; - -- No actions present, check for cases of right argument True/False - - if Compile_Time_Known_Value (Right) then - - -- Change (Left and then True) to Left. Note that we know there are - -- no actions associated with the True operand, since we just checked - -- for this case above. - - if Expr_Value_E (Right) = Standard_True then - Rewrite (N, Left); - - -- Change (Left and then False) to False, making sure to preserve any - -- side effects associated with the Left operand. - - else pragma Assert (Expr_Value_E (Right) = Standard_False); - Remove_Side_Effects (Left); - Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); - end if; - end if; + Rewrite (N, + Make_Expression_With_Actions (Loc, + Expression => Fexp, + Actions => Actions)); - Adjust_Result_Type (N, Typ); - end Expand_N_And_Then; + Analyze_And_Resolve (N, Typ); + end Expand_N_Case_Expression; ------------------------------------- -- Expand_N_Conditional_Expression -- ------------------------------------- - -- Expand into expression actions if then/else actions present + -- Deal with limited types and expression actions procedure Expand_N_Conditional_Expression (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); @@ -4021,33 +4034,68 @@ package body Exp_Ch4 is Elsex : constant Node_Id := Next (Thenx); Typ : constant Entity_Id := Etype (N); - Cnn : Entity_Id; - Decl : Node_Id; - New_If : Node_Id; - New_N : Node_Id; - P_Decl : Node_Id; + Cnn : Entity_Id; + Decl : Node_Id; + New_If : Node_Id; + New_N : Node_Id; + P_Decl : Node_Id; + Expr : Node_Id; + Actions : List_Id; begin - -- If either then or else actions are present, then given: + -- Fold at compile time if condition known. We have already folded + -- static conditional expressions, but it is possible to fold any + -- case in which the condition is known at compile time, even though + -- the result is non-static. + + -- Note that we don't do the fold of such cases in Sem_Elab because + -- it can cause infinite loops with the expander adding a conditional + -- expression, and Sem_Elab circuitry removing it repeatedly. + + if Compile_Time_Known_Value (Cond) then + if Is_True (Expr_Value (Cond)) then + Expr := Thenx; + Actions := Then_Actions (N); + else + Expr := Elsex; + Actions := Else_Actions (N); + end if; - -- if cond then then-expr else else-expr end + Remove (Expr); - -- we insert the following sequence of actions (using Insert_Actions): + if Present (Actions) then - -- Cnn : typ; - -- if cond then - -- <> - -- Cnn := then-expr; - -- else - -- <> - -- Cnn := else-expr - -- end if; + -- If we are not allowed to use Expression_With_Actions, just + -- skip the optimization, it is not critical for correctness. + + if not Use_Expression_With_Actions then + goto Skip_Optimization; + end if; + + Rewrite (N, + Make_Expression_With_Actions (Loc, + Expression => Relocate_Node (Expr), + Actions => Actions)); + Analyze_And_Resolve (N, Typ); + + else + Rewrite (N, Relocate_Node (Expr)); + end if; + + -- Note that the result is never static (legitimate cases of static + -- conditional expressions were folded in Sem_Eval). - -- and replace the conditional expression by a reference to Cnn + Set_Is_Static_Expression (N, False); + return; + end if; + + <> - -- If the type is limited or unconstrained, the above expansion is - -- not legal, because it involves either an uninitialized object - -- or an illegal assignment. Instead, we generate: + -- If the type is limited or unconstrained, we expand as follows to + -- avoid any possibility of improper copies. + + -- Note: it may be possible to avoid this special processing if the + -- back end uses its own mechanisms for handling by-reference types ??? -- type Ptr is access all Typ; -- Cnn : Ptr; @@ -4061,13 +4109,17 @@ package body Exp_Ch4 is -- and replace the conditional expresion by a reference to Cnn.all. - if Is_By_Reference_Type (Typ) then + -- This special case can be skipped if the back end handles limited + -- types properly and ensures that no incorrect copies are made. + + if Is_By_Reference_Type (Typ) + and then not Back_End_Handles_Limited_Types + then Cnn := Make_Temporary (Loc, 'C', N); P_Decl := Make_Full_Type_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, New_Internal_Name ('A')), + Defining_Identifier => Make_Temporary (Loc, 'A'), Type_Definition => Make_Access_To_Object_Definition (Loc, All_Present => True, @@ -4110,40 +4162,84 @@ package body Exp_Ch4 is -- associated with either branch. elsif Present (Then_Actions (N)) or else Present (Else_Actions (N)) then - Cnn := Make_Temporary (Loc, 'C', N); - Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Cnn, - Object_Definition => New_Occurrence_Of (Typ, Loc)); + -- We have two approaches to handling this. If we are allowed to use + -- N_Expression_With_Actions, then we can just wrap the actions into + -- the appropriate expression. + + if Use_Expression_With_Actions then + if Present (Then_Actions (N)) then + Rewrite (Thenx, + Make_Expression_With_Actions (Sloc (Thenx), + Actions => Then_Actions (N), + Expression => Relocate_Node (Thenx))); + Set_Then_Actions (N, No_List); + Analyze_And_Resolve (Thenx, Typ); + end if; - New_If := - Make_Implicit_If_Statement (N, - Condition => Relocate_Node (Cond), + if Present (Else_Actions (N)) then + Rewrite (Elsex, + Make_Expression_With_Actions (Sloc (Elsex), + Actions => Else_Actions (N), + Expression => Relocate_Node (Elsex))); + Set_Else_Actions (N, No_List); + Analyze_And_Resolve (Elsex, Typ); + end if; - Then_Statements => New_List ( - Make_Assignment_Statement (Sloc (Thenx), - Name => New_Occurrence_Of (Cnn, Sloc (Thenx)), - Expression => Relocate_Node (Thenx))), + return; - Else_Statements => New_List ( - Make_Assignment_Statement (Sloc (Elsex), - Name => New_Occurrence_Of (Cnn, Sloc (Elsex)), - Expression => Relocate_Node (Elsex)))); + -- if we can't use N_Expression_With_Actions nodes, then we insert + -- the following sequence of actions (using Insert_Actions): - Set_Assignment_OK (Name (First (Then_Statements (New_If)))); - Set_Assignment_OK (Name (First (Else_Statements (New_If)))); + -- Cnn : typ; + -- if cond then + -- <> + -- Cnn := then-expr; + -- else + -- <> + -- Cnn := else-expr + -- end if; - New_N := New_Occurrence_Of (Cnn, Loc); + -- and replace the conditional expression by a reference to Cnn - else - -- No expansion needed, gigi handles it like a C conditional - -- expression. + else + Cnn := Make_Temporary (Loc, 'C', N); + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Cnn, + Object_Definition => New_Occurrence_Of (Typ, Loc)); + + New_If := + Make_Implicit_If_Statement (N, + Condition => Relocate_Node (Cond), + + Then_Statements => New_List ( + Make_Assignment_Statement (Sloc (Thenx), + Name => New_Occurrence_Of (Cnn, Sloc (Thenx)), + Expression => Relocate_Node (Thenx))), + + Else_Statements => New_List ( + Make_Assignment_Statement (Sloc (Elsex), + Name => New_Occurrence_Of (Cnn, Sloc (Elsex)), + Expression => Relocate_Node (Elsex)))); + Set_Assignment_OK (Name (First (Then_Statements (New_If)))); + Set_Assignment_OK (Name (First (Else_Statements (New_If)))); + + New_N := New_Occurrence_Of (Cnn, Loc); + end if; + + -- If no actions then no expansion needed, gigi will handle it using + -- the same approach as a C conditional expression. + + else return; end if; - -- Move the SLOC of the parent If statement to the newly created one and + -- Fall through here for either the limited expansion, or the case of + -- inserting actions for non-limited types. In both these cases, we must + -- move the SLOC of the parent If statement to the newly created one and -- change it to the SLOC of the expression which, after expansion, will -- correspond to what is being evaluated. @@ -4274,14 +4370,14 @@ package body Exp_Ch4 is Analyze_And_Resolve (N, Rtyp); Error_Msg_N ("?explicit membership test may be optimized away", N); - Error_Msg_N ("\?use ''Valid attribute instead", N); + Error_Msg_N -- CODEFIX + ("\?use ''Valid attribute instead", N); return; end Substitute_Valid_Check; -- Start of processing for Expand_N_In begin - if Present (Alternatives (N)) then Remove_Side_Effects (Lop); Expand_Set_Membership; @@ -4290,9 +4386,12 @@ package body Exp_Ch4 is -- Check case of explicit test for an expression in range of its -- subtype. This is suspicious usage and we replace it with a 'Valid - -- test and give a warning. + -- test and give a warning. For floating point types however, this is a + -- standard way to check for finite numbers, and using 'Valid vould + -- typically be a pessimization. if Is_Scalar_Type (Etype (Lop)) + and then not Is_Floating_Point_Type (Etype (Lop)) and then Nkind (Rop) in N_Has_Entity and then Etype (Lop) = Entity (Rop) and then Comes_From_Source (N) @@ -4329,9 +4428,9 @@ package body Exp_Ch4 is and then Comes_From_Source (N) and then not In_Instance; -- This must be true for any of the optimization warnings, we - -- clearly want to give them only for source with the flag on. - -- We also skip these warnings in an instance since it may be - -- the case that different instantiations have different ranges. + -- clearly want to give them only for source with the flag on. We + -- also skip these warnings in an instance since it may be the + -- case that different instantiations have different ranges. Warn2 : constant Boolean := Warn1 @@ -4340,8 +4439,8 @@ package body Exp_Ch4 is -- For the case where only one bound warning is elided, we also -- insist on an explicit range and an integer type. The reason is -- that the use of enumeration ranges including an end point is - -- common, as is the use of a subtype name, one of whose bounds - -- is the same as the type of the expression. + -- common, as is the use of a subtype name, one of whose bounds is + -- the same as the type of the expression. begin -- If test is explicit x'first .. x'last, replace by valid check @@ -4386,8 +4485,8 @@ package body Exp_Ch4 is return; end if; - -- If we have an explicit range, do a bit of optimization based - -- on range analysis (we may be able to kill one or both checks). + -- If we have an explicit range, do a bit of optimization based on + -- range analysis (we may be able to kill one or both checks). Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => False); Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => False); @@ -4402,8 +4501,7 @@ package body Exp_Ch4 is Error_Msg_N ("\?value is known to be out of range", N); end if; - Rewrite (N, - New_Reference_To (Standard_False, Loc)); + Rewrite (N, New_Reference_To (Standard_False, Loc)); Analyze_And_Resolve (N, Rtyp); Set_Is_Static_Expression (N, Static); @@ -4418,8 +4516,7 @@ package body Exp_Ch4 is Error_Msg_N ("\?value is known to be in range", N); end if; - Rewrite (N, - New_Reference_To (Standard_True, Loc)); + Rewrite (N, New_Reference_To (Standard_True, Loc)); Analyze_And_Resolve (N, Rtyp); Set_Is_Static_Expression (N, Static); @@ -4533,11 +4630,8 @@ package body Exp_Ch4 is -- Update decoration of relocated node referenced by the -- SCIL node. - if Generate_SCIL - and then Present (SCIL_Node) - then - Set_SCIL_Related_Node (SCIL_Node, N); - Insert_Action (N, SCIL_Node); + if Generate_SCIL and then Present (SCIL_Node) then + Set_SCIL_Node (N, SCIL_Node); end if; end if; @@ -4576,12 +4670,10 @@ package body Exp_Ch4 is Make_Raise_Program_Error (Loc, Reason => PE_Unchecked_Union_Restriction)); - -- Prevent Gigi from generating incorrect code by rewriting - -- the test as a standard False. - - Rewrite (N, - New_Occurrence_Of (Standard_False, Loc)); + -- Prevent Gigi from generating incorrect code by rewriting the + -- test as False. + Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); return; end if; @@ -4592,8 +4684,7 @@ package body Exp_Ch4 is end if; if not Is_Constrained (Typ) then - Rewrite (N, - New_Reference_To (Standard_True, Loc)); + Rewrite (N, New_Reference_To (Standard_True, Loc)); Analyze_And_Resolve (N, Rtyp); -- For the constrained array case, we have to check the subscripts @@ -4601,19 +4692,18 @@ package body Exp_Ch4 is -- must match in any case). elsif Is_Array_Type (Typ) then - Check_Subscripts : declare - function Construct_Attribute_Reference + function Build_Attribute_Reference (E : Node_Id; Nam : Name_Id; Dim : Nat) return Node_Id; - -- Build attribute reference E'Nam(Dim) + -- Build attribute reference E'Nam (Dim) - ----------------------------------- - -- Construct_Attribute_Reference -- - ----------------------------------- + ------------------------------- + -- Build_Attribute_Reference -- + ------------------------------- - function Construct_Attribute_Reference + function Build_Attribute_Reference (E : Node_Id; Nam : Name_Id; Dim : Nat) return Node_Id @@ -4621,11 +4711,11 @@ package body Exp_Ch4 is begin return Make_Attribute_Reference (Loc, - Prefix => E, + Prefix => E, Attribute_Name => Nam, - Expressions => New_List ( + Expressions => New_List ( Make_Integer_Literal (Loc, Dim))); - end Construct_Attribute_Reference; + end Build_Attribute_Reference; -- Start of processing for Check_Subscripts @@ -4634,21 +4724,21 @@ package body Exp_Ch4 is Evolve_And_Then (Cond, Make_Op_Eq (Loc, Left_Opnd => - Construct_Attribute_Reference + Build_Attribute_Reference (Duplicate_Subexpr_No_Checks (Obj), Name_First, J), Right_Opnd => - Construct_Attribute_Reference + Build_Attribute_Reference (New_Occurrence_Of (Typ, Loc), Name_First, J))); Evolve_And_Then (Cond, Make_Op_Eq (Loc, Left_Opnd => - Construct_Attribute_Reference + Build_Attribute_Reference (Duplicate_Subexpr_No_Checks (Obj), Name_Last, J), Right_Opnd => - Construct_Attribute_Reference + Build_Attribute_Reference (New_Occurrence_Of (Typ, Loc), Name_Last, J))); end loop; @@ -4795,7 +4885,7 @@ package body Exp_Ch4 is -- The second expression in a 'Read attribute reference - -- The prefix of an address or size attribute reference + -- The prefix of an address or bit or size attribute reference -- The following circuit detects these exceptions @@ -4819,6 +4909,8 @@ package body Exp_Ch4 is elsif Nkind (Parnt) = N_Attribute_Reference and then (Attribute_Name (Parnt) = Name_Address or else + Attribute_Name (Parnt) = Name_Bit + or else Attribute_Name (Parnt) = Name_Size) and then Prefix (Parnt) = Child then @@ -5168,7 +5260,7 @@ package body Exp_Ch4 is and then Is_Power_Of_2_For_Shift (Ropnd) -- We cannot do this transformation in configurable run time mode if we - -- have 64-bit -- integers and long shifts are not available. + -- have 64-bit integers and long shifts are not available. and then (Esize (Ltyp) <= 32 @@ -5983,8 +6075,7 @@ package body Exp_Ch4 is -- En * En else -- Expv = 4 - Temp := - Make_Defining_Identifier (Loc, New_Internal_Name ('E')); + Temp := Make_Temporary (Loc, 'E', Base); Insert_Actions (N, New_List ( Make_Object_Declaration (Loc, @@ -6014,6 +6105,9 @@ package body Exp_Ch4 is -- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion -- of the higher level node converts it into a shift. + -- Another case is 2 ** N in any other context. We simply convert + -- this to 1 * 2 ** N, and then the above transformation applies. + -- Note: this transformation is not applicable for a modular type with -- a non-binary modulus in the multiplication case, since we get a wrong -- result if the shift causes an overflow before the modular reduction. @@ -6024,33 +6118,45 @@ package body Exp_Ch4 is and then Esize (Root_Type (Exptyp)) <= Esize (Standard_Integer) and then Is_Unsigned_Type (Exptyp) and then not Ovflo - and then Nkind (Parent (N)) in N_Binary_Op then - declare - P : constant Node_Id := Parent (N); - L : constant Node_Id := Left_Opnd (P); - R : constant Node_Id := Right_Opnd (P); + -- First the multiply and divide cases - begin - if (Nkind (P) = N_Op_Multiply - and then not Non_Binary_Modulus (Typ) - and then - ((Is_Integer_Type (Etype (L)) and then R = N) - or else - (Is_Integer_Type (Etype (R)) and then L = N)) - and then not Do_Overflow_Check (P)) - - or else - (Nkind (P) = N_Op_Divide - and then Is_Integer_Type (Etype (L)) - and then Is_Unsigned_Type (Etype (L)) - and then R = N - and then not Do_Overflow_Check (P)) - then - Set_Is_Power_Of_2_For_Shift (N); - return; - end if; - end; + if Nkind_In (Parent (N), N_Op_Divide, N_Op_Multiply) then + declare + P : constant Node_Id := Parent (N); + L : constant Node_Id := Left_Opnd (P); + R : constant Node_Id := Right_Opnd (P); + + begin + if (Nkind (P) = N_Op_Multiply + and then not Non_Binary_Modulus (Typ) + and then + ((Is_Integer_Type (Etype (L)) and then R = N) + or else + (Is_Integer_Type (Etype (R)) and then L = N)) + and then not Do_Overflow_Check (P)) + or else + (Nkind (P) = N_Op_Divide + and then Is_Integer_Type (Etype (L)) + and then Is_Unsigned_Type (Etype (L)) + and then R = N + and then not Do_Overflow_Check (P)) + then + Set_Is_Power_Of_2_For_Shift (N); + return; + end if; + end; + + -- Now the other cases + + elsif not Non_Binary_Modulus (Typ) then + Rewrite (N, + Make_Op_Multiply (Loc, + Left_Opnd => Make_Integer_Literal (Loc, 1), + Right_Opnd => Relocate_Node (N))); + Analyze_And_Resolve (N, Typ); + return; + end if; end if; -- Fall through if exponentiation must be done using a runtime routine @@ -6743,7 +6849,7 @@ package body Exp_Ch4 is --------------------- -- If the argument is other than a Boolean array type, there is no special - -- expansion required. + -- expansion required, except for VMS operations on signed integers. -- For the packed case, we call the special routine in Exp_Pakd, except -- that if the component size is greater than one, we use the standard @@ -6793,6 +6899,49 @@ package body Exp_Ch4 is return; end if; + -- For the VMS "not" on signed integer types, use conversion to and + -- from a predefined modular type. + + if Is_VMS_Operator (Entity (N)) then + declare + Rtyp : Entity_Id; + Utyp : Entity_Id; + + begin + -- If this is a derived type, retrieve original VMS type so that + -- the proper sized type is used for intermediate values. + + if Is_Derived_Type (Typ) then + Rtyp := First_Subtype (Etype (Typ)); + else + Rtyp := Typ; + end if; + + -- The proper unsigned type must have a size compatible with + -- the operand, to prevent misalignment.. + + if RM_Size (Rtyp) <= 8 then + Utyp := RTE (RE_Unsigned_8); + + elsif RM_Size (Rtyp) <= 16 then + Utyp := RTE (RE_Unsigned_16); + + elsif RM_Size (Rtyp) = RM_Size (Standard_Unsigned) then + Utyp := RTE (RE_Unsigned_32); + + else + Utyp := RTE (RE_Long_Long_Unsigned); + end if; + + Rewrite (N, + Unchecked_Convert_To (Typ, + Make_Op_Not (Loc, + Unchecked_Convert_To (Utyp, Right_Opnd (N))))); + Analyze_And_Resolve (N, Typ); + return; + end; + end if; + -- Only array types need any other processing if not Is_Array_Type (Typ) then @@ -6897,7 +7046,7 @@ package body Exp_Ch4 is Name => B_J, Expression => Make_Op_Not (Loc, A_J)))); - Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('N')); + Func_Name := Make_Temporary (Loc, 'N'); Set_Is_Inlined (Func_Name); Insert_Action (N, @@ -7168,104 +7317,8 @@ package body Exp_Ch4 is -- Expand_N_Or_Else -- ---------------------- - -- Expand into conditional expression if Actions present, and also - -- deal with optimizing case of arguments being True or False. - - procedure Expand_N_Or_Else (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Typ : constant Entity_Id := Etype (N); - Left : constant Node_Id := Left_Opnd (N); - Right : constant Node_Id := Right_Opnd (N); - Actlist : List_Id; - - begin - -- Deal with non-standard booleans - - if Is_Boolean_Type (Typ) then - Adjust_Condition (Left); - Adjust_Condition (Right); - Set_Etype (N, Standard_Boolean); - end if; - - -- Check for cases where left argument is known to be True or False - - if Compile_Time_Known_Value (Left) then - - -- If left argument is False, change (False or else Right) to Right. - -- Any actions associated with Right will be executed unconditionally - -- and can thus be inserted into the tree unconditionally. - - if Expr_Value_E (Left) = Standard_False then - if Present (Actions (N)) then - Insert_Actions (N, Actions (N)); - end if; - - Rewrite (N, Right); - - -- If left argument is True, change (True and then Right) to True. In - -- this case we can forget the actions associated with Right, since - -- they will never be executed. - - else pragma Assert (Expr_Value_E (Left) = Standard_True); - Kill_Dead_Code (Right); - Kill_Dead_Code (Actions (N)); - Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); - end if; - - Adjust_Result_Type (N, Typ); - return; - end if; - - -- If Actions are present, we expand - - -- left or else right - - -- into - - -- if left then True else right end - - -- with the actions becoming the Else_Actions of the conditional - -- expression. This conditional expression is then further expanded - -- (and will eventually disappear) - - if Present (Actions (N)) then - Actlist := Actions (N); - Rewrite (N, - Make_Conditional_Expression (Loc, - Expressions => New_List ( - Left, - New_Occurrence_Of (Standard_True, Loc), - Right))); - - Set_Else_Actions (N, Actlist); - Analyze_And_Resolve (N, Standard_Boolean); - Adjust_Result_Type (N, Typ); - return; - end if; - - -- No actions present, check for cases of right argument True/False - - if Compile_Time_Known_Value (Right) then - - -- Change (Left or else False) to Left. Note that we know there are - -- no actions associated with the True operand, since we just checked - -- for this case above. - - if Expr_Value_E (Right) = Standard_False then - Rewrite (N, Left); - - -- Change (Left or else True) to True, making sure to preserve any - -- side effects associated with the Left operand. - - else pragma Assert (Expr_Value_E (Right) = Standard_True); - Remove_Side_Effects (Left); - Rewrite - (N, New_Occurrence_Of (Standard_True, Loc)); - end if; - end if; - - Adjust_Result_Type (N, Typ); - end Expand_N_Or_Else; + procedure Expand_N_Or_Else (N : Node_Id) + renames Expand_Short_Circuit_Operator; ----------------------------------- -- Expand_N_Qualified_Expression -- @@ -7604,6 +7657,7 @@ package body Exp_Ch4 is procedure Make_Temporary_For_Slice is Decl : Node_Id; Ent : constant Entity_Id := Make_Temporary (Loc, 'T', N); + begin Decl := Make_Object_Declaration (Loc, @@ -7739,7 +7793,6 @@ package body Exp_Ch4 is Cons : List_Id; begin - -- Nothing else to do if no change of representation if Same_Representation (Operand_Type, Target_Type) then @@ -7828,7 +7881,7 @@ package body Exp_Ch4 is Constraints => Cons)); end if; - Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('C')); + Temp := Make_Temporary (Loc, 'C'); Decl := Make_Object_Declaration (Loc, Defining_Identifier => Temp, @@ -7990,9 +8043,7 @@ package body Exp_Ch4 is Enable_Overflow_Check (Conv); end if; - Tnn := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); + Tnn := Make_Temporary (Loc, 'T', Conv); Insert_Actions (N, New_List ( Make_Object_Declaration (Loc, @@ -8223,15 +8274,13 @@ package body Exp_Ch4 is -- renaming, since this is an error situation which will be caught by -- Sem_Ch8, and the expansion can interfere with this error check. - if Is_Access_Type (Target_Type) - and then Is_Renamed_Object (N) - then + if Is_Access_Type (Target_Type) and then Is_Renamed_Object (N) then return; end if; -- Otherwise, proceed with processing tagged conversion - declare + Tagged_Conversion : declare Actual_Op_Typ : Entity_Id; Actual_Targ_Typ : Entity_Id; Make_Conversion : Boolean := False; @@ -8286,7 +8335,7 @@ package body Exp_Ch4 is Reason => CE_Tag_Check_Failed)); end Make_Tag_Check; - -- Start of processing + -- Start of processing for Tagged_Conversion begin if Is_Access_Type (Target_Type) then @@ -8383,7 +8432,7 @@ package body Exp_Ch4 is end; end if; end if; - end; + end Tagged_Conversion; -- Case of other access type conversions @@ -8420,9 +8469,9 @@ package body Exp_Ch4 is end if; -- Otherwise do correct fixed-conversion, but skip these if the - -- Conversion_OK flag is set, because from a semantic point of - -- view these are simple integer conversions needing no further - -- processing (the backend will simply treat them as integers) + -- Conversion_OK flag is set, because from a semantic point of view + -- these are simple integer conversions needing no further processing + -- (the backend will simply treat them as integers). if not Conversion_OK (N) then if Is_Fixed_Point_Type (Etype (N)) then @@ -8476,7 +8525,7 @@ package body Exp_Ch4 is -- with the end-point. But that can lose precision in some cases, and -- give a wrong result. Converting the operand to Universal_Real is -- helpful, but still does not catch all cases with 64-bit integers - -- on targets with only 64-bit floats + -- on targets with only 64-bit floats. -- The above comment seems obsoleted by Apply_Float_Conversion_Check -- Can this code be removed ??? @@ -8559,7 +8608,7 @@ package body Exp_Ch4 is elsif Is_Enumeration_Type (Target_Type) then -- Special processing is required if there is a change of - -- representation (from enumeration representation clauses) + -- representation (from enumeration representation clauses). if not Same_Representation (Target_Type, Operand_Type) then @@ -8585,9 +8634,8 @@ package body Exp_Ch4 is end if; -- At this stage, either the conversion node has been transformed into - -- some other equivalent expression, or left as a conversion that can - -- be handled by Gigi. The conversions that Gigi can handle are the - -- following: + -- some other equivalent expression, or left as a conversion that can be + -- handled by Gigi, in the following cases: -- Conversions with no change of representation or type @@ -8640,7 +8688,7 @@ package body Exp_Ch4 is end if; -- Reset overflow flag, since the range check will include - -- dealing with possible overflow, and generate the check If + -- dealing with possible overflow, and generate the check. If -- Address is either a source type or target type, suppress -- range check to avoid typing anomalies when it is a visible -- integer type. @@ -8671,16 +8719,15 @@ package body Exp_Ch4 is -- Expand_N_Unchecked_Expression -- ----------------------------------- - -- Remove the unchecked expression node from the tree. It's job was simply + -- Remove the unchecked expression node from the tree. Its job was simply -- to make sure that its constituent expression was handled with checks -- off, and now that that is done, we can remove it from the tree, and - -- indeed must, since gigi does not expect to see these nodes. + -- indeed must, since Gigi does not expect to see these nodes. procedure Expand_N_Unchecked_Expression (N : Node_Id) is Exp : constant Node_Id := Expression (N); - begin - Set_Assignment_OK (Exp, Assignment_OK (N) or Assignment_OK (Exp)); + Set_Assignment_OK (Exp, Assignment_OK (N) or else Assignment_OK (Exp)); Rewrite (N, Exp); end Expand_N_Unchecked_Expression; @@ -8699,9 +8746,12 @@ package body Exp_Ch4 is begin -- Nothing at all to do if conversion is to the identical type so remove -- the conversion completely, it is useless, except that it may carry - -- an Assignment_OK indication which must be proprgated to the operand. + -- an Assignment_OK indication which must be propagated to the operand. if Operand_Type = Target_Type then + + -- Code duplicates Expand_N_Unchecked_Expression above, factor??? + if Assignment_OK (N) then Set_Assignment_OK (Operand); end if; @@ -8859,7 +8909,6 @@ package body Exp_Ch4 is Result := New_Reference_To (Standard_True, Loc); C := Suitable_Element (First_Entity (Typ)); - while Present (C) loop declare New_Lhs : Node_Id; @@ -8909,6 +8958,206 @@ package body Exp_Ch4 is return Result; end Expand_Record_Equality; + ----------------------------------- + -- Expand_Short_Circuit_Operator -- + ----------------------------------- + + -- Deal with special expansion if actions are present for the right operand + -- and deal with optimizing case of arguments being True or False. We also + -- deal with the special case of non-standard boolean values. + + procedure Expand_Short_Circuit_Operator (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + LocR : constant Source_Ptr := Sloc (Right); + Actlist : List_Id; + + Shortcut_Value : constant Boolean := Nkind (N) = N_Or_Else; + Shortcut_Ent : constant Entity_Id := Boolean_Literals (Shortcut_Value); + -- If Left = Shortcut_Value then Right need not be evaluated + + function Make_Test_Expr (Opnd : Node_Id) return Node_Id; + -- For Opnd a boolean expression, return a Boolean expression equivalent + -- to Opnd /= Shortcut_Value. + + -------------------- + -- Make_Test_Expr -- + -------------------- + + function Make_Test_Expr (Opnd : Node_Id) return Node_Id is + begin + if Shortcut_Value then + return Make_Op_Not (Sloc (Opnd), Opnd); + else + return Opnd; + end if; + end Make_Test_Expr; + + Op_Var : Entity_Id; + -- Entity for a temporary variable holding the value of the operator, + -- used for expansion in the case where actions are present. + + -- Start of processing for Expand_Short_Circuit_Operator + + begin + -- Deal with non-standard booleans + + if Is_Boolean_Type (Typ) then + Adjust_Condition (Left); + Adjust_Condition (Right); + Set_Etype (N, Standard_Boolean); + end if; + + -- Check for cases where left argument is known to be True or False + + if Compile_Time_Known_Value (Left) then + + -- Mark SCO for left condition as compile time known + + if Generate_SCO and then Comes_From_Source (Left) then + Set_SCO_Condition (Left, Expr_Value_E (Left) = Standard_True); + end if; + + -- Rewrite True AND THEN Right / False OR ELSE Right to Right. + -- Any actions associated with Right will be executed unconditionally + -- and can thus be inserted into the tree unconditionally. + + if Expr_Value_E (Left) /= Shortcut_Ent then + if Present (Actions (N)) then + Insert_Actions (N, Actions (N)); + end if; + + Rewrite (N, Right); + + -- Rewrite False AND THEN Right / True OR ELSE Right to Left. + -- In this case we can forget the actions associated with Right, + -- since they will never be executed. + + else + Kill_Dead_Code (Right); + Kill_Dead_Code (Actions (N)); + Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc)); + end if; + + Adjust_Result_Type (N, Typ); + return; + end if; + + -- If Actions are present for the right operand, we have to do some + -- special processing. We can't just let these actions filter back into + -- code preceding the short circuit (which is what would have happened + -- if we had not trapped them in the short-circuit form), since they + -- must only be executed if the right operand of the short circuit is + -- executed and not otherwise. + + -- the temporary variable C. + + if Present (Actions (N)) then + Actlist := Actions (N); + + -- The old approach is to expand: + + -- left AND THEN right + + -- into + + -- C : Boolean := False; + -- IF left THEN + -- Actions; + -- IF right THEN + -- C := True; + -- END IF; + -- END IF; + + -- and finally rewrite the operator into a reference to C. Similarly + -- for left OR ELSE right, with negated values. Note that this + -- rewrite causes some difficulties for coverage analysis because + -- of the introduction of the new variable C, which obscures the + -- structure of the test. + + -- We use this "old approach" if use of N_Expression_With_Actions + -- is False (see description in Opt of when this is or is not set). + + if not Use_Expression_With_Actions then + Op_Var := Make_Temporary (Loc, 'C', Related_Node => N); + + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => + Op_Var, + Object_Definition => + New_Occurrence_Of (Standard_Boolean, Loc), + Expression => + New_Occurrence_Of (Shortcut_Ent, Loc))); + + Append_To (Actlist, + Make_Implicit_If_Statement (Right, + Condition => Make_Test_Expr (Right), + Then_Statements => New_List ( + Make_Assignment_Statement (LocR, + Name => New_Occurrence_Of (Op_Var, LocR), + Expression => + New_Occurrence_Of + (Boolean_Literals (not Shortcut_Value), LocR))))); + + Insert_Action (N, + Make_Implicit_If_Statement (Left, + Condition => Make_Test_Expr (Left), + Then_Statements => Actlist)); + + Rewrite (N, New_Occurrence_Of (Op_Var, Loc)); + Analyze_And_Resolve (N, Standard_Boolean); + + -- The new approach, activated for now by the use of debug flag + -- -gnatd.X is to use the new Expression_With_Actions node for the + -- right operand of the short-circuit form. This should solve the + -- traceability problems for coverage analysis. + + else + Rewrite (Right, + Make_Expression_With_Actions (LocR, + Expression => Relocate_Node (Right), + Actions => Actlist)); + Set_Actions (N, No_List); + Analyze_And_Resolve (Right, Standard_Boolean); + end if; + + Adjust_Result_Type (N, Typ); + return; + end if; + + -- No actions present, check for cases of right argument True/False + + if Compile_Time_Known_Value (Right) then + + -- Mark SCO for left condition as compile time known + + if Generate_SCO and then Comes_From_Source (Right) then + Set_SCO_Condition (Right, Expr_Value_E (Right) = Standard_True); + end if; + + -- Change (Left and then True), (Left or else False) to Left. + -- Note that we know there are no actions associated with the right + -- operand, since we just checked for this case above. + + if Expr_Value_E (Right) /= Shortcut_Ent then + Rewrite (N, Left); + + -- Change (Left and then False), (Left or else True) to Right, + -- making sure to preserve any side effects associated with the Left + -- operand. + + else + Remove_Side_Effects (Left); + Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc)); + end if; + end if; + + Adjust_Result_Type (N, Typ); + end Expand_Short_Circuit_Operator; + ------------------------------------- -- Fixup_Universal_Fixed_Operation -- ------------------------------------- @@ -8975,7 +9224,7 @@ package body Exp_Ch4 is PtrT /= Etype (Defining_Unit_Name (Associated_Node_For_Itype (PtrT))) then - Owner := Make_Defining_Identifier (Loc, New_Internal_Name ('J')); + Owner := Make_Temporary (Loc, 'J'); Insert_Action (N, Make_Full_Type_Declaration (Loc, Defining_Identifier => Owner, @@ -8999,7 +9248,7 @@ package body Exp_Ch4 is then Owner := Scope (Return_Applies_To (Scope (PtrT))); - -- Case of an access discriminant, or (Ada 2005), of an anonymous + -- Case of an access discriminant, or (Ada 2005) of an anonymous -- access component or anonymous access function result: find the -- final list associated with the scope of the type. (In the -- anonymous access component kind, a list controller will have @@ -9466,7 +9715,7 @@ package body Exp_Ch4 is -- if ... end if; -- end Gnnn; - Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('G')); + Func_Name := Make_Temporary (Loc, 'G'); Func_Body := Make_Subprogram_Body (Loc, @@ -9594,8 +9843,7 @@ package body Exp_Ch4 is Defining_Identifier => B, Parameter_Type => New_Reference_To (Typ, Loc))); - Func_Name := - Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Func_Name := Make_Temporary (Loc, 'A'); Set_Is_Inlined (Func_Name); Func_Body := @@ -9647,7 +9895,7 @@ package body Exp_Ch4 is -- in the call to Compile_Time_Compare. If this call results in a -- clear result of always True or Always False, that's decisive and -- we are done. Otherwise we repeat the processing with Assume_Valid - -- set to True to generate additional warnings. We can stil that step + -- set to True to generate additional warnings. We can skip that step -- if Constant_Condition_Warnings is False. for AV in False .. True loop @@ -9736,9 +9984,9 @@ package body Exp_Ch4 is end if; -- If this is the second iteration (AV = True), and the original - -- node comes from source and we are not in an instance, then - -- give a warning if we know result would be True or False. Note - -- we know Constant_Condition_Warnings is set if we get here. + -- node comes from source and we are not in an instance, then give + -- a warning if we know result would be True or False. Note: we + -- know Constant_Condition_Warnings is set if we get here. elsif Comes_From_Source (Original_Node (N)) and then not In_Instance @@ -9756,9 +10004,9 @@ package body Exp_Ch4 is end; -- Skip second iteration if not warning on constant conditions or - -- if the first iteration already generated a warning of some kind - -- or if we are in any case assuming all values are valid (so that - -- the first iteration took care of the valid case). + -- if the first iteration already generated a warning of some kind or + -- if we are in any case assuming all values are valid (so that the + -- first iteration took care of the valid case). exit when not Constant_Condition_Warnings; exit when Warning_Generated; @@ -9825,7 +10073,7 @@ package body Exp_Ch4 is end if; end Is_Safe_Operand; - -- Start of processing for Is_Safe_In_Place_Array_Op + -- Start of processing for Is_Safe_In_Place_Array_Op begin -- Skip this processing if the component size is different from system @@ -9846,12 +10094,10 @@ package body Exp_Ch4 is elsif not Is_Unaliased (Lhs) then return False; + else Target := Entity (Lhs); - - return - Is_Safe_Operand (Op1) - and then Is_Safe_Operand (Op2); + return Is_Safe_Operand (Op1) and then Is_Safe_Operand (Op2); end if; end Safe_In_Place_Array_Op; diff --git a/gcc/ada/exp_ch4.ads b/gcc/ada/exp_ch4.ads index fad8c15eea1..745ce294d6a 100644 --- a/gcc/ada/exp_ch4.ads +++ b/gcc/ada/exp_ch4.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,9 +31,10 @@ package Exp_Ch4 is procedure Expand_N_Allocator (N : Node_Id); procedure Expand_N_And_Then (N : Node_Id); + procedure Expand_N_Case_Expression (N : Node_Id); procedure Expand_N_Conditional_Expression (N : Node_Id); - procedure Expand_N_In (N : Node_Id); procedure Expand_N_Explicit_Dereference (N : Node_Id); + procedure Expand_N_In (N : Node_Id); procedure Expand_N_Indexed_Component (N : Node_Id); procedure Expand_N_Not_In (N : Node_Id); procedure Expand_N_Null (N : Node_Id); diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 021afbf5282..71b58ae358e 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -516,8 +516,7 @@ package body Exp_Ch5 is if Nkind (Rhs) = N_String_Literal then declare - Temp : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('T')); + Temp : constant Entity_Id := Make_Temporary (Loc, 'T', Rhs); Decl : Node_Id; begin @@ -1028,13 +1027,8 @@ package body Exp_Ch5 is R_Index := First_Index (R_Type); for J in 1 .. Ndim loop - Lnn (J) := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('L')); - - Rnn (J) := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('R')); + Lnn (J) := Make_Temporary (Loc, 'L'); + Rnn (J) := Make_Temporary (Loc, 'R'); L_Index_Type (J) := Etype (L_Index); R_Index_Type (J) := Etype (R_Index); @@ -1624,8 +1618,7 @@ package body Exp_Ch5 is BPAR_Expr : constant Node_Id := Relocate_Node (Prefix (Lhs)); BPAR_Typ : constant Entity_Id := Etype (BPAR_Expr); Tnn : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); + Make_Temporary (Loc, 'T', BPAR_Expr); begin -- Insert the post assignment first, because we want to copy the @@ -2848,8 +2841,7 @@ package body Exp_Ch5 is -- Create an access type designating the function's -- result subtype. - Ref_Type := - Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Ref_Type := Make_Temporary (Loc, 'A'); Ptr_Type_Decl := Make_Full_Type_Declaration (Loc, @@ -2867,9 +2859,7 @@ package body Exp_Ch5 is -- from an implicit access value passed in by the caller -- or from the result of an allocator. - Alloc_Obj_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('R')); + Alloc_Obj_Id := Make_Temporary (Loc, 'R'); Set_Etype (Alloc_Obj_Id, Ref_Type); Alloc_Obj_Decl := @@ -3854,8 +3844,7 @@ package body Exp_Ch5 is then declare Return_Object_Entity : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('R')); + Make_Temporary (Loc, 'R', Exp); Obj_Decl : constant Node_Id := Make_Object_Declaration (Loc, Defining_Identifier => Return_Object_Entity, @@ -4009,13 +3998,9 @@ package body Exp_Ch5 is elsif CW_Or_Has_Controlled_Part (Utyp) then declare Loc : constant Source_Ptr := Sloc (N); - Temp : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('R')); - Acc_Typ : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('A')); + Acc_Typ : constant Entity_Id := Make_Temporary (Loc, 'A'); Alloc_Node : Node_Id; + Temp : Entity_Id; begin Set_Ekind (Acc_Typ, E_Access_Type); @@ -4031,13 +4016,15 @@ package body Exp_Ch5 is Expression => Make_Qualified_Expression (Loc, Subtype_Mark => New_Reference_To (Etype (Exp), Loc), - Expression => Relocate_Node (Exp))); + Expression => Relocate_Node (Exp))); -- We do not want discriminant checks on the declaration, -- given that it gets its value from the allocator. Set_No_Initialization (Alloc_Node); + Temp := Make_Temporary (Loc, 'R', Alloc_Node); + Insert_List_Before_And_Analyze (N, New_List ( Make_Full_Type_Declaration (Loc, Defining_Identifier => Acc_Typ, @@ -4118,18 +4105,18 @@ package body Exp_Ch5 is else declare + ExpR : constant Node_Id := Relocate_Node (Exp); Result_Id : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('R')); - Result_Exp : constant Node_Id := + Make_Temporary (Loc, 'R', ExpR); + Result_Exp : constant Node_Id := New_Reference_To (Result_Id, Loc); - Result_Obj : constant Node_Id := + Result_Obj : constant Node_Id := Make_Object_Declaration (Loc, Defining_Identifier => Result_Id, Object_Definition => New_Reference_To (R_Type, Loc), Constant_Present => True, - Expression => Relocate_Node (Exp)); + Expression => ExpR); begin Set_Assignment_OK (Result_Obj); @@ -4205,24 +4192,24 @@ package body Exp_Ch5 is end; end if; - -- If we are returning an object that may not be bit-aligned, then - -- copy the value into a temporary first. This copy may need to expand - -- to a loop of component operations.. + -- If we are returning an object that may not be bit-aligned, then copy + -- the value into a temporary first. This copy may need to expand to a + -- loop of component operations. if Is_Possibly_Unaligned_Slice (Exp) or else Is_Possibly_Unaligned_Object (Exp) then declare - Tnn : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('T')); + ExpR : constant Node_Id := Relocate_Node (Exp); + Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', ExpR); begin Insert_Action (Exp, Make_Object_Declaration (Loc, Defining_Identifier => Tnn, Constant_Present => True, Object_Definition => New_Occurrence_Of (R_Type, Loc), - Expression => Relocate_Node (Exp)), - Suppress => All_Checks); + Expression => ExpR), + Suppress => All_Checks); Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); end; end if; @@ -4255,8 +4242,8 @@ package body Exp_Ch5 is else declare - Tnn : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('T')); + ExpR : constant Node_Id := Relocate_Node (Exp); + Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', ExpR); begin -- For a complex expression of an elementary type, capture @@ -4268,7 +4255,7 @@ package body Exp_Ch5 is Defining_Identifier => Tnn, Constant_Present => True, Object_Definition => New_Occurrence_Of (R_Type, Loc), - Expression => Relocate_Node (Exp)), + Expression => ExpR), Suppress => All_Checks); Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); @@ -4281,7 +4268,7 @@ package body Exp_Ch5 is Make_Object_Renaming_Declaration (Loc, Defining_Identifier => Tnn, Subtype_Mark => New_Occurrence_Of (R_Type, Loc), - Name => Relocate_Node (Exp)), + Name => ExpR), Suppress => All_Checks); Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); @@ -4421,8 +4408,7 @@ package body Exp_Ch5 is -- Save the Tag in a local variable Tag_Tmp if Save_Tag then - Tag_Tmp := - Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Tag_Tmp := Make_Temporary (Loc, 'A'); Append_To (Res, Make_Object_Declaration (Loc, @@ -4461,8 +4447,7 @@ package body Exp_Ch5 is New_Reference_To (Controller_Component (T), Loc)); end if; - Prev_Tmp := - Make_Defining_Identifier (Loc, New_Internal_Name ('B')); + Prev_Tmp := Make_Temporary (Loc, 'B'); Append_To (Res, Make_Object_Declaration (Loc, @@ -4477,9 +4462,7 @@ package body Exp_Ch5 is Unchecked_Convert_To (RTE (RE_Finalizable), Ctrl_Ref), Selector_Name => Make_Identifier (Loc, Name_Prev)))); - Next_Tmp := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('C')); + Next_Tmp := Make_Temporary (Loc, 'C'); Append_To (Res, Make_Object_Declaration (Loc, @@ -4638,9 +4621,7 @@ package body Exp_Ch5 is Make_Integer_Literal (Loc, Intval => System_Storage_Unit)); - Range_Type := - Make_Defining_Identifier (Loc, - New_Internal_Name ('G')); + Range_Type := Make_Temporary (Loc, 'G'); Append_To (Res, Make_Subtype_Declaration (Loc, @@ -4659,9 +4640,7 @@ package body Exp_Ch5 is Append_To (Res, Make_Subtype_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - New_Internal_Name ('S')), + Defining_Identifier => Make_Temporary (Loc, 'S'), Subtype_Indication => Make_Subtype_Indication (Loc, Subtype_Mark => @@ -4673,9 +4652,7 @@ package body Exp_Ch5 is -- type A is access S - Opaque_Type := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('A')); + Opaque_Type := Make_Temporary (Loc, 'A'); Append_To (Res, Make_Full_Type_Declaration (Loc, @@ -4721,9 +4698,7 @@ package body Exp_Ch5 is -- Last index before hole: determined by position of the -- _Controller.Prev component. - Last_Before_Hole := - Make_Defining_Identifier (Loc, - New_Internal_Name ('L')); + Last_Before_Hole := Make_Temporary (Loc, 'L'); Append_To (Res, Make_Object_Declaration (Loc, @@ -4731,7 +4706,8 @@ package body Exp_Ch5 is Object_Definition => New_Occurrence_Of ( RTE (RE_Storage_Offset), Loc), Constant_Present => True, - Expression => Make_Op_Add (Loc, + Expression => + Make_Op_Add (Loc, Make_Attribute_Reference (Loc, Prefix => Prev_Ref, Attribute_Name => Name_Position), @@ -4756,9 +4732,7 @@ package body Exp_Ch5 is -- First index after hole - First_After_Hole := - Make_Defining_Identifier (Loc, - New_Internal_Name ('F')); + First_After_Hole := Make_Temporary (Loc, 'F'); Append_To (Res, Make_Object_Declaration (Loc, diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 4ab2df7b878..9ddb278417c 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -808,9 +808,7 @@ package body Exp_Ch6 is Elm := First_Elmt (Var_List); while Present (Elm) loop Var := Node (Elm); - Ent := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); + Ent := Make_Temporary (Loc, 'S'); Append_Elmt (Ent, Shad_List); -- Insert a declaration for this temporary at the start of the @@ -966,9 +964,7 @@ package body Exp_Ch6 is return; end if; - Temp := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); + Temp := Make_Temporary (Loc, 'T', Actual); -- Use formal type for temp, unless formal type is an unconstrained -- array, in which case we don't have to worry about bounds checks, @@ -1220,9 +1216,7 @@ package body Exp_Ch6 is Reset_Packed_Prefix; - Temp := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); + Temp := Make_Temporary (Loc, 'T', Actual); Incod := Relocate_Node (Actual); Outcod := New_Copy_Tree (Incod); @@ -1387,9 +1381,7 @@ package body Exp_Ch6 is return Entity (Actual); else - Var := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); + Var := Make_Temporary (Loc, 'T', Actual); N_Node := Make_Object_Renaming_Declaration (Loc, @@ -2676,9 +2668,7 @@ package body Exp_Ch6 is if Present (Inherited_From_Formal (Subp)) then Parent_Subp := Inherited_From_Formal (Subp); else - while Present (Alias (Parent_Subp)) loop - Parent_Subp := Alias (Parent_Subp); - end loop; + Parent_Subp := Ultimate_Alias (Parent_Subp); end if; -- The below setting of Entity is suspect, see F109-018 discussion??? @@ -2778,20 +2768,6 @@ package body Exp_Ch6 is Rewrite (Actual, Unchecked_Convert_To (Parent_Typ, Relocate_Node (Actual))); - - -- If the relocated node is a function call then it - -- can be part of the expansion of the predefined - -- equality operator of a tagged type and we may - -- need to adjust its SCIL dispatching node. - - if Generate_SCIL - and then Nkind (Actual) /= N_Null - and then Nkind (Expression (Actual)) - = N_Function_Call - then - Adjust_SCIL_Node (Actual, Expression (Actual)); - end if; - Analyze (Actual); Resolve (Actual, Parent_Typ); end if; @@ -2949,9 +2925,8 @@ package body Exp_Ch6 is return; end if; - if Ekind (Subp) = E_Function - or else Ekind (Subp) = E_Procedure - then + if Ekind_In (Subp, E_Function, E_Procedure) then + -- We perform two simple optimization on calls: -- a) replace calls to null procedures unconditionally; @@ -3104,12 +3079,14 @@ package body Exp_Ch6 is -- In Ada 2005, this may be an indirect call to an access parameter that -- is an access_to_subprogram. In that case the anonymous type has a -- scope that is a protected operation, but the call is a regular one. + -- In either case do not expand call if subprogram is eliminated. Scop := Scope (Subp); if Nkind (N) /= N_Entry_Call_Statement and then Is_Protected_Type (Scop) and then Ekind (Subp) /= E_Subprogram_Type + and then not Is_Eliminated (Subp) then -- If the call is an internal one, it is rewritten as a call to the -- corresponding unprotected subprogram. @@ -3304,6 +3281,9 @@ package body Exp_Ch6 is Temp : Entity_Id; Temp_Typ : Entity_Id; + Return_Object : Entity_Id := Empty; + -- Entity in declaration in an extended_return_statement + Is_Unc : constant Boolean := Is_Array_Type (Etype (Subp)) and then not Is_Constrained (Etype (Subp)); @@ -3312,8 +3292,8 @@ package body Exp_Ch6 is procedure Make_Exit_Label; -- Build declaration for exit label to be used in Return statements, - -- sets Exit_Lab (the label node) and Lab_Decl (corresponding implcit - -- declaration). + -- sets Exit_Lab (the label node) and Lab_Decl (corresponding implicit + -- declaration). Does nothing if Exit_Lab already set. function Process_Formals (N : Node_Id) return Traverse_Result; -- Replace occurrence of a formal with the corresponding actual, or the @@ -3343,20 +3323,15 @@ package body Exp_Ch6 is --------------------- procedure Make_Exit_Label is + Lab_Ent : Entity_Id; begin - -- Create exit label for subprogram if one does not exist yet - if No (Exit_Lab) then - Lab_Id := - Make_Identifier (Loc, - Chars => New_Internal_Name ('L')); - Set_Entity (Lab_Id, - Make_Defining_Identifier (Loc, Chars (Lab_Id))); + Lab_Ent := Make_Temporary (Loc, 'L'); + Lab_Id := New_Reference_To (Lab_Ent, Loc); Exit_Lab := Make_Label (Loc, Lab_Id); - Lab_Decl := Make_Implicit_Label_Declaration (Loc, - Defining_Identifier => Entity (Lab_Id), + Defining_Identifier => Lab_Ent, Label_Construct => Exit_Lab); end if; end Make_Exit_Label; @@ -3402,6 +3377,22 @@ package body Exp_Ch6 is Rewrite (N, New_Copy (A)); end if; end if; + return Skip; + + elsif Is_Entity_Name (N) + and then Present (Return_Object) + and then Chars (N) = Chars (Return_Object) + then + -- Occurrence within an extended return statement. The return + -- object is local to the body been inlined, and thus the generic + -- copy is not analyzed yet, so we match by name, and replace it + -- with target of call. + + if Nkind (Targ) = N_Defining_Identifier then + Rewrite (N, New_Occurrence_Of (Targ, Loc)); + else + Rewrite (N, New_Copy_Tree (Targ)); + end if; return Skip; @@ -3409,8 +3400,7 @@ package body Exp_Ch6 is if No (Expression (N)) then Make_Exit_Label; Rewrite (N, - Make_Goto_Statement (Loc, - Name => New_Copy (Lab_Id))); + Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id))); else if Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements @@ -3468,6 +3458,46 @@ package body Exp_Ch6 is return OK; + elsif Nkind (N) = N_Extended_Return_Statement then + + -- An extended return becomes a block whose first statement is + -- the assignment of the initial expression of the return object + -- to the target of the call itself. + + declare + Return_Decl : constant Entity_Id := + First (Return_Object_Declarations (N)); + Assign : Node_Id; + + begin + Return_Object := Defining_Identifier (Return_Decl); + + if Present (Expression (Return_Decl)) then + if Nkind (Targ) = N_Defining_Identifier then + Assign := + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Targ, Loc), + Expression => Expression (Return_Decl)); + else + Assign := + Make_Assignment_Statement (Loc, + Name => New_Copy (Targ), + Expression => Expression (Return_Decl)); + end if; + + Set_Assignment_OK (Name (Assign)); + Prepend (Assign, + Statements (Handled_Statement_Sequence (N))); + end if; + + Rewrite (N, + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Handled_Statement_Sequence (N))); + + return OK; + end; + -- Remove pragma Unreferenced since it may refer to formals that -- are not visible in the inlined body, and in any case we will -- not be posting warnings on the inlined body so it is unneeded. @@ -3674,15 +3704,18 @@ package body Exp_Ch6 is if Nkind (Orig_Bod) = N_Defining_Identifier or else Nkind (Orig_Bod) = N_Defining_Operator_Symbol then - -- Subprogram is a renaming_as_body. Calls appearing after the - -- renaming can be replaced with calls to the renamed entity - -- directly, because the subprograms are subtype conformant. If - -- the renamed subprogram is an inherited operation, we must redo - -- the expansion because implicit conversions may be needed. + -- Subprogram is renaming_as_body. Calls occurring after the renaming + -- can be replaced with calls to the renamed entity directly, because + -- the subprograms are subtype conformant. If the renamed subprogram + -- is an inherited operation, we must redo the expansion because + -- implicit conversions may be needed. Similarly, if the renamed + -- entity is inlined, expand the call for further optimizations. Set_Name (N, New_Occurrence_Of (Orig_Bod, Loc)); - if Present (Alias (Orig_Bod)) then + if Present (Alias (Orig_Bod)) + or else Is_Inlined (Orig_Bod) + then Expand_Call (N); end if; @@ -3793,9 +3826,7 @@ package body Exp_Ch6 is end if; else - Temp := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('C')); + Temp := Make_Temporary (Loc, 'C'); -- If the actual for an in/in-out parameter is a view conversion, -- make it into an unchecked conversion, given that an untagged @@ -3880,11 +3911,15 @@ package body Exp_Ch6 is then Targ := Name (Parent (N)); + elsif Nkind (Parent (N)) = N_Object_Declaration + and then Is_Limited_Type (Etype (Subp)) + then + Targ := Defining_Identifier (Parent (N)); + else -- Replace call with temporary and create its declaration - Temp := - Make_Defining_Identifier (Loc, New_Internal_Name ('C')); + Temp := Make_Temporary (Loc, 'C'); Set_Is_Internal (Temp); -- For the unconstrained case, the generated temporary has the @@ -4354,9 +4389,7 @@ package body Exp_Ch6 is -- For a procedure, we add a return for all possible syntactic ends of -- the subprogram. - if Ekind (Spec_Id) = E_Procedure - or else Ekind (Spec_Id) = E_Generic_Procedure - then + if Ekind_In (Spec_Id, E_Procedure, E_Generic_Procedure) then Add_Return (Statements (H)); if Present (Exception_Handlers (H)) then @@ -4610,10 +4643,8 @@ package body Exp_Ch6 is -- define _object later on. declare - Decls : List_Id; - Obj_Ptr : constant Entity_Id := Make_Defining_Identifier (Loc, - Chars => - New_Internal_Name ('T')); + Decls : List_Id; + Obj_Ptr : constant Entity_Id := Make_Temporary (Loc, 'T'); begin Decls := New_List ( @@ -4623,7 +4654,7 @@ package body Exp_Ch6 is Make_Access_To_Object_Definition (Loc, Subtype_Indication => New_Reference_To - (Corresponding_Record_Type (Scop), Loc)))); + (Corresponding_Record_Type (Scop), Loc)))); Insert_Actions (N, Decls); Insert_Actions (N, Freeze_Entity (Obj_Ptr, Sloc (N))); @@ -4719,14 +4750,21 @@ package body Exp_Ch6 is function Is_Build_In_Place_Function (E : Entity_Id) return Boolean is begin + -- This function is called from Expand_Subtype_From_Expr during + -- semantic analysis, even when expansion is off. In those cases + -- the build_in_place expansion will not take place. + + if not Expander_Active then + return False; + end if; + -- For now we test whether E denotes a function or access-to-function -- type whose result subtype is inherently limited. Later this test may -- be revised to allow composite nonlimited types. Functions with a -- foreign convention or whose result type has a foreign convention -- never qualify. - if Ekind (E) = E_Function - or else Ekind (E) = E_Generic_Function + if Ekind_In (E, E_Function, E_Generic_Function) or else (Ekind (E) = E_Subprogram_Type and then Etype (E) /= Standard_Void_Type) then @@ -5115,10 +5153,11 @@ package body Exp_Ch6 is Rewrite (Allocator, New_Allocator); -- Create a new access object and initialize it to the result of the - -- new uninitialized allocator. + -- new uninitialized allocator. Note: we do not use Allocator as the + -- Related_Node of Return_Obj_Access in call to Make_Temporary below + -- as this would create a sort of infinite "recursion". - Return_Obj_Access := - Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Return_Obj_Access := Make_Temporary (Loc, 'R'); Set_Etype (Return_Obj_Access, Acc_Type); Insert_Action (Allocator, @@ -5251,9 +5290,7 @@ package body Exp_Ch6 is -- Create a temporary object to hold the function result - Return_Obj_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('R')); + Return_Obj_Id := Make_Temporary (Loc, 'R'); Set_Etype (Return_Obj_Id, Result_Subt); Return_Obj_Decl := @@ -5406,8 +5443,7 @@ package body Exp_Ch6 is -- Create an access type designating the function's result subtype - Ptr_Typ := - Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Ptr_Typ := Make_Temporary (Loc, 'A'); Ptr_Typ_Decl := Make_Full_Type_Declaration (Loc, @@ -5422,7 +5458,7 @@ package body Exp_Ch6 is -- Finally, create an access object initialized to a reference to the -- function call. - Obj_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Obj_Id := Make_Temporary (Loc, 'R'); Set_Etype (Obj_Id, Ptr_Typ); Obj_Decl := @@ -5682,10 +5718,12 @@ package body Exp_Ch6 is Add_Access_Actual_To_Build_In_Place_Call (Func_Call, Function_Id, Caller_Object, Is_Access => Pass_Caller_Acc); - -- Create an access type designating the function's result subtype + -- Create an access type designating the function's result subtype. We + -- use the type of the original expression because it may be a call to + -- an inherited operation, which the expansion has replaced with the + -- parent operation that yields the parent type. - Ref_Type := - Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Ref_Type := Make_Temporary (Loc, 'A'); Ptr_Typ_Decl := Make_Full_Type_Declaration (Loc, @@ -5694,7 +5732,7 @@ package body Exp_Ch6 is Make_Access_To_Object_Definition (Loc, All_Present => True, Subtype_Indication => - New_Reference_To (Result_Subt, Loc))); + New_Reference_To (Etype (Function_Call), Loc))); -- The access type and its accompanying object must be inserted after -- the object declaration in the constrained case, so that the function @@ -5712,15 +5750,13 @@ package body Exp_Ch6 is -- Finally, create an access object initialized to a reference to the -- function call. - Def_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('R')); - Set_Etype (Def_Id, Ref_Type); - New_Expr := Make_Reference (Loc, Prefix => Relocate_Node (Func_Call)); + Def_Id := Make_Temporary (Loc, 'R', New_Expr); + Set_Etype (Def_Id, Ref_Type); + Insert_After_And_Analyze (Ptr_Typ_Decl, Make_Object_Declaration (Loc, Defining_Identifier => Def_Id, @@ -5744,8 +5780,7 @@ package body Exp_Ch6 is Rewrite (Object_Decl, Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => Make_Defining_Identifier (Loc, - New_Internal_Name ('D')), + Defining_Identifier => Make_Temporary (Loc, 'D'), Access_Definition => Empty, Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc), Name => Call_Deref)); diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 880ae4e4cb9..308021472c2 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -54,7 +54,6 @@ with Sem_Ch3; use Sem_Ch3; with Sem_Ch7; use Sem_Ch7; with Sem_Ch8; use Sem_Ch8; with Sem_Res; use Sem_Res; -with Sem_SCIL; use Sem_SCIL; with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Snames; use Snames; @@ -586,9 +585,7 @@ package body Exp_Ch7 is -- Here we generate the required loop else - Index := - Make_Defining_Identifier (Loc, New_Internal_Name ('J')); - + Index := Make_Temporary (Loc, 'J'); Append (New_Reference_To (Index, Loc), Index_List); return New_List ( @@ -1162,7 +1159,7 @@ package body Exp_Ch7 is and then not Sec_Stack_Needed_For_Return (Current_Scope) and then VM_Target = No_VM then - Mark := Make_Defining_Identifier (Loc, New_Internal_Name ('M')); + Mark := Make_Temporary (Loc, 'M'); Append_To (New_Decls, Make_Object_Declaration (Loc, Defining_Identifier => Mark, @@ -1785,9 +1782,7 @@ package body Exp_Ch7 is end if; end if; - Id := - Make_Defining_Identifier (Flist_Loc, - Chars => New_Internal_Name ('F')); + Id := Make_Temporary (Flist_Loc, 'F'); end; Set_Finalization_Chain_Entity (S, Id); @@ -3438,7 +3433,7 @@ package body Exp_Ch7 is -- Fxxx : Finalizable_Ptr renames Lxxx.F; if Present (Finalization_Chain_Entity (S)) then - LC := Make_Defining_Identifier (Loc, New_Internal_Name ('L')); + LC := Make_Temporary (Loc, 'L'); -- Use the Sloc of the first declaration of N's containing list, to -- maintain monotonicity of source-line stepping during debugging. @@ -3570,15 +3565,6 @@ package body Exp_Ch7 is Expr : constant Node_Id := Relocate_Node (N); begin - -- If the relocated node is a function call then check if some SCIL - -- node references it and needs readjustment. - - if Generate_SCIL - and then Nkind (N) = N_Function_Call - then - Adjust_SCIL_Node (N, Expr); - end if; - Insert_Actions (N, New_List ( Make_Object_Declaration (Loc, Defining_Identifier => E, @@ -3626,15 +3612,6 @@ package body Exp_Ch7 is New_Statement : constant Node_Id := Relocate_Node (N); begin - -- If the relocated node is a procedure call then check if some SCIL - -- node references it and needs readjustment. - - if Generate_SCIL - and then Nkind (New_Statement) = N_Procedure_Call_Statement - then - Adjust_SCIL_Node (N, New_Statement); - end if; - Rewrite (N, Make_Transient_Block (Loc, New_Statement)); -- With the scope stack back to normal, we can call analyze on the diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads index a7c5cd7ba5a..669f998c402 100644 --- a/gcc/ada/exp_ch7.ads +++ b/gcc/ada/exp_ch7.ads @@ -229,11 +229,11 @@ package Exp_Ch7 is procedure Store_Before_Actions_In_Scope (L : List_Id); -- Append the list L of actions to the end of the before-actions store in - -- the top of the scope stack + -- the top of the scope stack. procedure Store_After_Actions_In_Scope (L : List_Id); -- Append the list L of actions to the beginning of the after-actions store - -- in the top of the scope stack + -- in the top of the scope stack. procedure Wrap_Transient_Declaration (N : Node_Id); -- N is an object declaration. Expand the finalization calls after the diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index ac439917107..2aec546e91a 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -128,6 +128,14 @@ package body Exp_Ch9 is -- Build a specification for a function implementing the protected entry -- barrier of the specified entry body. + function Build_Corresponding_Record + (N : Node_Id; + Ctyp : Node_Id; + Loc : Source_Ptr) return Node_Id; + -- Common to tasks and protected types. Copy discriminant specifications, + -- build record declaration. N is the type declaration, Ctyp is the + -- concurrent entity (task type or protected type). + function Build_Entry_Count_Expression (Concurrent_Type : Node_Id; Component_List : List_Id; @@ -1037,8 +1045,9 @@ package body Exp_Ch9 is -- record is "limited tagged". It is "limited" to reflect the underlying -- limitedness of the task or protected object that it represents, and -- ensuring for example that it is properly passed by reference. It is - -- "tagged" to give support to dispatching calls through interfaces (Ada - -- 2005: AI-345) + -- "tagged" to give support to dispatching calls through interfaces. We + -- propagate here the list of interfaces covered by the concurrent type + -- (Ada 2005: AI-345). return Make_Full_Type_Declaration (Loc, @@ -1051,6 +1060,7 @@ package body Exp_Ch9 is Component_Items => Cdecls), Tagged_Present => Ada_Version >= Ada_05 and then Is_Tagged_Type (Ctyp), + Interface_List => Interface_List (N), Limited_Present => True)); end Build_Corresponding_Record; @@ -1168,8 +1178,7 @@ package body Exp_Ch9 is procedure Build_Entry_Family_Name (Id : Entity_Id) is Def : constant Node_Id := Discrete_Subtype_Definition (Parent (Id)); - L_Id : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('L')); + L_Id : constant Entity_Id := Make_Temporary (Loc, 'L'); L_Stmts : constant List_Id := New_List; Val : Node_Id; @@ -1265,9 +1274,8 @@ package body Exp_Ch9 is Make_Iteration_Scheme (Loc, Loop_Parameter_Specification => Make_Loop_Parameter_Specification (Loc, - Defining_Identifier => L_Id, - Discrete_Subtype_Definition => - Build_Range (Def))), + Defining_Identifier => L_Id, + Discrete_Subtype_Definition => Build_Range (Def))), Statements => L_Stmts, End_Label => Empty)); end Build_Entry_Family_Name; @@ -1411,7 +1419,7 @@ package body Exp_Ch9 is return Empty; end if; - Index := Make_Defining_Identifier (Loc, New_Internal_Name ('I')); + Index := Make_Temporary (Loc, 'I'); -- Step 1: Generate the declaration of the index variable: -- Inn : Protected_Entry_Index := 0; @@ -1428,10 +1436,8 @@ package body Exp_Ch9 is Append_To (B_Decls, Make_Object_Declaration (Loc, Defining_Identifier => Index, - Object_Definition => - New_Reference_To (RTE (Index_Typ), Loc), - Expression => - Make_Integer_Literal (Loc, 0))); + Object_Definition => New_Reference_To (RTE (Index_Typ), Loc), + Expression => Make_Integer_Literal (Loc, 0))); B_Stmts := New_List; @@ -1488,19 +1494,15 @@ package body Exp_Ch9 is -- Generate: -- type Ann is access all - Comp_Nam := - Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Comp_Nam := Make_Temporary (Loc, 'A'); Append_To (Decls, Make_Full_Type_Declaration (Loc, - Defining_Identifier => - Comp_Nam, - Type_Definition => + Defining_Identifier => Comp_Nam, + Type_Definition => Make_Access_To_Object_Definition (Loc, - All_Present => - True, - Constant_Present => - Ekind (Formal) = E_In_Parameter, + All_Present => True, + Constant_Present => Ekind (Formal) = E_In_Parameter, Subtype_Indication => New_Reference_To (Etype (Actual), Loc)))); @@ -1525,8 +1527,7 @@ package body Exp_Ch9 is Next_Formal_With_Extras (Formal); end loop; - Rec_Nam := - Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Rec_Nam := Make_Temporary (Loc, 'P'); if Has_Comp then @@ -2141,7 +2142,6 @@ package body Exp_Ch9 is -- record type, so mark the spec accordingly. if Ekind (Subp_Id) = E_Function then - declare Res_Def : Node_Id; @@ -2397,12 +2397,10 @@ package body Exp_Ch9 is Add_Object_Pointer (Loc, Typ, Decls); while Present (Ent) loop - if Ekind (Ent) = E_Entry then Add_If_Clause (Make_Integer_Literal (Loc, 1)); elsif Ekind (Ent) = E_Entry_Family then - E_Typ := Etype (Discrete_Subtype_Definition (Parent (Ent))); Hi := Convert_Discriminant_Ref (Type_High_Bound (E_Typ)); Lo := Convert_Discriminant_Ref (Type_Low_Bound (E_Typ)); @@ -3104,7 +3102,7 @@ package body Exp_Ch9 is if Nkind (Op_Spec) = N_Function_Specification then if Exc_Safe then - R := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + R := Make_Temporary (Loc, 'R'); Unprot_Call := Make_Object_Declaration (Loc, Defining_Identifier => R, @@ -3115,8 +3113,10 @@ package body Exp_Ch9 is Name => Make_Identifier (Loc, Chars (Defining_Unit_Name (N_Op_Spec))), Parameter_Associations => Uactuals)); - Return_Stmt := Make_Simple_Return_Statement (Loc, - Expression => New_Reference_To (R, Loc)); + + Return_Stmt := + Make_Simple_Return_Statement (Loc, + Expression => New_Reference_To (R, Loc)); else Unprot_Call := Make_Simple_Return_Statement (Loc, @@ -3489,8 +3489,8 @@ package body Exp_Ch9 is and then Ada_Version >= Ada_05 then declare - Obj : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('F')); + ExpR : constant Node_Id := Relocate_Node (Concval); + Obj : constant Entity_Id := Make_Temporary (Loc, 'F', ExpR); Decl : Node_Id; begin @@ -3498,7 +3498,7 @@ package body Exp_Ch9 is Make_Object_Declaration (Loc, Defining_Identifier => Obj, Object_Definition => New_Occurrence_Of (Conctyp, Loc), - Expression => Relocate_Node (Concval)); + Expression => ExpR); Set_Etype (Obj, Conctyp); Decls := New_List (Decl); Rewrite (Concval, New_Occurrence_Of (Obj, Loc)); @@ -3568,11 +3568,9 @@ package body Exp_Ch9 is if Is_By_Copy_Type (Etype (Actual)) then N_Node := Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('J')), - Aliased_Present => True, - Object_Definition => + Defining_Identifier => Make_Temporary (Loc, 'J'), + Aliased_Present => True, + Object_Definition => New_Reference_To (Etype (Formal), Loc)); -- Mark the object as not needing initialization since the @@ -3683,13 +3681,12 @@ package body Exp_Ch9 is -- Bnn : Communications_Block; - Comm_Name := - Make_Defining_Identifier (Loc, New_Internal_Name ('B')); + Comm_Name := Make_Temporary (Loc, 'B'); Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Comm_Name, - Object_Definition => + Object_Definition => New_Reference_To (RTE (RE_Communication_Block), Loc))); -- Some additional statements for protected entry calls @@ -3941,16 +3938,13 @@ package body Exp_Ch9 is Loc : constant Source_Ptr := Sloc (N); Chain : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uChain); - - Blkent : Entity_Id; + Blkent : constant Entity_Id := Make_Temporary (Loc, 'A'); Block : Node_Id; begin - Blkent := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); - Block := Make_Block_Statement (Loc, - Identifier => New_Reference_To (Blkent, Loc), + Identifier => New_Reference_To (Blkent, Loc), Declarations => New_List ( -- _Chain : Activation_Chain; @@ -4006,12 +4000,10 @@ package body Exp_Ch9 is Loc : constant Source_Ptr := Sloc (N); Chain : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uChain); - Blkent : Entity_Id; + Blkent : constant Entity_Id := Make_Temporary (Loc, 'A'); Block : Node_Id; begin - Blkent := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); - Append_To (Init_Stmts, Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Activate_Tasks), Loc), @@ -4141,9 +4133,7 @@ package body Exp_Ch9 is Efam := First_Entity (Conctyp); while Present (Efam) loop if Ekind (Efam) = E_Entry_Family then - Efam_Type := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('F')); + Efam_Type := Make_Temporary (Loc, 'F'); declare Bas : Entity_Id := @@ -4158,9 +4148,7 @@ package body Exp_Ch9 is (Discrete_Subtype_Definition (Parent (Efam)), Lo, Hi); if Is_Potentially_Large_Family (Bas, Conctyp, Lo, Hi) then - Bas := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('B')); + Bas := Make_Temporary (Loc, 'B'); Bas_Decl := Make_Subtype_Declaration (Loc, @@ -4397,20 +4385,19 @@ package body Exp_Ch9 is else declare Decl : Node_Id; - T_Self : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); + T_Self : constant Entity_Id := Make_Temporary (Loc, 'T'); T_Body : constant Node_Id := Parent (Corresponding_Body (Parent (Entity (N)))); begin - Decl := Make_Object_Declaration (Loc, - Defining_Identifier => T_Self, - Object_Definition => - New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc), - Expression => - Make_Function_Call (Loc, - Name => New_Reference_To (RTE (RE_Self), Loc))); + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => T_Self, + Object_Definition => + New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Self), Loc))); Prepend (Decl, Declarations (T_Body)); Analyze (Decl); Set_Scope (T_Self, Entity (N)); @@ -4707,25 +4694,28 @@ package body Exp_Ch9 is -- completes in the middle of the accept body. if Present (Handled_Statement_Sequence (N)) then - Lab_Id := Make_Identifier (Loc, New_Internal_Name ('L')); - Set_Entity (Lab_Id, - Make_Defining_Identifier (Loc, Chars (Lab_Id))); - Lab := Make_Label (Loc, Lab_Id); - Ldecl := - Make_Implicit_Label_Declaration (Loc, - Defining_Identifier => Entity (Lab_Id), - Label_Construct => Lab); - Append (Lab, Statements (Handled_Statement_Sequence (N))); - - Lab_Id := Make_Identifier (Loc, New_Internal_Name ('L')); - Set_Entity (Lab_Id, - Make_Defining_Identifier (Loc, Chars (Lab_Id))); - Lab := Make_Label (Loc, Lab_Id); - Ldecl2 := - Make_Implicit_Label_Declaration (Loc, - Defining_Identifier => Entity (Lab_Id), - Label_Construct => Lab); - Append (Lab, Statements (Handled_Statement_Sequence (N))); + declare + Ent : Entity_Id; + + begin + Ent := Make_Temporary (Loc, 'L'); + Lab_Id := New_Reference_To (Ent, Loc); + Lab := Make_Label (Loc, Lab_Id); + Ldecl := + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => Ent, + Label_Construct => Lab); + Append (Lab, Statements (Handled_Statement_Sequence (N))); + + Ent := Make_Temporary (Loc, 'L'); + Lab_Id := New_Reference_To (Ent, Loc); + Lab := Make_Label (Loc, Lab_Id); + Ldecl2 := + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => Ent, + Label_Construct => Lab); + Append (Lab, Statements (Handled_Statement_Sequence (N))); + end; else Ldecl := Empty; @@ -4737,9 +4727,7 @@ package body Exp_Ch9 is if Is_List_Member (N) then if Present (Handled_Statement_Sequence (N)) then - Ann := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('A')); + Ann := Make_Temporary (Loc, 'A'); Adecl := Make_Object_Declaration (Loc, @@ -4796,9 +4784,7 @@ package body Exp_Ch9 is -- label for requeue expansion must be declared. if N = Accept_Statement (Alt) then - Ann := - Make_Defining_Identifier (Loc, New_Internal_Name ('A')); - + Ann := Make_Temporary (Loc, 'A'); Adecl := Make_Object_Declaration (Loc, Defining_Identifier => Ann, @@ -4911,10 +4897,8 @@ package body Exp_Ch9 is Comps : List_Id; T : constant Entity_Id := Defining_Identifier (N); D_T : constant Entity_Id := Designated_Type (T); - D_T2 : constant Entity_Id := Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('D')); - E_T : constant Entity_Id := Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('E')); + D_T2 : constant Entity_Id := Make_Temporary (Loc, 'D'); + E_T : constant Entity_Id := Make_Temporary (Loc, 'E'); P_List : constant List_Id := Build_Protected_Spec (N, RTE (RE_Address), D_T, False); Decl1 : Node_Id; @@ -4950,8 +4934,7 @@ package body Exp_Ch9 is Comps := New_List ( Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, New_Internal_Name ('P')), + Defining_Identifier => Make_Temporary (Loc, 'P'), Component_Definition => Make_Component_Definition (Loc, Aliased_Present => False, @@ -4959,11 +4942,10 @@ package body Exp_Ch9 is New_Occurrence_Of (RTE (RE_Address), Loc))), Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, New_Internal_Name ('S')), + Defining_Identifier => Make_Temporary (Loc, 'S'), Component_Definition => Make_Component_Definition (Loc, - Aliased_Present => False, + Aliased_Present => False, Subtype_Indication => New_Occurrence_Of (D_T2, Loc)))); Decl2 := @@ -5291,7 +5273,7 @@ package body Exp_Ch9 is -- Construct the block, using the declarations from the accept -- statement if any to initialize the declarations of the block. - Blkent := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Blkent := Make_Temporary (Loc, 'A'); Set_Ekind (Blkent, E_Block); Set_Etype (Blkent, Standard_Void_Type); Set_Scope (Blkent, Current_Scope); @@ -5676,7 +5658,7 @@ package body Exp_Ch9 is T : Entity_Id; -- Additional status flag begin - Blk_Ent := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Blk_Ent := Make_Temporary (Loc, 'A'); Ecall := Triggering_Statement (Trig); -- The arguments in the call may require dynamic allocation, and the @@ -5717,13 +5699,11 @@ package body Exp_Ch9 is -- Communication block processing, generate: -- Bnn : Communication_Block; - Bnn := Make_Defining_Identifier (Loc, New_Internal_Name ('B')); - + Bnn := Make_Temporary (Loc, 'B'); Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - Bnn, - Object_Definition => + Defining_Identifier => Bnn, + Object_Definition => New_Reference_To (RTE (RE_Communication_Block), Loc))); -- Call kind processing, generate: @@ -5761,14 +5741,13 @@ package body Exp_Ch9 is S := Build_S (Loc, Decls); -- Additional status flag processing, generate: + -- Tnn : Boolean; - T := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); - + T := Make_Temporary (Loc, 'T'); Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - T, - Object_Definition => + Defining_Identifier => T, + Object_Definition => New_Reference_To (Standard_Boolean, Loc))); ------------------------------ @@ -5853,9 +5832,7 @@ package body Exp_Ch9 is -- _clean; -- end; - Cleanup_Block_Ent := - Make_Defining_Identifier (Loc, New_Internal_Name ('C')); - + Cleanup_Block_Ent := Make_Temporary (Loc, 'C'); Cleanup_Block := Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, Bnn); @@ -5868,9 +5845,7 @@ package body Exp_Ch9 is -- when Abort_Signal => Abort_Undefer; -- end; - Abort_Block_Ent := - Make_Defining_Identifier (Loc, New_Internal_Name ('A')); - + Abort_Block_Ent := Make_Temporary (Loc, 'A'); ProtE_Stmts := New_List ( Make_Implicit_Label_Declaration (Loc, @@ -5985,9 +5960,7 @@ package body Exp_Ch9 is -- _clean; -- end; - Cleanup_Block_Ent := - Make_Defining_Identifier (Loc, New_Internal_Name ('C')); - + Cleanup_Block_Ent := Make_Temporary (Loc, 'C'); Cleanup_Block := Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, T); @@ -6000,13 +5973,11 @@ package body Exp_Ch9 is -- when Abort_Signal => Abort_Undefer; -- end; - Abort_Block_Ent := - Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Abort_Block_Ent := Make_Temporary (Loc, 'A'); Append_To (TaskE_Stmts, Make_Implicit_Label_Declaration (Loc, - Defining_Identifier => - Abort_Block_Ent)); + Defining_Identifier => Abort_Block_Ent)); Append_To (TaskE_Stmts, Build_Abort_Block @@ -6143,8 +6114,7 @@ package body Exp_Ch9 is -- Add a Delay_Block object to the parameter list of the delay -- procedure to form the parameter list of the Wait entry call. - Dblock_Ent := - Make_Defining_Identifier (Loc, New_Internal_Name ('D')); + Dblock_Ent := Make_Temporary (Loc, 'D'); Pdef := Entity (Name (Ecall)); @@ -7092,8 +7062,7 @@ package body Exp_Ch9 is -- Declare new access type and then append - Ctype := - Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Ctype := Make_Temporary (Loc, 'A'); Decl := Make_Full_Type_Declaration (Loc, @@ -7120,8 +7089,7 @@ package body Exp_Ch9 is -- Create the Entry_Parameter_Record declaration - Rec_Ent := - Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Rec_Ent := Make_Temporary (Loc, 'P'); Decl := Make_Full_Type_Declaration (Loc, @@ -7137,8 +7105,7 @@ package body Exp_Ch9 is -- Construct and link in the corresponding access type - Acc_Ent := - Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Acc_Ent := Make_Temporary (Loc, 'A'); Set_Entry_Parameters_Type (Entry_Ent, Acc_Ent); @@ -7725,11 +7692,6 @@ package body Exp_Ch9 is Cdecls := Component_Items (Component_List (Type_Definition (Rec_Decl))); - -- Ada 2005 (AI-345): Propagate the attribute that contains the list - -- of implemented interfaces. - - Set_Interface_List (Type_Definition (Rec_Decl), Interface_List (N)); - Qualify_Entity_Names (N); -- If the type has discriminants, their occurrences in the declaration @@ -8751,8 +8713,7 @@ package body Exp_Ch9 is function Accept_Or_Raise return List_Id is Cond : Node_Id; Stats : List_Id; - J : constant Entity_Id := Make_Defining_Identifier (Loc, - New_Internal_Name ('J')); + J : constant Entity_Id := Make_Temporary (Loc, 'J'); begin -- We generate the following: @@ -9344,8 +9305,8 @@ package body Exp_Ch9 is -- Create Duration and Delay_Mode objects used for passing a delay -- value to RTS - D := Make_Defining_Identifier (Loc, New_Internal_Name ('D')); - M := Make_Defining_Identifier (Loc, New_Internal_Name ('M')); + D := Make_Temporary (Loc, 'D'); + M := Make_Temporary (Loc, 'M'); declare Discr : Entity_Id; @@ -9990,11 +9951,6 @@ package body Exp_Ch9 is Rec_Decl := Build_Corresponding_Record (N, Tasktyp, Loc); - -- Ada 2005 (AI-345): Propagate the attribute that contains the list - -- of implemented interfaces. - - Set_Interface_List (Type_Definition (Rec_Decl), Interface_List (N)); - Rec_Ent := Defining_Identifier (Rec_Decl); Cdecls := Component_Items (Component_List (Type_Definition (Rec_Decl))); @@ -10579,7 +10535,7 @@ package body Exp_Ch9 is New_List (New_Copy (Expression (D_Stat)))); end if; - D := Make_Defining_Identifier (Loc, New_Internal_Name ('D')); + D := Make_Temporary (Loc, 'D'); -- Generate: -- D : Duration; @@ -10591,7 +10547,7 @@ package body Exp_Ch9 is Object_Definition => New_Reference_To (Standard_Duration, Loc))); - M := Make_Defining_Identifier (Loc, New_Internal_Name ('M')); + M := Make_Temporary (Loc, 'M'); -- Generate: -- M : Integer := (0 | 1 | 2); @@ -11370,9 +11326,7 @@ package body Exp_Ch9 is if Is_Protected then declare - Prot_Ent : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('R')); + Prot_Ent : constant Entity_Id := Make_Temporary (Loc, 'R'); Prot_Typ : RE_Id; begin @@ -11561,8 +11515,7 @@ package body Exp_Ch9 is High := Replace_Bound (High); Low := Replace_Bound (Low); - Index_Typ := - Make_Defining_Identifier (Loc, New_Internal_Name ('J')); + Index_Typ := Make_Temporary (Loc, 'J'); -- Generate: -- subtype Jnn is range Low .. High; @@ -11790,9 +11743,7 @@ package body Exp_Ch9 is -- Interrupt_Priority). else - Temp := - Make_Defining_Identifier (Loc, New_Internal_Name ('R')); - + Temp := Make_Temporary (Loc, 'R', Prio); Append_To (L, Make_Object_Declaration (Loc, Defining_Identifier => Temp, @@ -11800,7 +11751,7 @@ package body Exp_Ch9 is New_Occurrence_Of (RTE (RE_Any_Priority), Loc), Expression => Relocate_Node (Prio))); - Append_To (Args, New_Occurrence_Of (Temp, Loc)); + Append_To (Args, New_Occurrence_Of (Temp, Loc)); end if; end; @@ -12170,9 +12121,8 @@ package body Exp_Ch9 is -- Master parameter. This is a reference to the _Master parameter of -- the initialization procedure, except in the case of the pragma - -- Restrictions (No_Task_Hierarchy) where the value is fixed to 3. - -- See comments in System.Tasking.Initialization.Init_RTS for the - -- value 3. + -- Restrictions (No_Task_Hierarchy) where the value is fixed to 3 + -- (3 is System.Tasking.Library_Task_Level). if Restriction_Active (No_Task_Hierarchy) = False then Append_To (Args, Make_Identifier (Loc, Name_uMaster)); @@ -12380,8 +12330,7 @@ package body Exp_Ch9 is -- Generate: -- Jnn : aliased - Temp_Nam := - Make_Defining_Identifier (Loc, New_Internal_Name ('J')); + Temp_Nam := Make_Temporary (Loc, 'J'); Append_To (Decls, Make_Object_Declaration (Loc, @@ -12447,7 +12396,7 @@ package body Exp_Ch9 is -- 'reference; -- ...); - P := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + P := Make_Temporary (Loc, 'P'); Append_To (Decls, Make_Object_Declaration (Loc, diff --git a/gcc/ada/exp_ch9.ads b/gcc/ada/exp_ch9.ads index 22a27d6422e..80d870ad8a1 100644 --- a/gcc/ada/exp_ch9.ads +++ b/gcc/ada/exp_ch9.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -50,14 +50,6 @@ package Exp_Ch9 is -- Task_Id of the associated task as the parameter. The caller is -- responsible for analyzing and resolving the resulting tree. - function Build_Corresponding_Record - (N : Node_Id; - Ctyp : Node_Id; - Loc : Source_Ptr) return Node_Id; - -- Common to tasks and protected types. Copy discriminant specifications, - -- build record declaration. N is the type declaration, Ctyp is the - -- concurrent entity (task type or protected type). - function Build_Entry_Names (Conc_Typ : Entity_Id) return Node_Id; -- Create the statements which populate the entry names array of a task or -- protected type. The statements are wrapped inside a block due to a local diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb index 34ae7e2b652..610ac0e5520 100644 --- a/gcc/ada/exp_dbug.adb +++ b/gcc/ada/exp_dbug.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -38,6 +38,7 @@ with Sinfo; use Sinfo; with Stand; use Stand; with Stringt; use Stringt; with Table; +with Targparm; use Targparm; with Tbuild; use Tbuild; with Urealp; use Urealp; @@ -341,6 +342,14 @@ package body Exp_Dbug is return Empty; end if; + -- Do not output those local variables in VM case, as this does not + -- help debugging (they are just unused), and might lead to duplicated + -- local variable names. + + if VM_Target /= No_VM then + return Empty; + end if; + -- Get renamed entity and compute suffix Name_Len := 0; diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index b7f31c36c4a..7599a25dc73 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,6 +31,7 @@ with Elists; use Elists; with Errout; use Errout; with Exp_Atag; use Exp_Atag; with Exp_Ch7; use Exp_Ch7; +with Exp_CG; use Exp_CG; with Exp_Dbug; use Exp_Dbug; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; @@ -59,6 +60,7 @@ with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; +with SCIL_LL; use SCIL_LL; with Tbuild; use Tbuild; with Uintp; use Uintp; @@ -577,8 +579,9 @@ package body Exp_Disp is -- Local variables - New_Node : Node_Id; - SCIL_Node : Node_Id; + New_Node : Node_Id; + SCIL_Node : Node_Id; + SCIL_Related_Node : Node_Id := Call_Node; -- Start of processing for Expand_Dispatching_Call @@ -648,19 +651,6 @@ package body Exp_Disp is Typ := Non_Limited_View (Typ); end if; - -- Generate the SCIL node for this dispatching call. The SCIL node for a - -- dispatching call is inserted in the tree before the call is rewriten - -- and expanded because the SCIL node must be found by the SCIL backend - -- BEFORE the expanded nodes associated with the call node are found. - - if Generate_SCIL then - SCIL_Node := Make_SCIL_Dispatching_Call (Sloc (Call_Node)); - Set_SCIL_Related_Node (SCIL_Node, Call_Node); - Set_SCIL_Entity (SCIL_Node, Typ); - Set_SCIL_Target_Prim (SCIL_Node, Subp); - Insert_Action (Call_Node, SCIL_Node); - end if; - if not Is_Limited_Type (Typ) then Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq); end if; @@ -840,12 +830,16 @@ package body Exp_Disp is New_Call_Name := Unchecked_Convert_To (Subp_Ptr_Typ, New_Node); - -- Complete decoration of SCIL dispatching node. It must be done after - -- the new call name is built to reference the nodes that will see the - -- SCIL backend (because Build_Get_Prim_Op_Address generates an - -- unchecked type conversion which relocates the controlling tag node). + -- Generate the SCIL node for this dispatching call. Done now because + -- attribute SCIL_Controlling_Tag must be set after the new call name + -- is built to reference the nodes that will see the SCIL backend + -- (because Build_Get_Prim_Op_Address generates an unchecked type + -- conversion which relocates the controlling tag node). if Generate_SCIL then + SCIL_Node := Make_SCIL_Dispatching_Call (Sloc (Call_Node)); + Set_SCIL_Entity (SCIL_Node, Typ); + Set_SCIL_Target_Prim (SCIL_Node, Subp); -- Common case: the controlling tag is the tag of an object -- (for example, obj.tag) @@ -943,6 +937,8 @@ package body Exp_Disp is New_Reference_To (First_Tag_Component (Typ), Loc))), Right_Opnd => New_Call); + + SCIL_Related_Node := Right_Opnd (New_Call); end if; else @@ -952,8 +948,18 @@ package body Exp_Disp is Parameter_Associations => New_Params); end if; + -- Register the dispatching call in the call graph nodes table + + Register_CG_Node (Call_Node); + Rewrite (Call_Node, New_Call); + -- Associate the SCIL node of this dispatching call + + if Generate_SCIL then + Set_SCIL_Node (SCIL_Related_Node, SCIL_Node); + end if; + -- Suppress all checks during the analysis of the expanded code -- to avoid the generation of spurious warnings under ZFP run-time. @@ -1148,8 +1154,7 @@ package body Exp_Disp is New_Typ_Decl := Make_Full_Type_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, New_Internal_Name ('T')), + Defining_Identifier => Make_Temporary (Loc, 'T'), Type_Definition => Make_Access_To_Object_Definition (Loc, All_Present => True, @@ -1190,10 +1195,7 @@ package body Exp_Disp is Else_Statements => Stats)); end if; - Fent := - Make_Defining_Identifier (Loc, - New_Internal_Name ('F')); - + Fent := Make_Temporary (Loc, 'F'); Func := Make_Subprogram_Body (Loc, Specification => @@ -1464,10 +1466,15 @@ package body Exp_Disp is Thunk_Id := Empty; Thunk_Code := Empty; + -- No thunk needed if the primitive has been eliminated + + if Is_Eliminated (Ultimate_Alias (Prim)) then + return; + -- In case of primitives that are functions without formals and a -- controlling result there is no need to build the thunk. - if not Present (First_Formal (Target)) then + elsif not Present (First_Formal (Target)) then pragma Assert (Ekind (Target) = E_Function and then Has_Controlling_Result (Target)); return; @@ -1528,16 +1535,22 @@ package body Exp_Disp is Formal := First (Formals); while Present (Formal) loop - -- Handle concurrent types + -- If the parent is a constrained discriminated type, then the + -- primitive operation will have been defined on a first subtype. + -- For proper matching with controlling type, use base type. if Ekind (Target_Formal) = E_In_Parameter and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type then - Ftyp := Directly_Designated_Type (Etype (Target_Formal)); + Ftyp := + Base_Type (Directly_Designated_Type (Etype (Target_Formal))); else - Ftyp := Etype (Target_Formal); + Ftyp := Base_Type (Etype (Target_Formal)); end if; + -- For concurrent types, the relevant information is found in the + -- Corresponding_Record_Type, rather than the type entity itself. + if Is_Concurrent_Type (Ftyp) then Ftyp := Corresponding_Record_Type (Ftyp); end if; @@ -1553,9 +1566,7 @@ package body Exp_Disp is Decl_2 := Make_Full_Type_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - New_Internal_Name ('T')), + Defining_Identifier => Make_Temporary (Loc, 'T'), Type_Definition => Make_Access_To_Object_Definition (Loc, All_Present => True, @@ -1580,9 +1591,7 @@ package body Exp_Disp is Decl_1 := Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - New_Internal_Name ('S')), + Defining_Identifier => Make_Temporary (Loc, 'S'), Constant_Present => True, Object_Definition => New_Reference_To (RTE (RE_Storage_Offset), Loc), @@ -1632,8 +1641,7 @@ package body Exp_Disp is Decl_1 := Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, New_Internal_Name ('S')), + Defining_Identifier => Make_Temporary (Loc, 'S'), Constant_Present => True, Object_Definition => New_Reference_To (RTE (RE_Storage_Offset), Loc), @@ -1652,11 +1660,11 @@ package body Exp_Disp is Decl_2 := Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, New_Internal_Name ('S')), - Constant_Present => True, - Object_Definition => New_Reference_To (RTE (RE_Addr_Ptr), Loc), - Expression => + Defining_Identifier => Make_Temporary (Loc, 'S'), + Constant_Present => True, + Object_Definition => + New_Reference_To (RTE (RE_Addr_Ptr), Loc), + Expression => Unchecked_Convert_To (RTE (RE_Addr_Ptr), New_Reference_To (Defining_Identifier (Decl_1), Loc))); @@ -1664,7 +1672,7 @@ package body Exp_Disp is Append_To (Decl, Decl_1); Append_To (Decl, Decl_2); - -- Reference the new actual. Generate: + -- Reference the new actual, generate: -- Target_Formal (S2.all) Append_To (Actuals, @@ -1683,10 +1691,7 @@ package body Exp_Disp is Next (Formal); end loop; - Thunk_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); - + Thunk_Id := Make_Temporary (Loc, 'T'); Set_Is_Thunk (Thunk_Id); -- Procedure case @@ -1769,7 +1774,7 @@ package body Exp_Disp is or else TSS_Name = TSS_Stream_Output or else (Chars (E) = Name_Op_Eq - and then Etype (First_Entity (E)) = Etype (Last_Entity (E))) + and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) or else Chars (E) = Name_uAssign or else TSS_Name = TSS_Deep_Adjust or else TSS_Name = TSS_Deep_Finalize @@ -1811,7 +1816,7 @@ package body Exp_Disp is or else Chars (E) = Name_uAlignment or else (Chars (E) = Name_Op_Eq - and then Etype (First_Entity (E)) = Etype (Last_Entity (E))) + and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) or else Chars (E) = Name_uAssign or else TSS_Name = TSS_Deep_Adjust or else TSS_Name = TSS_Deep_Finalize @@ -1830,23 +1835,10 @@ package body Exp_Disp is function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean is - E : Entity_Id; - begin - if not Is_Predefined_Dispatching_Operation (Prim) + return not Is_Predefined_Dispatching_Operation (Prim) and then Present (Alias (Prim)) - then - E := Prim; - while Present (Alias (E)) loop - E := Alias (E); - end loop; - - if Is_Predefined_Dispatching_Operation (E) then - return True; - end if; - end if; - - return False; + and then Is_Predefined_Dispatching_Operation (Ultimate_Alias (Prim)); end Is_Predefined_Dispatching_Alias; --------------------------------------- @@ -1985,9 +1977,7 @@ package body Exp_Disp is -- Generate: -- Bnn : Communication_Block; - Com_Block := - Make_Defining_Identifier (Loc, New_Internal_Name ('B')); - + Com_Block := Make_Temporary (Loc, 'B'); Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => @@ -2338,8 +2328,7 @@ package body Exp_Disp is -- where Bnn is the name of the communication block used in the -- call to Protected_Entry_Call. - Blk_Nam := Make_Defining_Identifier (Loc, New_Internal_Name ('B')); - + Blk_Nam := Make_Temporary (Loc, 'B'); Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => @@ -3584,13 +3573,8 @@ package body Exp_Disp is Exporting_Table : constant Boolean := Building_Static_DT (Typ) and then Suffix_Index > 0; - Iface_DT : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); - Name_Predef_Prims : constant Name_Id := New_Internal_Name ('R'); - Predef_Prims : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => Name_Predef_Prims); + Iface_DT : constant Entity_Id := Make_Temporary (Loc, 'T'); + Predef_Prims : constant Entity_Id := Make_Temporary (Loc, 'R'); DT_Constr_List : List_Id; DT_Aggr_List : List_Id; Empty_DT : Boolean := False; @@ -3689,6 +3673,7 @@ package body Exp_Disp is if Is_Predefined_Dispatching_Operation (Prim) and then not Is_Abstract_Subprogram (Prim) + and then not Is_Eliminated (Prim) and then not Present (Prim_Table (UI_To_Int (DT_Position (Prim)))) then @@ -3697,11 +3682,8 @@ package body Exp_Disp is Alias (Prim); else - while Present (Alias (Prim)) loop - Prim := Alias (Prim); - end loop; - - Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); + Expand_Interface_Thunk + (Ultimate_Alias (Prim), Thunk_Id, Thunk_Code); if Present (Thunk_Id) then Append_To (Result, Thunk_Code); @@ -3739,10 +3721,8 @@ package body Exp_Disp is Decl := Make_Subtype_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - New_Internal_Name ('S')), - Subtype_Indication => + Defining_Identifier => Make_Temporary (Loc, 'S'), + Subtype_Indication => New_Reference_To (RTE (RE_Address_Array), Loc)); Append_To (Result, Decl); @@ -3870,12 +3850,7 @@ package body Exp_Disp is (Interface_Alias (Prim)) = Iface then Prim_Alias := Interface_Alias (Prim); - - E := Prim; - while Present (Alias (E)) loop - E := Alias (E); - end loop; - + E := Ultimate_Alias (Prim); Pos := UI_To_Int (DT_Position (Prim_Alias)); if Present (Prim_Table (Pos)) then @@ -3903,7 +3878,7 @@ package body Exp_Disp is pragma Assert (Count = Nb_Prim); end; - OSD := Make_Defining_Identifier (Loc, New_Internal_Name ('I')); + OSD := Make_Temporary (Loc, 'I'); Append_To (Result, Make_Object_Declaration (Loc, @@ -3916,21 +3891,23 @@ package body Exp_Disp is Make_Index_Or_Discriminant_Constraint (Loc, Constraints => New_List ( Make_Integer_Literal (Loc, Nb_Prim)))), - Expression => Make_Aggregate (Loc, - Component_Associations => New_List ( - Make_Component_Association (Loc, - Choices => New_List ( - New_Occurrence_Of - (RTE_Record_Component (RE_OSD_Num_Prims), Loc)), - Expression => - Make_Integer_Literal (Loc, Nb_Prim)), - Make_Component_Association (Loc, - Choices => New_List ( - New_Occurrence_Of - (RTE_Record_Component (RE_OSD_Table), Loc)), - Expression => Make_Aggregate (Loc, - Component_Associations => OSD_Aggr_List)))))); + Expression => + Make_Aggregate (Loc, + Component_Associations => New_List ( + Make_Component_Association (Loc, + Choices => New_List ( + New_Occurrence_Of + (RTE_Record_Component (RE_OSD_Num_Prims), Loc)), + Expression => + Make_Integer_Literal (Loc, Nb_Prim)), + + Make_Component_Association (Loc, + Choices => New_List ( + New_Occurrence_Of + (RTE_Record_Component (RE_OSD_Table), Loc)), + Expression => Make_Aggregate (Loc, + Component_Associations => OSD_Aggr_List)))))); Append_To (Result, Make_Attribute_Definition_Clause (Loc, @@ -3979,10 +3956,14 @@ package body Exp_Disp is while Present (Prim_Elmt) loop Prim := Node (Prim_Elmt); + -- Do not reference predefined primitives because they + -- are located in a separate dispatch table; skip also + -- abstract and eliminated primitives. + if not Is_Predefined_Dispatching_Operation (Prim) and then Present (Interface_Alias (Prim)) and then not Is_Abstract_Subprogram (Alias (Prim)) - and then not Is_Imported (Alias (Prim)) + and then not Is_Eliminated (Alias (Prim)) and then Find_Dispatching_Type (Interface_Alias (Prim)) = Iface @@ -4395,17 +4376,6 @@ package body Exp_Disp is New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc))); - -- Generate a SCIL node for the previous object declaration - -- because it has a null dispatch table. - - if Generate_SCIL then - New_Node := - Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result))); - Set_SCIL_Related_Node (New_Node, Last (Result)); - Set_SCIL_Entity (New_Node, Typ); - Insert_Before (Last (Result), New_Node); - end if; - Append_To (Result, Make_Attribute_Definition_Clause (Loc, Name => New_Reference_To (DT, Loc), @@ -4438,9 +4408,8 @@ package body Exp_Disp is if Generate_SCIL then New_Node := Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result))); - Set_SCIL_Related_Node (New_Node, Last (Result)); Set_SCIL_Entity (New_Node, Typ); - Insert_Before (Last (Result), New_Node); + Set_SCIL_Node (Last (Result), New_Node); end if; -- Generate: @@ -4472,17 +4441,6 @@ package body Exp_Disp is Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => DT_Constr_List)))); - -- Generate the SCIL node for the previous object declaration - -- because it contains a dispatch table. - - if Generate_SCIL then - New_Node := - Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result))); - Set_SCIL_Related_Node (New_Node, Last (Result)); - Set_SCIL_Entity (New_Node, Typ); - Insert_Before (Last (Result), New_Node); - end if; - Append_To (Result, Make_Attribute_Definition_Clause (Loc, Name => New_Reference_To (DT, Loc), @@ -4515,9 +4473,8 @@ package body Exp_Disp is if Generate_SCIL then New_Node := Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result))); - Set_SCIL_Related_Node (New_Node, Last (Result)); Set_SCIL_Entity (New_Node, Typ); - Insert_Before (Last (Result), New_Node); + Set_SCIL_Node (Last (Result), New_Node); end if; Append_To (Result, @@ -4902,9 +4859,14 @@ package body Exp_Disp is -- Size_Func if RTE_Record_Component_Available (RE_Size_Func) then - if not Building_Static_DT (Typ) - or else Is_Interface (Typ) - then + + -- Initialize this field to Null_Address if we are not building + -- static dispatch tables static or if the size function is not + -- available. In the former case we cannot initialize this field + -- until the function is frozen and registered in the dispatch + -- table (see Register_Primitive). + + if not Building_Static_DT (Typ) or else not Has_DT (Typ) then Append_To (TSD_Aggr_List, Unchecked_Convert_To (RTE (RE_Size_Ptr), New_Reference_To (RTE (RE_Null_Address), Loc))); @@ -4920,9 +4882,7 @@ package body Exp_Disp is Prim := Node (Prim_Elmt); if Chars (Prim) = Name_uSize then - while Present (Alias (Prim)) loop - Prim := Alias (Prim); - end loop; + Prim := Ultimate_Alias (Prim); if Is_Abstract_Subprogram (Prim) then Append_To (TSD_Aggr_List, @@ -5287,17 +5247,6 @@ package body Exp_Disp is Expression => Make_Aggregate (Loc, Expressions => DT_Aggr_List))); - -- Generate the SCIL node for the previous object declaration - -- because it has a null dispatch table. - - if Generate_SCIL then - New_Node := - Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result))); - Set_SCIL_Related_Node (New_Node, Last (Result)); - Set_SCIL_Entity (New_Node, Typ); - Insert_Before (Last (Result), New_Node); - end if; - Append_To (Result, Make_Attribute_Definition_Clause (Loc, Name => New_Reference_To (DT, Loc), @@ -5379,14 +5328,11 @@ package body Exp_Disp is if Is_Predefined_Dispatching_Operation (Prim) and then not Is_Abstract_Subprogram (Prim) + and then not Is_Eliminated (Prim) and then not Present (Prim_Table (UI_To_Int (DT_Position (Prim)))) then - E := Prim; - while Present (Alias (E)) loop - E := Alias (E); - end loop; - + E := Ultimate_Alias (Prim); pragma Assert (not Is_Abstract_Subprogram (E)); Prim_Table (UI_To_Int (DT_Position (Prim))) := E; end if; @@ -5415,10 +5361,8 @@ package body Exp_Disp is Decl := Make_Subtype_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - New_Internal_Name ('S')), - Subtype_Indication => + Defining_Identifier => Make_Temporary (Loc, 'S'), + Subtype_Indication => New_Reference_To (RTE (RE_Address_Array), Loc)); Append_To (Result, Decl); @@ -5527,23 +5471,22 @@ package body Exp_Disp is E := Ultimate_Alias (Prim); - if Is_Imported (Prim) - or else Present (Interface_Alias (Prim)) - or else Is_Predefined_Dispatching_Operation (Prim) - or else Is_Eliminated (E) - then - null; + -- Do not reference predefined primitives because they are + -- located in a separate dispatch table; skip entities with + -- attribute Interface_Alias because they are only required + -- to build secondary dispatch tables; skip also abstract + -- and eliminated primitives. - else - if not Is_Predefined_Dispatching_Operation (E) - and then not Is_Abstract_Subprogram (E) - and then not Present (Interface_Alias (E)) - then - pragma Assert - (UI_To_Int (DT_Position (Prim)) <= Nb_Prim); + if not Is_Predefined_Dispatching_Operation (Prim) + and then not Is_Predefined_Dispatching_Operation (E) + and then not Present (Interface_Alias (Prim)) + and then not Is_Abstract_Subprogram (E) + and then not Is_Eliminated (E) + then + pragma Assert + (UI_To_Int (DT_Position (Prim)) <= Nb_Prim); - Prim_Table (UI_To_Int (DT_Position (Prim))) := E; - end if; + Prim_Table (UI_To_Int (DT_Position (Prim))) := E; end if; Next_Elmt (Prim_Elmt); @@ -5604,17 +5547,6 @@ package body Exp_Disp is Expression => Make_Aggregate (Loc, Expressions => DT_Aggr_List))); - -- Generate the SCIL node for the previous object declaration - -- because it contains a dispatch table. - - if Generate_SCIL then - New_Node := - Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result))); - Set_SCIL_Related_Node (New_Node, Last (Result)); - Set_SCIL_Entity (New_Node, Typ); - Insert_Before (Last (Result), New_Node); - end if; - Append_To (Result, Make_Attribute_Definition_Clause (Loc, Name => New_Reference_To (DT, Loc), @@ -5944,7 +5876,7 @@ package body Exp_Disp is -- Mark entities containing dispatch tables. Required by the backend to -- handle them properly. - if not Is_Interface (Typ) then + if Has_DT (Typ) then declare Elmt : Elmt_Id; @@ -5976,6 +5908,10 @@ package body Exp_Disp is end; end if; + -- Register the tagged type in the call graph nodes table + + Register_CG_Node (Typ); + return Result; end Make_DT; @@ -6083,6 +6019,9 @@ package body Exp_Disp is -- Look for primitive overriding an abstract interface subprogram if Present (Interface_Alias (Prim)) + and then not + Is_Ancestor + (Find_Dispatching_Type (Interface_Alias (Prim)), Typ) and then not Examined (UI_To_Int (DT_Position (Alias (Prim)))) then Prim_Pos := DT_Position (Alias (Prim)); @@ -6103,10 +6042,7 @@ package body Exp_Disp is -- Retrieve the root of the alias chain - Prim_Als := Prim; - while Present (Alias (Prim_Als)) loop - Prim_Als := Alias (Prim_Als); - end loop; + Prim_Als := Ultimate_Alias (Prim); -- In the case of an entry wrapper, set the entry index @@ -6312,9 +6248,8 @@ package body Exp_Disp is if Generate_SCIL then New_Node := Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result))); - Set_SCIL_Related_Node (New_Node, Last (Result)); Set_SCIL_Entity (New_Node, Typ); - Insert_Before (Last (Result), New_Node); + Set_SCIL_Node (Last (Result), New_Node); end if; Append_To (Result, @@ -6351,17 +6286,6 @@ package body Exp_Disp is New_Occurrence_Of (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)), Attribute_Name => Name_Address)))); - - -- Generate the SCIL node for the previous object declaration - -- because it has a tag initialization. - - if Generate_SCIL then - New_Node := - Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result))); - Set_SCIL_Related_Node (New_Node, Last (Result)); - Set_SCIL_Entity (New_Node, Typ); - Insert_Before (Last (Result), New_Node); - end if; end if; Set_Is_True_Constant (DT_Ptr); @@ -6638,10 +6562,7 @@ package body Exp_Disp is begin -- Retrieve the original primitive operation - Prim_Op := Prim; - while Present (Alias (Prim_Op)) loop - Prim_Op := Alias (Prim_Op); - end loop; + Prim_Op := Ultimate_Alias (Prim); if Ekind (Typ) = E_Record_Type and then Present (Corresponding_Concurrent_Type (Typ)) @@ -6739,7 +6660,11 @@ package body Exp_Disp is begin pragma Assert (not Restriction_Active (No_Dispatching_Calls)); - if not RTE_Available (RE_Tag) then + -- Do not register in the dispatch table eliminated primitives + + if not RTE_Available (RE_Tag) + or else Is_Eliminated (Ultimate_Alias (Prim)) + then return L; end if; @@ -6804,6 +6729,13 @@ package body Exp_Disp is pragma Assert (Is_Interface (Iface_Typ)); + -- No action needed for interfaces that are ancestors of Typ because + -- their primitives are located in the primary dispatch table. + + if Is_Ancestor (Iface_Typ, Tag_Typ) then + return L; + end if; + Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); if not Is_Ancestor (Iface_Typ, Tag_Typ) @@ -7157,12 +7089,8 @@ package body Exp_Disp is Set_DT_Position (Prim, Default_Prim_Op_Position (Prim)); elsif Is_Predefined_Dispatching_Alias (Prim) then - E := Alias (Prim); - while Present (Alias (E)) loop - E := Alias (E); - end loop; - - Set_DT_Position (Prim, Default_Prim_Op_Position (E)); + Set_DT_Position (Prim, + Default_Prim_Op_Position (Ultimate_Alias (Prim))); -- Overriding primitives of ancestor abstract interfaces @@ -7204,7 +7132,7 @@ package body Exp_Disp is Next_Elmt (Prim_Elmt); end loop; - -- Third stage: Fix the position of all the new primitives + -- Third stage: Fix the position of all the new primitives. -- Entries associated with primitives covering interfaces -- are handled in a latter round. @@ -7324,11 +7252,11 @@ package body Exp_Disp is Adjusted := True; end if; - -- An abstract operation cannot be declared in the private part - -- for a visible abstract type, because it could never be over- - -- ridden. For explicit declarations this is checked at the - -- point of declaration, but for inherited operations it must - -- be done when building the dispatch table. + -- An abstract operation cannot be declared in the private part for a + -- visible abstract type, because it can't be overridden outside this + -- package hierarchy. For explicit declarations this is checked at + -- the point of declaration, but for inherited operations it must be + -- done when building the dispatch table. -- Ada 2005 (AI-251): Primitives associated with interfaces are -- excluded from this check because interfaces must be visible in @@ -7592,6 +7520,17 @@ package body Exp_Disp is Write_Str ("(predefined) "); end if; + -- Prefix the name of the primitive with its corresponding tagged + -- type to facilitate seeing inherited primitives. + + if Present (Alias (Prim)) then + Write_Name + (Chars (Find_Dispatching_Type (Ultimate_Alias (Prim)))); + else + Write_Name (Chars (Typ)); + end if; + + Write_Str ("."); Write_Name (Chars (Prim)); -- Indicate if this primitive has an aliased primitive diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index 6a653654800..5817d7ac73e 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -975,10 +975,10 @@ package body Exp_Dist is Defining_Unit_Name (Specification (Current_Declaration))), Asynchronous => Nkind (Specification (Current_Declaration)) = - N_Procedure_Specification - and then - Is_Asynchronous (Defining_Unit_Name (Specification - (Current_Declaration)))); + N_Procedure_Specification + and then + Is_Asynchronous (Defining_Unit_Name (Specification + (Current_Declaration)))); Append_To (Decls, Subp_Stubs); Analyze (Subp_Stubs); @@ -1293,9 +1293,7 @@ package body Exp_Dist is end if; if not Is_RAS then - RPC_Receiver := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('P')); + RPC_Receiver := Make_Temporary (Loc, 'P'); Specific_Build_RPC_Receiver_Body (RPC_Receiver => RPC_Receiver, @@ -1348,13 +1346,7 @@ package body Exp_Dist is -- primitive may have been inherited, go back the alias chain -- until the real primitive has been found. - Current_Primitive_Alias := Current_Primitive; - while Present (Alias (Current_Primitive_Alias)) loop - pragma Assert - (Current_Primitive_Alias - /= Alias (Current_Primitive_Alias)); - Current_Primitive_Alias := Alias (Current_Primitive_Alias); - end loop; + Current_Primitive_Alias := Ultimate_Alias (Current_Primitive); -- Copy the spec from the original declaration for the purpose -- of declaring an overriding subprogram: we need to replace @@ -1529,9 +1521,7 @@ package body Exp_Dist is Param_Assoc : constant List_Id := New_List; Stmts : constant List_Id := New_List; - RAS_Parameter : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('P')); + RAS_Parameter : constant Entity_Id := Make_Temporary (Loc, 'P'); Is_Function : constant Boolean := Nkind (Type_Def) = N_Access_Function_Definition; @@ -1897,8 +1887,7 @@ package body Exp_Dist is end if; Existing := False; - Stub_Type := - Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('S')); + Stub_Type := Make_Temporary (Loc, 'S'); Set_Ekind (Stub_Type, E_Record_Type); Set_Is_RACW_Stub_Type (Stub_Type); Stub_Type_Access := @@ -2058,8 +2047,8 @@ package body Exp_Dist is declare Constant_Object : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('P')); + Make_Temporary (Loc, 'P'); + begin Set_Defining_Identifier (Last (Decls), Constant_Object); @@ -2429,9 +2418,10 @@ package body Exp_Dist is -- Start of processing for Build_Subprogram_Calling_Stubs begin - Subp_Spec := Copy_Specification (Loc, - Spec => Specification (Vis_Decl), - New_Name => New_Name); + Subp_Spec := + Copy_Specification (Loc, + Spec => Specification (Vis_Decl), + New_Name => New_Name); if Locator = Empty then RCI_Locator := RCI_Cache; @@ -3019,9 +3009,7 @@ package body Exp_Dist is Remote_Statements : List_Id; -- Various parts of the procedure - Pnam : constant Entity_Id := - Make_Defining_Identifier - (Loc, New_Internal_Name ('R')); + Pnam : constant Entity_Id := Make_Temporary (Loc, 'R'); Asynchronous_Flag : constant Entity_Id := Asynchronous_Flags_Table.Get (RACW_Type); pragma Assert (Present (Asynchronous_Flag)); @@ -3063,16 +3051,11 @@ package body Exp_Dist is -- Prepare local identifiers - Source_Partition := - Make_Defining_Identifier (Loc, New_Internal_Name ('P')); - Source_Receiver := - Make_Defining_Identifier (Loc, New_Internal_Name ('S')); - Source_Address := - Make_Defining_Identifier (Loc, New_Internal_Name ('P')); - Local_Stub := - Make_Defining_Identifier (Loc, New_Internal_Name ('L')); - Stubbed_Result := - Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + Source_Partition := Make_Temporary (Loc, 'P'); + Source_Receiver := Make_Temporary (Loc, 'S'); + Source_Address := Make_Temporary (Loc, 'P'); + Local_Stub := Make_Temporary (Loc, 'L'); + Stubbed_Result := Make_Temporary (Loc, 'S'); -- Generate object declarations @@ -3274,8 +3257,7 @@ package body Exp_Dist is Remote_Statements : List_Id; Null_Statements : List_Id; - Pnam : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Pnam : constant Entity_Id := Make_Temporary (Loc, 'R'); begin Build_Stream_Procedure @@ -3455,25 +3437,16 @@ package body Exp_Dist is Proc_Decls : List_Id; Proc_Statements : List_Id; - Origin : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('P')); + Origin : constant Entity_Id := Make_Temporary (Loc, 'P'); -- Additional local variables for the local case - Proxy_Addr : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('P')); + Proxy_Addr : constant Entity_Id := Make_Temporary (Loc, 'P'); -- Additional local variables for the remote case - Local_Stub : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('L')); - - Stub_Ptr : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); + Local_Stub : constant Entity_Id := Make_Temporary (Loc, 'L'); + Stub_Ptr : constant Entity_Id := Make_Temporary (Loc, 'S'); function Set_Field (Field_Name : Name_Id; @@ -3699,18 +3672,15 @@ package body Exp_Dist is Request_Parameter : Node_Id; Pkg_RPC_Receiver : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('H')); + Make_Temporary (Loc, 'H'); Pkg_RPC_Receiver_Statements : List_Id; Pkg_RPC_Receiver_Cases : constant List_Id := New_List; Pkg_RPC_Receiver_Body : Node_Id; -- A Pkg_RPC_Receiver is built to decode the request - Lookup_RAS_Info : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('R')); - -- A remote subprogram is created to allow peers to look up - -- RAS information using subprogram ids. + Lookup_RAS_Info : constant Entity_Id := Make_Temporary (Loc, 'R'); + -- A remote subprogram is created to allow peers to look up RAS + -- information using subprogram ids. Subp_Id : Entity_Id; Subp_Index : Entity_Id; @@ -3720,11 +3690,8 @@ package body Exp_Dist is Current_Subprogram_Number : Int := First_RCI_Subprogram_Id; Current_Stubs : Node_Id; - Subp_Info_Array : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('I')); - - Subp_Info_List : constant List_Id := New_List; + Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I'); + Subp_Info_List : constant List_Id := New_List; Register_Pkg_Actuals : constant List_Id := New_List; @@ -4165,8 +4132,7 @@ package body Exp_Dist is -- well as the declaration of Result. For a function call, 'Input is -- always used to read the result even if it is constrained. - Stream_Parameter := - Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + Stream_Parameter := Make_Temporary (Loc, 'S'); Append_To (Decls, Make_Object_Declaration (Loc, @@ -4182,8 +4148,7 @@ package body Exp_Dist is New_List (Make_Integer_Literal (Loc, 0)))))); if not Is_Known_Asynchronous then - Result_Parameter := - Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Result_Parameter := Make_Temporary (Loc, 'R'); Append_To (Decls, Make_Object_Declaration (Loc, @@ -4198,8 +4163,7 @@ package body Exp_Dist is Constraints => New_List (Make_Integer_Literal (Loc, 0)))))); - Exception_Return_Parameter := - Make_Defining_Identifier (Loc, New_Internal_Name ('E')); + Exception_Return_Parameter := Make_Temporary (Loc, 'E'); Append_To (Decls, Make_Object_Declaration (Loc, @@ -4318,8 +4282,7 @@ package body Exp_Dist is -- type and push it in the stream after the regular -- parameters. - Extra_Parameter := Make_Defining_Identifier - (Loc, New_Internal_Name ('P')); + Extra_Parameter := Make_Temporary (Loc, 'P'); Append_To (Decls, Make_Object_Declaration (Loc, @@ -4556,7 +4519,7 @@ package body Exp_Dist is (RPC_Receiver => RPC_Receiver, Request_Parameter => Request); - Subp_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Subp_Id := Make_Temporary (Loc, 'P'); Subp_Index := Subp_Id; -- Subp_Id may not be a constant, because in the case of the RPC @@ -4600,9 +4563,10 @@ package body Exp_Dist is Controlling_Parameter : Entity_Id) return RPC_Target is Target_Info : RPC_Target (PCS_Kind => Name_GARLIC_DSA); + begin - Target_Info.Partition := - Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Target_Info.Partition := Make_Temporary (Loc, 'P'); + if Present (Controlling_Parameter) then Append_To (Decls, Make_Object_Declaration (Loc, @@ -4707,10 +4671,9 @@ package body Exp_Dist is begin RPC_Receiver_Decl := Make_Subprogram_Declaration (Loc, - Build_RPC_Receiver_Specification ( - RPC_Receiver => Make_Defining_Identifier (Loc, - New_Internal_Name ('R')), - Request_Parameter => RPC_Receiver_Request)); + Build_RPC_Receiver_Specification + (RPC_Receiver => Make_Temporary (Loc, 'R'), + Request_Parameter => RPC_Receiver_Request)); end; end if; end Build_Stub_Type; @@ -4729,9 +4692,7 @@ package body Exp_Dist is is Loc : constant Source_Ptr := Sloc (Vis_Decl); - Request_Parameter : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('R')); + Request_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R'); -- Formal parameter for receiving stubs: a descriptor for an incoming -- request. @@ -4784,8 +4745,7 @@ package body Exp_Dist is end if; if Dynamically_Asynchronous then - Dynamic_Async := - Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + Dynamic_Async := Make_Temporary (Loc, 'S'); else Dynamic_Async := Empty; end if; @@ -4830,9 +4790,7 @@ package body Exp_Dist is Need_Extra_Constrained : Boolean; -- True when an Extra_Constrained actual is required - Object : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('P')); + Object : constant Entity_Id := Make_Temporary (Loc, 'P'); Expr : Node_Id := Empty; @@ -5051,9 +5009,8 @@ package body Exp_Dist is declare Etyp : constant Entity_Id := Etype (Result_Definition (Specification (Vis_Decl))); - Result : constant Node_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('R')); + Result : constant Node_Id := Make_Temporary (Loc, 'R'); + begin Inner_Decls := New_List ( Make_Object_Declaration (Loc, @@ -5139,8 +5096,7 @@ package body Exp_Dist is -- exception occurrence is copied into the output stream and -- no other output parameter is written. - Excep_Choice := - Make_Defining_Identifier (Loc, New_Internal_Name ('E')); + Excep_Choice := Make_Temporary (Loc, 'E'); Excep_Code := New_List ( Make_Attribute_Reference (Loc, @@ -5171,8 +5127,7 @@ package body Exp_Dist is Subp_Spec := Make_Procedure_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, New_Internal_Name ('F')), + Defining_Unit_Name => Make_Temporary (Loc, 'F'), Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, @@ -5308,10 +5263,10 @@ package body Exp_Dist is begin return Make_Subprogram_Body (Loc, - Specification => Make_Function_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, New_Internal_Name ('S')), - Result_Definition => New_Occurrence_Of (Var_Type, Loc)), + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => Make_Temporary (Loc, 'S'), + Result_Definition => New_Occurrence_Of (Var_Type, Loc)), Declarations => No_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, New_List ( @@ -5394,8 +5349,7 @@ package body Exp_Dist is -------------------- function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is - Occ : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('E')); + Occ : constant Entity_Id := Make_Temporary (Loc, 'E'); begin return Make_Block_Statement (Loc, @@ -5762,8 +5716,7 @@ package body Exp_Dist is Make_Defining_Identifier (Loc, Name_R); -- Various parts of the procedure - Pnam : constant Entity_Id := Make_Defining_Identifier (Loc, - New_Internal_Name ('R')); + Pnam : constant Entity_Id := Make_Temporary (Loc, 'R'); Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); @@ -5882,10 +5835,8 @@ package body Exp_Dist is RACW_Parameter : constant Entity_Id := Make_Defining_Identifier (Loc, Name_R); - Reference : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('R')); - Any : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Reference : constant Entity_Id := Make_Temporary (Loc, 'R'); + Any : constant Entity_Id := Make_Temporary (Loc, 'A'); begin Func_Spec := @@ -6074,8 +6025,7 @@ package body Exp_Dist is Attr_Decl : Node_Id; Statements : constant List_Id := New_List; - Pnam : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Pnam : constant Entity_Id := Make_Temporary (Loc, 'R'); function Stream_Parameter return Node_Id; function Object return Node_Id; @@ -6233,16 +6183,10 @@ package body Exp_Dist is Make_Defining_Identifier (Loc, Name_A); -- For the call to Get_Local_Address + Local_Stub : constant Entity_Id := Make_Temporary (Loc, 'L'); + Stub_Ptr : constant Entity_Id := Make_Temporary (Loc, 'S'); -- Additional local variables for the remote case - Local_Stub : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('L')); - - Stub_Ptr : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); - function Set_Field (Field_Name : Name_Id; Value : Node_Id) return Node_Id; @@ -6554,12 +6498,8 @@ package body Exp_Dist is Func_Spec : Node_Id; - Any : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('A')); - RAS_Parameter : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('R')); + Any : constant Entity_Id := Make_Temporary (Loc, 'A'); + RAS_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R'); RACW_Parameter : constant Node_Id := Make_Selected_Component (Loc, Prefix => RAS_Parameter, @@ -6675,8 +6615,7 @@ package body Exp_Dist is Loc : constant Source_Ptr := Sloc (Pkg_Spec); Pkg_RPC_Receiver : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('H')); + Make_Temporary (Loc, 'H'); Pkg_RPC_Receiver_Object : Node_Id; Pkg_RPC_Receiver_Body : Node_Id; Pkg_RPC_Receiver_Decls : List_Id; @@ -6697,13 +6636,9 @@ package body Exp_Dist is -- from the request structure, or the local subprogram address (in -- case of a RAS). - Is_Local : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('L')); + Is_Local : constant Entity_Id := Make_Temporary (Loc, 'L'); - Local_Address : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('A')); + Local_Address : constant Entity_Id := Make_Temporary (Loc, 'A'); -- Address of a local subprogram designated by a reference -- corresponding to a RAS. @@ -6714,9 +6649,7 @@ package body Exp_Dist is Current_Stubs : Node_Id; Current_Subprogram_Number : Int := First_RCI_Subprogram_Id; - Subp_Info_Array : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('I')); + Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I'); Subp_Info_List : constant List_Id := New_List; @@ -7073,8 +7006,7 @@ package body Exp_Dist is Pkg_RPC_Receiver_Object := Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, New_Internal_Name ('R')), + Defining_Identifier => Make_Temporary (Loc, 'R'), Aliased_Present => True, Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc)); Append_To (Decls, Pkg_RPC_Receiver_Object); @@ -7163,8 +7095,7 @@ package body Exp_Dist is is Loc : constant Source_Ptr := Sloc (Nod); - Request : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Request : constant Entity_Id := Make_Temporary (Loc, 'R'); -- The request object constructed by these stubs -- Could we use Name_R instead??? (see GLADE client stubs) @@ -7247,9 +7178,7 @@ package body Exp_Dist is Object_Definition => New_Occurrence_Of (RTE (RE_Request_Access), Loc))); - Result := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('R')); + Result := Make_Temporary (Loc, 'R'); if Is_Function then Result_TC := @@ -7285,8 +7214,7 @@ package body Exp_Dist is Expression => Make_Integer_Literal (Loc, 0)))))); if not Is_Known_Asynchronous then - Exception_Return_Parameter := - Make_Defining_Identifier (Loc, New_Internal_Name ('E')); + Exception_Return_Parameter := Make_Temporary (Loc, 'E'); Append_To (Decls, Make_Object_Declaration (Loc, @@ -7300,8 +7228,7 @@ package body Exp_Dist is -- Initialize and fill in arguments list - Arguments := - Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Arguments := Make_Temporary (Loc, 'A'); Declare_Create_NVList (Loc, Arguments, Decls, Statements); Current_Parameter := First (Ordered_Parameters_List); @@ -7336,9 +7263,7 @@ package body Exp_Dist is Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp); - Any : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('A')); + Any : constant Entity_Id := Make_Temporary (Loc, 'A'); Actual_Parameter : Node_Id := New_Occurrence_Of ( @@ -7447,8 +7372,7 @@ package body Exp_Dist is declare Extra_Any_Parameter : constant Entity_Id := - Make_Defining_Identifier - (Loc, New_Internal_Name ('P')); + Make_Temporary (Loc, 'P'); Parameter_Exp : constant Node_Id := Make_Attribute_Reference (Loc, @@ -7595,9 +7519,8 @@ package body Exp_Dist is Controlling_Parameter : Entity_Id) return RPC_Target is Target_Info : RPC_Target (PCS_Kind => Name_PolyORB_DSA); - Target_Reference : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('T')); + Target_Reference : constant Entity_Id := Make_Temporary (Loc, 'T'); + begin if Present (Controlling_Parameter) then Append_To (Decls, @@ -7666,8 +7589,7 @@ package body Exp_Dist is RPC_Receiver_Decl := Make_Object_Declaration (Loc, - Defining_Identifier => Make_Defining_Identifier (Loc, - New_Internal_Name ('R')), + Defining_Identifier => Make_Temporary (Loc, 'R'), Aliased_Present => True, Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc)); @@ -7747,9 +7669,7 @@ package body Exp_Dist is is Loc : constant Source_Ptr := Sloc (Vis_Decl); - Request_Parameter : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('R')); + Request_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R'); -- Formal parameter for receiving stubs: a descriptor for an incoming -- request. @@ -7793,9 +7713,7 @@ package body Exp_Dist is Build_Ordered_Parameters_List (Specification (Vis_Decl)); - Arguments : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('A')); + Arguments : constant Entity_Id := Make_Temporary (Loc, 'A'); -- Name of the named values list used to retrieve parameters Subp_Spec : Node_Id; @@ -7825,11 +7743,9 @@ package body Exp_Dist is declare Etyp : Entity_Id; Constrained : Boolean; - Any : Entity_Id := Empty; - Object : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('P')); - Expr : Node_Id := Empty; + Any : Entity_Id := Empty; + Object : constant Entity_Id := Make_Temporary (Loc, 'P'); + Expr : Node_Id := Empty; Is_Controlling_Formal : constant Boolean := Is_RACW_Controlling_Formal @@ -7865,9 +7781,7 @@ package body Exp_Dist is Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp); if not Is_First_Controlling_Formal then - Any := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('A')); + Any := Make_Temporary (Loc, 'A'); Append_To (Outer_Decls, Make_Object_Declaration (Loc, @@ -7891,13 +7805,10 @@ package body Exp_Dist is if Is_First_Controlling_Formal then declare - Addr : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('A')); + Addr : constant Entity_Id := Make_Temporary (Loc, 'A'); Is_Local : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('L')); + Make_Temporary (Loc, 'L'); begin -- Special case: obtain the first controlling formal @@ -8067,8 +7978,7 @@ package body Exp_Dist is (Current_Parameter)); Extra_Any : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('A')); + Make_Temporary (Loc, 'A'); Formal_Entity : constant Entity_Id := Make_Defining_Identifier (Loc, @@ -8139,9 +8049,7 @@ package body Exp_Dist is declare Etyp : constant Entity_Id := Etype (Result_Definition (Specification (Vis_Decl))); - Result : constant Node_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('R')); + Result : constant Node_Id := Make_Temporary (Loc, 'R'); begin Inner_Decls := New_List ( @@ -8209,8 +8117,7 @@ package body Exp_Dist is Subp_Spec := Make_Procedure_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, New_Internal_Name ('F')), + Defining_Unit_Name => Make_Temporary (Loc, 'F'), Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, @@ -8396,9 +8303,7 @@ package body Exp_Dist is N : Node_Id; Target : Entity_Id) is - Strm : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); + Strm : constant Entity_Id := Make_Temporary (Loc, 'S'); Expr : Node_Id; Read_Call_List : List_Id; @@ -8456,9 +8361,7 @@ package body Exp_Dist is else declare - Temp : constant Entity_Id := - Make_Defining_Identifier - (Loc, New_Internal_Name ('R')); + Temp : constant Entity_Id := Make_Temporary (Loc, 'R'); begin Read_Call_List := New_List; @@ -8659,9 +8562,7 @@ package body Exp_Dist is Decls : constant List_Id := New_List; Stms : constant List_Id := New_List; - Any_Parameter : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('A')); + Any_Parameter : constant Entity_Id := Make_Temporary (Loc, 'A'); Use_Opaque_Representation : Boolean; @@ -8744,9 +8645,7 @@ package body Exp_Dist is -- The returned object - Res : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('R')); + Res : constant Entity_Id := Make_Temporary (Loc, 'R'); Res_Definition : Node_Id := New_Occurrence_Of (Typ, Loc); @@ -8813,8 +8712,7 @@ package body Exp_Dist is Choice_List : List_Id; Struct_Any : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('S')); + Make_Temporary (Loc, 'S'); begin Append_To (Decls, @@ -9454,7 +9352,7 @@ package body Exp_Dist is -- that the expected type of its parameter is U_Type. if Ekind (Fnam) = E_Function - and then Present (First_Formal (Fnam)) + and then Present (First_Formal (Fnam)) then C_Type := Etype (First_Formal (Fnam)); else @@ -9641,12 +9539,10 @@ package body Exp_Dist is Choice_List : List_Id; Union_Any : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('V')); + Make_Temporary (Loc, 'V'); Struct_Any : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('S')); + Make_Temporary (Loc, 'S'); function Make_Discriminant_Reference return Node_Id; @@ -9865,8 +9761,7 @@ package body Exp_Dist is declare Dummy_Any : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('A')); + Make_Temporary (Loc, 'A'); begin Append_To (Decls, @@ -10016,9 +9911,7 @@ package body Exp_Dist is if Use_Opaque_Representation then declare - Strm : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); + Strm : constant Entity_Id := Make_Temporary (Loc, 'S'); -- Stream used to store data representation produced by -- stream attribute. @@ -11192,9 +11085,7 @@ package body Exp_Dist is Pkg_Name := String_From_Name_Buffer; Inst := Make_Package_Instantiation (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('R')), + Defining_Unit_Name => Make_Temporary (Loc, 'R'), Name => New_Occurrence_Of (RTE (RE_RCI_Locator), Loc), diff --git a/gcc/ada/exp_fixd.adb b/gcc/ada/exp_fixd.adb index fa878c2bf78..28b93b5f8a5 100644 --- a/gcc/ada/exp_fixd.adb +++ b/gcc/ada/exp_fixd.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -505,8 +505,8 @@ package body Exp_Fixd is -- Define quotient and remainder, and set their Etypes, so -- that they can be picked up by Build_xxx routines. - Qnn := Make_Defining_Identifier (Loc, New_Internal_Name ('S')); - Rnn := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Qnn := Make_Temporary (Loc, 'S'); + Rnn := Make_Temporary (Loc, 'R'); Set_Etype (Qnn, QR_Typ); Set_Etype (Rnn, QR_Typ); @@ -518,8 +518,8 @@ package body Exp_Fixd is -- Create temporaries for numerator and denominator and set Etypes, -- so that New_Occurrence_Of picks them up for Build_xxx calls. - Nnn := Make_Defining_Identifier (Loc, New_Internal_Name ('N')); - Dnn := Make_Defining_Identifier (Loc, New_Internal_Name ('D')); + Nnn := Make_Temporary (Loc, 'N'); + Dnn := Make_Temporary (Loc, 'D'); Set_Etype (Nnn, QR_Typ); Set_Etype (Dnn, QR_Typ); @@ -882,8 +882,8 @@ package body Exp_Fixd is -- Define quotient and remainder, and set their Etypes, so -- that they can be picked up by Build_xxx routines. - Qnn := Make_Defining_Identifier (Loc, New_Internal_Name ('S')); - Rnn := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Qnn := Make_Temporary (Loc, 'S'); + Rnn := Make_Temporary (Loc, 'R'); Set_Etype (Qnn, QR_Typ); Set_Etype (Rnn, QR_Typ); @@ -891,8 +891,8 @@ package body Exp_Fixd is -- Case that we can compute the numerator in 64 bits if QR_Siz <= 64 then - Nnn := Make_Defining_Identifier (Loc, New_Internal_Name ('N')); - Dnn := Make_Defining_Identifier (Loc, New_Internal_Name ('D')); + Nnn := Make_Temporary (Loc, 'N'); + Dnn := Make_Temporary (Loc, 'D'); -- Set Etypes, so that they can be picked up by New_Occurrence_Of diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb index cf4a9c02a80..9c0be21634e 100644 --- a/gcc/ada/exp_imgv.adb +++ b/gcc/ada/exp_imgv.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -43,9 +43,15 @@ with Stringt; use Stringt; with Tbuild; use Tbuild; with Ttypes; use Ttypes; with Uintp; use Uintp; +with Urealp; use Urealp; package body Exp_Imgv is + function Has_Decimal_Small (E : Entity_Id) return Boolean; + -- Applies to all entities. True for a Decimal_Fixed_Point_Type, or an + -- Ordinary_Fixed_Point_Type with a small that is a negative power of ten. + -- Shouldn't this be in einfo.adb or sem_aux.adb??? + ------------------------------------ -- Build_Enumeration_Image_Tables -- ------------------------------------ @@ -260,13 +266,8 @@ package body Exp_Imgv is Ins_List : List_Id; -- List of actions to be inserted - Snn : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); - - Pnn : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('P')); + Snn : constant Entity_Id := Make_Temporary (Loc, 'S'); + Pnn : constant Entity_Id := Make_Temporary (Loc, 'P'); begin -- Build declarations of Snn and Pnn to be inserted @@ -335,7 +336,7 @@ package body Exp_Imgv is Tent := RTE (RE_Long_Long_Unsigned); end if; - elsif Is_Decimal_Fixed_Point_Type (Rtyp) then + elsif Is_Fixed_Point_Type (Rtyp) and then Has_Decimal_Small (Rtyp) then if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then Imid := RE_Image_Decimal; Tent := Standard_Integer; @@ -358,8 +359,8 @@ package body Exp_Imgv is if Discard_Names (First_Subtype (Ptyp)) or else No (Lit_Strings (Root_Type (Ptyp))) then - -- When pragma Discard_Names applies to the first subtype, - -- then build (Pref'Pos)'Img. + -- When pragma Discard_Names applies to the first subtype, build + -- (Pref'Pos)'Img. Rewrite (N, Make_Attribute_Reference (Loc, @@ -380,8 +381,10 @@ package body Exp_Imgv is if Ttyp = Standard_Integer_8 then Imid := RE_Image_Enumeration_8; - elsif Ttyp = Standard_Integer_16 then + + elsif Ttyp = Standard_Integer_16 then Imid := RE_Image_Enumeration_16; + else Imid := RE_Image_Enumeration_32; end if; @@ -454,18 +457,23 @@ package body Exp_Imgv is Prefix => New_Reference_To (Ptyp, Loc), Attribute_Name => Name_Aft)); + if Has_Decimal_Small (Rtyp) then + Set_Conversion_OK (First (Arg_List)); + Set_Etype (First (Arg_List), Tent); + end if; + -- For decimal, append Scale and also set to do literal conversion elsif Is_Decimal_Fixed_Point_Type (Rtyp) then Append_To (Arg_List, Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Ptyp, Loc), + Prefix => New_Reference_To (Ptyp, Loc), Attribute_Name => Name_Scale)); Set_Conversion_OK (First (Arg_List)); Set_Etype (First (Arg_List), Tent); - -- For Wide_Character, append Ada 2005 indication + -- For Wide_Character, append Ada 2005 indication elsif Rtyp = Standard_Wide_Character then Append_To (Arg_List, @@ -771,14 +779,8 @@ package body Exp_Imgv is procedure Expand_Wide_Image_Attribute (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Rtyp : constant Entity_Id := Root_Type (Entity (Prefix (N))); - - Rnn : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); - - Lnn : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('P')); + Rnn : constant Entity_Id := Make_Temporary (Loc, 'S'); + Lnn : constant Entity_Id := Make_Temporary (Loc, 'P'); begin Insert_Actions (N, New_List ( @@ -869,13 +871,8 @@ package body Exp_Imgv is Loc : constant Source_Ptr := Sloc (N); Rtyp : constant Entity_Id := Root_Type (Entity (Prefix (N))); - Rnn : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); - - Lnn : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('P')); + Rnn : constant Entity_Id := Make_Temporary (Loc, 'S'); + Lnn : constant Entity_Id := Make_Temporary (Loc, 'P'); begin Insert_Actions (N, New_List ( @@ -1254,4 +1251,16 @@ package body Exp_Imgv is Analyze_And_Resolve (N, Typ); end Expand_Width_Attribute; + ----------------------- + -- Has_Decimal_Small -- + ----------------------- + + function Has_Decimal_Small (E : Entity_Id) return Boolean is + begin + return Is_Decimal_Fixed_Point_Type (E) + or else + (Is_Ordinary_Fixed_Point_Type (E) + and then Ureal_10**Aft_Value (E) * Small_Value (E) = Ureal_1); + end Has_Decimal_Small; + end Exp_Imgv; diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index da6cf5a988c..0c4a67cb684 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -63,6 +63,10 @@ package body Exp_Intr is -- Local Subprograms -- ----------------------- + procedure Expand_Binary_Operator_Call (N : Node_Id); + -- Expand a call to an intrinsic arithmetic operator when the operand + -- types or sizes are not identical. + procedure Expand_Is_Negative (N : Node_Id); -- Expand a call to the intrinsic Is_Negative function @@ -108,6 +112,49 @@ package body Exp_Intr is -- Name_Source_Location - expand string of form file:line -- Name_Enclosing_Entity - expand string with name of enclosing entity + --------------------------------- + -- Expand_Binary_Operator_Call -- + --------------------------------- + + procedure Expand_Binary_Operator_Call (N : Node_Id) is + T1 : constant Entity_Id := Underlying_Type (Left_Opnd (N)); + T2 : constant Entity_Id := Underlying_Type (Right_Opnd (N)); + TR : constant Entity_Id := Etype (N); + T3 : Entity_Id; + Res : Node_Id; + + Siz : constant Uint := UI_Max (Esize (T1), Esize (T2)); + -- Maximum of operand sizes + + begin + -- Use Unsigned_32 for sizes of 32 or below, else Unsigned_64 + + if Siz > 32 then + T3 := RTE (RE_Unsigned_64); + else + T3 := RTE (RE_Unsigned_32); + end if; + + -- Copy operator node, and reset type and entity fields, for + -- subsequent reanalysis. + + Res := New_Copy (N); + Set_Etype (Res, Empty); + Set_Entity (Res, Empty); + + -- Convert operands to large enough intermediate type + + Set_Left_Opnd (Res, + Unchecked_Convert_To (T3, Relocate_Node (Left_Opnd (N)))); + Set_Right_Opnd (Res, + Unchecked_Convert_To (T3, Relocate_Node (Right_Opnd (N)))); + + -- Analyze and resolve result formed by conversion to target type + + Rewrite (N, Unchecked_Convert_To (TR, Res)); + Analyze_And_Resolve (N, TR); + end Expand_Binary_Operator_Call; + ----------------------------------------- -- Expand_Dispatching_Constructor_Call -- ----------------------------------------- @@ -171,11 +218,10 @@ package body Exp_Intr is Iface_Tag := Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, New_Internal_Name ('V')), - Object_Definition => + Defining_Identifier => Make_Temporary (Loc, 'V'), + Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), - Expression => + Expression => Make_Function_Call (Loc, Name => New_Reference_To (RTE (RE_Secondary_Tag), Loc), Parameter_Associations => New_List ( @@ -325,7 +371,7 @@ package body Exp_Intr is -- be referencing it by normal visibility methods. if No (Choice_Parameter (P)) then - E := Make_Defining_Identifier (Loc, New_Internal_Name ('E')); + E := Make_Temporary (Loc, 'E'); Set_Choice_Parameter (P, E); Set_Ekind (E, E_Variable); Set_Etype (E, RTE (RE_Exception_Occurrence)); @@ -362,11 +408,9 @@ package body Exp_Intr is Loc : constant Source_Ptr := Sloc (N); Ent : constant Entity_Id := Entity (Name (N)); Str : constant Node_Id := First_Actual (N); - Dum : Entity_Id; + Dum : constant Entity_Id := Make_Temporary (Loc, 'D'); begin - Dum := Make_Defining_Identifier (Loc, New_Internal_Name ('D')); - Insert_Actions (N, New_List ( Make_Object_Declaration (Loc, Defining_Identifier => Dum, @@ -490,6 +534,9 @@ package body Exp_Intr is elsif Present (Alias (E)) then Expand_Intrinsic_Call (N, Alias (E)); + elsif Nkind (N) in N_Binary_Op then + Expand_Binary_Operator_Call (N); + -- The only other case is where an external name was specified, -- since this is the only way that an otherwise unrecognized -- name could escape the checking in Sem_Prag. Nothing needs @@ -1025,13 +1072,11 @@ package body Exp_Intr is D_Type := Entity (D_Subtyp); else - D_Type := Make_Defining_Identifier (Loc, - New_Internal_Name ('A')); + D_Type := Make_Temporary (Loc, 'A'); Insert_Action (Deref, Make_Subtype_Declaration (Loc, Defining_Identifier => D_Type, Subtype_Indication => D_Subtyp)); - end if; -- Force freezing at the point of the dereference. For the diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb index c1d25c2d68f..bd8a69771a4 100644 --- a/gcc/ada/exp_pakd.adb +++ b/gcc/ada/exp_pakd.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -455,6 +455,15 @@ package body Exp_Pakd is -- expression whose type is the implementation type used to represent -- the packed array. Aexp is analyzed and resolved on entry and on exit. + procedure Get_Base_And_Bit_Offset + (N : Node_Id; + Base : out Node_Id; + Offset : out Node_Id); + -- Given a node N for a name which involves a packed array reference, + -- return the base object of the reference and build an expression of + -- type Standard.Integer representing the zero-based offset in bits + -- from Base'Address to the first bit of the reference. + function Known_Aligned_Enough (Obj : Node_Id; Csiz : Nat) return Boolean; -- There are two versions of the Set routines, the ones used when the -- object is known to be sufficiently well aligned given the number of @@ -1347,10 +1356,9 @@ package body Exp_Pakd is begin Decl := Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, New_Internal_Name ('T')), - Object_Definition => New_Occurrence_Of (Ctyp, Loc), - Expression => New_Copy_Tree (Rhs)); + Defining_Identifier => Make_Temporary (Loc, 'T', Rhs), + Object_Definition => New_Occurrence_Of (Ctyp, Loc), + Expression => New_Copy_Tree (Rhs)); Insert_Actions (N, New_List (Decl)); Rhs := New_Occurrence_Of (Defining_Identifier (Decl), Loc); @@ -1373,6 +1381,19 @@ package body Exp_Pakd is Analyze_And_Resolve (Rhs, Ctyp); end if; + -- For the AAMP target, indexing of certain packed array is passed + -- through to the back end without expansion, because the expansion + -- results in very inefficient code on that target. This allows the + -- GNAAMP back end to generate specialized macros that support more + -- efficient indexing of packed arrays with components having sizes + -- that are small powers of two. + + if AAMP_On_Target + and then (Csiz = 1 or else Csiz = 2 or else Csiz = 4) + then + return; + end if; + -- Case of component size 1,2,4 or any component size for the modular -- case. These are the cases for which we can inline the code. @@ -1664,18 +1685,11 @@ package body Exp_Pakd is procedure Expand_Packed_Address_Reference (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); - Ploc : Source_Ptr; - Pref : Node_Id; - Expr : Node_Id; - Term : Node_Id; - Atyp : Entity_Id; - Subscr : Node_Id; + Base : Node_Id; + Offset : Node_Id; begin - Pref := Prefix (N); - Expr := Empty; - - -- We build up an expression serially that has the form + -- We build an expression that has the form -- outer_object'Address -- + (linear-subscript * component_size for each array reference @@ -1683,49 +1697,7 @@ package body Exp_Pakd is -- + ... -- + ...) / Storage_Unit; - -- Some additional conversions are required to deal with the addition - -- operation, which is not normally visible to generated code. - - loop - Ploc := Sloc (Pref); - - if Nkind (Pref) = N_Indexed_Component then - Convert_To_Actual_Subtype (Prefix (Pref)); - Atyp := Etype (Prefix (Pref)); - Compute_Linear_Subscript (Atyp, Pref, Subscr); - - Term := - Make_Op_Multiply (Ploc, - Left_Opnd => Subscr, - Right_Opnd => - Make_Attribute_Reference (Ploc, - Prefix => New_Occurrence_Of (Atyp, Ploc), - Attribute_Name => Name_Component_Size)); - - elsif Nkind (Pref) = N_Selected_Component then - Term := - Make_Attribute_Reference (Ploc, - Prefix => Selector_Name (Pref), - Attribute_Name => Name_Bit_Position); - - else - exit; - end if; - - Term := Convert_To (RTE (RE_Integer_Address), Term); - - if No (Expr) then - Expr := Term; - - else - Expr := - Make_Op_Add (Ploc, - Left_Opnd => Expr, - Right_Opnd => Term); - end if; - - Pref := Prefix (Pref); - end loop; + Get_Base_And_Bit_Offset (Prefix (N), Base, Offset); Rewrite (N, Unchecked_Convert_To (RTE (RE_Address), @@ -1733,18 +1705,47 @@ package body Exp_Pakd is Left_Opnd => Unchecked_Convert_To (RTE (RE_Integer_Address), Make_Attribute_Reference (Loc, - Prefix => Pref, + Prefix => Base, Attribute_Name => Name_Address)), Right_Opnd => - Make_Op_Divide (Loc, - Left_Opnd => Expr, - Right_Opnd => - Make_Integer_Literal (Loc, System_Storage_Unit))))); + Unchecked_Convert_To (RTE (RE_Integer_Address), + Make_Op_Divide (Loc, + Left_Opnd => Offset, + Right_Opnd => + Make_Integer_Literal (Loc, System_Storage_Unit)))))); Analyze_And_Resolve (N, RTE (RE_Address)); end Expand_Packed_Address_Reference; + --------------------------------- + -- Expand_Packed_Bit_Reference -- + --------------------------------- + + procedure Expand_Packed_Bit_Reference (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Base : Node_Id; + Offset : Node_Id; + + begin + -- We build an expression that has the form + + -- (linear-subscript * component_size for each array reference + -- + field'Bit_Position for each record field + -- + ... + -- + ...) mod Storage_Unit; + + Get_Base_And_Bit_Offset (Prefix (N), Base, Offset); + + Rewrite (N, + Unchecked_Convert_To (Universal_Integer, + Make_Op_Mod (Loc, + Left_Opnd => Offset, + Right_Opnd => Make_Integer_Literal (Loc, System_Storage_Unit)))); + + Analyze_And_Resolve (N, Universal_Integer); + end Expand_Packed_Bit_Reference; + ------------------------------------ -- Expand_Packed_Boolean_Operator -- ------------------------------------ @@ -1841,11 +1842,8 @@ package body Exp_Pakd is else declare - Result_Ent : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); - - E_Id : RE_Id; + Result_Ent : constant Entity_Id := Make_Temporary (Loc, 'T'); + E_Id : RE_Id; begin if Nkind (N) = N_Op_And then @@ -1948,6 +1946,19 @@ package body Exp_Pakd is Ctyp := Component_Type (Atyp); Csiz := UI_To_Int (Component_Size (Atyp)); + -- For the AAMP target, indexing of certain packed array is passed + -- through to the back end without expansion, because the expansion + -- results in very inefficient code on that target. This allows the + -- GNAAMP back end to generate specialized macros that support more + -- efficient indexing of packed arrays with components having sizes + -- that are small powers of two. + + if AAMP_On_Target + and then (Csiz = 1 or else Csiz = 2 or else Csiz = 4) + then + return; + end if; + -- Case of component size 1,2,4 or any component size for the modular -- case. These are the cases for which we can inline the code. @@ -2192,9 +2203,7 @@ package body Exp_Pakd is else declare - Result_Ent : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); + Result_Ent : constant Entity_Id := Make_Temporary (Loc, 'T'); begin Insert_Actions (N, New_List ( @@ -2235,6 +2244,70 @@ package body Exp_Pakd is end Expand_Packed_Not; + ----------------------------- + -- Get_Base_And_Bit_Offset -- + ----------------------------- + + procedure Get_Base_And_Bit_Offset + (N : Node_Id; + Base : out Node_Id; + Offset : out Node_Id) + is + Loc : Source_Ptr; + Term : Node_Id; + Atyp : Entity_Id; + Subscr : Node_Id; + + begin + Base := N; + Offset := Empty; + + -- We build up an expression serially that has the form + + -- linear-subscript * component_size for each array reference + -- + field'Bit_Position for each record field + -- + ... + + loop + Loc := Sloc (Base); + + if Nkind (Base) = N_Indexed_Component then + Convert_To_Actual_Subtype (Prefix (Base)); + Atyp := Etype (Prefix (Base)); + Compute_Linear_Subscript (Atyp, Base, Subscr); + + Term := + Make_Op_Multiply (Loc, + Left_Opnd => Subscr, + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Atyp, Loc), + Attribute_Name => Name_Component_Size)); + + elsif Nkind (Base) = N_Selected_Component then + Term := + Make_Attribute_Reference (Loc, + Prefix => Selector_Name (Base), + Attribute_Name => Name_Bit_Position); + + else + return; + end if; + + if No (Offset) then + Offset := Term; + + else + Offset := + Make_Op_Add (Loc, + Left_Opnd => Offset, + Right_Opnd => Term); + end if; + + Base := Prefix (Base); + end loop; + end Get_Base_And_Bit_Offset; + ------------------------------------- -- Involves_Packed_Array_Reference -- ------------------------------------- diff --git a/gcc/ada/exp_pakd.ads b/gcc/ada/exp_pakd.ads index 0c2e815e2ff..bd21a30effe 100644 --- a/gcc/ada/exp_pakd.ads +++ b/gcc/ada/exp_pakd.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -272,4 +272,9 @@ package Exp_Pakd is -- the prefix involves a packed array reference. This routine expands the -- necessary code for performing the address reference in this case. + procedure Expand_Packed_Bit_Reference (N : Node_Id); + -- The node N is an attribute reference for the 'Bit reference, where the + -- prefix involves a packed array reference. This routine expands the + -- necessary code for performing the bit reference in this case. + end Exp_Pakd; diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index 6bddf9670b9..987cddc0bbd 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -269,8 +269,8 @@ package body Exp_Prag is -------------------------- procedure Expand_Pragma_Check (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); Cond : constant Node_Id := Arg2 (N); + Loc : constant Source_Ptr := Sloc (Cond); Nam : constant Name_Id := Chars (Arg1 (N)); Msg : Node_Id; @@ -536,17 +536,14 @@ package body Exp_Prag is begin if Present (Call) then declare - Excep_Internal : constant Node_Id := - Make_Defining_Identifier - (Loc, New_Internal_Name ('V')); - - Export_Pragma : Node_Id; - Excep_Alias : Node_Id; - Excep_Object : Node_Id; - Excep_Image : String_Id; - Exdata : List_Id; - Lang_Char : Node_Id; - Code : Node_Id; + Excep_Internal : constant Node_Id := Make_Temporary (Loc, 'V'); + Export_Pragma : Node_Id; + Excep_Alias : Node_Id; + Excep_Object : Node_Id; + Excep_Image : String_Id; + Exdata : List_Id; + Lang_Char : Node_Id; + Code : Node_Id; begin if Present (Interface_Name (Id)) then diff --git a/gcc/ada/exp_sel.adb b/gcc/ada/exp_sel.adb index 25d1a32b4c9..8250516a04f 100644 --- a/gcc/ada/exp_sel.adb +++ b/gcc/ada/exp_sel.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -83,19 +83,13 @@ package body Exp_Sel is (Loc : Source_Ptr; Decls : List_Id) return Entity_Id is - B : constant Entity_Id := Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('B')); - + B : constant Entity_Id := Make_Temporary (Loc, 'B'); begin Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - B, - Object_Definition => - New_Reference_To (Standard_Boolean, Loc), - Expression => - New_Reference_To (Standard_False, Loc))); - + Defining_Identifier => B, + Object_Definition => New_Reference_To (Standard_Boolean, Loc), + Expression => New_Reference_To (Standard_False, Loc))); return B; end Build_B; @@ -107,17 +101,12 @@ package body Exp_Sel is (Loc : Source_Ptr; Decls : List_Id) return Entity_Id is - C : constant Entity_Id := Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('C')); - + C : constant Entity_Id := Make_Temporary (Loc, 'C'); begin Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - C, - Object_Definition => - New_Reference_To (RTE (RE_Prim_Op_Kind), Loc))); - + Defining_Identifier => C, + Object_Definition => New_Reference_To (RTE (RE_Prim_Op_Kind), Loc))); return C; end Build_C; @@ -155,9 +144,7 @@ package body Exp_Sel is Decls : List_Id; Obj : Entity_Id) return Entity_Id is - K : constant Entity_Id := Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('K')); - + K : constant Entity_Id := Make_Temporary (Loc, 'K'); begin Append_To (Decls, Make_Object_Declaration (Loc, @@ -169,7 +156,6 @@ package body Exp_Sel is Name => New_Reference_To (RTE (RE_Get_Tagged_Kind), Loc), Parameter_Associations => New_List ( Unchecked_Convert_To (RTE (RE_Tag), Obj))))); - return K; end Build_K; @@ -181,16 +167,12 @@ package body Exp_Sel is (Loc : Source_Ptr; Decls : List_Id) return Entity_Id is - S : constant Entity_Id := Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); - + S : constant Entity_Id := Make_Temporary (Loc, 'S'); begin Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => S, - Object_Definition => - New_Reference_To (Standard_Integer, Loc))); - + Object_Definition => New_Reference_To (Standard_Integer, Loc))); return S; end Build_S; diff --git a/gcc/ada/exp_smem.adb b/gcc/ada/exp_smem.adb index 6cbca26e0a8..f2cbfd083c9 100644 --- a/gcc/ada/exp_smem.adb +++ b/gcc/ada/exp_smem.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -270,10 +270,7 @@ package body Exp_Smem is return False; else - if Ekind (Formal) = E_Out_Parameter - or else - Ekind (Formal) = E_In_Out_Parameter - then + if Ekind_In (Formal, E_Out_Parameter, E_In_Out_Parameter) then Insert_Node := Call; return True; else diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb index 42c34a8487e..ddb1064c475 100644 --- a/gcc/ada/exp_strm.adb +++ b/gcc/ada/exp_strm.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1396,7 +1396,7 @@ package body Exp_Strm is -- If the enclosing record is an unchecked_union, we use the -- default expressions for the discriminant (it must exist) -- because we cannot generate a reference to it, given that - -- it is not stored.. + -- it is not stored. if Is_Unchecked_Union (Scope (Entity (Name (VP)))) then D_Ref := diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index c450b677faf..b9e5d389fce 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -43,7 +43,6 @@ with Rident; use Rident; with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Ch8; use Sem_Ch8; -with Sem_SCIL; use Sem_SCIL; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; @@ -306,11 +305,9 @@ package body Exp_Util is else if No (Actions (Fnode)) then Set_Actions (Fnode, L); - else Append_List (L, Actions (Fnode)); end if; - end if; end Append_Freeze_Actions; @@ -398,7 +395,7 @@ package body Exp_Util is Pos : Entity_Id; -- Running index for substring assignments - Pref : Entity_Id; + Pref : constant Entity_Id := Make_Temporary (Loc, 'P'); -- Name of enclosing variable, prefix of resulting name Res : Entity_Id; @@ -417,8 +414,6 @@ package body Exp_Util is Stats : constant List_Id := New_List; begin - Pref := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); - -- For a dynamic task, the name comes from the target variable. -- For a static one it is a formal of the enclosing init proc. @@ -444,7 +439,7 @@ package body Exp_Util is Val := First (Expressions (Id_Ref)); for J in 1 .. Dims loop - T := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); + T := Make_Temporary (Loc, 'T'); Temps (J) := T; Append_To (Decls, @@ -454,10 +449,8 @@ package body Exp_Util is Expression => Make_Attribute_Reference (Loc, Attribute_Name => Name_Image, - Prefix => - New_Occurrence_Of (Etype (Indx), Loc), - Expressions => New_List ( - New_Copy_Tree (Val))))); + Prefix => New_Occurrence_Of (Etype (Indx), Loc), + Expressions => New_List (New_Copy_Tree (Val))))); Next_Index (Indx); Next (Val); @@ -613,7 +606,7 @@ package body Exp_Util is if Restriction_Active (No_Implicit_Heap_Allocations) or else Global_Discard_Names then - T_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('J')); + T_Id := Make_Temporary (Loc, 'J'); Name_Len := 0; return @@ -697,9 +690,8 @@ package body Exp_Util is Expression => New_Occurrence_Of (Res, Loc))); Spec := Make_Function_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, New_Internal_Name ('F')), - Result_Definition => New_Occurrence_Of (Standard_String, Loc)); + Defining_Unit_Name => Make_Temporary (Loc, 'F'), + Result_Definition => New_Occurrence_Of (Standard_String, Loc)); -- Calls to 'Image use the secondary stack, which must be cleaned -- up after the task name is built. @@ -726,15 +718,15 @@ package body Exp_Util is Stats : List_Id) is begin - Len := Make_Defining_Identifier (Loc, New_Internal_Name ('L')); + Len := Make_Temporary (Loc, 'L', Sum); Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Len, - Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), - Expression => Sum)); + Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), + Expression => Sum)); - Res := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Res := Make_Temporary (Loc, 'R'); Append_To (Decls, Make_Object_Declaration (Loc, @@ -750,12 +742,12 @@ package body Exp_Util is Low_Bound => Make_Integer_Literal (Loc, 1), High_Bound => New_Occurrence_Of (Len, Loc))))))); - Pos := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Pos := Make_Temporary (Loc, 'P'); Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Pos, - Object_Definition => New_Occurrence_Of (Standard_Integer, Loc))); + Object_Definition => New_Occurrence_Of (Standard_Integer, Loc))); -- Pos := Prefix'Length; @@ -765,29 +757,29 @@ package body Exp_Util is Expression => Make_Attribute_Reference (Loc, Attribute_Name => Name_Length, - Prefix => New_Occurrence_Of (Prefix, Loc), - Expressions => - New_List (Make_Integer_Literal (Loc, 1))))); + Prefix => New_Occurrence_Of (Prefix, Loc), + Expressions => New_List (Make_Integer_Literal (Loc, 1))))); -- Res (1 .. Pos) := Prefix; Append_To (Stats, - Make_Assignment_Statement (Loc, - Name => Make_Slice (Loc, - Prefix => New_Occurrence_Of (Res, Loc), + Make_Assignment_Statement (Loc, + Name => + Make_Slice (Loc, + Prefix => New_Occurrence_Of (Res, Loc), Discrete_Range => Make_Range (Loc, - Low_Bound => Make_Integer_Literal (Loc, 1), + Low_Bound => Make_Integer_Literal (Loc, 1), High_Bound => New_Occurrence_Of (Pos, Loc))), - Expression => New_Occurrence_Of (Prefix, Loc))); + Expression => New_Occurrence_Of (Prefix, Loc))); Append_To (Stats, Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Pos, Loc), + Name => New_Occurrence_Of (Pos, Loc), Expression => Make_Op_Add (Loc, - Left_Opnd => New_Occurrence_Of (Pos, Loc), + Left_Opnd => New_Occurrence_Of (Pos, Loc), Right_Opnd => Make_Integer_Literal (Loc, 1)))); end Build_Task_Image_Prefix; @@ -809,7 +801,7 @@ package body Exp_Util is Res : Entity_Id; -- String to hold result - Pref : Entity_Id; + Pref : constant Entity_Id := Make_Temporary (Loc, 'P'); -- Name of enclosing variable, prefix of resulting name Sum : Node_Id; @@ -822,8 +814,6 @@ package body Exp_Util is Stats : constant List_Id := New_List; begin - Pref := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); - -- For a dynamic task, the name comes from the target variable. -- For a static one it is a formal of the enclosing init proc. @@ -845,15 +835,15 @@ package body Exp_Util is Name => Make_Identifier (Loc, Name_uTask_Name))); end if; - Sel := Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + Sel := Make_Temporary (Loc, 'S'); Get_Name_String (Chars (Selector_Name (Id_Ref))); Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Sel, - Object_Definition => New_Occurrence_Of (Standard_String, Loc), - Expression => + Object_Definition => New_Occurrence_Of (Standard_String, Loc), + Expression => Make_String_Literal (Loc, Strval => String_From_Name_Buffer))); @@ -1300,9 +1290,7 @@ package body Exp_Util is end if; else - T := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); + T := Make_Temporary (Loc, 'T'); Insert_Action (N, Make_Subtype_Declaration (Loc, @@ -1496,7 +1484,7 @@ package body Exp_Util is -- Handle access types if Is_Access_Type (Typ) then - Typ := Directly_Designated_Type (Typ); + Typ := Designated_Type (Typ); end if; -- Handle task and protected types implementing interfaces @@ -1603,7 +1591,7 @@ package body Exp_Util is -- Handle access types if Is_Access_Type (Typ) then - Typ := Directly_Designated_Type (Typ); + Typ := Designated_Type (Typ); end if; -- Handle class-wide types @@ -1679,7 +1667,7 @@ package body Exp_Util is exit when Chars (Op) = Name and then (Name /= Name_Op_Eq - or else Etype (First_Entity (Op)) = Etype (Last_Entity (Op))); + or else Etype (First_Formal (Op)) = Etype (Last_Formal (Op))); Next_Elmt (Prim); @@ -2016,6 +2004,17 @@ package body Exp_Util is -- unknown before the ELSE part or after the IF statement. elsif Nkind (CV) = N_Elsif_Part then + + -- if the Elsif_Part had condition_actions, the elsif has been + -- rewritten as a nested if, and the original elsif_part is + -- detached from the tree, so there is no way to obtain useful + -- information on the current value of the variable. + -- Can this be improved ??? + + if No (Parent (CV)) then + return; + end if; + Stm := Parent (CV); -- Before start of ELSIF part @@ -2116,9 +2115,7 @@ package body Exp_Util is begin -- Only consider record types - if Ekind (Typ) /= E_Record_Type - and then Ekind (Typ) /= E_Record_Subtype - then + if not Ekind_In (Typ, E_Record_Type, E_Record_Subtype) then return False; end if; @@ -2129,9 +2126,9 @@ package body Exp_Util is if Ekind (D_Typ) = E_Anonymous_Access_Type and then - (Is_Controlled (Directly_Designated_Type (D_Typ)) + (Is_Controlled (Designated_Type (D_Typ)) or else - Is_Concurrent_Type (Directly_Designated_Type (D_Typ))) + Is_Concurrent_Type (Designated_Type (D_Typ))) then return True; end if; @@ -2143,6 +2140,37 @@ package body Exp_Util is return False; end Has_Controlled_Coextensions; + ------------------------ + -- Has_Address_Clause -- + ------------------------ + + -- Should this function check the private part in a package ??? + + function Has_Following_Address_Clause (D : Node_Id) return Boolean is + Id : constant Entity_Id := Defining_Identifier (D); + Decl : Node_Id; + + begin + Decl := Next (D); + while Present (Decl) loop + if Nkind (Decl) = N_At_Clause + and then Chars (Identifier (Decl)) = Chars (Id) + then + return True; + + elsif Nkind (Decl) = N_Attribute_Definition_Clause + and then Chars (Decl) = Name_Address + and then Chars (Name (Decl)) = Chars (Id) + then + return True; + end if; + + Next (Decl); + end loop; + + return False; + end Has_Following_Address_Clause; + -------------------- -- Homonym_Number -- -------------------- @@ -2397,6 +2425,28 @@ package body Exp_Util is end if; end; + -- Alternative of case expression, we place the action in + -- the Actions field of the case expression alternative, this + -- will be handled when the case expression is expanded. + + when N_Case_Expression_Alternative => + if Present (Actions (P)) then + Insert_List_After_And_Analyze + (Last (Actions (P)), Ins_Actions); + else + Set_Actions (P, Ins_Actions); + Analyze_List (Then_Actions (P)); + end if; + + return; + + -- Case of appearing within an Expressions_With_Actions node. We + -- prepend the actions to the list of actions already there. + + when N_Expression_With_Actions => + Prepend_List (Ins_Actions, Actions (P)); + return; + -- Case of appearing in the condition of a while expression or -- elsif. We insert the actions into the Condition_Actions field. -- They will be moved further out when the while loop or elsif @@ -2652,6 +2702,7 @@ package body Exp_Util is N_Access_To_Object_Definition | N_Aggregate | N_Allocator | + N_Case_Expression | N_Case_Statement_Alternative | N_Character_Literal | N_Compilation_Unit | @@ -2758,11 +2809,9 @@ package body Exp_Util is N_Real_Range_Specification | N_Record_Definition | N_Reference | - N_SCIL_Dispatch_Table_Object_Init | N_SCIL_Dispatch_Table_Tag_Init | N_SCIL_Dispatching_Call | N_SCIL_Membership_Test | - N_SCIL_Tag_Init | N_Selected_Component | N_Signed_Integer_Type_Definition | N_Single_Protected_Declaration | @@ -3093,16 +3142,23 @@ package body Exp_Util is end if; end if; + -- The following code is historical, it used to be present but it + -- is too cautious, because the front-end does not know the proper + -- default alignments for the target. Also, if the alignment is + -- not known, the front end can't know in any case! If a copy is + -- needed, the back-end will take care of it. This whole section + -- including this comment can be removed later ??? + -- If the component reference is for a record that has a specified -- alignment, and we either know it is too small, or cannot tell, - -- then the component may be unaligned + -- then the component may be unaligned. - if Known_Alignment (Etype (P)) - and then Alignment (Etype (P)) < Ttypes.Maximum_Alignment - and then M > Alignment (Etype (P)) - then - return True; - end if; + -- if Known_Alignment (Etype (P)) + -- and then Alignment (Etype (P)) < Ttypes.Maximum_Alignment + -- and then M > Alignment (Etype (P)) + -- then + -- return True; + -- end if; -- Case of component clause present which may specify an -- unaligned position. @@ -3724,24 +3780,27 @@ package body Exp_Util is Sizexpr : Node_Id; begin - if not Has_Discriminants (Root_Typ) then + -- If the root type is already constrained, there are no discriminants + -- in the expression. + + if not Has_Discriminants (Root_Typ) + or else Is_Constrained (Root_Typ) + then Constr_Root := Root_Typ; else - Constr_Root := - Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Constr_Root := Make_Temporary (Loc, 'R'); -- subtype cstr__n is T (List of discr constraints taken from Exp) Append_To (List_Def, Make_Subtype_Declaration (Loc, Defining_Identifier => Constr_Root, - Subtype_Indication => - Make_Subtype_From_Expr (E, Root_Typ))); + Subtype_Indication => Make_Subtype_From_Expr (E, Root_Typ))); end if; -- Generate the range subtype declaration - Range_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('G')); + Range_Type := Make_Temporary (Loc, 'G'); if not Is_Interface (Root_Typ) then @@ -3790,7 +3849,7 @@ package body Exp_Util is -- subtype str__nn is Storage_Array (rg__x); - Str_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + Str_Type := Make_Temporary (Loc, 'S'); Append_To (List_Def, Make_Subtype_Declaration (Loc, Defining_Identifier => Str_Type, @@ -3807,7 +3866,7 @@ package body Exp_Util is -- E : Str_Type; -- end Equiv_T; - Equiv_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); + Equiv_Type := Make_Temporary (Loc, 'T'); Set_Ekind (Equiv_Type, E_Record_Type); Set_Parent_Subtype (Equiv_Type, Constr_Root); @@ -3832,9 +3891,7 @@ package body Exp_Util is Append_To (Comp_List, Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('C')), + Defining_Identifier => Make_Temporary (Loc, 'C'), Component_Definition => Make_Component_Definition (Loc, Aliased_Present => False, @@ -3960,15 +4017,12 @@ package body Exp_Util is -- actual or an explicit subtype. Utyp := Underlying_Type (Base_Type (Unc_Typ)); - Full_Subtyp := Make_Defining_Identifier (Loc, - New_Internal_Name ('C')); + Full_Subtyp := Make_Temporary (Loc, 'C'); Full_Exp := - Unchecked_Convert_To - (Utyp, Duplicate_Subexpr_No_Checks (E)); + Unchecked_Convert_To (Utyp, Duplicate_Subexpr_No_Checks (E)); Set_Parent (Full_Exp, Parent (E)); - Priv_Subtyp := - Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Priv_Subtyp := Make_Temporary (Loc, 'P'); Insert_Action (E, Make_Subtype_Declaration (Loc, @@ -4027,6 +4081,20 @@ package body Exp_Util is -- additional intermediate type to handle the assignment). if Expander_Active and then Tagged_Type_Expansion then + + -- If this is the class_wide type of a completion that is + -- a record subtype, set the type of the class_wide type + -- to be the full base type, for use in the expanded code + -- for the equivalent type. Should this be done earlier when + -- the completion is analyzed ??? + + if Is_Private_Type (Etype (Unc_Typ)) + and then + Ekind (Full_View (Etype (Unc_Typ))) = E_Record_Subtype + then + Set_Etype (Unc_Typ, Base_Type (Full_View (Etype (Unc_Typ)))); + end if; + EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E); end if; @@ -4391,9 +4459,7 @@ package body Exp_Util is -- already rewritten a variable node with a constant as -- a result of an earlier Force_Evaluation call. - if Ekind (Entity (N)) = E_Constant - or else Ekind (Entity (N)) = E_In_Parameter - then + if Ekind_In (Entity (N), E_Constant, E_In_Parameter) then return True; -- Functions are not side effect free @@ -4631,14 +4697,15 @@ package body Exp_Util is Scope_Suppress := (others => True); -- If it is a scalar type and we need to capture the value, just make - -- a copy. Likewise for a function call, an attribute reference or an - -- operator. And if we have a volatile reference and Name_Req is not - -- set (see comments above for Side_Effect_Free). + -- a copy. Likewise for a function call, an attribute reference, an + -- allocator, or an operator. And if we have a volatile reference and + -- Name_Req is not set (see comments above for Side_Effect_Free). if Is_Elementary_Type (Exp_Type) and then (Variable_Ref or else Nkind (Exp) = N_Function_Call or else Nkind (Exp) = N_Attribute_Reference + or else Nkind (Exp) = N_Allocator or else Nkind (Exp) in N_Op or else (not Name_Req and then Is_Volatile_Reference (Exp))) then @@ -4653,15 +4720,6 @@ package body Exp_Util is Constant_Present => True, Expression => Relocate_Node (Exp)); - -- Check if the previous node relocation requires readjustment of - -- some SCIL Dispatching node. - - if Generate_SCIL - and then Nkind (Exp) = N_Function_Call - then - Adjust_SCIL_Node (Exp, Expression (E)); - end if; - Set_Assignment_OK (E); Insert_Action (Exp, E); @@ -4823,15 +4881,6 @@ package body Exp_Util is Object_Definition => New_Occurrence_Of (Exp_Type, Loc), Expression => Relocate_Node (Exp)); - -- Check if the previous node relocation requires readjustment - -- of some SCIL Dispatching node. - - if Generate_SCIL - and then Nkind (Exp) = N_Function_Call - then - Adjust_SCIL_Node (Exp, Expression (Decl)); - end if; - Insert_Action (Exp, Decl); Set_Etype (Obj, Exp_Type); Rewrite (Exp, New_Occurrence_Of (Obj, Loc)); @@ -4839,7 +4888,7 @@ package body Exp_Util is end; end if; - Ref_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Ref_Type := Make_Temporary (Loc, 'A'); Ptr_Typ_Decl := Make_Full_Type_Declaration (Loc, @@ -4891,15 +4940,6 @@ package body Exp_Util is Defining_Identifier => Def_Id, Object_Definition => New_Reference_To (Ref_Type, Loc), Expression => New_Exp)); - - -- Check if the previous node relocation requires readjustment - -- of some SCIL Dispatching node. - - if Generate_SCIL - and then Nkind (Exp) = N_Function_Call - then - Adjust_SCIL_Node (Exp, Prefix (New_Exp)); - end if; end if; -- Preserve the Assignment_OK flag in all copies, since at least diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 1f3c9e8a211..b036338da97 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -444,6 +444,11 @@ package Exp_Util is -- Determine whether a record type has anonymous access discriminants with -- a controlled designated type. + function Has_Following_Address_Clause (D : Node_Id) return Boolean; + -- D is the node for an object declaration. This function searches the + -- current declarative part to look for an address clause for the object + -- being declared, and returns True if one is found. + function Homonym_Number (Subp : Entity_Id) return Nat; -- Here subp is the entity for a subprogram. This routine returns the -- homonym number used to disambiguate overloaded subprograms in the same diff --git a/gcc/ada/expander.adb b/gcc/ada/expander.adb index 674137df1da..cc2122dd6e6 100644 --- a/gcc/ada/expander.adb +++ b/gcc/ada/expander.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -163,6 +163,9 @@ package body Expander is when N_Block_Statement => Expand_N_Block_Statement (N); + when N_Case_Expression => + Expand_N_Case_Expression (N); + when N_Case_Statement => Expand_N_Case_Statement (N); @@ -470,7 +473,6 @@ package body Expander is Debug_A_Exit ("expanding ", N, " (done)"); end if; - end Expand; --------------------------- diff --git a/gcc/ada/fmap.adb b/gcc/ada/fmap.adb index 8de27ec6b7e..171f7a18e7d 100644 --- a/gcc/ada/fmap.adb +++ b/gcc/ada/fmap.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,7 +29,10 @@ with Output; use Output; with Table; with Types; use Types; +pragma Warnings (Off); +-- This package is used also by gnatcoll with System.OS_Lib; use System.OS_Lib; +pragma Warnings (On); with Unchecked_Conversion; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index c9639361ec0..584ec944058 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -36,6 +36,7 @@ with Exp_Pakd; use Exp_Pakd; with Exp_Util; use Exp_Util; with Exp_Tss; use Exp_Tss; with Layout; use Layout; +with Lib; use Lib; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; @@ -203,12 +204,64 @@ package body Freeze is New_S : Entity_Id; After : in out Node_Id) is - Body_Node : constant Node_Id := Build_Renamed_Body (Decl, New_S); + Body_Decl : constant Node_Id := Unit_Declaration_Node (New_S); + Ent : constant Entity_Id := Defining_Entity (Decl); + Body_Node : Node_Id; + Renamed_Subp : Entity_Id; + begin - Insert_After (After, Body_Node); - Mark_Rewrite_Insertion (Body_Node); - Analyze (Body_Node); - After := Body_Node; + -- If the renamed subprogram is intrinsic, there is no need for a + -- wrapper body: we set the alias that will be called and expanded which + -- completes the declaration. This transformation is only legal if the + -- renamed entity has already been elaborated. + + -- Note that it is legal for a renaming_as_body to rename an intrinsic + -- subprogram, as long as the renaming occurs before the new entity + -- is frozen. See RM 8.5.4 (5). + + if Nkind (Body_Decl) = N_Subprogram_Renaming_Declaration + and then Is_Entity_Name (Name (Body_Decl)) + then + Renamed_Subp := Entity (Name (Body_Decl)); + else + Renamed_Subp := Empty; + end if; + + if Present (Renamed_Subp) + and then Is_Intrinsic_Subprogram (Renamed_Subp) + and then + (not In_Same_Source_Unit (Renamed_Subp, Ent) + or else Sloc (Renamed_Subp) < Sloc (Ent)) + + -- We can make the renaming entity intrisic if the renamed function + -- has an interface name, or if it is one of the shift/rotate + -- operations known to the compiler. + + and then (Present (Interface_Name (Renamed_Subp)) + or else Chars (Renamed_Subp) = Name_Rotate_Left + or else Chars (Renamed_Subp) = Name_Rotate_Right + or else Chars (Renamed_Subp) = Name_Shift_Left + or else Chars (Renamed_Subp) = Name_Shift_Right + or else Chars (Renamed_Subp) = Name_Shift_Right_Arithmetic) + then + Set_Interface_Name (Ent, Interface_Name (Renamed_Subp)); + + if Present (Alias (Renamed_Subp)) then + Set_Alias (Ent, Alias (Renamed_Subp)); + else + Set_Alias (Ent, Renamed_Subp); + end if; + + Set_Is_Intrinsic_Subprogram (Ent); + Set_Has_Completion (Ent); + + else + Body_Node := Build_Renamed_Body (Decl, New_S); + Insert_After (After, Body_Node); + Mark_Rewrite_Insertion (Body_Node); + Analyze (Body_Node); + After := Body_Node; + end if; end Build_And_Analyze_Renamed_Body; ------------------------ @@ -220,12 +273,12 @@ package body Freeze is New_S : Entity_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (New_S); - -- We use for the source location of the renamed body, the location - -- of the spec entity. It might seem more natural to use the location - -- of the renaming declaration itself, but that would be wrong, since - -- then the body we create would look as though it was created far - -- too late, and this could cause problems with elaboration order - -- analysis, particularly in connection with instantiations. + -- We use for the source location of the renamed body, the location of + -- the spec entity. It might seem more natural to use the location of + -- the renaming declaration itself, but that would be wrong, since then + -- the body we create would look as though it was created far too late, + -- and this could cause problems with elaboration order analysis, + -- particularly in connection with instantiations. N : constant Node_Id := Unit_Declaration_Node (New_S); Nam : constant Node_Id := Name (N); @@ -301,18 +354,16 @@ package body Freeze is Call_Name := New_Copy (Name (N)); end if; - -- The original name may have been overloaded, but - -- is fully resolved now. + -- Original name may have been overloaded, but is fully resolved now Set_Is_Overloaded (Call_Name, False); end if; -- For simple renamings, subsequent calls can be expanded directly as - -- called to the renamed entity. The body must be generated in any case - -- for calls they may appear elsewhere. + -- calls to the renamed entity. The body must be generated in any case + -- for calls that may appear elsewhere. - if (Ekind (Old_S) = E_Function - or else Ekind (Old_S) = E_Procedure) + if Ekind_In (Old_S, E_Function, E_Procedure) and then Nkind (Decl) = N_Subprogram_Declaration then Set_Body_To_Inline (Decl, Old_S); @@ -331,7 +382,6 @@ package body Freeze is Form_Type : constant Entity_Id := Etype (First_Formal (Old_S)); begin - -- The controlling formal may be an access parameter, or the -- actual may be an access value, so adjust accordingly. @@ -380,10 +430,8 @@ package body Freeze is if Present (Formal) then O_Formal := First_Formal (Old_S); Param_Spec := First (Parameter_Specifications (Spec)); - while Present (Formal) loop if Is_Entry (Old_S) then - if Nkind (Parameter_Type (Param_Spec)) /= N_Access_Definition then @@ -446,7 +494,6 @@ package body Freeze is Make_Defining_Identifier (Loc, Chars => Chars (New_S))); Param_Spec := First (Parameter_Specifications (Spec)); - while Present (Param_Spec) loop Set_Defining_Identifier (Param_Spec, Make_Defining_Identifier (Loc, @@ -515,27 +562,20 @@ package body Freeze is if (No (Expression (Decl)) and then not Needs_Finalization (Typ) - and then - (not Has_Non_Null_Base_Init_Proc (Typ) - or else Is_Imported (E))) - - or else - (Present (Expression (Decl)) - and then Is_Scalar_Type (Typ)) - - or else - Is_Access_Type (Typ) - + and then (not Has_Non_Null_Base_Init_Proc (Typ) + or else Is_Imported (E))) + or else (Present (Expression (Decl)) and then Is_Scalar_Type (Typ)) + or else Is_Access_Type (Typ) or else (Is_Bit_Packed_Array (Typ) - and then - Is_Modular_Integer_Type (Packed_Array_Type (Typ))) + and then Is_Modular_Integer_Type (Packed_Array_Type (Typ))) then null; -- Otherwise, we require the address clause to be constant because -- the call to the initialization procedure (or the attach code) has -- to happen at the point of the declaration. + -- Actually the IP call has been moved to the freeze actions -- anyway, so maybe we can relax this restriction??? @@ -551,7 +591,36 @@ package body Freeze is end if; end if; - if not Error_Posted (Expr) + -- If Rep_Clauses are to be ignored, remove address clause from + -- list attached to entity, because it may be illegal for gigi, + -- for example by breaking order of elaboration.. + + if Ignore_Rep_Clauses then + declare + Rep : Node_Id; + + begin + Rep := First_Rep_Item (E); + + if Rep = Addr then + Set_First_Rep_Item (E, Next_Rep_Item (Addr)); + + else + while Present (Rep) + and then Next_Rep_Item (Rep) /= Addr + loop + Rep := Next_Rep_Item (Rep); + end loop; + end if; + + if Present (Rep) then + Set_Next_Rep_Item (Rep, Next_Rep_Item (Addr)); + end if; + end; + + Rewrite (Addr, Make_Null_Statement (Sloc (E))); + + elsif not Error_Posted (Expr) and then not Needs_Finalization (Typ) then Warn_Overlay (Expr, Typ, Name (Addr)); @@ -789,7 +858,7 @@ package body Freeze is and then Present (Parent (T)) and then Nkind (Parent (T)) = N_Full_Type_Declaration and then Nkind (Type_Definition (Parent (T))) = - N_Record_Definition + N_Record_Definition and then not Null_Present (Type_Definition (Parent (T))) and then Present (Variant_Part (Component_List (Type_Definition (Parent (T))))) @@ -801,8 +870,7 @@ package body Freeze is if not Is_Constrained (T) and then - No (Discriminant_Default_Value - (First_Discriminant (T))) + No (Discriminant_Default_Value (First_Discriminant (T))) and then Unknown_Esize (T) then return False; @@ -1145,10 +1213,7 @@ package body Freeze is if Nkind_In (Par, N_Object_Declaration, N_Assignment_Statement) and then Comes_From_Source (Par) then - Temp := - Make_Defining_Identifier (Loc, - New_Internal_Name ('T')); - + Temp := Make_Temporary (Loc, 'T', E); New_N := Make_Object_Declaration (Loc, Defining_Identifier => Temp, @@ -1191,10 +1256,7 @@ package body Freeze is -- Freeze_All_Ent -- -------------------- - procedure Freeze_All_Ent - (From : Entity_Id; - After : in out Node_Id) - is + procedure Freeze_All_Ent (From : Entity_Id; After : in out Node_Id) is E : Entity_Id; Flist : List_Id; Lastn : Node_Id; @@ -1277,7 +1339,6 @@ package body Freeze is begin Prim := First_Elmt (Prim_List); - while Present (Prim) loop Subp := Node (Prim); @@ -1312,11 +1373,11 @@ package body Freeze is Bod : constant Node_Id := Next (After); begin - if (Nkind (Bod) = N_Subprogram_Body - or else Nkind (Bod) = N_Entry_Body - or else Nkind (Bod) = N_Package_Body - or else Nkind (Bod) = N_Protected_Body - or else Nkind (Bod) = N_Task_Body + if (Nkind_In (Bod, N_Subprogram_Body, + N_Entry_Body, + N_Package_Body, + N_Protected_Body, + N_Task_Body) or else Nkind (Bod) in N_Body_Stub) and then List_Containing (After) = List_Containing (Parent (E)) @@ -1343,6 +1404,9 @@ package body Freeze is -- point at which such functions are constructed (after all types that -- might be used in such expressions have been frozen). + -- For subprograms that are renaming_as_body, we create the wrapper + -- bodies as needed. + -- We also add finalization chains to access types whose designated -- types are controlled. This is normally done when freezing the type, -- but this misses recursive type definitions where the later members @@ -1383,11 +1447,10 @@ package body Freeze is then declare Ent : Entity_Id; + begin Ent := First_Entity (E); - while Present (Ent) loop - if Is_Entry (Ent) and then not Default_Expressions_Processed (Ent) then @@ -1776,7 +1839,7 @@ package body Freeze is Prev := Empty; while Present (Comp) loop - -- First handle the (real) component case + -- First handle the component case if Ekind (Comp) = E_Component or else Ekind (Comp) = E_Discriminant @@ -1847,129 +1910,12 @@ package body Freeze is Component_Name (Component_Clause (Comp))); end if; end if; - - -- If component clause is present, then deal with the non- - -- default bit order case for Ada 95 mode. The required - -- processing for Ada 2005 mode is handled separately after - -- processing all components. - - -- We only do this processing for the base type, and in - -- fact that's important, since otherwise if there are - -- record subtypes, we could reverse the bits once for - -- each subtype, which would be incorrect. - - if Present (CC) - and then Reverse_Bit_Order (Rec) - and then Ekind (E) = E_Record_Type - and then Ada_Version <= Ada_95 - then - declare - CFB : constant Uint := Component_Bit_Offset (Comp); - CSZ : constant Uint := Esize (Comp); - CLC : constant Node_Id := Component_Clause (Comp); - Pos : constant Node_Id := Position (CLC); - FB : constant Node_Id := First_Bit (CLC); - - Storage_Unit_Offset : constant Uint := - CFB / System_Storage_Unit; - - Start_Bit : constant Uint := - CFB mod System_Storage_Unit; - - begin - -- Cases where field goes over storage unit boundary - - if Start_Bit + CSZ > System_Storage_Unit then - - -- Allow multi-byte field but generate warning - - if Start_Bit mod System_Storage_Unit = 0 - and then CSZ mod System_Storage_Unit = 0 - then - Error_Msg_N - ("multi-byte field specified with non-standard" - & " Bit_Order?", CLC); - - if Bytes_Big_Endian then - Error_Msg_N - ("bytes are not reversed " - & "(component is big-endian)?", CLC); - else - Error_Msg_N - ("bytes are not reversed " - & "(component is little-endian)?", CLC); - end if; - - -- Do not allow non-contiguous field - - else - Error_Msg_N - ("attempt to specify non-contiguous field " - & "not permitted", CLC); - Error_Msg_N - ("\caused by non-standard Bit_Order " - & "specified", CLC); - Error_Msg_N - ("\consider possibility of using " - & "Ada 2005 mode here", CLC); - end if; - - -- Case where field fits in one storage unit - - else - -- Give warning if suspicious component clause - - if Intval (FB) >= System_Storage_Unit - and then Warn_On_Reverse_Bit_Order - then - Error_Msg_N - ("?Bit_Order clause does not affect " & - "byte ordering", Pos); - Error_Msg_Uint_1 := - Intval (Pos) + Intval (FB) / - System_Storage_Unit; - Error_Msg_N - ("?position normalized to ^ before bit " & - "order interpreted", Pos); - end if; - - -- Here is where we fix up the Component_Bit_Offset - -- value to account for the reverse bit order. - -- Some examples of what needs to be done are: - - -- First_Bit .. Last_Bit Component_Bit_Offset - -- old new old new - - -- 0 .. 0 7 .. 7 0 7 - -- 0 .. 1 6 .. 7 0 6 - -- 0 .. 2 5 .. 7 0 5 - -- 0 .. 7 0 .. 7 0 4 - - -- 1 .. 1 6 .. 6 1 6 - -- 1 .. 4 3 .. 6 1 3 - -- 4 .. 7 0 .. 3 4 0 - - -- The general rule is that the first bit is - -- is obtained by subtracting the old ending bit - -- from storage_unit - 1. - - Set_Component_Bit_Offset - (Comp, - (Storage_Unit_Offset * System_Storage_Unit) + - (System_Storage_Unit - 1) - - (Start_Bit + CSZ - 1)); - - Set_Normalized_First_Bit - (Comp, - Component_Bit_Offset (Comp) mod - System_Storage_Unit); - end if; - end; - end if; end; end if; - -- Gather data for possible Implicit_Packing later + -- Gather data for possible Implicit_Packing later. Note that at + -- this stage we might be dealing with a real component, or with + -- an implicit subtype declaration. if not Is_Scalar_Type (Etype (Comp)) then All_Scalar_Components := False; @@ -1982,12 +1928,12 @@ package body Freeze is -- If the component is an Itype with Delayed_Freeze and is either -- a record or array subtype and its base type has not yet been - -- frozen, we must remove this from the entity list of this - -- record and put it on the entity list of the scope of its base - -- type. Note that we know that this is not the type of a - -- component since we cleared Has_Delayed_Freeze for it in the - -- previous loop. Thus this must be the Designated_Type of an - -- access type, which is the type of a component. + -- frozen, we must remove this from the entity list of this record + -- and put it on the entity list of the scope of its base type. + -- Note that we know that this is not the type of a component + -- since we cleared Has_Delayed_Freeze for it in the previous + -- loop. Thus this must be the Designated_Type of an access type, + -- which is the type of a component. if Is_Itype (Comp) and then Is_Type (Scope (Comp)) @@ -2118,25 +2064,35 @@ package body Freeze is Next_Entity (Comp); end loop; - -- Deal with pragma Bit_Order + -- Deal with pragma Bit_Order setting non-standard bit order if Reverse_Bit_Order (Rec) and then Base_Type (Rec) = Rec then if not Placed_Component then ADC := Get_Attribute_Definition_Clause (Rec, Attribute_Bit_Order); - Error_Msg_N - ("?Bit_Order specification has no effect", ADC); + Error_Msg_N ("?Bit_Order specification has no effect", ADC); Error_Msg_N ("\?since no component clauses were specified", ADC); - -- Here is where we do Ada 2005 processing for bit order (the Ada - -- 95 case was already taken care of above). + -- Here is where we do the processing for reversed bit order - elsif Ada_Version >= Ada_05 then + else Adjust_Record_For_Reverse_Bit_Order (Rec); end if; end if; + -- Complete error checking on record representation clause (e.g. + -- overlap of components). This is called after adjusting the + -- record for reverse bit order. + + declare + RRC : constant Node_Id := Get_Record_Representation_Clause (Rec); + begin + if Present (RRC) then + Check_Record_Representation_Clause (RRC); + end if; + end; + -- Set OK_To_Reorder_Components depending on debug flags if Rec = Base_Type (Rec) @@ -2172,7 +2128,7 @@ package body Freeze is -- Give warning if redundant constructs warnings on if Warn_On_Redundant_Constructs then - Error_Msg_N + Error_Msg_N -- CODEFIX ("?pragma Pack has no effect, no unplaced components", Get_Rep_Pragma (Rec, Name_Pack)); end if; @@ -2341,9 +2297,9 @@ package body Freeze is declare Sz : constant Node_Id := Size_Clause (Rec); begin - Error_Msg_NE -- CODEFIX + Error_Msg_NE -- CODEFIX ("size given for& too small", Sz, Rec); - Error_Msg_N -- CODEFIX + Error_Msg_N -- CODEFIX ("\use explicit pragma Pack " & "or use pragma Implicit_Packing", Sz); end; @@ -2400,6 +2356,7 @@ package body Freeze is S : Entity_Id := Current_Scope; begin + while Present (S) loop if Is_Overloadable (S) then if Comes_From_Source (S) @@ -2461,8 +2418,8 @@ package body Freeze is -- Skip this if the entity is stubbed, since we don't need a name -- for any stubbed routine. For the case on intrinsics, if no -- external name is specified, then calls will be handled in - -- Exp_Intr.Expand_Intrinsic_Call, and no name is needed; if - -- an external name is provided, then Expand_Intrinsic_Call leaves + -- Exp_Intr.Expand_Intrinsic_Call, and no name is needed. If an + -- external name is provided, then Expand_Intrinsic_Call leaves -- calls in place for expansion by GIGI. if (Is_Imported (E) or else Is_Exported (E)) @@ -2572,8 +2529,7 @@ package body Freeze is and then not Has_Size_Clause (F_Type) and then VM_Target = No_VM then - Error_Msg_N - ("& is an 8-bit Ada Boolean?", Formal); + Error_Msg_N ("& is an 8-bit Ada Boolean?", Formal); Error_Msg_N ("\use appropriate corresponding type in C " & "(e.g. char)?", Formal); @@ -2840,7 +2796,8 @@ package body Freeze is Object_Definition (Parent (E))); if Is_CPP_Class (Etype (E)) then - Error_Msg_NE ("\} may need a cpp_constructor", + Error_Msg_NE + ("\} may need a cpp_constructor", Object_Definition (Parent (E)), Etype (E)); end if; end if; @@ -3120,7 +3077,7 @@ package body Freeze is else Error_Msg_NE ("size given for& too small", SZ, E); - Error_Msg_N + Error_Msg_N -- CODEFIX ("\use explicit pragma Pack " & "or use pragma Implicit_Packing", SZ); end if; @@ -4244,8 +4201,8 @@ package body Freeze is -- exiting from the loop when it is appropriate to insert the freeze -- node before the current node P. - -- Also checks som special exceptions to the freezing rules. These cases - -- result in a direct return, bypassing the freeze action. + -- Also checks some special exceptions to the freezing rules. These + -- cases result in a direct return, bypassing the freeze action. P := N; loop @@ -4422,6 +4379,8 @@ package body Freeze is N_Entry_Call_Alternative | N_Triggering_Alternative | N_Abortable_Part | + N_And_Then | + N_Or_Else | N_Freeze_Entity => exit when Is_List_Member (P); @@ -4510,8 +4469,8 @@ package body Freeze is Scope_Stack.Table (Pos).Pending_Freeze_Actions := Freeze_Nodes; else - Append_List (Freeze_Nodes, Scope_Stack.Table - (Pos).Pending_Freeze_Actions); + Append_List (Freeze_Nodes, + Scope_Stack.Table (Pos).Pending_Freeze_Actions); end if; end if; end; @@ -5413,6 +5372,26 @@ package body Freeze is return True; end; + -- For the designated type of an access to subprogram, all types in + -- the profile must be fully defined. + + elsif Ekind (T) = E_Subprogram_Type then + declare + F : Entity_Id; + + begin + F := First_Formal (T); + while Present (F) loop + if not Is_Fully_Defined (Etype (F)) then + return False; + end if; + + Next_Formal (F); + end loop; + + return Is_Fully_Defined (Etype (T)); + end; + else return not Is_Private_Type (T) or else Present (Full_View (Base_Type (T))); @@ -5523,8 +5502,7 @@ package body Freeze is -- involve secondary stack expansion. else - Dnam := - Make_Defining_Identifier (Loc, New_Internal_Name ('D')); + Dnam := Make_Temporary (Loc, 'D'); Dbody := Make_Subprogram_Body (Loc, @@ -5659,16 +5637,18 @@ package body Freeze is -- We only give the warning for non-imported entities of a type for -- which a non-null base init proc is defined, or for objects of access - -- types with implicit null initialization, or when Initialize_Scalars + -- types with implicit null initialization, or when Normalize_Scalars -- applies and the type is scalar or a string type (the latter being -- tested for because predefined String types are initialized by inline - -- code rather than by an init_proc). + -- code rather than by an init_proc). Note that we do not give the + -- warning for Initialize_Scalars, since we suppressed initialization + -- in this case. if Present (Expr) and then not Is_Imported (Ent) and then (Has_Non_Null_Base_Init_Proc (Typ) or else Is_Access_Type (Typ) - or else (Init_Or_Norm_Scalars + or else (Normalize_Scalars and then (Is_Scalar_Type (Typ) or else Is_String_Type (Typ)))) then diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb index 89746b88035..fb5eb4319f1 100644 --- a/gcc/ada/frontend.adb +++ b/gcc/ada/frontend.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -60,6 +60,7 @@ with Sem_Warn; use Sem_Warn; with Sinfo; use Sinfo; with Sinput; use Sinput; with Sinput.L; use Sinput.L; +with SCIL_LL; use SCIL_LL; with Targparm; use Targparm; with Tbuild; use Tbuild; with Types; use Types; @@ -89,6 +90,10 @@ begin Sem_Warn.Initialize; Prep.Initialize; + if Generate_SCIL then + SCIL_LL.Initialize; + end if; + -- Create package Standard CStand.Create_Standard; diff --git a/gcc/ada/g-comlin.ads b/gcc/ada/g-comlin.ads index 8752ddcff5f..cea2e7b12e8 100644 --- a/gcc/ada/g-comlin.ads +++ b/gcc/ada/g-comlin.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1999-2009, AdaCore -- +-- Copyright (C) 1999-2010, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -106,12 +106,12 @@ -- end loop; -- end; --- The example above have shown how to parse the command line when the --- arguments are read directly from Ada.Command_Line. However, these arguments --- can also be read from a list of strings. This can be useful in several --- contexts, either because your system does not support Ada.Command_Line, or --- because you are manipulating other tools and creating their command line by --- hand, or for any other reason. +-- The examples above show how to parse the command line when the arguments +-- are read directly from Ada.Command_Line. However, these arguments can also +-- be read from a list of strings. This can be useful in several contexts, +-- either because your system does not support Ada.Command_Line, or because +-- you are manipulating other tools and creating their command lines by hand, +-- or for any other reason. -- To create the list of strings, it is recommended to use -- GNAT.OS_Lib.Argument_String_To_List. @@ -140,10 +140,10 @@ -- adding or removing arguments from them. The resulting command line is kept -- as short as possible by coalescing arguments whenever possible. --- Complex command lines can thus be constructed, for example from an GUI +-- Complex command lines can thus be constructed, for example from a GUI -- (although this package does not by itself depend upon any specific GUI --- toolkit). For instance, if you are configuring the command line to use --- when spawning a tool with the following characteristics: +-- toolkit). For instance, if you are configuring the command line to use when +-- spawning a tool with the following characteristics: -- * Specifying -gnatwa is the same as specifying -gnatwu -gnatwv, but -- shorter and more readable @@ -298,7 +298,7 @@ package GNAT.Command_Line is -- as a switch (returned by getopt), otherwise it will be considered -- as a normal argument (returned by Get_Argument). -- - -- If SECTION_DELIMITERS is set, then every following subprogram + -- If Section_Delimiters is set, then every following subprogram -- (Getopt and Get_Argument) will only operate within a section, which -- is delimited by any of these delimiters or the end of the command line. -- @@ -306,9 +306,9 @@ package GNAT.Command_Line is -- Initialize_Option_Scan (Section_Delimiters => "largs bargs cargs"); -- -- Arguments on command line : my_application -c -bargs -d -e -largs -f - -- This line is made of three section, the first one is the default one + -- This line contains three sections, the first one is the default one -- and includes only the '-c' switch, the second one is between -bargs - -- and -largs and includes '-d -e' and the last one includes '-f' + -- and -largs and includes '-d -e' and the last one includes '-f'. procedure Free (Parser : in out Opt_Parser); -- Free the memory used by the parser. Calling this is not mandatory for @@ -317,16 +317,18 @@ package GNAT.Command_Line is procedure Goto_Section (Name : String := ""; Parser : Opt_Parser := Command_Line_Parser); - -- Change the current section. The next Getopt of Get_Argument will start + -- Change the current section. The next Getopt or Get_Argument will start -- looking at the beginning of the section. An empty name ("") refers to -- the first section between the program name and the first section - -- delimiter. If the section does not exist, then Invalid_Section is - -- raised. + -- delimiter. If the section does not exist in Section_Delimiters, then + -- Invalid_Section is raised. If the section does not appear on the command + -- line, then it is treated as an empty section. function Full_Switch (Parser : Opt_Parser := Command_Line_Parser) return String; - -- Returns the full name of the last switch found (Getopt only returns - -- the first character) + -- Returns the full name of the last switch found (Getopt only returns the + -- first character). Does not include the Switch_Char ('-' by default), + -- unless the "*" option of Getopt is used (see below). function Getopt (Switches : String; @@ -336,13 +338,13 @@ package GNAT.Command_Line is -- switch character followed by a character within Switches, casing being -- significant). The result returned is the first character of the switch -- that is located. If there are no more switches in the current section, - -- returns ASCII.NUL. If Concatenate is True (by default), the switches - -- does not need to be separated by spaces (they can be concatenated if - -- they do not require an argument, e.g. -ab is the same as two separate - -- arguments -a -b). + -- returns ASCII.NUL. If Concatenate is True (the default), the switches do + -- not need to be separated by spaces (they can be concatenated if they do + -- not require an argument, e.g. -ab is the same as two separate arguments + -- -a -b). -- - -- Switches is a string of all the possible switches, separated by a - -- space. A switch can be followed by one of the following characters: + -- Switches is a string of all the possible switches, separated by + -- spaces. A switch can be followed by one of the following characters: -- -- ':' The switch requires a parameter. There can optionally be a space -- on the command line between the switch and its parameter. @@ -389,14 +391,14 @@ package GNAT.Command_Line is -- Example -- Getopt ("* a b") -- If the command line is '-a -c toto.o -b', Getopt will return - -- successively 'a', '*', '*' and 'b'. When '*' is returned, - -- Full_Switch returns the corresponding item on the command line. + -- successively 'a', '*', '*' and 'b', with Full_Switch returning + -- "a", "-c", "toto.o", and "b". -- -- When Getopt encounters an invalid switch, it raises the exception -- Invalid_Switch and sets Full_Switch to return the invalid switch. -- When Getopt cannot find the parameter associated with a switch, it -- raises Invalid_Parameter, and sets Full_Switch to return the invalid - -- switch character. + -- switch. -- -- Note: in case of ambiguity, e.g. switches a ab abc, then the longest -- matching switch is returned. @@ -416,33 +418,31 @@ package GNAT.Command_Line is function Get_Argument (Do_Expansion : Boolean := False; Parser : Opt_Parser := Command_Line_Parser) return String; - -- Returns the next element on the command line which is not a switch. - -- This function should not be called before Getopt has returned - -- ASCII.NUL. + -- Returns the next element on the command line that is not a switch. This + -- function should not be called before Getopt has returned ASCII.NUL. -- - -- If Expansion is True, then the parameter on the command line will be - -- considered as a filename with wild cards, and will be expanded. The - -- matching file names will be returned one at a time. When there are no - -- more arguments on the command line, this function returns an empty - -- string. This is useful in non-Unix systems for obtaining normal - -- expansion of wild card references. + -- If Do_Expansion is True, then the parameter on the command line will + -- be considered as a filename with wild cards, and will be expanded. The + -- matching file names will be returned one at a time. This is useful in + -- non-Unix systems for obtaining normal expansion of wild card references. + -- When there are no more arguments on the command line, this function + -- returns an empty string. function Parameter (Parser : Opt_Parser := Command_Line_Parser) return String; - -- Returns the parameter associated with the last switch returned by - -- Getopt. If no parameter was associated with the last switch, or no - -- previous call has been made to Get_Argument, raises Invalid_Parameter. - -- If the last switch was associated with an optional argument and this - -- argument was not found on the command line, Parameter returns an empty - -- string. + -- Returns parameter associated with the last switch returned by Getopt. + -- If no parameter was associated with the last switch, or no previous call + -- has been made to Get_Argument, raises Invalid_Parameter. If the last + -- switch was associated with an optional argument and this argument was + -- not found on the command line, Parameter returns an empty string. function Separator (Parser : Opt_Parser := Command_Line_Parser) return Character; -- The separator that was between the switch and its parameter. This is - -- of little use in general, only if you want to know exactly what was on - -- the command line. This is in general a single character, set to - -- ASCII.NUL if the switch and the parameter were concatenated. A space is - -- returned if the switch and its argument were in two separate arguments. + -- useful if you want to know exactly what was on the command line. This + -- is in general a single character, set to ASCII.NUL if the switch and + -- the parameter were concatenated. A space is returned if the switch and + -- its argument were in two separate arguments. type Expansion_Iterator is limited private; -- Type used during expansion of file names @@ -462,16 +462,15 @@ package GNAT.Command_Line is -- Subdirectories of Directory will also be searched, up to one -- hundred levels deep. -- - -- When Start_Expansion has been called, function Expansion should be - -- called repeatedly until it returns an empty string, before + -- When Start_Expansion has been called, function Expansion should + -- be called repeatedly until it returns an empty string, before -- Start_Expansion can be called again with the same Expansion_Iterator -- variable. function Expansion (Iterator : Expansion_Iterator) return String; -- Returns the next file in the directory matching the parameters given -- to Start_Expansion and updates Iterator to point to the next entry. - -- Returns an empty string when there is no more file in the directory - -- and its subdirectories. + -- Returns an empty string when there are no more files. -- -- If Expansion is called again after an empty string has been returned, -- then the exception GNAT.Directory_Operations.Directory_Error is raised. @@ -508,31 +507,31 @@ package GNAT.Command_Line is (Config : in out Command_Line_Configuration; Prefix : String); -- Indicates that all switches starting with the given prefix should be - -- grouped. For instance, for the GNAT compiler we would define "-gnatw" - -- as a prefix, so that "-gnatwu -gnatwv" can be grouped into "-gnatwuv" - -- It is assume that the remaining of the switch ("uv") is a set of - -- characters whose order is irrelevant. In fact, this package will sort - -- them alphabetically. + -- grouped. For instance, for the GNAT compiler we would define "-gnatw" as + -- a prefix, so that "-gnatwu -gnatwv" can be grouped into "-gnatwuv" It is + -- assumed that the remainder of the switch ("uv") is a set of characters + -- whose order is irrelevant. In fact, this package will sort them + -- alphabetically. procedure Define_Switch (Config : in out Command_Line_Configuration; Switch : String); -- Indicates a new switch. The format of this switch follows the getopt -- format (trailing ':', '?', etc for defining a switch with parameters). - -- The switches defined in the command_line_configuration object are used + -- The switches defined in the Command_Line_Configuration object are used -- when ungrouping switches with more that one character after the prefix. procedure Define_Section (Config : in out Command_Line_Configuration; Section : String); - -- Indicates a new switch section. Every switch belonging to the same + -- Indicates a new switch section. All switches belonging to the same -- section are ordered together, preceded by the section. They are placed - -- at the end of the command line (as in 'gnatmake somefile.adb -cargs -g') + -- at the end of the command line (as in "gnatmake somefile.adb -cargs -g") function Get_Switches (Config : Command_Line_Configuration; Switch_Char : Character) return String; - -- Get the switches list as expected by getopt. This list is built using + -- Get the switches list as expected by Getopt. This list is built using -- all switches defined previously via Define_Switch above. procedure Free (Config : in out Command_Line_Configuration); @@ -562,7 +561,7 @@ package GNAT.Command_Line is -- version with Switches. -- -- The parsing of Switches is done through calls to Getopt, by passing - -- Getopt_Description as an argument. (a "*" is automatically prepended so + -- Getopt_Description as an argument. (A "*" is automatically prepended so -- that all switches and command line arguments are accepted). -- -- To properly handle switches that take parameters, you should document @@ -571,8 +570,8 @@ package GNAT.Command_Line is -- Command_Line_Iterator (which might be fine depending on your -- application). -- - -- If the command line has sections (such as -bargs -largs -cargs), then - -- they should be listed in the Sections parameter (as "-bargs -cargs") + -- If the command line has sections (such as -bargs -cargs), then they + -- should be listed in the Sections parameter (as "-bargs -cargs"). -- -- This function can be used to reset Cmd by passing an empty string. @@ -600,16 +599,16 @@ package GNAT.Command_Line is -- to pass "--check=full" to Remove_Switch as well. -- -- A Switch with a parameter will never be grouped with another switch to - -- avoid ambiguities as to who the parameter applies to. + -- avoid ambiguities as to what the parameter applies to. -- -- Separator is the character that goes between the switches and its -- parameter on the command line. If it is set to ASCII.NUL, then no - -- separator is applied, and they are concatenated + -- separator is applied, and they are concatenated. -- -- If the switch is part of a section, then it should be specified so that -- the switch is correctly placed in the command line, and the section -- added if not already present. For example, to add the -g switch into the - -- -cargs section, you need to call (Cmd, "-g", Section => "-cargs") + -- -cargs section, you need to pass (Cmd, "-g", Section => "-cargs"). -- -- Add_Before allows insertion of the switch at the beginning of the -- command line. @@ -667,6 +666,9 @@ package GNAT.Command_Line is -- Remove a switch with a specific parameter. If Parameter is the empty -- string, then only a switch with no parameter will be removed. + procedure Free (Cmd : in out Command_Line); + -- Free the memory used by Cmd + --------------- -- Iteration -- --------------- @@ -703,9 +705,6 @@ package GNAT.Command_Line is procedure Next (Iter : in out Command_Line_Iterator); -- Move to the next switch - procedure Free (Cmd : in out Command_Line); - -- Free the memory used by Cmd - private Max_Depth : constant := 100; diff --git a/gcc/ada/g-dirope.ads b/gcc/ada/g-dirope.ads index 7ef84726dc3..32b914bdfe8 100644 --- a/gcc/ada/g-dirope.ads +++ b/gcc/ada/g-dirope.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1998-2008, AdaCore -- +-- Copyright (C) 1998-2010, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -209,8 +209,8 @@ package GNAT.Directory_Operations is -- Recognize both forms described above. -- -- System_Default - -- Uses either UNIX on Unix and OpenVMS systems, or DOS on Windows and - -- OS/2 depending on the running environment. + -- Uses either UNIX on Unix and OpenVMS systems, or DOS on Windows, + -- depending on the running environment. What about other OS's??? --------------- -- Iterators -- diff --git a/gcc/ada/g-expect-vms.adb b/gcc/ada/g-expect-vms.adb index cc413f7248d..4d1a770822a 100644 --- a/gcc/ada/g-expect-vms.adb +++ b/gcc/ada/g-expect-vms.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2009, AdaCore -- +-- Copyright (C) 2002-2010, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -50,6 +50,11 @@ package body GNAT.Expect is Save_Output : File_Descriptor; Save_Error : File_Descriptor; + Expect_Process_Died : constant Expect_Match := -100; + Expect_Internal_Error : constant Expect_Match := -101; + -- Additional possible outputs of Expect_Internal. These are not visible in + -- the spec because the user will never see them. + procedure Expect_Internal (Descriptors : in out Array_Of_Pd; Result : out Expect_Match; @@ -57,11 +62,14 @@ package body GNAT.Expect is Full_Buffer : Boolean); -- Internal function used to read from the process Descriptor. -- - -- Three outputs are possible: + -- Several outputs are possible: -- Result=Expect_Timeout, if no output was available before the timeout -- expired. -- Result=Expect_Full_Buffer, if Full_Buffer is True and some characters -- had to be discarded from the internal buffer of Descriptor. + -- Result=Express_Process_Died if one of the processes was terminated. + -- That process's Input_Fd is set to Invalid_FD + -- Result=Express_Internal_Error -- Result=, indicates how many characters were added to the -- internal buffer. These characters are from indexes -- Descriptor.Buffer_Index - Result + 1 .. Descriptor.Buffer_Index @@ -209,7 +217,9 @@ package body GNAT.Expect is Status : out Integer) is begin - Close (Descriptor.Input_Fd); + if Descriptor.Input_Fd /= Invalid_FD then + Close (Descriptor.Input_Fd); + end if; if Descriptor.Error_Fd /= Descriptor.Output_Fd then Close (Descriptor.Error_Fd); @@ -331,10 +341,17 @@ package body GNAT.Expect is Expect_Internal (Descriptors, N, Timeout_Tmp, Full_Buffer); - if N = Expect_Timeout or else N = Expect_Full_Buffer then - Result := N; - return; - end if; + case N is + when Expect_Internal_Error | Expect_Process_Died => + raise Process_Died; + + when Expect_Timeout | Expect_Full_Buffer => + Result := N; + return; + + when others => + null; -- See below + end case; -- Calculate the timeout for the next turn @@ -478,10 +495,17 @@ package body GNAT.Expect is Expect_Internal (Descriptors, N, Timeout, Full_Buffer); - if N = Expect_Timeout or else N = Expect_Full_Buffer then - Result := N; - return; - end if; + case N is + when Expect_Internal_Error | Expect_Process_Died => + raise Process_Died; + + when Expect_Timeout | Expect_Full_Buffer => + Result := N; + return; + + when others => + null; -- Continue + end case; end loop; end Expect; @@ -500,7 +524,10 @@ package body GNAT.Expect is for J in Descriptors'Range loop Descriptors (J) := Regexps (J).Descriptor; - Reinitialize_Buffer (Regexps (J).Descriptor.all); + + if Descriptors (J) /= null then + Reinitialize_Buffer (Regexps (J).Descriptor.all); + end if; end loop; loop @@ -511,25 +538,36 @@ package body GNAT.Expect is -- checking the regexps). for J in Regexps'Range loop - Match (Regexps (J).Regexp.all, - Regexps (J).Descriptor.Buffer - (1 .. Regexps (J).Descriptor.Buffer_Index), - Matched); - - if Matched (0) /= No_Match then - Result := Expect_Match (J); - Regexps (J).Descriptor.Last_Match_Start := Matched (0).First; - Regexps (J).Descriptor.Last_Match_End := Matched (0).Last; - return; + if Regexps (J).Regexp /= null + and then Regexps (J).Descriptor /= null + then + Match (Regexps (J).Regexp.all, + Regexps (J).Descriptor.Buffer + (1 .. Regexps (J).Descriptor.Buffer_Index), + Matched); + + if Matched (0) /= No_Match then + Result := Expect_Match (J); + Regexps (J).Descriptor.Last_Match_Start := Matched (0).First; + Regexps (J).Descriptor.Last_Match_End := Matched (0).Last; + return; + end if; end if; end loop; Expect_Internal (Descriptors, N, Timeout, Full_Buffer); - if N = Expect_Timeout or else N = Expect_Full_Buffer then - Result := N; - return; - end if; + case N is + when Expect_Internal_Error | Expect_Process_Died => + raise Process_Died; + + when Expect_Timeout | Expect_Full_Buffer => + Result := N; + return; + + when others => + null; -- Continue + end case; end loop; end Expect; @@ -549,21 +587,30 @@ package body GNAT.Expect is N : Integer; type File_Descriptor_Array is - array (Descriptors'Range) of File_Descriptor; + array (0 .. Descriptors'Length - 1) of File_Descriptor; Fds : aliased File_Descriptor_Array; + Fds_Count : Natural := 0; + + Fds_To_Descriptor : array (Fds'Range) of Integer; + -- Maps file descriptor entries from Fds to entries in Descriptors. + -- They do not have the same index when entries in Descriptors are null. - type Integer_Array is array (Descriptors'Range) of Integer; + type Integer_Array is array (Fds'Range) of Integer; Is_Set : aliased Integer_Array; begin for J in Descriptors'Range loop - Fds (J) := Descriptors (J).Output_Fd; + if Descriptors (J) /= null then + Fds (Fds'First + Fds_Count) := Descriptors (J).Output_Fd; + Fds_To_Descriptor (Fds'First + Fds_Count) := J; + Fds_Count := Fds_Count + 1; - if Descriptors (J).Buffer_Size = 0 then - Buffer_Size := Integer'Max (Buffer_Size, 4096); - else - Buffer_Size := - Integer'Max (Buffer_Size, Descriptors (J).Buffer_Size); + if Descriptors (J).Buffer_Size = 0 then + Buffer_Size := Integer'Max (Buffer_Size, 4096); + else + Buffer_Size := + Integer'Max (Buffer_Size, Descriptors (J).Buffer_Size); + end if; end if; end loop; @@ -572,19 +619,23 @@ package body GNAT.Expect is -- Buffer used for input. This is allocated only once, not for -- every iteration of the loop + D : Integer; + -- Index in Descriptors + begin -- Loop until we match or we have a timeout loop Num_Descriptors := - Poll (Fds'Address, Fds'Length, Timeout, Is_Set'Address); + Poll (Fds'Address, Fds_Count, Timeout, Is_Set'Address); case Num_Descriptors is -- Error? when -1 => - raise Process_Died; + Result := Expect_Internal_Error; + return; -- Timeout? @@ -595,15 +646,17 @@ package body GNAT.Expect is -- Some input when others => - for J in Descriptors'Range loop - if Is_Set (J) = 1 then - Buffer_Size := Descriptors (J).Buffer_Size; + for F in Fds'Range loop + if Is_Set (F) = 1 then + D := Fds_To_Descriptor (F); + + Buffer_Size := Descriptors (D).Buffer_Size; if Buffer_Size = 0 then Buffer_Size := 4096; end if; - N := Read (Descriptors (J).Output_Fd, Buffer'Address, + N := Read (Descriptors (D).Output_Fd, Buffer'Address, Buffer_Size); -- Error or End of file @@ -611,43 +664,46 @@ package body GNAT.Expect is if N <= 0 then -- ??? Note that ddd tries again up to three times -- in that case. See LiterateA.C:174 - raise Process_Died; + + Descriptors (D).Input_Fd := Invalid_FD; + Result := Expect_Process_Died; + return; else -- If there is no limit to the buffer size - if Descriptors (J).Buffer_Size = 0 then + if Descriptors (D).Buffer_Size = 0 then declare - Tmp : String_Access := Descriptors (J).Buffer; + Tmp : String_Access := Descriptors (D).Buffer; begin if Tmp /= null then - Descriptors (J).Buffer := + Descriptors (D).Buffer := new String (1 .. Tmp'Length + N); - Descriptors (J).Buffer (1 .. Tmp'Length) := + Descriptors (D).Buffer (1 .. Tmp'Length) := Tmp.all; - Descriptors (J).Buffer + Descriptors (D).Buffer (Tmp'Length + 1 .. Tmp'Length + N) := Buffer (1 .. N); Free (Tmp); - Descriptors (J).Buffer_Index := - Descriptors (J).Buffer'Last; + Descriptors (D).Buffer_Index := + Descriptors (D).Buffer'Last; else - Descriptors (J).Buffer := + Descriptors (D).Buffer := new String (1 .. N); - Descriptors (J).Buffer.all := + Descriptors (D).Buffer.all := Buffer (1 .. N); - Descriptors (J).Buffer_Index := N; + Descriptors (D).Buffer_Index := N; end if; end; else -- Add what we read to the buffer - if Descriptors (J).Buffer_Index + N > - Descriptors (J).Buffer_Size + if Descriptors (D).Buffer_Index + N > + Descriptors (D).Buffer_Size then -- If the user wants to know when we have -- read more than the buffer can contain. @@ -660,33 +716,33 @@ package body GNAT.Expect is -- Keep as much as possible from the buffer, -- and forget old characters. - Descriptors (J).Buffer - (1 .. Descriptors (J).Buffer_Size - N) := - Descriptors (J).Buffer - (N - Descriptors (J).Buffer_Size + - Descriptors (J).Buffer_Index + 1 .. - Descriptors (J).Buffer_Index); - Descriptors (J).Buffer_Index := - Descriptors (J).Buffer_Size - N; + Descriptors (D).Buffer + (1 .. Descriptors (D).Buffer_Size - N) := + Descriptors (D).Buffer + (N - Descriptors (D).Buffer_Size + + Descriptors (D).Buffer_Index + 1 .. + Descriptors (D).Buffer_Index); + Descriptors (D).Buffer_Index := + Descriptors (D).Buffer_Size - N; end if; -- Keep what we read in the buffer - Descriptors (J).Buffer - (Descriptors (J).Buffer_Index + 1 .. - Descriptors (J).Buffer_Index + N) := + Descriptors (D).Buffer + (Descriptors (D).Buffer_Index + 1 .. + Descriptors (D).Buffer_Index + N) := Buffer (1 .. N); - Descriptors (J).Buffer_Index := - Descriptors (J).Buffer_Index + N; + Descriptors (D).Buffer_Index := + Descriptors (D).Buffer_Index + N; end if; -- Call each of the output filter with what we -- read. Call_Filters - (Descriptors (J).all, Buffer (1 .. N), Output); + (Descriptors (D).all, Buffer (1 .. N), Output); - Result := Expect_Match (N); + Result := Expect_Match (D); return; end if; end if; @@ -715,6 +771,25 @@ package body GNAT.Expect is (Descriptor.Last_Match_Start .. Descriptor.Last_Match_End); end Expect_Out_Match; + ------------------------ + -- First_Dead_Process -- + ------------------------ + + function First_Dead_Process + (Regexp : Multiprocess_Regexp_Array) return Natural + is + begin + for R in Regexp'Range loop + if Regexp (R).Descriptor /= null + and then Regexp (R).Descriptor.Input_Fd = GNAT.OS_Lib.Invalid_FD + then + return R; + end if; + end loop; + + return 0; + end First_Dead_Process; + ----------- -- Flush -- ----------- @@ -770,6 +845,18 @@ package body GNAT.Expect is end loop; end Flush; + ---------- + -- Free -- + ---------- + + procedure Free (Regexp : in out Multiprocess_Regexp) is + procedure Unchecked_Free is new Ada.Unchecked_Deallocation + (Process_Descriptor'Class, Process_Descriptor_Access); + begin + Unchecked_Free (Regexp.Descriptor); + Free (Regexp.Regexp); + end Free; + ------------------------ -- Get_Command_Output -- ------------------------ @@ -897,6 +984,15 @@ package body GNAT.Expect is return Descriptor.Pid; end Get_Pid; + ----------------- + -- Has_Process -- + ----------------- + + function Has_Process (Regexp : Multiprocess_Regexp_Array) return Boolean is + begin + return Regexp /= (Regexp'Range => (null, null)); + end Has_Process; + --------------- -- Interrupt -- --------------- @@ -1023,6 +1119,13 @@ package body GNAT.Expect is Expect_Internal (Descriptors, Result, Timeout => 0, Full_Buffer => False); + + if Result = Expect_Internal_Error + or else Result = Expect_Process_Died + then + raise Process_Died; + end if; + Descriptor.Last_Match_End := Descriptor.Buffer_Index; -- Empty the buffer diff --git a/gcc/ada/g-expect.adb b/gcc/ada/g-expect.adb index 6510c310813..c8b368fc58a 100644 --- a/gcc/ada/g-expect.adb +++ b/gcc/ada/g-expect.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2000-2009, AdaCore -- +-- Copyright (C) 2000-2010, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -45,6 +45,11 @@ package body GNAT.Expect is type Array_Of_Pd is array (Positive range <>) of Process_Descriptor_Access; + Expect_Process_Died : constant Expect_Match := -100; + Expect_Internal_Error : constant Expect_Match := -101; + -- Additional possible outputs of Expect_Internal. These are not visible in + -- the spec because the user will never see them. + procedure Expect_Internal (Descriptors : in out Array_Of_Pd; Result : out Expect_Match; @@ -52,11 +57,14 @@ package body GNAT.Expect is Full_Buffer : Boolean); -- Internal function used to read from the process Descriptor. -- - -- Three outputs are possible: + -- Several outputs are possible: -- Result=Expect_Timeout, if no output was available before the timeout -- expired. -- Result=Expect_Full_Buffer, if Full_Buffer is True and some characters -- had to be discarded from the internal buffer of Descriptor. + -- Result=Express_Process_Died if one of the processes was terminated. + -- That process's Input_Fd is set to Invalid_FD + -- Result=Express_Internal_Error -- Result=, indicates how many characters were added to the -- internal buffer. These characters are from indexes -- Descriptor.Buffer_Index - Result + 1 .. Descriptor.Buffer_Index @@ -211,7 +219,9 @@ package body GNAT.Expect is Next_Filter : Filter_List; begin - Close (Descriptor.Input_Fd); + if Descriptor.Input_Fd /= Invalid_FD then + Close (Descriptor.Input_Fd); + end if; if Descriptor.Error_Fd /= Descriptor.Output_Fd then Close (Descriptor.Error_Fd); @@ -344,10 +354,17 @@ package body GNAT.Expect is Expect_Internal (Descriptors, N, Timeout_Tmp, Full_Buffer); - if N = Expect_Timeout or else N = Expect_Full_Buffer then - Result := N; - return; - end if; + case N is + when Expect_Internal_Error | Expect_Process_Died => + raise Process_Died; + + when Expect_Timeout | Expect_Full_Buffer => + Result := N; + return; + + when others => + null; -- See below + end case; -- Calculate the timeout for the next turn @@ -493,10 +510,17 @@ package body GNAT.Expect is Expect_Internal (Descriptors, N, Timeout, Full_Buffer); - if N = Expect_Timeout or else N = Expect_Full_Buffer then - Result := N; - return; - end if; + case N is + when Expect_Internal_Error | Expect_Process_Died => + raise Process_Died; + + when Expect_Timeout | Expect_Full_Buffer => + Result := N; + return; + + when others => + null; -- Continue + end case; end loop; end Expect; @@ -515,7 +539,10 @@ package body GNAT.Expect is for J in Descriptors'Range loop Descriptors (J) := Regexps (J).Descriptor; - Reinitialize_Buffer (Regexps (J).Descriptor.all); + + if Descriptors (J) /= null then + Reinitialize_Buffer (Regexps (J).Descriptor.all); + end if; end loop; loop @@ -526,25 +553,36 @@ package body GNAT.Expect is -- checking the regexps). for J in Regexps'Range loop - Match (Regexps (J).Regexp.all, - Regexps (J).Descriptor.Buffer - (1 .. Regexps (J).Descriptor.Buffer_Index), - Matched); - - if Matched (0) /= No_Match then - Result := Expect_Match (J); - Regexps (J).Descriptor.Last_Match_Start := Matched (0).First; - Regexps (J).Descriptor.Last_Match_End := Matched (0).Last; - return; + if Regexps (J).Regexp /= null + and then Regexps (J).Descriptor /= null + then + Match (Regexps (J).Regexp.all, + Regexps (J).Descriptor.Buffer + (1 .. Regexps (J).Descriptor.Buffer_Index), + Matched); + + if Matched (0) /= No_Match then + Result := Expect_Match (J); + Regexps (J).Descriptor.Last_Match_Start := Matched (0).First; + Regexps (J).Descriptor.Last_Match_End := Matched (0).Last; + return; + end if; end if; end loop; Expect_Internal (Descriptors, N, Timeout, Full_Buffer); - if N = Expect_Timeout or else N = Expect_Full_Buffer then - Result := N; - return; - end if; + case N is + when Expect_Internal_Error | Expect_Process_Died => + raise Process_Died; + + when Expect_Timeout | Expect_Full_Buffer => + Result := N; + return; + + when others => + null; -- Continue + end case; end loop; end Expect; @@ -564,21 +602,30 @@ package body GNAT.Expect is N : Integer; type File_Descriptor_Array is - array (Descriptors'Range) of File_Descriptor; + array (0 .. Descriptors'Length - 1) of File_Descriptor; Fds : aliased File_Descriptor_Array; + Fds_Count : Natural := 0; - type Integer_Array is array (Descriptors'Range) of Integer; + Fds_To_Descriptor : array (Fds'Range) of Integer; + -- Maps file descriptor entries from Fds to entries in Descriptors. + -- They do not have the same index when entries in Descriptors are null. + + type Integer_Array is array (Fds'Range) of Integer; Is_Set : aliased Integer_Array; begin for J in Descriptors'Range loop - Fds (J) := Descriptors (J).Output_Fd; + if Descriptors (J) /= null then + Fds (Fds'First + Fds_Count) := Descriptors (J).Output_Fd; + Fds_To_Descriptor (Fds'First + Fds_Count) := J; + Fds_Count := Fds_Count + 1; - if Descriptors (J).Buffer_Size = 0 then - Buffer_Size := Integer'Max (Buffer_Size, 4096); - else - Buffer_Size := - Integer'Max (Buffer_Size, Descriptors (J).Buffer_Size); + if Descriptors (J).Buffer_Size = 0 then + Buffer_Size := Integer'Max (Buffer_Size, 4096); + else + Buffer_Size := + Integer'Max (Buffer_Size, Descriptors (J).Buffer_Size); + end if; end if; end loop; @@ -587,19 +634,23 @@ package body GNAT.Expect is -- Buffer used for input. This is allocated only once, not for -- every iteration of the loop + D : Integer; + -- Index in Descriptors + begin -- Loop until we match or we have a timeout loop Num_Descriptors := - Poll (Fds'Address, Fds'Length, Timeout, Is_Set'Address); + Poll (Fds'Address, Fds_Count, Timeout, Is_Set'Address); case Num_Descriptors is -- Error? when -1 => - raise Process_Died; + Result := Expect_Internal_Error; + return; -- Timeout? @@ -610,15 +661,17 @@ package body GNAT.Expect is -- Some input when others => - for J in Descriptors'Range loop - if Is_Set (J) = 1 then - Buffer_Size := Descriptors (J).Buffer_Size; + for F in Fds'Range loop + if Is_Set (F) = 1 then + D := Fds_To_Descriptor (F); + + Buffer_Size := Descriptors (D).Buffer_Size; if Buffer_Size = 0 then Buffer_Size := 4096; end if; - N := Read (Descriptors (J).Output_Fd, Buffer'Address, + N := Read (Descriptors (D).Output_Fd, Buffer'Address, Buffer_Size); -- Error or End of file @@ -626,43 +679,46 @@ package body GNAT.Expect is if N <= 0 then -- ??? Note that ddd tries again up to three times -- in that case. See LiterateA.C:174 - raise Process_Died; + + Descriptors (D).Input_Fd := Invalid_FD; + Result := Expect_Process_Died; + return; else -- If there is no limit to the buffer size - if Descriptors (J).Buffer_Size = 0 then + if Descriptors (D).Buffer_Size = 0 then declare - Tmp : String_Access := Descriptors (J).Buffer; + Tmp : String_Access := Descriptors (D).Buffer; begin if Tmp /= null then - Descriptors (J).Buffer := + Descriptors (D).Buffer := new String (1 .. Tmp'Length + N); - Descriptors (J).Buffer (1 .. Tmp'Length) := + Descriptors (D).Buffer (1 .. Tmp'Length) := Tmp.all; - Descriptors (J).Buffer + Descriptors (D).Buffer (Tmp'Length + 1 .. Tmp'Length + N) := Buffer (1 .. N); Free (Tmp); - Descriptors (J).Buffer_Index := - Descriptors (J).Buffer'Last; + Descriptors (D).Buffer_Index := + Descriptors (D).Buffer'Last; else - Descriptors (J).Buffer := + Descriptors (D).Buffer := new String (1 .. N); - Descriptors (J).Buffer.all := + Descriptors (D).Buffer.all := Buffer (1 .. N); - Descriptors (J).Buffer_Index := N; + Descriptors (D).Buffer_Index := N; end if; end; else -- Add what we read to the buffer - if Descriptors (J).Buffer_Index + N > - Descriptors (J).Buffer_Size + if Descriptors (D).Buffer_Index + N > + Descriptors (D).Buffer_Size then -- If the user wants to know when we have -- read more than the buffer can contain. @@ -675,33 +731,33 @@ package body GNAT.Expect is -- Keep as much as possible from the buffer, -- and forget old characters. - Descriptors (J).Buffer - (1 .. Descriptors (J).Buffer_Size - N) := - Descriptors (J).Buffer - (N - Descriptors (J).Buffer_Size + - Descriptors (J).Buffer_Index + 1 .. - Descriptors (J).Buffer_Index); - Descriptors (J).Buffer_Index := - Descriptors (J).Buffer_Size - N; + Descriptors (D).Buffer + (1 .. Descriptors (D).Buffer_Size - N) := + Descriptors (D).Buffer + (N - Descriptors (D).Buffer_Size + + Descriptors (D).Buffer_Index + 1 .. + Descriptors (D).Buffer_Index); + Descriptors (D).Buffer_Index := + Descriptors (D).Buffer_Size - N; end if; -- Keep what we read in the buffer - Descriptors (J).Buffer - (Descriptors (J).Buffer_Index + 1 .. - Descriptors (J).Buffer_Index + N) := + Descriptors (D).Buffer + (Descriptors (D).Buffer_Index + 1 .. + Descriptors (D).Buffer_Index + N) := Buffer (1 .. N); - Descriptors (J).Buffer_Index := - Descriptors (J).Buffer_Index + N; + Descriptors (D).Buffer_Index := + Descriptors (D).Buffer_Index + N; end if; -- Call each of the output filter with what we -- read. Call_Filters - (Descriptors (J).all, Buffer (1 .. N), Output); + (Descriptors (D).all, Buffer (1 .. N), Output); - Result := Expect_Match (N); + Result := Expect_Match (D); return; end if; end if; @@ -730,6 +786,24 @@ package body GNAT.Expect is (Descriptor.Last_Match_Start .. Descriptor.Last_Match_End); end Expect_Out_Match; + ------------------------ + -- First_Dead_Process -- + ------------------------ + + function First_Dead_Process + (Regexp : Multiprocess_Regexp_Array) return Natural is + begin + for R in Regexp'Range loop + if Regexp (R).Descriptor /= null + and then Regexp (R).Descriptor.Input_Fd = GNAT.OS_Lib.Invalid_FD + then + return R; + end if; + end loop; + + return 0; + end First_Dead_Process; + ----------- -- Flush -- ----------- @@ -785,6 +859,18 @@ package body GNAT.Expect is end loop; end Flush; + ---------- + -- Free -- + ---------- + + procedure Free (Regexp : in out Multiprocess_Regexp) is + procedure Unchecked_Free is new Ada.Unchecked_Deallocation + (Process_Descriptor'Class, Process_Descriptor_Access); + begin + Unchecked_Free (Regexp.Descriptor); + Free (Regexp.Regexp); + end Free; + ------------------------ -- Get_Command_Output -- ------------------------ @@ -915,6 +1001,15 @@ package body GNAT.Expect is return Descriptor.Pid; end Get_Pid; + ----------------- + -- Has_Process -- + ----------------- + + function Has_Process (Regexp : Multiprocess_Regexp_Array) return Boolean is + begin + return Regexp /= (Regexp'Range => (null, null)); + end Has_Process; + --------------- -- Interrupt -- --------------- @@ -1136,6 +1231,13 @@ package body GNAT.Expect is Expect_Internal (Descriptors, Result, Timeout => 0, Full_Buffer => False); + + if Result = Expect_Internal_Error + or else Result = Expect_Process_Died + then + raise Process_Died; + end if; + Descriptor.Last_Match_End := Descriptor.Buffer_Index; -- Empty the buffer diff --git a/gcc/ada/g-expect.ads b/gcc/ada/g-expect.ads index 1e50852522a..9a00cf0571e 100644 --- a/gcc/ada/g-expect.ads +++ b/gcc/ada/g-expect.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2009, AdaCore -- +-- Copyright (C) 2000-2010, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -180,16 +180,16 @@ package GNAT.Expect is -- till Expect matches), but this is slower. -- -- If Err_To_Out is True, then the standard error of the spawned process is - -- connected to the standard output. This is the only way to get the - -- Except subprograms to also match on output on standard error. + -- connected to the standard output. This is the only way to get the Except + -- subprograms to also match on output on standard error. -- -- Invalid_Process is raised if the process could not be spawned. procedure Close (Descriptor : in out Process_Descriptor); - -- Terminate the process and close the pipes to it. It implicitly - -- does the 'wait' command required to clean up the process table. - -- This also frees the buffer associated with the process id. Raise - -- Invalid_Process if the process id is invalid. + -- Terminate the process and close the pipes to it. It implicitly does the + -- 'wait' command required to clean up the process table. This also frees + -- the buffer associated with the process id. Raise Invalid_Process if the + -- process id is invalid. procedure Close (Descriptor : in out Process_Descriptor; @@ -247,8 +247,8 @@ package GNAT.Expect is (Descriptor : Process_Descriptor'Class; Str : String; User_Data : System.Address := System.Null_Address); - -- Function called every time new characters are read from or written - -- to the process. + -- Function called every time new characters are read from or written to + -- the process. -- -- Str is a string of all these characters. -- @@ -301,9 +301,9 @@ package GNAT.Expect is Empty_Buffer : Boolean := False); -- Send a string to the file descriptor. -- - -- The string is not formatted in any way, except if Add_LF is True, - -- in which case an ASCII.LF is added at the end, so that Str is - -- recognized as a command by the external process. + -- The string is not formatted in any way, except if Add_LF is True, in + -- which case an ASCII.LF is added at the end, so that Str is recognized + -- as a command by the external process. -- -- If Empty_Buffer is True, any input waiting from the process (or in the -- buffer) is first discarded before the command is sent. The output @@ -330,8 +330,8 @@ package GNAT.Expect is Regexp : String; Timeout : Integer := 10_000; Full_Buffer : Boolean := False); - -- Wait till a string matching Fd can be read from Fd, and return 1 - -- if a match was found. + -- Wait till a string matching Fd can be read from Fd, and return 1 if a + -- match was found. -- -- It consumes all the characters read from Fd until a match found, and -- then sets the return values for the subprograms Expect_Out and @@ -402,15 +402,13 @@ package GNAT.Expect is type Regexp_Array is array (Positive range <>) of GNAT.OS_Lib.String_Access; type Pattern_Matcher_Access is access all GNAT.Regpat.Pattern_Matcher; - type Compiled_Regexp_Array is array (Positive range <>) - of Pattern_Matcher_Access; + type Compiled_Regexp_Array is + array (Positive range <>) of Pattern_Matcher_Access; function "+" - (P : GNAT.Regpat.Pattern_Matcher) - return Pattern_Matcher_Access; - -- Allocate some memory for the pattern matcher. - -- This is only a convenience function to help create the array of - -- compiled regular expressions. + (P : GNAT.Regpat.Pattern_Matcher) return Pattern_Matcher_Access; + -- Allocate some memory for the pattern matcher. This is only a convenience + -- function to help create the array of compiled regular expressions. procedure Expect (Descriptor : in out Process_Descriptor; @@ -441,6 +439,7 @@ package GNAT.Expect is Full_Buffer : Boolean := False); -- Same as above, except that you can also access the parenthesis -- groups inside the matching regular expression. + -- -- The first index in Matched must be 0, or Constraint_Error will be -- raised. The index 0 contains the indexes for the whole string that was -- matched, the index 1 contains the indexes for the first parentheses @@ -453,9 +452,8 @@ package GNAT.Expect is Matched : out GNAT.Regpat.Match_Array; Timeout : Integer := 10_000; Full_Buffer : Boolean := False); - -- Same as above, but with precompiled regular expressions. - -- The first index in Matched must be 0, or Constraint_Error will be - -- raised. + -- Same as above, but with precompiled regular expressions. The first index + -- in Matched must be 0, or Constraint_Error will be raised. ------------------------------------------- -- Working on the output (multi-process) -- @@ -465,8 +463,23 @@ package GNAT.Expect is Descriptor : Process_Descriptor_Access; Regexp : Pattern_Matcher_Access; end record; - type Multiprocess_Regexp_Array is array (Positive range <>) - of Multiprocess_Regexp; + + type Multiprocess_Regexp_Array is + array (Positive range <>) of Multiprocess_Regexp; + + procedure Free (Regexp : in out Multiprocess_Regexp); + -- Free the memory occupied by Regexp + + function Has_Process (Regexp : Multiprocess_Regexp_Array) return Boolean; + -- Return True if at least one entry in Regexp is non-null, ie there is + -- still at least one process to monitor + + function First_Dead_Process + (Regexp : Multiprocess_Regexp_Array) return Natural; + -- Find the first entry in Regexp that corresponds to a dead process that + -- wasn't Free-d yet. This function is called in general when Expect + -- (below) raises the exception Process_Died. This returns 0 if no process + -- has died yet. procedure Expect (Result : out Expect_Match; @@ -474,15 +487,37 @@ package GNAT.Expect is Matched : out GNAT.Regpat.Match_Array; Timeout : Integer := 10_000; Full_Buffer : Boolean := False); - -- Same as above, but for multi processes + -- Same as above, but for multi processes. Any of the entries in + -- Regexps can have a null Descriptor or Regexp. Such entries will + -- simply be ignored. Therefore when a process terminates, you can + -- simply reset its entry. + -- + -- The expect loop would therefore look like: + -- + -- Processes : Multiprocess_Regexp_Array (...) := ...; + -- R : Natural; + -- + -- while Has_Process (Processes) loop + -- begin + -- Expect (Result, Processes, Timeout => -1); + -- ... process output of process Result (output, full buffer,...) + -- + -- exception + -- when Process_Died => + -- -- Free memory + -- R := First_Dead_Process (Processes); + -- Close (Processes (R).Descriptor.all, Status); + -- Free (Processes (R)); + -- end; + -- end loop; procedure Expect (Result : out Expect_Match; Regexps : Multiprocess_Regexp_Array; Timeout : Integer := 10_000; Full_Buffer : Boolean := False); - -- Same as the previous one, but for multiple processes. - -- This procedure finds the first regexp that match the associated process. + -- Same as the previous one, but for multiple processes. This procedure + -- finds the first regexp that match the associated process. ------------------------ -- Getting the output -- @@ -494,8 +529,8 @@ package GNAT.Expect is -- Discard all output waiting from the process. -- -- This output is simply discarded, and no filter is called. This output - -- will also not be visible by the next call to Expect, nor will any - -- output currently buffered. + -- will also not be visible by the next call to Expect, nor will any output + -- currently buffered. -- -- Timeout is the delay for which we wait for output to be available from -- the process. If 0, we only get what is immediately available. @@ -503,13 +538,13 @@ package GNAT.Expect is function Expect_Out (Descriptor : Process_Descriptor) return String; -- Return the string matched by the last Expect call. -- - -- The returned string is in fact the concatenation of all the strings - -- read from the file descriptor up to, and including, the characters - -- that matched the regular expression. + -- The returned string is in fact the concatenation of all the strings read + -- from the file descriptor up to, and including, the characters that + -- matched the regular expression. -- - -- For instance, with an input "philosophic", and a regular expression - -- "hi" in the call to expect, the strings returned the first and second - -- time would be respectively "phi" and "losophi". + -- For instance, with an input "philosophic", and a regular expression "hi" + -- in the call to expect, the strings returned the first and second time + -- would be respectively "phi" and "losophi". function Expect_Out_Match (Descriptor : Process_Descriptor) return String; -- Return the string matched by the last Expect call. @@ -573,10 +608,9 @@ private Pipe3 : in out Pipe_Type; Cmd : String; Args : System.Address); - -- Finish the set up of the pipes while in the child process - -- This also spawns the child process (based on Cmd). - -- On systems that support fork, this procedure is executed inside the - -- newly created process. + -- Finish the set up of the pipes while in the child process This also + -- spawns the child process (based on Cmd). On systems that support fork, + -- this procedure is executed inside the newly created process. type Process_Descriptor is tagged record Pid : aliased Process_Id := Invalid_Pid; @@ -604,7 +638,7 @@ private Args : System.Address); pragma Import (C, Portable_Execvp, "__gnat_expect_portable_execvp"); -- Executes, in a portable way, the command Cmd (full path must be - -- specified), with the given Args. Args must be an array of string + -- specified), with the given Args, which must be an array of string -- pointers. Note that the first element in Args must be the executable -- name, and the last element must be a null pointer. The returned value -- in Pid is the process ID, or zero if not supported on the platform. diff --git a/gcc/ada/g-mbdira.adb b/gcc/ada/g-mbdira.adb new file mode 100644 index 00000000000..f5fd4dce60d --- /dev/null +++ b/gcc/ada/g-mbdira.adb @@ -0,0 +1,282 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . M B B S _ D I S C R E T E _ R A N D O M -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Calendar; + +with Interfaces; use Interfaces; + +package body GNAT.MBBS_Discrete_Random is + + package Calendar renames Ada.Calendar; + + Fits_In_32_Bits : constant Boolean := + Rst'Size < 31 + or else (Rst'Size = 31 + and then Rst'Pos (Rst'First) < 0); + -- This is set True if we do not need more than 32 bits in the result. If + -- we need 64-bits, we will only use the meaningful 48 bits of any 64-bit + -- number generated, since if more than 48 bits are required, we split the + -- computation into two separate parts, since the algorithm does not behave + -- above 48 bits. + + -- The way this expression works is that obviously if the size is 31 bits, + -- it fits in 32 bits. In the 32-bit case, it fits in 32-bit signed if the + -- range has negative values. It is too conservative in the case that the + -- programmer has set a size greater than the default, e.g. a size of 33 + -- for an integer type with a range of 1..10, but an over-conservative + -- result is OK. The important thing is that the value is only True if + -- we know the result will fit in 32-bits signed. If the value is False + -- when it could be True, the behavior will be correct, just a bit less + -- efficient than it could have been in some unusual cases. + -- + -- One might assume that we could get a more accurate result by testing + -- the lower and upper bounds of the type Rst against the bounds of 32-bit + -- Integer. However, there is no easy way to do that. Why? Because in the + -- relatively rare case where this expresion has to be evaluated at run + -- time rather than compile time (when the bounds are dynamic), we need a + -- type to use for the computation. But the possible range of upper bound + -- values for Rst (remembering the possibility of 64-bit modular types) is + -- from -2**63 to 2**64-1, and no run-time type has a big enough range. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Square_Mod_N (X, N : Int) return Int; + pragma Inline (Square_Mod_N); + -- Computes X**2 mod N avoiding intermediate overflow + + ----------- + -- Image -- + ----------- + + function Image (Of_State : State) return String is + begin + return Int'Image (Of_State.X1) & + ',' & + Int'Image (Of_State.X2) & + ',' & + Int'Image (Of_State.Q); + end Image; + + ------------ + -- Random -- + ------------ + + function Random (Gen : Generator) return Rst is + S : State renames Gen.Writable.Self.Gen_State; + Temp : Int; + TF : Flt; + + begin + -- Check for flat range here, since we are typically run with checks + -- off, note that in practice, this condition will usually be static + -- so we will not actually generate any code for the normal case. + + if Rst'Last < Rst'First then + raise Constraint_Error; + end if; + + -- Continue with computation if non-flat range + + S.X1 := Square_Mod_N (S.X1, S.P); + S.X2 := Square_Mod_N (S.X2, S.Q); + Temp := S.X2 - S.X1; + + -- Following duplication is not an error, it is a loop unwinding! + + if Temp < 0 then + Temp := Temp + S.Q; + end if; + + if Temp < 0 then + Temp := Temp + S.Q; + end if; + + TF := Offs + (Flt (Temp) * Flt (S.P) + Flt (S.X1)) * S.Scl; + + -- Pathological, but there do exist cases where the rounding implicit + -- in calculating the scale factor will cause rounding to 'Last + 1. + -- In those cases, returning 'First results in the least bias. + + if TF >= Flt (Rst'Pos (Rst'Last)) + 0.5 then + return Rst'First; + + elsif not Fits_In_32_Bits then + return Rst'Val (Interfaces.Integer_64 (TF)); + + else + return Rst'Val (Int (TF)); + end if; + end Random; + + ----------- + -- Reset -- + ----------- + + procedure Reset (Gen : Generator; Initiator : Integer) is + S : State renames Gen.Writable.Self.Gen_State; + X1, X2 : Int; + + begin + X1 := 2 + Int (Initiator) mod (K1 - 3); + X2 := 2 + Int (Initiator) mod (K2 - 3); + + for J in 1 .. 5 loop + X1 := Square_Mod_N (X1, K1); + X2 := Square_Mod_N (X2, K2); + end loop; + + -- Eliminate effects of small Initiators + + S := + (X1 => X1, + X2 => X2, + P => K1, + Q => K2, + FP => K1F, + Scl => Scal); + end Reset; + + ----------- + -- Reset -- + ----------- + + procedure Reset (Gen : Generator) is + S : State renames Gen.Writable.Self.Gen_State; + Now : constant Calendar.Time := Calendar.Clock; + X1 : Int; + X2 : Int; + + begin + X1 := Int (Calendar.Year (Now)) * 12 * 31 + + Int (Calendar.Month (Now) * 31) + + Int (Calendar.Day (Now)); + + X2 := Int (Calendar.Seconds (Now) * Duration (1000.0)); + + X1 := 2 + X1 mod (K1 - 3); + X2 := 2 + X2 mod (K2 - 3); + + -- Eliminate visible effects of same day starts + + for J in 1 .. 5 loop + X1 := Square_Mod_N (X1, K1); + X2 := Square_Mod_N (X2, K2); + end loop; + + S := + (X1 => X1, + X2 => X2, + P => K1, + Q => K2, + FP => K1F, + Scl => Scal); + + end Reset; + + ----------- + -- Reset -- + ----------- + + procedure Reset (Gen : Generator; From_State : State) is + begin + Gen.Writable.Self.Gen_State := From_State; + end Reset; + + ---------- + -- Save -- + ---------- + + procedure Save (Gen : Generator; To_State : out State) is + begin + To_State := Gen.Gen_State; + end Save; + + ------------------ + -- Square_Mod_N -- + ------------------ + + function Square_Mod_N (X, N : Int) return Int is + begin + return Int ((Integer_64 (X) ** 2) mod (Integer_64 (N))); + end Square_Mod_N; + + ----------- + -- Value -- + ----------- + + function Value (Coded_State : String) return State is + Last : constant Natural := Coded_State'Last; + Start : Positive := Coded_State'First; + Stop : Positive := Coded_State'First; + Outs : State; + + begin + while Stop <= Last and then Coded_State (Stop) /= ',' loop + Stop := Stop + 1; + end loop; + + if Stop > Last then + raise Constraint_Error; + end if; + + Outs.X1 := Int'Value (Coded_State (Start .. Stop - 1)); + Start := Stop + 1; + + loop + Stop := Stop + 1; + exit when Stop > Last or else Coded_State (Stop) = ','; + end loop; + + if Stop > Last then + raise Constraint_Error; + end if; + + Outs.X2 := Int'Value (Coded_State (Start .. Stop - 1)); + Outs.Q := Int'Value (Coded_State (Stop + 1 .. Last)); + Outs.P := Outs.Q * 2 + 1; + Outs.FP := Flt (Outs.P); + Outs.Scl := (RstL - RstF + 1.0) / (Flt (Outs.P) * Flt (Outs.Q)); + + -- Now do *some* sanity checks + + if Outs.Q < 31 + or else Outs.X1 not in 2 .. Outs.P - 1 + or else Outs.X2 not in 2 .. Outs.Q - 1 + then + raise Constraint_Error; + end if; + + return Outs; + end Value; + +end GNAT.MBBS_Discrete_Random; diff --git a/gcc/ada/g-mbdira.ads b/gcc/ada/g-mbdira.ads new file mode 100644 index 00000000000..c415a24cfcf --- /dev/null +++ b/gcc/ada/g-mbdira.ads @@ -0,0 +1,123 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . M B B S _ D I S C R E T E _ R A N D O M -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- The implementation used in this package was contributed by Robert +-- Eachus. It is based on the work of L. Blum, M. Blum, and M. Shub, SIAM +-- Journal of Computing, Vol 15. No 2, May 1986. The particular choices for P +-- and Q chosen here guarantee a period of 562,085,314,430,582 (about 2**49), +-- and the generated sequence has excellent randomness properties. For further +-- details, see the paper "Fast Generation of Trustworthy Random Numbers", by +-- Robert Eachus, which describes both the algorithm and the efficient +-- implementation approach used here. + +-- Formerly, this package was Ada.Numerics.Discrete_Random. It is retained +-- here in part to allow users to reconstruct number sequences generated +-- by previous versions. + +with Interfaces; + +generic + type Result_Subtype is (<>); + +package GNAT.MBBS_Discrete_Random is + + -- The algorithm used here is reliable from a required statistical point of + -- view only up to 48 bits. We try to behave reasonably in the case of + -- larger types, but we can't guarantee the required properties. So + -- generate a warning for these (slightly) dubious cases. + + pragma Compile_Time_Warning + (Result_Subtype'Size > 48, + "statistical properties not guaranteed for size > 48"); + + -- Basic facilities + + type Generator is limited private; + + function Random (Gen : Generator) return Result_Subtype; + + procedure Reset (Gen : Generator); + procedure Reset (Gen : Generator; Initiator : Integer); + + -- Advanced facilities + + type State is private; + + procedure Save (Gen : Generator; To_State : out State); + procedure Reset (Gen : Generator; From_State : State); + + Max_Image_Width : constant := 80; + + function Image (Of_State : State) return String; + function Value (Coded_State : String) return State; + +private + subtype Int is Interfaces.Integer_32; + subtype Rst is Result_Subtype; + + -- We prefer to use 14 digits for Flt, but some targets are more limited + + type Flt is digits Positive'Min (14, Long_Long_Float'Digits); + + RstF : constant Flt := Flt (Rst'Pos (Rst'First)); + RstL : constant Flt := Flt (Rst'Pos (Rst'Last)); + + Offs : constant Flt := RstF - 0.5; + + K1 : constant := 94_833_359; + K1F : constant := 94_833_359.0; + K2 : constant := 47_416_679; + K2F : constant := 47_416_679.0; + Scal : constant Flt := (RstL - RstF + 1.0) / (K1F * K2F); + + type State is record + X1 : Int := Int (2999 ** 2); + X2 : Int := Int (1439 ** 2); + P : Int := K1; + Q : Int := K2; + FP : Flt := K1F; + Scl : Flt := Scal; + end record; + + type Writable_Access (Self : access Generator) is limited null record; + -- Auxiliary type to make Generator a self-referential type + + type Generator is limited record + Writable : Writable_Access (Generator'Access); + -- This self reference allows functions to modify Generator arguments + Gen_State : State; + end record; + +end GNAT.MBBS_Discrete_Random; diff --git a/gcc/ada/g-mbflra.adb b/gcc/ada/g-mbflra.adb new file mode 100644 index 00000000000..1d59069d112 --- /dev/null +++ b/gcc/ada/g-mbflra.adb @@ -0,0 +1,314 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . M B B S _ F L O A T _ R A N D O M -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Calendar; + +package body GNAT.MBBS_Float_Random is + + ------------------------- + -- Implementation Note -- + ------------------------- + + -- The design of this spec is a bit awkward, as a result of Ada 95 not + -- permitting in-out parameters for function formals (most naturally + -- Generator values would be passed this way). In pure Ada 95, the only + -- solution would be to add a self-referential component to the generator + -- allowing access to the generator object from inside the function. This + -- would work because the generator is limited, which prevents any copy. + + -- This is a bit heavy, so what we do is to use Unrestricted_Access to + -- get a pointer to the state in the passed Generator. This works because + -- Generator is a limited type and will thus always be passed by reference. + + package Calendar renames Ada.Calendar; + + type Pointer is access all State; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Euclid (P, Q : Int; X, Y : out Int; GCD : out Int); + + function Euclid (P, Q : Int) return Int; + + function Square_Mod_N (X, N : Int) return Int; + + ------------ + -- Euclid -- + ------------ + + procedure Euclid (P, Q : Int; X, Y : out Int; GCD : out Int) is + + XT : Int := 1; + YT : Int := 0; + + procedure Recur + (P, Q : Int; -- a (i-1), a (i) + X, Y : Int; -- x (i), y (i) + XP, YP : in out Int; -- x (i-1), y (i-1) + GCD : out Int); + + procedure Recur + (P, Q : Int; + X, Y : Int; + XP, YP : in out Int; + GCD : out Int) + is + Quo : Int := P / Q; -- q <-- |_ a (i-1) / a (i) _| + XT : Int := X; -- x (i) + YT : Int := Y; -- y (i) + + begin + if P rem Q = 0 then -- while does not divide + GCD := Q; + XP := X; + YP := Y; + else + Recur (Q, P - Q * Quo, XP - Quo * X, YP - Quo * Y, XT, YT, Quo); + + -- a (i) <== a (i) + -- a (i+1) <-- a (i-1) - q*a (i) + -- x (i+1) <-- x (i-1) - q*x (i) + -- y (i+1) <-- y (i-1) - q*y (i) + -- x (i) <== x (i) + -- y (i) <== y (i) + + XP := XT; + YP := YT; + GCD := Quo; + end if; + end Recur; + + -- Start of processing for Euclid + + begin + Recur (P, Q, 0, 1, XT, YT, GCD); + X := XT; + Y := YT; + end Euclid; + + function Euclid (P, Q : Int) return Int is + X, Y, GCD : Int; + pragma Unreferenced (Y, GCD); + begin + Euclid (P, Q, X, Y, GCD); + return X; + end Euclid; + + ----------- + -- Image -- + ----------- + + function Image (Of_State : State) return String is + begin + return Int'Image (Of_State.X1) & ',' & Int'Image (Of_State.X2) + & ',' & + Int'Image (Of_State.P) & ',' & Int'Image (Of_State.Q); + end Image; + + ------------ + -- Random -- + ------------ + + function Random (Gen : Generator) return Uniformly_Distributed is + Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; + + begin + Genp.X1 := Square_Mod_N (Genp.X1, Genp.P); + Genp.X2 := Square_Mod_N (Genp.X2, Genp.Q); + return + Float ((Flt (((Genp.X2 - Genp.X1) * Genp.X) + mod Genp.Q) * Flt (Genp.P) + + Flt (Genp.X1)) * Genp.Scl); + end Random; + + ----------- + -- Reset -- + ----------- + + -- Version that works from given initiator value + + procedure Reset (Gen : Generator; Initiator : Integer) is + Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; + X1, X2 : Int; + + begin + X1 := 2 + Int (Initiator) mod (K1 - 3); + X2 := 2 + Int (Initiator) mod (K2 - 3); + + -- Eliminate effects of small initiators + + for J in 1 .. 5 loop + X1 := Square_Mod_N (X1, K1); + X2 := Square_Mod_N (X2, K2); + end loop; + + Genp.all := + (X1 => X1, + X2 => X2, + P => K1, + Q => K2, + X => 1, + Scl => Scal); + end Reset; + + -- Version that works from specific saved state + + procedure Reset (Gen : Generator; From_State : State) is + Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; + + begin + Genp.all := From_State; + end Reset; + + -- Version that works from calendar + + procedure Reset (Gen : Generator) is + Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; + Now : constant Calendar.Time := Calendar.Clock; + X1, X2 : Int; + + begin + X1 := Int (Calendar.Year (Now)) * 12 * 31 + + Int (Calendar.Month (Now)) * 31 + + Int (Calendar.Day (Now)); + + X2 := Int (Calendar.Seconds (Now) * Duration (1000.0)); + + X1 := 2 + X1 mod (K1 - 3); + X2 := 2 + X2 mod (K2 - 3); + + -- Eliminate visible effects of same day starts + + for J in 1 .. 5 loop + X1 := Square_Mod_N (X1, K1); + X2 := Square_Mod_N (X2, K2); + end loop; + + Genp.all := + (X1 => X1, + X2 => X2, + P => K1, + Q => K2, + X => 1, + Scl => Scal); + + end Reset; + + ---------- + -- Save -- + ---------- + + procedure Save (Gen : Generator; To_State : out State) is + begin + To_State := Gen.Gen_State; + end Save; + + ------------------ + -- Square_Mod_N -- + ------------------ + + function Square_Mod_N (X, N : Int) return Int is + Temp : constant Flt := Flt (X) * Flt (X); + Div : Int; + + begin + Div := Int (Temp / Flt (N)); + Div := Int (Temp - Flt (Div) * Flt (N)); + + if Div < 0 then + return Div + N; + else + return Div; + end if; + end Square_Mod_N; + + ----------- + -- Value -- + ----------- + + function Value (Coded_State : String) return State is + Last : constant Natural := Coded_State'Last; + Start : Positive := Coded_State'First; + Stop : Positive := Coded_State'First; + Outs : State; + + begin + while Stop <= Last and then Coded_State (Stop) /= ',' loop + Stop := Stop + 1; + end loop; + + if Stop > Last then + raise Constraint_Error; + end if; + + Outs.X1 := Int'Value (Coded_State (Start .. Stop - 1)); + Start := Stop + 1; + + loop + Stop := Stop + 1; + exit when Stop > Last or else Coded_State (Stop) = ','; + end loop; + + if Stop > Last then + raise Constraint_Error; + end if; + + Outs.X2 := Int'Value (Coded_State (Start .. Stop - 1)); + Start := Stop + 1; + + loop + Stop := Stop + 1; + exit when Stop > Last or else Coded_State (Stop) = ','; + end loop; + + if Stop > Last then + raise Constraint_Error; + end if; + + Outs.P := Int'Value (Coded_State (Start .. Stop - 1)); + Outs.Q := Int'Value (Coded_State (Stop + 1 .. Last)); + Outs.X := Euclid (Outs.P, Outs.Q); + Outs.Scl := 1.0 / (Flt (Outs.P) * Flt (Outs.Q)); + + -- Now do *some* sanity checks + + if Outs.Q < 31 or else Outs.P < 31 + or else Outs.X1 not in 2 .. Outs.P - 1 + or else Outs.X2 not in 2 .. Outs.Q - 1 + then + raise Constraint_Error; + end if; + + return Outs; + end Value; +end GNAT.MBBS_Float_Random; diff --git a/gcc/ada/g-mbflra.ads b/gcc/ada/g-mbflra.ads new file mode 100644 index 00000000000..4deac482b52 --- /dev/null +++ b/gcc/ada/g-mbflra.ads @@ -0,0 +1,103 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . M B B S _ F L O A T _ R A N D O M -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- The implementation used in this package was contributed by +-- Robert Eachus. It is based on the work of L. Blum, M. Blum, and +-- M. Shub, SIAM Journal of Computing, Vol 15. No 2, May 1986. The +-- particular choices for P and Q chosen here guarantee a period of +-- 562,085,314,430,582 (about 2**49), and the generated sequence has +-- excellent randomness properties. For further details, see the +-- paper "Fast Generation of Trustworthy Random Numbers", by Robert +-- Eachus, which describes both the algorithm and the efficient +-- implementation approach used here. + +-- Formerly, this package was Ada.Numerics.Float_Random. It is retained +-- here in part to allow users to reconstruct number sequences generated +-- by previous versions. + +with Interfaces; + +package GNAT.MBBS_Float_Random is + + -- Basic facilities + + type Generator is limited private; + + subtype Uniformly_Distributed is Float range 0.0 .. 1.0; + + function Random (Gen : Generator) return Uniformly_Distributed; + + procedure Reset (Gen : Generator); + procedure Reset (Gen : Generator; Initiator : Integer); + + -- Advanced facilities + + type State is private; + + procedure Save (Gen : Generator; To_State : out State); + procedure Reset (Gen : Generator; From_State : State); + + Max_Image_Width : constant := 80; + + function Image (Of_State : State) return String; + function Value (Coded_State : String) return State; + +private + type Int is new Interfaces.Integer_32; + + -- We prefer to use 14 digits for Flt, but some targets are more limited + + type Flt is digits Positive'Min (14, Long_Long_Float'Digits); + + K1 : constant := 94_833_359; + K1F : constant := 94_833_359.0; + K2 : constant := 47_416_679; + K2F : constant := 47_416_679.0; + Scal : constant := 1.0 / (K1F * K2F); + + type State is record + X1 : Int := 2999 ** 2; -- Square mod p + X2 : Int := 1439 ** 2; -- Square mod q + P : Int := K1; + Q : Int := K2; + X : Int := 1; + Scl : Flt := Scal; + end record; + + type Generator is limited record + Gen_State : State; + end record; + +end GNAT.MBBS_Float_Random; diff --git a/gcc/ada/g-pehage.adb b/gcc/ada/g-pehage.adb index e96b9cc0c58..b59e1ecec98 100644 --- a/gcc/ada/g-pehage.adb +++ b/gcc/ada/g-pehage.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2009, AdaCore -- +-- Copyright (C) 2002-2010, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,7 +31,9 @@ -- -- ------------------------------------------------------------------------------ -with Ada.IO_Exceptions; use Ada.IO_Exceptions; +with Ada.IO_Exceptions; use Ada.IO_Exceptions; +with Ada.Characters.Handling; use Ada.Characters.Handling; +with Ada.Directories; with GNAT.Heap_Sort_G; with GNAT.OS_Lib; use GNAT.OS_Lib; @@ -143,6 +145,9 @@ package body GNAT.Perfect_Hash_Generators is -- Return a string which includes string Str or integer Int preceded by -- leading spaces if required by width W. + function Trim_Trailing_Nuls (Str : String) return String; + -- Return Str with trailing NUL characters removed + Output : File_Descriptor renames GNAT.OS_Lib.Standout; -- Shortcuts @@ -213,6 +218,12 @@ package body GNAT.Perfect_Hash_Generators is procedure Put_Vertex_Table (File : File_Descriptor; Title : String); -- Output a title and a vertex table + function Ada_File_Base_Name (Pkg_Name : String) return String; + -- Return the base file name (i.e. without .ads/.adb extension) for an + -- Ada source file containing the named package, using the standard GNAT + -- file-naming convention. For example, if Pkg_Name is "Parent.Child", we + -- return "parent-child". + ---------------------------------- -- Character Position Selection -- ---------------------------------- @@ -494,11 +505,29 @@ package body GNAT.Perfect_Hash_Generators is return True; end Acyclic; + ------------------------ + -- Ada_File_Base_Name -- + ------------------------ + + function Ada_File_Base_Name (Pkg_Name : String) return String is + begin + -- Convert to lower case, then replace '.' with '-' + + return Result : String := To_Lower (Pkg_Name) do + for J in Result'Range loop + if Result (J) = '.' then + Result (J) := '-'; + end if; + end loop; + end return; + end Ada_File_Base_Name; + --------- -- Add -- --------- procedure Add (C : Character) is + pragma Assert (C /= ASCII.NUL); begin Line (Last + 1) := C; Last := Last + 1; @@ -511,6 +540,11 @@ package body GNAT.Perfect_Hash_Generators is procedure Add (S : String) is Len : constant Natural := S'Length; begin + for J in S'Range loop + pragma Assert (S (J) /= ASCII.NUL); + null; + end loop; + Line (Last + 1 .. Last + Len) := S; Last := Last + Len; end Add; @@ -864,6 +898,11 @@ package body GNAT.Perfect_Hash_Generators is procedure Finalize is begin + if Verbose then + Put (Output, "Finalize"); + New_Line (Output); + end if; + -- Deallocate all the WT components (both initial and reduced -- ones) to avoid memory leaks. @@ -1137,10 +1176,15 @@ package body GNAT.Perfect_Hash_Generators is procedure Initialize (Seed : Natural; K_To_V : Float := Default_K_To_V; - Optim : Optimization := CPU_Time; + Optim : Optimization := Memory_Space; Tries : Positive := Default_Tries) is begin + if Verbose then + Put (Output, "Initialize"); + New_Line (Output); + end if; + -- Deallocate the part of the table concerning the reduced words. -- Initial words are already present in the table. We may have reduced -- words already there because a previous computation failed. We are @@ -1221,6 +1265,16 @@ package body GNAT.Perfect_Hash_Generators is Len : constant Natural := Value'Length; begin + if Verbose then + Put (Output, "Inserting """ & Value & """"); + New_Line (Output); + end if; + + for J in Value'Range loop + pragma Assert (Value (J) /= ASCII.NUL); + null; + end loop; + WT.Set_Last (NK); WT.Table (NK) := New_Word (Value); NK := NK + 1; @@ -1369,7 +1423,7 @@ package body GNAT.Perfect_Hash_Generators is -- Produce -- ------------- - procedure Produce (Pkg_Name : String := Default_Pkg_Name) is + procedure Produce (Pkg_Name : String := Default_Pkg_Name) is File : File_Descriptor; Status : Boolean; @@ -1462,28 +1516,26 @@ package body GNAT.Perfect_Hash_Generators is L : Natural; P : Natural; - PLen : constant Natural := Pkg_Name'Length; - FName : String (1 .. PLen + 4); + FName : String := Ada_File_Base_Name (Pkg_Name) & ".ads"; + -- Initially, the name of the spec file; then modified to be the name of + -- the body file. -- Start of processing for Produce begin - FName (1 .. PLen) := Pkg_Name; - for J in 1 .. PLen loop - if FName (J) in 'A' .. 'Z' then - FName (J) := Character'Val (Character'Pos (FName (J)) - - Character'Pos ('A') - + Character'Pos ('a')); - - elsif FName (J) = '.' then - FName (J) := '-'; - end if; - end loop; - FName (PLen + 1 .. PLen + 4) := ".ads"; + if Verbose then + Put (Output, + "Producing " & Ada.Directories.Current_Directory & "/" & FName); + New_Line (Output); + end if; File := Create_File (FName, Binary); + if File = Invalid_FD then + raise Program_Error with "cannot create: " & FName; + end if; + Put (File, "package "); Put (File, Pkg_Name); Put (File, " is"); @@ -1500,10 +1552,14 @@ package body GNAT.Perfect_Hash_Generators is raise Device_Error; end if; - FName (PLen + 4) := 'b'; + FName (FName'Last) := 'b'; -- Set to body file name File := Create_File (FName, Binary); + if File = Invalid_FD then + raise Program_Error with "cannot create: " & FName; + end if; + Put (File, "with Interfaces; use Interfaces;"); New_Line (File); New_Line (File); @@ -1540,39 +1596,41 @@ package body GNAT.Perfect_Hash_Generators is New_Line (File); - if Opt = CPU_Time then - Put_Int_Matrix - (File, - Array_Img ("T1", Type_Img (NV), - Range_Img (0, T1_Len - 1), - Range_Img (0, T2_Len - 1, Type_Img (256))), - T1, T1_Len, T2_Len); - - else - Put_Int_Matrix - (File, - Array_Img ("T1", Type_Img (NV), - Range_Img (0, T1_Len - 1)), - T1, T1_Len, 0); - end if; + case Opt is + when CPU_Time => + Put_Int_Matrix + (File, + Array_Img ("T1", Type_Img (NV), + Range_Img (0, T1_Len - 1), + Range_Img (0, T2_Len - 1, Type_Img (256))), + T1, T1_Len, T2_Len); + + when Memory_Space => + Put_Int_Matrix + (File, + Array_Img ("T1", Type_Img (NV), + Range_Img (0, T1_Len - 1)), + T1, T1_Len, 0); + end case; New_Line (File); - if Opt = CPU_Time then - Put_Int_Matrix - (File, - Array_Img ("T2", Type_Img (NV), - Range_Img (0, T1_Len - 1), - Range_Img (0, T2_Len - 1, Type_Img (256))), - T2, T1_Len, T2_Len); - - else - Put_Int_Matrix - (File, - Array_Img ("T2", Type_Img (NV), - Range_Img (0, T1_Len - 1)), - T2, T1_Len, 0); - end if; + case Opt is + when CPU_Time => + Put_Int_Matrix + (File, + Array_Img ("T2", Type_Img (NV), + Range_Img (0, T1_Len - 1), + Range_Img (0, T2_Len - 1, Type_Img (256))), + T2, T1_Len, T2_Len); + + when Memory_Space => + Put_Int_Matrix + (File, + Array_Img ("T2", Type_Img (NV), + Range_Img (0, T1_Len - 1)), + T2, T1_Len, 0); + end case; New_Line (File); @@ -1594,11 +1652,12 @@ package body GNAT.Perfect_Hash_Generators is Put (File, " J : "); - if Opt = CPU_Time then - Put (File, Type_Img (256)); - else - Put (File, "Natural"); - end if; + case Opt is + when CPU_Time => + Put (File, Type_Img (256)); + when Memory_Space => + Put (File, "Natural"); + end case; Put (File, ";"); New_Line (File); @@ -1611,11 +1670,12 @@ package body GNAT.Perfect_Hash_Generators is New_Line (File); Put (File, " J := "); - if Opt = CPU_Time then - Put (File, "C"); - else - Put (File, "Character'Pos"); - end if; + case Opt is + when CPU_Time => + Put (File, "C"); + when Memory_Space => + Put (File, "Character'Pos"); + end case; Put (File, " (S (P (K) + F));"); New_Line (File); @@ -1684,6 +1744,11 @@ package body GNAT.Perfect_Hash_Generators is procedure Put (File : File_Descriptor; Str : String) is Len : constant Natural := Str'Length; begin + for J in Str'Range loop + pragma Assert (Str (J) /= ASCII.NUL); + null; + end loop; + if Write (File, Str'Address, Len) /= Len then raise Program_Error; end if; @@ -1726,13 +1791,12 @@ package body GNAT.Perfect_Hash_Generators is Last := 0; end if; - if Last + Len + 3 > Max then + if Last + Len + 3 >= Max then Flush; end if; if Last = 0 then - Line (Last + 1 .. Last + 5) := " "; - Last := Last + 5; + Add (" "); if F1 <= L1 then if C1 = F1 and then C2 = F2 then @@ -1759,8 +1823,7 @@ package body GNAT.Perfect_Hash_Generators is Add (' '); end if; - Line (Last + 1 .. Last + Len) := S; - Last := Last + Len; + Add (S); if C2 = L2 then Add (')'); @@ -1827,7 +1890,8 @@ package body GNAT.Perfect_Hash_Generators is K := Get_Key (J); Put (File, Image (J, M), F1, L1, J, 1, 3, 1); Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2); - Put (File, WT.Table (Initial (J)).all, F1, L1, J, 1, 3, 3); + Put (File, Trim_Trailing_Nuls (WT.Table (Initial (J)).all), + F1, L1, J, 1, 3, 3); end loop; end Put_Initial_Keys; @@ -1908,7 +1972,8 @@ package body GNAT.Perfect_Hash_Generators is K := Get_Key (J); Put (File, Image (J, M), F1, L1, J, 1, 3, 1); Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2); - Put (File, WT.Table (Reduced (J)).all, F1, L1, J, 1, 3, 3); + Put (File, Trim_Trailing_Nuls (WT.Table (Reduced (J)).all), + F1, L1, J, 1, 3, 3); end loop; end Put_Reduced_Keys; @@ -2295,7 +2360,8 @@ package body GNAT.Perfect_Hash_Generators is Same_Keys_Sets_Table (J).First .. Same_Keys_Sets_Table (J).Last loop - Put (Output, WT.Table (Reduced (K)).all); + Put (Output, + Trim_Trailing_Nuls (WT.Table (Reduced (K)).all)); New_Line (Output); end loop; Put (Output, "--"); @@ -2428,24 +2494,40 @@ package body GNAT.Perfect_Hash_Generators is R : Natural; begin - if Opt = CPU_Time then - for J in 0 .. T1_Len - 1 loop - exit when Word (J + 1) = ASCII.NUL; - R := Get_Table (Table, J, Get_Used_Char (Word (J + 1))); - S := (S + R) mod NV; - end loop; + case Opt is + when CPU_Time => + for J in 0 .. T1_Len - 1 loop + exit when Word (J + 1) = ASCII.NUL; + R := Get_Table (Table, J, Get_Used_Char (Word (J + 1))); + S := (S + R) mod NV; + end loop; - else - for J in 0 .. T1_Len - 1 loop - exit when Word (J + 1) = ASCII.NUL; - R := Get_Table (Table, J, 0); - S := (S + R * Character'Pos (Word (J + 1))) mod NV; - end loop; - end if; + when Memory_Space => + for J in 0 .. T1_Len - 1 loop + exit when Word (J + 1) = ASCII.NUL; + R := Get_Table (Table, J, 0); + S := (S + R * Character'Pos (Word (J + 1))) mod NV; + end loop; + end case; return S; end Sum; + ------------------------ + -- Trim_Trailing_Nuls -- + ------------------------ + + function Trim_Trailing_Nuls (Str : String) return String is + begin + for J in reverse Str'Range loop + if Str (J) /= ASCII.NUL then + return Str (Str'First .. J); + end if; + end loop; + + return Str; + end Trim_Trailing_Nuls; + --------------- -- Type_Size -- --------------- diff --git a/gcc/ada/g-pehage.ads b/gcc/ada/g-pehage.ads index e4d0e902df9..dfe926ef782 100644 --- a/gcc/ada/g-pehage.ads +++ b/gcc/ada/g-pehage.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2008, AdaCore -- +-- Copyright (C) 2002-2010, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -86,8 +86,9 @@ package GNAT.Perfect_Hash_Generators is -- number of tries. type Optimization is (Memory_Space, CPU_Time); - Default_Optimization : constant Optimization := CPU_Time; - -- Optimize either the memory space or the execution time + -- Optimize either the memory space or the execution time. Note: in + -- practice, the optimization mode has little effect on speed. The tables + -- are somewhat smaller with Memory_Space. Verbose : Boolean := False; -- Output the status of the algorithm. For instance, the tables, the random @@ -97,7 +98,7 @@ package GNAT.Perfect_Hash_Generators is procedure Initialize (Seed : Natural; K_To_V : Float := Default_K_To_V; - Optim : Optimization := CPU_Time; + Optim : Optimization := Memory_Space; Tries : Positive := Default_Tries); -- Initialize the generator and its internal structures. Set the ratio of -- vertices over keys in the random graphs. This value has to be greater @@ -116,7 +117,7 @@ package GNAT.Perfect_Hash_Generators is -- Deallocate the internal structures and the words table procedure Insert (Value : String); - -- Insert a new word in the table + -- Insert a new word into the table. ASCII.NUL characters are not allowed. Too_Many_Tries : exception; -- Raised after Tries unsuccessful runs @@ -124,15 +125,19 @@ package GNAT.Perfect_Hash_Generators is procedure Compute (Position : String := Default_Position); -- Compute the hash function. Position allows to define selection of -- character positions used in the word hash function. Positions can be - -- separated by commas and range like x-y may be used. Character '$' + -- separated by commas and ranges like x-y may be used. Character '$' -- represents the final character of a word. With an empty position, the -- generator automatically produces positions to reduce the memory usage. - -- Raise Too_Many_Tries in case that the algorithm does not succeed in less - -- than Tries attempts (see Initialize). + -- Raise Too_Many_Tries if the algorithm does not succeed within Tries + -- attempts (see Initialize). - procedure Produce (Pkg_Name : String := Default_Pkg_Name); + procedure Produce (Pkg_Name : String := Default_Pkg_Name); -- Generate the hash function package Pkg_Name. This package includes the - -- minimal perfect Hash function. + -- minimal perfect Hash function. The output is placed in the current + -- directory, in files X.ads and X.adb, where X is the standard GNAT file + -- name for a package named Pkg_Name. + + ---------------------------------------------------------------- -- The routines and structures defined below allow producing the hash -- function using a different way from the procedure above. The procedure diff --git a/gcc/ada/g-sercom-linux.adb b/gcc/ada/g-sercom-linux.adb index a89b09b8d08..3432f86b3d9 100644 --- a/gcc/ada/g-sercom-linux.adb +++ b/gcc/ada/g-sercom-linux.adb @@ -158,8 +158,8 @@ package body GNAT.Serial_Communications is Buffer : out Stream_Element_Array; Last : out Stream_Element_Offset) is - Len : constant int := Buffer'Length; - Res : int; + Len : constant size_t := Buffer'Length; + Res : ssize_t; begin if Port.H = null then @@ -264,8 +264,8 @@ package body GNAT.Serial_Communications is (Port : in out Serial_Port; Buffer : Stream_Element_Array) is - Len : constant int := Buffer'Length; - Res : int; + Len : constant size_t := Buffer'Length; + Res : ssize_t; begin if Port.H = null then @@ -273,11 +273,12 @@ package body GNAT.Serial_Communications is end if; Res := write (int (Port.H.all), Buffer'Address, Len); - pragma Assert (Res = Len); if Res = -1 then Raise_Error ("write failed"); end if; + + pragma Assert (size_t (Res) = Len); end Write; ----------- diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb index bbfaecf89c3..b75c525202f 100644 --- a/gcc/ada/g-socket.adb +++ b/gcc/ada/g-socket.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2009, AdaCore -- +-- Copyright (C) 2001-2010, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -40,7 +40,6 @@ with Interfaces.C.Strings; with GNAT.Sockets.Thin_Common; use GNAT.Sockets.Thin_Common; with GNAT.Sockets.Thin; use GNAT.Sockets.Thin; -with GNAT.Sockets.Thin.Task_Safe_NetDB; use GNAT.Sockets.Thin.Task_Safe_NetDB; with GNAT.Sockets.Linker_Options; pragma Warnings (Off, GNAT.Sockets.Linker_Options); @@ -49,6 +48,7 @@ pragma Warnings (Off, GNAT.Sockets.Linker_Options); with System; use System; with System.Communication; use System.Communication; with System.CRTL; use System.CRTL; +with System.Task_Lock; package body GNAT.Sockets is @@ -59,6 +59,7 @@ package body GNAT.Sockets is ENOERROR : constant := 0; Netdb_Buffer_Size : constant := SOSC.Need_Netdb_Buffer * 1024; + Need_Netdb_Lock : constant Boolean := SOSC.Need_Netdb_Lock /= 0; -- The network database functions gethostbyname, gethostbyaddr, -- getservbyname and getservbyport can either be guaranteed task safe by -- the operating system, or else return data through a user-provided buffer @@ -155,18 +156,29 @@ package body GNAT.Sockets is function Is_IP_Address (Name : String) return Boolean; -- Return true when Name is an IP address in standard dot notation + procedure Netdb_Lock; + pragma Inline (Netdb_Lock); + procedure Netdb_Unlock; + pragma Inline (Netdb_Unlock); + -- Lock/unlock operation used to protect netdb access for platforms that + -- require such protection. + function To_In_Addr (Addr : Inet_Addr_Type) return In_Addr; procedure To_Inet_Addr (Addr : In_Addr; Result : out Inet_Addr_Type); -- Conversion functions - function To_Host_Entry (E : Hostent) return Host_Entry_Type; + function To_Host_Entry (E : Hostent_Access) return Host_Entry_Type; -- Conversion function function To_Service_Entry (E : Servent_Access) return Service_Entry_Type; -- Conversion function + function Value (S : System.Address) return String; + -- Same as Interfaces.C.Strings.Value but taking a System.Address (on VMS, + -- chars_ptr is a 32-bit pointer, and here we need a 64-bit version). + function To_Timeval (Val : Timeval_Duration) return Timeval; -- Separate Val in seconds and microseconds @@ -261,7 +273,8 @@ package body GNAT.Sockets is function Is_Open (S : Selector_Type) return Boolean; -- Return True for an "open" Selector_Type object, i.e. one for which - -- Create_Selector has been called and Close_Selector has not been called. + -- Create_Selector has been called and Close_Selector has not been called, + -- or the null selector. --------- -- "+" -- @@ -282,6 +295,10 @@ package body GNAT.Sockets is begin if not Is_Open (Selector) then raise Program_Error with "closed selector"; + + elsif Selector.Is_Null then + raise Program_Error with "null selector"; + end if; -- Send one byte to unblock select system call @@ -453,7 +470,7 @@ package body GNAT.Sockets is -------------------- procedure Check_Selector - (Selector : in out Selector_Type; + (Selector : Selector_Type; R_Socket_Set : in out Socket_Set_Type; W_Socket_Set : in out Socket_Set_Type; Status : out Selector_Status; @@ -470,7 +487,7 @@ package body GNAT.Sockets is -------------------- procedure Check_Selector - (Selector : in out Selector_Type; + (Selector : Selector_Type; R_Socket_Set : in out Socket_Set_Type; W_Socket_Set : in out Socket_Set_Type; E_Socket_Set : in out Socket_Set_Type; @@ -479,7 +496,7 @@ package body GNAT.Sockets is is Res : C.int; Last : C.int; - RSig : constant Socket_Type := Selector.R_Sig_Socket; + RSig : Socket_Type := No_Socket; TVal : aliased Timeval; TPtr : Timeval_Access; @@ -499,9 +516,12 @@ package body GNAT.Sockets is TPtr := TVal'Unchecked_Access; end if; - -- Add read signalling socket + -- Add read signalling socket, if present - Set (R_Socket_Set, RSig); + if not Selector.Is_Null then + RSig := Selector.R_Sig_Socket; + Set (R_Socket_Set, RSig); + end if; Last := C.int'Max (C.int'Max (C.int (R_Socket_Set.Last), C.int (W_Socket_Set.Last)), @@ -528,7 +548,7 @@ package body GNAT.Sockets is -- If Select was resumed because of read signalling socket, read this -- data and remove socket from set. - if Is_Set (R_Socket_Set, RSig) then + if RSig /= No_Socket and then Is_Set (R_Socket_Set, RSig) then Clear (R_Socket_Set, RSig); Res := Signalling_Fds.Read (C.int (RSig)); @@ -573,10 +593,9 @@ package body GNAT.Sockets is procedure Close_Selector (Selector : in out Selector_Type) is begin - if not Is_Open (Selector) then - - -- Selector already in closed state: nothing to do + -- Nothing to do if selector already in closed state + if Selector.Is_Null or else not Is_Open (Selector) then return; end if; @@ -891,13 +910,20 @@ package body GNAT.Sockets is Err : aliased C.int; begin - if Safe_Gethostbyaddr (HA'Address, HA'Size / 8, SOSC.AF_INET, + Netdb_Lock; + + if C_Gethostbyaddr (HA'Address, HA'Size / 8, SOSC.AF_INET, Res'Access, Buf'Address, Buflen, Err'Access) /= 0 then + Netdb_Unlock; Raise_Host_Error (Integer (Err)); end if; - return To_Host_Entry (Res); + return H : constant Host_Entry_Type := + To_Host_Entry (Res'Unchecked_Access) + do + Netdb_Unlock; + end return; end Get_Host_By_Address; ---------------------- @@ -920,13 +946,20 @@ package body GNAT.Sockets is Err : aliased C.int; begin - if Safe_Gethostbyname + Netdb_Lock; + + if C_Gethostbyname (HN, Res'Access, Buf'Address, Buflen, Err'Access) /= 0 then + Netdb_Unlock; Raise_Host_Error (Integer (Err)); end if; - return To_Host_Entry (Res); + return H : constant Host_Entry_Type := + To_Host_Entry (Res'Unchecked_Access) + do + Netdb_Unlock; + end return; end; end Get_Host_By_Name; @@ -965,13 +998,20 @@ package body GNAT.Sockets is Res : aliased Servent; begin - if Safe_Getservbyname (SN, SP, Res'Access, Buf'Address, Buflen) /= 0 then + Netdb_Lock; + + if C_Getservbyname (SN, SP, Res'Access, Buf'Address, Buflen) /= 0 then + Netdb_Unlock; raise Service_Error with "Service not found"; end if; -- Translate from the C format to the API format - return To_Service_Entry (Res'Unchecked_Access); + return S : constant Service_Entry_Type := + To_Service_Entry (Res'Unchecked_Access) + do + Netdb_Unlock; + end return; end Get_Service_By_Name; ------------------------- @@ -988,16 +1028,23 @@ package body GNAT.Sockets is Res : aliased Servent; begin - if Safe_Getservbyport + Netdb_Lock; + + if C_Getservbyport (C.int (Short_To_Network (C.unsigned_short (Port))), SP, Res'Access, Buf'Address, Buflen) /= 0 then + Netdb_Unlock; raise Service_Error with "Service not found"; end if; -- Translate from the C format to the API format - return To_Service_Entry (Res'Unchecked_Access); + return S : constant Service_Entry_Type := + To_Service_Entry (Res'Unchecked_Access) + do + Netdb_Unlock; + end return; end Get_Service_By_Port; --------------------- @@ -1282,7 +1329,6 @@ package body GNAT.Sockets is use Interfaces.C.Strings; Img : aliased char_array := To_C (Image); - Cp : constant chars_ptr := To_Chars_Ptr (Img'Unchecked_Access); Addr : aliased C.int; Res : C.int; Result : Inet_Addr_Type; @@ -1295,7 +1341,7 @@ package body GNAT.Sockets is Raise_Socket_Error (SOSC.EINVAL); end if; - Res := Inet_Pton (SOSC.AF_INET, Cp, Addr'Address); + Res := Inet_Pton (SOSC.AF_INET, Img'Address, Addr'Address); if Res < 0 then Raise_Socket_Error (Socket_Errno); @@ -1386,14 +1432,19 @@ package body GNAT.Sockets is function Is_Open (S : Selector_Type) return Boolean is begin - -- Either both controlling socket descriptors are valid (case of an - -- open selector) or neither (case of a closed selector). + if S.Is_Null then + return True; - pragma Assert ((S.R_Sig_Socket /= No_Socket) - = - (S.W_Sig_Socket /= No_Socket)); + else + -- Either both controlling socket descriptors are valid (case of an + -- open selector) or neither (case of a closed selector). + + pragma Assert ((S.R_Sig_Socket /= No_Socket) + = + (S.W_Sig_Socket /= No_Socket)); - return S.R_Sig_Socket /= No_Socket; + return S.R_Sig_Socket /= No_Socket; + end if; end Is_Open; ------------ @@ -1438,6 +1489,28 @@ package body GNAT.Sockets is end if; end Narrow; + ---------------- + -- Netdb_Lock -- + ---------------- + + procedure Netdb_Lock is + begin + if Need_Netdb_Lock then + System.Task_Lock.Lock; + end if; + end Netdb_Lock; + + ------------------ + -- Netdb_Unlock -- + ------------------ + + procedure Netdb_Unlock is + begin + if Need_Netdb_Lock then + System.Task_Lock.Unlock; + end if; + end Netdb_Unlock; + -------------------------------- -- Normalize_Empty_Socket_Set -- -------------------------------- @@ -2273,54 +2346,49 @@ package body GNAT.Sockets is -- To_Host_Entry -- ------------------- - function To_Host_Entry (E : Hostent) return Host_Entry_Type is + function To_Host_Entry (E : Hostent_Access) return Host_Entry_Type is use type C.size_t; + use C.Strings; - Official : constant String := - C.Strings.Value (E.H_Name); - - Aliases : constant Chars_Ptr_Array := - Chars_Ptr_Pointers.Value (E.H_Aliases); - -- H_Aliases points to a list of name aliases. The list is terminated by - -- a NULL pointer. + Aliases_Count, Addresses_Count : Natural; - Addresses : constant In_Addr_Access_Array := - In_Addr_Access_Pointers.Value (E.H_Addr_List); - -- H_Addr_List points to a list of binary addresses (in network byte - -- order). The list is terminated by a NULL pointer. - -- - -- H_Length is not used because it is currently only set to 4. + -- H_Length is not used because it is currently only set to 4 -- H_Addrtype is always AF_INET - Result : Host_Entry_Type - (Aliases_Length => Aliases'Length - 1, - Addresses_Length => Addresses'Length - 1); - -- The last element is a null pointer - - Source : C.size_t; - Target : Natural; - begin - Result.Official := To_Name (Official); - - Source := Aliases'First; - Target := Result.Aliases'First; - while Target <= Result.Aliases_Length loop - Result.Aliases (Target) := - To_Name (C.Strings.Value (Aliases (Source))); - Source := Source + 1; - Target := Target + 1; + Aliases_Count := 0; + while Hostent_H_Alias (E, C.int (Aliases_Count)) /= Null_Address loop + Aliases_Count := Aliases_Count + 1; end loop; - Source := Addresses'First; - Target := Result.Addresses'First; - while Target <= Result.Addresses_Length loop - To_Inet_Addr (Addresses (Source).all, Result.Addresses (Target)); - Source := Source + 1; - Target := Target + 1; + Addresses_Count := 0; + while Hostent_H_Addr (E, C.int (Addresses_Count)) /= Null_Address loop + Addresses_Count := Addresses_Count + 1; end loop; - return Result; + return Result : Host_Entry_Type + (Aliases_Length => Aliases_Count, + Addresses_Length => Addresses_Count) + do + Result.Official := To_Name (Value (Hostent_H_Name (E))); + + for J in Result.Aliases'Range loop + Result.Aliases (J) := + To_Name (Value (Hostent_H_Alias + (E, C.int (J - Result.Aliases'First)))); + end loop; + + for J in Result.Addresses'Range loop + declare + Addr : In_Addr; + for Addr'Address use + Hostent_H_Addr (E, C.int (J - Result.Addresses'First)); + pragma Import (Ada, Addr); + begin + To_Inet_Addr (Addr, Result.Addresses (J)); + end; + end loop; + end return; end To_Host_Entry; ---------------- @@ -2394,40 +2462,30 @@ package body GNAT.Sockets is ---------------------- function To_Service_Entry (E : Servent_Access) return Service_Entry_Type is + use C.Strings; use type C.size_t; - Official : constant String := C.Strings.Value (Servent_S_Name (E)); - - Aliases : constant Chars_Ptr_Array := - Chars_Ptr_Pointers.Value (Servent_S_Aliases (E)); - -- S_Aliases points to a list of name aliases. The list is - -- terminated by a NULL pointer. - - Protocol : constant String := C.Strings.Value (Servent_S_Proto (E)); - - Result : Service_Entry_Type (Aliases_Length => Aliases'Length - 1); - -- The last element is a null pointer - - Source : C.size_t; - Target : Natural; + Aliases_Count : Natural; begin - Result.Official := To_Name (Official); - - Source := Aliases'First; - Target := Result.Aliases'First; - while Target <= Result.Aliases_Length loop - Result.Aliases (Target) := - To_Name (C.Strings.Value (Aliases (Source))); - Source := Source + 1; - Target := Target + 1; + Aliases_Count := 0; + while Servent_S_Alias (E, C.int (Aliases_Count)) /= Null_Address loop + Aliases_Count := Aliases_Count + 1; end loop; - Result.Port := - Port_Type (Network_To_Short (C.unsigned_short (Servent_S_Port (E)))); + return Result : Service_Entry_Type (Aliases_Length => Aliases_Count) do + Result.Official := To_Name (Value (Servent_S_Name (E))); - Result.Protocol := To_Name (Protocol); - return Result; + for J in Result.Aliases'Range loop + Result.Aliases (J) := + To_Name (Value (Servent_S_Alias + (E, C.int (J - Result.Aliases'First)))); + end loop; + + Result.Protocol := To_Name (Value (Servent_S_Proto (E))); + Result.Port := + Port_Type (Network_To_Short (Servent_S_Port (E))); + end return; end To_Service_Entry; --------------- @@ -2464,6 +2522,25 @@ package body GNAT.Sockets is return (S, uS); end To_Timeval; + ----------- + -- Value -- + ----------- + + function Value (S : System.Address) return String is + Str : String (1 .. Positive'Last); + for Str'Address use S; + pragma Import (Ada, Str); + + Terminator : Positive := Str'First; + + begin + while Str (Terminator) /= ASCII.NUL loop + Terminator := Terminator + 1; + end loop; + + return Str (1 .. Terminator - 1); + end Value; + ----------- -- Write -- ----------- diff --git a/gcc/ada/g-socket.ads b/gcc/ada/g-socket.ads index 8d3138e65d6..55330bd784a 100644 --- a/gcc/ada/g-socket.ads +++ b/gcc/ada/g-socket.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2009, AdaCore -- +-- Copyright (C) 2001-2010, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -422,6 +422,11 @@ package GNAT.Sockets is type Selector_Access is access all Selector_Type; -- Selector objects are used to wait for i/o events to occur on sockets + Null_Selector : constant Selector_Type; + -- The Null_Selector can be used in place of a normal selector without + -- having to call Create_Selector if the use of Abort_Selector is not + -- required. + -- Timeval_Duration is a subtype of Standard.Duration because the full -- range of Standard.Duration cannot be represented in the equivalent C -- structure. Moreover, negative values are not allowed to avoid system @@ -459,8 +464,7 @@ package GNAT.Sockets is type Family_Type is (Family_Inet, Family_Inet6); -- Address family (or protocol family) identifies the communication domain - -- and groups protocols with similar address formats. IPv6 will soon be - -- supported. + -- and groups protocols with similar address formats. type Mode_Type is (Socket_Stream, Socket_Datagram); -- Stream sockets provide connection-oriented byte streams. Datagram @@ -665,33 +669,33 @@ package GNAT.Sockets is -- with a socket. Options may exist at multiple protocol levels in the -- communication stack. Socket_Level is the uppermost socket level. - type Level_Type is ( - Socket_Level, - IP_Protocol_For_IP_Level, - IP_Protocol_For_UDP_Level, - IP_Protocol_For_TCP_Level); + type Level_Type is + (Socket_Level, + IP_Protocol_For_IP_Level, + IP_Protocol_For_UDP_Level, + IP_Protocol_For_TCP_Level); -- There are several options available to manipulate sockets. Each option -- has a name and several values available. Most of the time, the value is -- a boolean to enable or disable this option. - type Option_Name is ( - Keep_Alive, -- Enable sending of keep-alive messages - Reuse_Address, -- Allow bind to reuse local address - Broadcast, -- Enable datagram sockets to recv/send broadcasts - Send_Buffer, -- Set/get the maximum socket send buffer in bytes - Receive_Buffer, -- Set/get the maximum socket recv buffer in bytes - Linger, -- Shutdown wait for msg to be sent or timeout occur - Error, -- Get and clear the pending socket error - No_Delay, -- Do not delay send to coalesce data (TCP_NODELAY) - Add_Membership, -- Join a multicast group - Drop_Membership, -- Leave a multicast group - Multicast_If, -- Set default out interface for multicast packets - Multicast_TTL, -- Set the time-to-live of sent multicast packets - Multicast_Loop, -- Sent multicast packets are looped to local socket - Receive_Packet_Info, -- Receive low level packet info as ancillary data - Send_Timeout, -- Set timeout value for output - Receive_Timeout); -- Set timeout value for input + type Option_Name is + (Keep_Alive, -- Enable sending of keep-alive messages + Reuse_Address, -- Allow bind to reuse local address + Broadcast, -- Enable datagram sockets to recv/send broadcasts + Send_Buffer, -- Set/get the maximum socket send buffer in bytes + Receive_Buffer, -- Set/get the maximum socket recv buffer in bytes + Linger, -- Shutdown wait for msg to be sent or timeout occur + Error, -- Get and clear the pending socket error + No_Delay, -- Do not delay send to coalesce data (TCP_NODELAY) + Add_Membership, -- Join a multicast group + Drop_Membership, -- Leave a multicast group + Multicast_If, -- Set default out interface for multicast packets + Multicast_TTL, -- Set the time-to-live of sent multicast packets + Multicast_Loop, -- Sent multicast packets are looped to local socket + Receive_Packet_Info, -- Receive low level packet info as ancillary data + Send_Timeout, -- Set timeout value for output + Receive_Timeout); -- Set timeout value for input type Option_Type (Name : Option_Name := Keep_Alive) is record case Name is @@ -741,8 +745,8 @@ package GNAT.Sockets is -- socket options in that they are not specific to sockets but are -- available for any device. - type Request_Name is ( - Non_Blocking_IO, -- Cause a caller not to wait on blocking operations. + type Request_Name is + (Non_Blocking_IO, -- Cause a caller not to wait on blocking operations N_Bytes_To_Read); -- Return the number of bytes available to read type Request_Type (Name : Request_Name := Non_Blocking_IO) is record @@ -1068,7 +1072,7 @@ package GNAT.Sockets is -- the situation where a change to the monitored sockets set must be made. procedure Create_Selector (Selector : out Selector_Type); - -- Create a new selector + -- Initialize (open) a new selector procedure Close_Selector (Selector : in out Selector_Type); -- Close Selector and all internal descriptors associated; deallocate any @@ -1078,7 +1082,7 @@ package GNAT.Sockets is -- already closed. procedure Check_Selector - (Selector : in out Selector_Type; + (Selector : Selector_Type; R_Socket_Set : in out Socket_Set_Type; W_Socket_Set : in out Socket_Set_Type; Status : out Selector_Status; @@ -1089,15 +1093,17 @@ package GNAT.Sockets is -- R_Socket_Set or W_Socket_Set. Status is set to Expired if no socket was -- ready after a Timeout expiration. Status is set to Aborted if an abort -- signal has been received while checking socket status. + -- -- Note that two different Socket_Set_Type objects must be passed as -- R_Socket_Set and W_Socket_Set (even if they denote the same set of -- Sockets), or some event may be lost. + -- -- Socket_Error is raised when the select(2) system call returns an -- error condition, or when a read error occurs on the signalling socket -- used for the implementation of Abort_Selector. procedure Check_Selector - (Selector : in out Selector_Type; + (Selector : Selector_Type; R_Socket_Set : in out Socket_Set_Type; W_Socket_Set : in out Socket_Set_Type; E_Socket_Set : in out Socket_Set_Type; @@ -1109,7 +1115,8 @@ package GNAT.Sockets is -- different objects. procedure Abort_Selector (Selector : Selector_Type); - -- Send an abort signal to the selector + -- Send an abort signal to the selector. The Selector may not be the + -- Null_Selector. type Fd_Set is private; -- ??? This type must not be used directly, it needs to be visible because @@ -1125,14 +1132,28 @@ private type Socket_Type is new Integer; No_Socket : constant Socket_Type := -1; - type Selector_Type is limited record - R_Sig_Socket : Socket_Type := No_Socket; - W_Sig_Socket : Socket_Type := No_Socket; - -- Signalling sockets used to abort a select operation + -- A selector is either a null selector, which is always "open" and can + -- never be aborted, or a regular selector, which is created "closed", + -- becomes "open" when Create_Selector is called, and "closed" again when + -- Close_Selector is called. + + type Selector_Type (Is_Null : Boolean := False) is limited record + case Is_Null is + when True => + null; + + when False => + R_Sig_Socket : Socket_Type := No_Socket; + W_Sig_Socket : Socket_Type := No_Socket; + -- Signalling sockets used to abort a select operation + + end case; end record; pragma Volatile (Selector_Type); + Null_Selector : constant Selector_Type := (Is_Null => True); + type Fd_Set is new System.Storage_Elements.Storage_Array (1 .. SOSC.SIZEOF_fd_set); for Fd_Set'Alignment use Interfaces.C.long'Alignment; diff --git a/gcc/ada/g-socthi-mingw.adb b/gcc/ada/g-socthi-mingw.adb index 49df16363b3..727a69ddba9 100644 --- a/gcc/ada/g-socthi-mingw.adb +++ b/gcc/ada/g-socthi-mingw.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2009, AdaCore -- +-- Copyright (C) 2001-2010, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -37,8 +37,11 @@ -- This version is for NT -with Interfaces.C.Strings; use Interfaces.C.Strings; -with System; use System; +with Ada.Streams; use Ada.Streams; +with Ada.Unchecked_Conversion; +with Interfaces.C.Strings; use Interfaces.C.Strings; +with System; use System; +with System.Storage_Elements; use System.Storage_Elements; package body GNAT.Sockets.Thin is @@ -269,8 +272,14 @@ package body GNAT.Sockets.Thin is function C_Recvmsg (S : C.int; Msg : System.Address; - Flags : C.int) return ssize_t + Flags : C.int) return System.CRTL.ssize_t is + use type C.size_t; + + Fill : constant Boolean := + (C.unsigned (Flags) and SOSC.MSG_WAITALL) /= 0; + -- Is the MSG_WAITALL flag set? If so we need to fully fill all vectors + Res : C.int; Count : C.int := 0; @@ -281,25 +290,81 @@ package body GNAT.Sockets.Thin is for Iovec'Address use MH.Msg_Iov; pragma Import (Ada, Iovec); + Iov_Index : Integer; + Current_Iovec : Vector_Element; + + function To_Access is new Ada.Unchecked_Conversion + (System.Address, Stream_Element_Reference); + pragma Warnings (Off, Stream_Element_Reference); + + Req : Request_Type (Name => N_Bytes_To_Read); + begin -- Windows does not provide an implementation of recvmsg(). The spec for -- WSARecvMsg() is incompatible with the data types we define, and is - -- not available in all versions of Windows. So, we use C_Recv instead. + -- available starting with Windows Vista and Server 2008 only. So, + -- we use C_Recv instead. - for J in Iovec'Range loop - Res := C_Recv - (S, - Iovec (J).Base.all'Address, - C.int (Iovec (J).Length), - Flags); + -- Check how much data are available + + Control_Socket (Socket_Type (S), Req); + + -- Fill the vectors + + Iov_Index := -1; + Current_Iovec := (Base => null, Length => 0); + + loop + if Current_Iovec.Length = 0 then + Iov_Index := Iov_Index + 1; + exit when Iov_Index > Integer (Iovec'Last); + Current_Iovec := Iovec (SOSC.Msg_Iovlen_T (Iov_Index)); + end if; + + Res := + C_Recv + (S, + Current_Iovec.Base.all'Address, + C.int (Current_Iovec.Length), + Flags); if Res < 0 then - return ssize_t (Res); + return System.CRTL.ssize_t (Res); + + elsif Res = 0 and then not Fill then + exit; + else + pragma Assert (Stream_Element_Count (Res) <= Current_Iovec.Length); + Count := Count + Res; + Current_Iovec.Length := + Current_Iovec.Length - Stream_Element_Count (Res); + Current_Iovec.Base := + To_Access (Current_Iovec.Base.all'Address + + Storage_Offset (Res)); + + -- If all the data that was initially available read, do not + -- attempt to receive more, since this might block, or merge data + -- from successive datagrams for a datagram-oriented socket. We + -- still try to receive more if we need to fill all vectors + -- (MSG_WAITALL flag is set). + + exit when Natural (Count) >= Req.Size + and then + + -- Either we are not in fill mode + + (not Fill + + -- Or else last vector filled + + or else (Interfaces.C.size_t (Iov_Index) = Iovec'Last + and then Current_Iovec.Length = 0)); end if; end loop; - return ssize_t (Count); + + return System.CRTL.ssize_t (Count); end C_Recvmsg; -------------- @@ -322,8 +387,8 @@ package body GNAT.Sockets.Thin is Last : aliased C.int; begin - -- Asynchronous connection failures are notified in the exception fd set - -- instead of the write fd set. To ensure POSIX compatibility, copy + -- Asynchronous connection failures are notified in the exception fd + -- set instead of the write fd set. To ensure POSIX compatibility, copy -- write fd set into exception fd set. Once select() returns, check any -- socket present in the exception fd set and peek at incoming -- out-of-band data. If the test is not successful, and the socket is @@ -369,10 +434,11 @@ package body GNAT.Sockets.Thin is -- Check out-of-band data - Length := C_Recvfrom - (S, Buffer'Address, 1, Flag, - From => System.Null_Address, - Fromlen => Fromlen'Unchecked_Access); + Length := + C_Recvfrom + (S, Buffer'Address, 1, Flag, + From => System.Null_Address, + Fromlen => Fromlen'Unchecked_Access); -- Is Fromlen necessary if From is Null_Address??? -- If the signal is not an out-of-band data, then it @@ -404,8 +470,10 @@ package body GNAT.Sockets.Thin is function C_Sendmsg (S : C.int; Msg : System.Address; - Flags : C.int) return ssize_t + Flags : C.int) return System.CRTL.ssize_t is + use type C.size_t; + Res : C.int; Count : C.int := 0; @@ -419,25 +487,31 @@ package body GNAT.Sockets.Thin is begin -- Windows does not provide an implementation of sendmsg(). The spec for -- WSASendMsg() is incompatible with the data types we define, and is - -- not available in all versions of Windows. So, we'll use C_Sendto - -- instead. + -- available starting with Windows Vista and Server 2008 only. So + -- use C_Sendto instead. for J in Iovec'Range loop - Res := C_Sendto - (S, - Iovec (J).Base.all'Address, - C.int (Iovec (J).Length), - Flags => Flags, - To => MH.Msg_Name, - Tolen => C.int (MH.Msg_Namelen)); + Res := + C_Sendto + (S, + Iovec (J).Base.all'Address, + C.int (Iovec (J).Length), + Flags => Flags, + To => MH.Msg_Name, + Tolen => C.int (MH.Msg_Namelen)); if Res < 0 then - return ssize_t (Res); + return System.CRTL.ssize_t (Res); else Count := Count + Res; end if; + + -- Exit now if the buffer is not fully transmitted + + exit when Stream_Element_Count (Res) < Iovec (J).Length; end loop; - return ssize_t (Count); + + return System.CRTL.ssize_t (Count); end C_Sendmsg; -------------- @@ -459,13 +533,12 @@ package body GNAT.Sockets.Thin is package body Host_Error_Messages is -- On Windows, socket and host errors share the same code space, and - -- error messages are provided by Socket_Error_Message. The default - -- separate body for Host_Error_Messages is therefore not used in - -- this case. + -- error messages are provided by Socket_Error_Message, so the default + -- separate body for Host_Error_Messages is not used in this case. function Host_Error_Message (H_Errno : Integer) return C.Strings.chars_ptr - renames Socket_Error_Message; + renames Socket_Error_Message; end Host_Error_Messages; diff --git a/gcc/ada/g-socthi-mingw.ads b/gcc/ada/g-socthi-mingw.ads index 6d851e17cb4..bc1f256497e 100644 --- a/gcc/ada/g-socthi-mingw.ads +++ b/gcc/ada/g-socthi-mingw.ads @@ -42,6 +42,7 @@ with Interfaces.C.Strings; with GNAT.Sockets.Thin_Common; with System; +with System.CRTL; package GNAT.Sockets.Thin is @@ -49,10 +50,7 @@ package GNAT.Sockets.Thin is package C renames Interfaces.C; - use type C.size_t; - type ssize_t is range -(2 ** (C.size_t'Size - 1)) - .. +(2 ** (C.size_t'Size - 1) - 1); - -- Signed type of the same size as size_t + use type System.CRTL.ssize_t; function Socket_Errno return Integer; -- Returns last socket error number @@ -146,7 +144,7 @@ package GNAT.Sockets.Thin is function C_Recvmsg (S : C.int; Msg : System.Address; - Flags : C.int) return ssize_t; + Flags : C.int) return System.CRTL.ssize_t; function C_Select (Nfds : C.int; @@ -158,7 +156,7 @@ package GNAT.Sockets.Thin is function C_Sendmsg (S : C.int; Msg : System.Address; - Flags : C.int) return ssize_t; + Flags : C.int) return System.CRTL.ssize_t; function C_Sendto (S : C.int; diff --git a/gcc/ada/g-socthi-vms.adb b/gcc/ada/g-socthi-vms.adb index b9e23ecbfb5..1331821446f 100644 --- a/gcc/ada/g-socthi-vms.adb +++ b/gcc/ada/g-socthi-vms.adb @@ -292,7 +292,7 @@ package body GNAT.Sockets.Thin is function C_Recvmsg (S : C.int; Msg : System.Address; - Flags : C.int) return ssize_t + Flags : C.int) return System.CRTL.ssize_t is Res : C.int; @@ -314,7 +314,7 @@ package body GNAT.Sockets.Thin is GNAT_Msg := Msghdr (VMS_Msg); - return ssize_t (Res); + return System.CRTL.ssize_t (Res); end C_Recvmsg; --------------- @@ -324,7 +324,7 @@ package body GNAT.Sockets.Thin is function C_Sendmsg (S : C.int; Msg : System.Address; - Flags : C.int) return ssize_t + Flags : C.int) return System.CRTL.ssize_t is Res : C.int; @@ -346,7 +346,7 @@ package body GNAT.Sockets.Thin is GNAT_Msg := Msghdr (VMS_Msg); - return ssize_t (Res); + return System.CRTL.ssize_t (Res); end C_Sendmsg; -------------- diff --git a/gcc/ada/g-socthi-vms.ads b/gcc/ada/g-socthi-vms.ads index a1bb487e136..3a443ac652d 100644 --- a/gcc/ada/g-socthi-vms.ads +++ b/gcc/ada/g-socthi-vms.ads @@ -43,6 +43,7 @@ with GNAT.OS_Lib; with GNAT.Sockets.Thin_Common; with System; +with System.CRTL; package GNAT.Sockets.Thin is @@ -52,10 +53,7 @@ package GNAT.Sockets.Thin is package C renames Interfaces.C; - use type C.size_t; - type ssize_t is range -(2 ** (C.size_t'Size - 1)) - .. +(2 ** (C.size_t'Size - 1) - 1); - -- Signed type of the same size as size_t + use type System.CRTL.ssize_t; function Socket_Errno return Integer renames GNAT.OS_Lib.Errno; -- Returns last socket error number @@ -149,7 +147,7 @@ package GNAT.Sockets.Thin is function C_Recvmsg (S : C.int; Msg : System.Address; - Flags : C.int) return ssize_t; + Flags : C.int) return System.CRTL.ssize_t; function C_Select (Nfds : C.int; @@ -161,7 +159,7 @@ package GNAT.Sockets.Thin is function C_Sendmsg (S : C.int; Msg : System.Address; - Flags : C.int) return ssize_t; + Flags : C.int) return System.CRTL.ssize_t; function C_Sendto (S : C.int; diff --git a/gcc/ada/g-socthi-vxworks.adb b/gcc/ada/g-socthi-vxworks.adb index e6a8ee60644..8c119661ed4 100644 --- a/gcc/ada/g-socthi-vxworks.adb +++ b/gcc/ada/g-socthi-vxworks.adb @@ -309,7 +309,7 @@ package body GNAT.Sockets.Thin is function C_Recvmsg (S : C.int; Msg : System.Address; - Flags : C.int) return ssize_t + Flags : C.int) return System.CRTL.ssize_t is Res : C.int; @@ -323,7 +323,7 @@ package body GNAT.Sockets.Thin is delay Quantum; end loop; - return ssize_t (Res); + return System.CRTL.ssize_t (Res); end C_Recvmsg; --------------- @@ -333,7 +333,7 @@ package body GNAT.Sockets.Thin is function C_Sendmsg (S : C.int; Msg : System.Address; - Flags : C.int) return ssize_t + Flags : C.int) return System.CRTL.ssize_t is Res : C.int; @@ -347,7 +347,7 @@ package body GNAT.Sockets.Thin is delay Quantum; end loop; - return ssize_t (Res); + return System.CRTL.ssize_t (Res); end C_Sendmsg; -------------- diff --git a/gcc/ada/g-socthi-vxworks.ads b/gcc/ada/g-socthi-vxworks.ads index 4f92b3a8143..64cc87668ce 100644 --- a/gcc/ada/g-socthi-vxworks.ads +++ b/gcc/ada/g-socthi-vxworks.ads @@ -43,6 +43,7 @@ with GNAT.OS_Lib; with GNAT.Sockets.Thin_Common; with System; +with System.CRTL; package GNAT.Sockets.Thin is @@ -50,10 +51,7 @@ package GNAT.Sockets.Thin is package C renames Interfaces.C; - use type C.size_t; - type ssize_t is range -(2 ** (C.size_t'Size - 1)) - .. +(2 ** (C.size_t'Size - 1) - 1); - -- Signed type of the same size as size_t + use type System.CRTL.ssize_t; function Socket_Errno return Integer renames GNAT.OS_Lib.Errno; -- Returns last socket error number @@ -147,7 +145,7 @@ package GNAT.Sockets.Thin is function C_Recvmsg (S : C.int; Msg : System.Address; - Flags : C.int) return ssize_t; + Flags : C.int) return System.CRTL.ssize_t; function C_Select (Nfds : C.int; @@ -159,7 +157,7 @@ package GNAT.Sockets.Thin is function C_Sendmsg (S : C.int; Msg : System.Address; - Flags : C.int) return ssize_t; + Flags : C.int) return System.CRTL.ssize_t; function C_Sendto (S : C.int; diff --git a/gcc/ada/g-socthi.adb b/gcc/ada/g-socthi.adb index ca797631b08..301d8be45d4 100644 --- a/gcc/ada/g-socthi.adb +++ b/gcc/ada/g-socthi.adb @@ -95,13 +95,13 @@ package body GNAT.Sockets.Thin is function Syscall_Recvmsg (S : C.int; Msg : System.Address; - Flags : C.int) return ssize_t; + Flags : C.int) return System.CRTL.ssize_t; pragma Import (C, Syscall_Recvmsg, "recvmsg"); function Syscall_Sendmsg (S : C.int; Msg : System.Address; - Flags : C.int) return ssize_t; + Flags : C.int) return System.CRTL.ssize_t; pragma Import (C, Syscall_Sendmsg, "sendmsg"); function Syscall_Sendto @@ -307,15 +307,15 @@ package body GNAT.Sockets.Thin is function C_Recvmsg (S : C.int; Msg : System.Address; - Flags : C.int) return ssize_t + Flags : C.int) return System.CRTL.ssize_t is - Res : ssize_t; + Res : System.CRTL.ssize_t; begin loop Res := Syscall_Recvmsg (S, Msg, Flags); exit when SOSC.Thread_Blocking_IO - or else Res /= ssize_t (Failure) + or else Res /= System.CRTL.ssize_t (Failure) or else Non_Blocking_Socket (S) or else Errno /= SOSC.EWOULDBLOCK; delay Quantum; @@ -331,15 +331,15 @@ package body GNAT.Sockets.Thin is function C_Sendmsg (S : C.int; Msg : System.Address; - Flags : C.int) return ssize_t + Flags : C.int) return System.CRTL.ssize_t is - Res : ssize_t; + Res : System.CRTL.ssize_t; begin loop Res := Syscall_Sendmsg (S, Msg, Flags); exit when SOSC.Thread_Blocking_IO - or else Res /= ssize_t (Failure) + or else Res /= System.CRTL.ssize_t (Failure) or else Non_Blocking_Socket (S) or else Errno /= SOSC.EWOULDBLOCK; delay Quantum; diff --git a/gcc/ada/g-socthi.ads b/gcc/ada/g-socthi.ads index 1f103e89a74..32013c35e7f 100644 --- a/gcc/ada/g-socthi.ads +++ b/gcc/ada/g-socthi.ads @@ -43,6 +43,7 @@ with GNAT.OS_Lib; with GNAT.Sockets.Thin_Common; with System; +with System.CRTL; package GNAT.Sockets.Thin is @@ -54,10 +55,7 @@ package GNAT.Sockets.Thin is package C renames Interfaces.C; - use type C.size_t; - type ssize_t is range -(2 ** (C.size_t'Size - 1)) - .. +(2 ** (C.size_t'Size - 1) - 1); - -- Signed type of the same size as size_t + use type System.CRTL.ssize_t; function Socket_Errno return Integer renames GNAT.OS_Lib.Errno; -- Returns last socket error number @@ -148,7 +146,7 @@ package GNAT.Sockets.Thin is function C_Recvmsg (S : C.int; Msg : System.Address; - Flags : C.int) return ssize_t; + Flags : C.int) return System.CRTL.ssize_t; function C_Select (Nfds : C.int; @@ -160,7 +158,7 @@ package GNAT.Sockets.Thin is function C_Sendmsg (S : C.int; Msg : System.Address; - Flags : C.int) return ssize_t; + Flags : C.int) return System.CRTL.ssize_t; function C_Sendto (S : C.int; diff --git a/gcc/ada/g-sothco.ads b/gcc/ada/g-sothco.ads index 82003e2ffd5..6ffd06631e7 100644 --- a/gcc/ada/g-sothco.ads +++ b/gcc/ada/g-sothco.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2008-2009, AdaCore -- +-- Copyright (C) 2008-2010, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -38,7 +38,6 @@ with Ada.Unchecked_Conversion; with Interfaces.C; with Interfaces.C.Pointers; -with Interfaces.C.Strings; package GNAT.Sockets.Thin_Common is @@ -200,18 +199,45 @@ package GNAT.Sockets.Thin_Common is pragma Inline (Set_Address); -- Set Sin.Sin_Addr to Address + ------------------ + -- Host entries -- + ------------------ + + type Hostent is new + System.Storage_Elements.Storage_Array (1 .. SOSC.SIZEOF_struct_hostent); + for Hostent'Alignment use 8; + -- Host entry. This is an opaque type used only via the following + -- accessor functions, because 'struct hostent' has different layouts on + -- different platforms. + + type Hostent_Access is access all Hostent; + pragma Convention (C, Hostent_Access); + -- Access to host entry + + -- Note: the hostent and servent accessors that return char* + -- values are compiled with GCC, and on VMS they always return + -- 64-bit pointers, so we can't use C.Strings.chars_ptr, which + -- on VMS is 32 bits. + + function Hostent_H_Name + (E : Hostent_Access) return System.Address; + + function Hostent_H_Alias + (E : Hostent_Access; I : C.int) return System.Address; + + function Hostent_H_Addrtype + (E : Hostent_Access) return C.int; + + function Hostent_H_Length + (E : Hostent_Access) return C.int; + + function Hostent_H_Addr + (E : Hostent_Access; Index : C.int) return System.Address; + --------------------- -- Service entries -- --------------------- - type Chars_Ptr_Array is array (C.size_t range <>) of - aliased C.Strings.chars_ptr; - - package Chars_Ptr_Pointers is - new C.Pointers (C.size_t, C.Strings.chars_ptr, Chars_Ptr_Array, - C.Strings.Null_Ptr); - -- Arrays of C (char *) - type Servent is new System.Storage_Elements.Storage_Array (1 .. SOSC.SIZEOF_struct_servent); for Servent'Alignment use 8; @@ -224,50 +250,62 @@ package GNAT.Sockets.Thin_Common is -- Access to service entry function Servent_S_Name - (E : Servent_Access) return C.Strings.chars_ptr; + (E : Servent_Access) return System.Address; - function Servent_S_Aliases - (E : Servent_Access) return Chars_Ptr_Pointers.Pointer; + function Servent_S_Alias + (E : Servent_Access; Index : C.int) return System.Address; function Servent_S_Port - (E : Servent_Access) return C.int; + (E : Servent_Access) return C.unsigned_short; function Servent_S_Proto - (E : Servent_Access) return C.Strings.chars_ptr; - - procedure Servent_Set_S_Name - (E : Servent_Access; - S_Name : C.Strings.chars_ptr); - - procedure Servent_Set_S_Aliases - (E : Servent_Access; - S_Aliases : Chars_Ptr_Pointers.Pointer); - - procedure Servent_Set_S_Port - (E : Servent_Access; - S_Port : C.int); - - procedure Servent_Set_S_Proto - (E : Servent_Access; - S_Proto : C.Strings.chars_ptr); + (E : Servent_Access) return System.Address; ------------------ - -- Host entries -- + -- NetDB access -- ------------------ - type Hostent is record - H_Name : C.Strings.chars_ptr; - H_Aliases : Chars_Ptr_Pointers.Pointer; - H_Addrtype : SOSC.H_Addrtype_T; - H_Length : SOSC.H_Length_T; - H_Addr_List : In_Addr_Access_Pointers.Pointer; - end record; - pragma Convention (C, Hostent); - -- Host entry - - type Hostent_Access is access all Hostent; - pragma Convention (C, Hostent_Access); - -- Access to host entry + -- There are three possible situations for the following NetDB access + -- functions: + -- - inherently thread safe (case of data returned in a thread specific + -- buffer); + -- - thread safe using user-provided buffer; + -- - thread unsafe. + -- + -- In the first and third cases, the Buf and Buflen are ignored. In the + -- second case, the caller must provide a buffer large enough to accomodate + -- the returned data. In the third case, the caller must ensure that these + -- functions are called within a critical section. + + function C_Gethostbyname + (Name : C.char_array; + Ret : not null access Hostent; + Buf : System.Address; + Buflen : C.int; + H_Errnop : not null access C.int) return C.int; + + function C_Gethostbyaddr + (Addr : System.Address; + Addr_Len : C.int; + Addr_Type : C.int; + Ret : not null access Hostent; + Buf : System.Address; + Buflen : C.int; + H_Errnop : not null access C.int) return C.int; + + function C_Getservbyname + (Name : C.char_array; + Proto : C.char_array; + Ret : not null access Servent; + Buf : System.Address; + Buflen : C.int) return C.int; + + function C_Getservbyport + (Port : C.int; + Proto : C.char_array; + Ret : not null access Servent; + Buf : System.Address; + Buflen : C.int) return C.int; ------------------------------------ -- Scatter/gather vector handling -- @@ -344,7 +382,7 @@ package GNAT.Sockets.Thin_Common is function Inet_Pton (Af : C.int; - Cp : C.Strings.chars_ptr; + Cp : System.Address; Inp : System.Address) return C.int; function C_Ioctl @@ -362,12 +400,20 @@ private pragma Import (C, C_Ioctl, "__gnat_socket_ioctl"); pragma Import (C, Inet_Pton, SOSC.Inet_Pton_Linkname); - pragma Import (C, Servent_S_Name, "__gnat_servent_s_name"); - pragma Import (C, Servent_S_Aliases, "__gnat_servent_s_aliases"); - pragma Import (C, Servent_S_Port, "__gnat_servent_s_port"); + pragma Import (C, C_Gethostbyname, "__gnat_gethostbyname"); + pragma Import (C, C_Gethostbyaddr, "__gnat_gethostbyaddr"); + pragma Import (C, C_Getservbyname, "__gnat_getservbyname"); + pragma Import (C, C_Getservbyport, "__gnat_getservbyport"); + + pragma Import (C, Servent_S_Name, "__gnat_servent_s_name"); + pragma Import (C, Servent_S_Alias, "__gnat_servent_s_alias"); + pragma Import (C, Servent_S_Port, "__gnat_servent_s_port"); pragma Import (C, Servent_S_Proto, "__gnat_servent_s_proto"); - pragma Import (C, Servent_Set_S_Name, "__gnat_servent_set_s_name"); - pragma Import (C, Servent_Set_S_Aliases, "__gnat_servent_set_s_aliases"); - pragma Import (C, Servent_Set_S_Port, "__gnat_servent_set_s_port"); - pragma Import (C, Servent_Set_S_Proto, "__gnat_servent_set_s_proto"); + + pragma Import (C, Hostent_H_Name, "__gnat_hostent_h_name"); + pragma Import (C, Hostent_H_Alias, "__gnat_hostent_h_alias"); + pragma Import (C, Hostent_H_Addrtype, "__gnat_hostent_h_addrtype"); + pragma Import (C, Hostent_H_Length, "__gnat_hostent_h_length"); + pragma Import (C, Hostent_H_Addr, "__gnat_hostent_h_addr"); + end GNAT.Sockets.Thin_Common; diff --git a/gcc/ada/g-spipat.adb b/gcc/ada/g-spipat.adb index c5c07f105e2..a85697507f3 100644 --- a/gcc/ada/g-spipat.adb +++ b/gcc/ada/g-spipat.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2008, AdaCore -- +-- Copyright (C) 1998-2009, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -2793,9 +2793,8 @@ package body GNAT.Spitbol.Patterns is (Subject : VString; Pat : Pattern) return Boolean is - S : String_Access; + S : Big_String_Access; L : Natural; - Start : Natural; Stop : Natural; pragma Unreferenced (Stop); @@ -2838,7 +2837,7 @@ package body GNAT.Spitbol.Patterns is is Start : Natural; Stop : Natural; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -2867,7 +2866,7 @@ package body GNAT.Spitbol.Patterns is is Start : Natural; Stop : Natural; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -2892,7 +2891,7 @@ package body GNAT.Spitbol.Patterns is (Subject : VString; Pat : Pattern) is - S : String_Access; + S : Big_String_Access; L : Natural; Start : Natural; @@ -2933,7 +2932,7 @@ package body GNAT.Spitbol.Patterns is is Start : Natural; Stop : Natural; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -2958,7 +2957,7 @@ package body GNAT.Spitbol.Patterns is is Start : Natural; Stop : Natural; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -2980,7 +2979,7 @@ package body GNAT.Spitbol.Patterns is Pat : PString) return Boolean is Pat_Len : constant Natural := Pat'Length; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -3038,7 +3037,7 @@ package body GNAT.Spitbol.Patterns is is Start : Natural; Stop : Natural; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -3067,7 +3066,7 @@ package body GNAT.Spitbol.Patterns is is Start : Natural; Stop : Natural; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -3092,7 +3091,7 @@ package body GNAT.Spitbol.Patterns is (Subject : VString; Pat : PString) is - S : String_Access; + S : Big_String_Access; L : Natural; Start : Natural; @@ -3133,7 +3132,7 @@ package body GNAT.Spitbol.Patterns is is Start : Natural; Stop : Natural; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -3158,7 +3157,7 @@ package body GNAT.Spitbol.Patterns is is Start : Natural; Stop : Natural; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -3182,7 +3181,7 @@ package body GNAT.Spitbol.Patterns is is Start : Natural; Stop : Natural; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -3213,7 +3212,7 @@ package body GNAT.Spitbol.Patterns is is Start : Natural; Stop : Natural; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -3362,7 +3361,7 @@ package body GNAT.Spitbol.Patterns is (Result : in out Match_Result; Replace : VString) is - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -3955,7 +3954,7 @@ package body GNAT.Spitbol.Patterns is when PC_Any_VF => declare U : constant VString := Node.VF.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -3975,7 +3974,7 @@ package body GNAT.Spitbol.Patterns is when PC_Any_VP => declare U : constant VString := Node.VP.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -4142,7 +4141,7 @@ package body GNAT.Spitbol.Patterns is when PC_Break_VF => declare U : constant VString := Node.VF.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -4163,7 +4162,7 @@ package body GNAT.Spitbol.Patterns is when PC_Break_VP => declare U : constant VString := Node.VP.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -4210,7 +4209,7 @@ package body GNAT.Spitbol.Patterns is when PC_BreakX_VF => declare U : constant VString := Node.VF.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -4231,7 +4230,7 @@ package body GNAT.Spitbol.Patterns is when PC_BreakX_VP => declare U : constant VString := Node.VP.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -4376,7 +4375,7 @@ package body GNAT.Spitbol.Patterns is when PC_NotAny_VF => declare U : constant VString := Node.VF.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -4397,7 +4396,7 @@ package body GNAT.Spitbol.Patterns is when PC_NotAny_VP => declare U : constant VString := Node.VP.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -4440,7 +4439,7 @@ package body GNAT.Spitbol.Patterns is when PC_NSpan_VF => declare U : constant VString := Node.VF.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -4459,7 +4458,7 @@ package body GNAT.Spitbol.Patterns is when PC_NSpan_VP => declare U : constant VString := Node.VP.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -4682,7 +4681,7 @@ package body GNAT.Spitbol.Patterns is when PC_Span_VF => declare U : constant VString := Node.VF.all; - S : String_Access; + S : Big_String_Access; L : Natural; P : Natural; @@ -4708,7 +4707,7 @@ package body GNAT.Spitbol.Patterns is when PC_Span_VP => declare U : constant VString := Node.VP.all; - S : String_Access; + S : Big_String_Access; L : Natural; P : Natural; @@ -4809,7 +4808,7 @@ package body GNAT.Spitbol.Patterns is when PC_String_VF => declare U : constant VString := Node.VF.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -4829,7 +4828,7 @@ package body GNAT.Spitbol.Patterns is when PC_String_VP => declare U : constant VString := Node.VP.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -5354,7 +5353,7 @@ package body GNAT.Spitbol.Patterns is when PC_Any_VF => declare U : constant VString := Node.VF.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -5376,7 +5375,7 @@ package body GNAT.Spitbol.Patterns is when PC_Any_VP => declare U : constant VString := Node.VP.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -5563,7 +5562,7 @@ package body GNAT.Spitbol.Patterns is when PC_Break_VF => declare U : constant VString := Node.VF.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -5585,7 +5584,7 @@ package body GNAT.Spitbol.Patterns is when PC_Break_VP => declare U : constant VString := Node.VP.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -5637,7 +5636,7 @@ package body GNAT.Spitbol.Patterns is when PC_BreakX_VF => declare U : constant VString := Node.VF.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -5659,7 +5658,7 @@ package body GNAT.Spitbol.Patterns is when PC_BreakX_VP => declare U : constant VString := Node.VP.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -5826,7 +5825,7 @@ package body GNAT.Spitbol.Patterns is when PC_NotAny_VF => declare U : constant VString := Node.VF.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -5848,7 +5847,7 @@ package body GNAT.Spitbol.Patterns is when PC_NotAny_VP => declare U : constant VString := Node.VP.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -5896,7 +5895,7 @@ package body GNAT.Spitbol.Patterns is when PC_NSpan_VF => declare U : constant VString := Node.VF.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -5916,7 +5915,7 @@ package body GNAT.Spitbol.Patterns is when PC_NSpan_VP => declare U : constant VString := Node.VP.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -6172,7 +6171,7 @@ package body GNAT.Spitbol.Patterns is when PC_Span_VF => declare U : constant VString := Node.VF.all; - S : String_Access; + S : Big_String_Access; L : Natural; P : Natural; @@ -6199,7 +6198,7 @@ package body GNAT.Spitbol.Patterns is when PC_Span_VP => declare U : constant VString := Node.VP.all; - S : String_Access; + S : Big_String_Access; L : Natural; P : Natural; @@ -6314,7 +6313,7 @@ package body GNAT.Spitbol.Patterns is when PC_String_VF => declare U : constant VString := Node.VF.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -6335,7 +6334,7 @@ package body GNAT.Spitbol.Patterns is when PC_String_VP => declare U : constant VString := Node.VP.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin diff --git a/gcc/ada/g-spitbo.adb b/gcc/ada/g-spitbo.adb index 5b5e2a78e04..4769fa3025d 100644 --- a/gcc/ada/g-spitbo.adb +++ b/gcc/ada/g-spitbo.adb @@ -135,7 +135,7 @@ package body GNAT.Spitbol is ------- function N (Str : VString) return Integer is - S : String_Access; + S : Big_String_Access; L : Natural; begin Get_String (Str, S, L); @@ -147,7 +147,7 @@ package body GNAT.Spitbol is -------------------- function Reverse_String (Str : VString) return VString is - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -177,7 +177,7 @@ package body GNAT.Spitbol is end Reverse_String; procedure Reverse_String (Str : in out VString) is - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -191,7 +191,7 @@ package body GNAT.Spitbol is Result (J) := S (L + 1 - J); end loop; - Set_String (Str, Result); + Set_Unbounded_String (Str, Result); end; end Reverse_String; @@ -284,7 +284,7 @@ package body GNAT.Spitbol is Start : Positive; Len : Natural) return VString is - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -413,7 +413,7 @@ package body GNAT.Spitbol is if Elmt.Name /= null then loop - Set_String (TA (P).Name, Elmt.Name.all); + Set_Unbounded_String (TA (P).Name, Elmt.Name.all); TA (P).Value := Elmt.Value; P := P + 1; Elmt := Elmt.Next; @@ -458,7 +458,7 @@ package body GNAT.Spitbol is end Delete; procedure Delete (T : in out Table; Name : VString) is - S : String_Access; + S : Big_String_Access; L : Natural; begin Get_String (Name, S, L); @@ -584,7 +584,7 @@ package body GNAT.Spitbol is end Get; function Get (T : Table; Name : VString) return Value_Type is - S : String_Access; + S : Big_String_Access; L : Natural; begin Get_String (Name, S, L); @@ -625,7 +625,7 @@ package body GNAT.Spitbol is end Present; function Present (T : Table; Name : VString) return Boolean is - S : String_Access; + S : Big_String_Access; L : Natural; begin Get_String (Name, S, L); @@ -661,7 +661,7 @@ package body GNAT.Spitbol is --------- procedure Set (T : in out Table; Name : VString; Value : Value_Type) is - S : String_Access; + S : Big_String_Access; L : Natural; begin Get_String (Name, S, L); diff --git a/gcc/ada/g-sttsne-dummy.ads b/gcc/ada/g-sttsne-dummy.ads deleted file mode 100644 index 9cb25898dfa..00000000000 --- a/gcc/ada/g-sttsne-dummy.ads +++ /dev/null @@ -1,39 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . T H I N . T A S K _ S A F E _ N E T D B -- --- -- --- S p e c -- --- -- --- Copyright (C) 2007-2008, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT 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 distributed with GNAT; see file COPYING. If not, write -- --- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package is a placeholder for the sockets binding for platforms where --- it is not implemented. - -package GNAT.Sockets.Thin.Task_Safe_NetDB is - pragma Unimplemented_Unit; -end GNAT.Sockets.Thin.Task_Safe_NetDB; diff --git a/gcc/ada/g-sttsne-locking.adb b/gcc/ada/g-sttsne-locking.adb deleted file mode 100644 index c5e39b734b9..00000000000 --- a/gcc/ada/g-sttsne-locking.adb +++ /dev/null @@ -1,460 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . T H I N . T A S K _ S A F E _ N E T D B -- --- -- --- B o d y -- --- -- --- Copyright (C) 2007-2009, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT 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 distributed with GNAT; see file COPYING. If not, write -- --- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version is used on VMS and LynxOS - -with GNAT.Task_Lock; - -with Interfaces.C; use Interfaces.C; - -package body GNAT.Sockets.Thin.Task_Safe_NetDB is - - -- The Safe_GetXXXbyYYY routines wrap the Nonreentrant_ versions using the - -- task lock, and copy the relevant data structures (under the lock) into - -- the result. The Nonreentrant_ versions are expected to be in the parent - -- package GNAT.Sockets.Thin (on platforms that use this version of - -- Task_Safe_NetDB). - - procedure Copy_Host_Entry - (Source_Hostent : Hostent; - Target_Hostent : out Hostent; - Target_Buffer : System.Address; - Target_Buffer_Length : C.int; - Result : out C.int); - -- Copy all the information from Source_Hostent into Target_Hostent, - -- using Target_Buffer to store associated data. - -- 0 is returned on success, -1 on failure (in case the provided buffer - -- is too small for the associated data). - - procedure Copy_Service_Entry - (Source_Servent : Servent_Access; - Target_Servent : Servent_Access; - Target_Buffer : System.Address; - Target_Buffer_Length : C.int; - Result : out C.int); - -- Copy all the information from Source_Servent into Target_Servent, - -- using Target_Buffer to store associated data. - -- 0 is returned on success, -1 on failure (in case the provided buffer - -- is too small for the associated data). - - procedure Store_Name - (Name : char_array; - Storage : in out char_array; - Storage_Index : in out size_t; - Stored_Name : out C.Strings.chars_ptr); - -- Store the given Name at the first available location in Storage - -- (indicated by Storage_Index, which is updated afterwards), and return - -- the address of that location in Stored_Name. - -- (Supporting routine for the two below). - - --------------------- - -- Copy_Host_Entry -- - --------------------- - - procedure Copy_Host_Entry - (Source_Hostent : Hostent; - Target_Hostent : out Hostent; - Target_Buffer : System.Address; - Target_Buffer_Length : C.int; - Result : out C.int) - is - use type C.Strings.chars_ptr; - - Names_Length : size_t; - - Source_Aliases : Chars_Ptr_Array - renames Chars_Ptr_Pointers.Value - (Source_Hostent.H_Aliases, Terminator => C.Strings.Null_Ptr); - -- Null-terminated list of aliases (last element of this array is - -- Null_Ptr). - - Source_Addresses : In_Addr_Access_Array - renames In_Addr_Access_Pointers.Value - (Source_Hostent.H_Addr_List, Terminator => null); - - begin - Result := -1; - Names_Length := C.Strings.Strlen (Source_Hostent.H_Name) + 1; - - for J in Source_Aliases'Range loop - if Source_Aliases (J) /= C.Strings.Null_Ptr then - Names_Length := - Names_Length + C.Strings.Strlen (Source_Aliases (J)) + 1; - end if; - end loop; - - declare - type In_Addr_Array is array (Source_Addresses'Range) - of aliased In_Addr; - - type Netdb_Host_Data is record - Aliases_List : aliased Chars_Ptr_Array (Source_Aliases'Range); - Names : aliased char_array (1 .. Names_Length); - - Addresses_List : aliased In_Addr_Access_Array - (In_Addr_Array'Range); - Addresses : In_Addr_Array; - -- ??? This assumes support only for Inet family - - end record; - - Netdb_Data : Netdb_Host_Data; - pragma Import (Ada, Netdb_Data); - for Netdb_Data'Address use Target_Buffer; - - Names_Index : size_t := Netdb_Data.Names'First; - -- Index of first available location in Netdb_Data.Names - - begin - if Netdb_Data'Size / 8 > Target_Buffer_Length then - return; - end if; - - -- Copy host name - - Store_Name - (C.Strings.Value (Source_Hostent.H_Name), - Netdb_Data.Names, Names_Index, - Target_Hostent.H_Name); - - -- Copy aliases (null-terminated string pointer array) - - Target_Hostent.H_Aliases := - Netdb_Data.Aliases_List - (Netdb_Data.Aliases_List'First)'Unchecked_Access; - for J in Netdb_Data.Aliases_List'Range loop - if J = Netdb_Data.Aliases_List'Last then - Netdb_Data.Aliases_List (J) := C.Strings.Null_Ptr; - else - Store_Name - (C.Strings.Value (Source_Aliases (J)), - Netdb_Data.Names, Names_Index, - Netdb_Data.Aliases_List (J)); - end if; - end loop; - - -- Copy address type and length - - Target_Hostent.H_Addrtype := Source_Hostent.H_Addrtype; - Target_Hostent.H_Length := Source_Hostent.H_Length; - - -- Copy addresses - - Target_Hostent.H_Addr_List := - Netdb_Data.Addresses_List - (Netdb_Data.Addresses_List'First)'Unchecked_Access; - - for J in Netdb_Data.Addresses'Range loop - if J = Netdb_Data.Addresses'Last then - Netdb_Data.Addresses_List (J) := null; - else - Netdb_Data.Addresses_List (J) := - Netdb_Data.Addresses (J)'Unchecked_Access; - - Netdb_Data.Addresses (J) := Source_Addresses (J).all; - end if; - end loop; - end; - - Result := 0; - end Copy_Host_Entry; - - ------------------------ - -- Copy_Service_Entry -- - ------------------------ - - procedure Copy_Service_Entry - (Source_Servent : Servent_Access; - Target_Servent : Servent_Access; - Target_Buffer : System.Address; - Target_Buffer_Length : C.int; - Result : out C.int) - is - use type C.Strings.chars_ptr; - - Names_Length : size_t; - - Source_Aliases : Chars_Ptr_Array - renames Chars_Ptr_Pointers.Value - (Servent_S_Aliases (Source_Servent), - Terminator => C.Strings.Null_Ptr); - -- Null-terminated list of aliases (last element of this array is - -- Null_Ptr). - - begin - Result := -1; - Names_Length := C.Strings.Strlen (Servent_S_Name (Source_Servent)) + 1 + - C.Strings.Strlen (Servent_S_Proto (Source_Servent)) + 1; - - for J in Source_Aliases'Range loop - if Source_Aliases (J) /= C.Strings.Null_Ptr then - Names_Length := - Names_Length + C.Strings.Strlen (Source_Aliases (J)) + 1; - end if; - end loop; - - declare - type Netdb_Service_Data is record - Aliases_List : aliased Chars_Ptr_Array (Source_Aliases'Range); - Names : aliased char_array (1 .. Names_Length); - end record; - - Netdb_Data : Netdb_Service_Data; - pragma Import (Ada, Netdb_Data); - for Netdb_Data'Address use Target_Buffer; - - Names_Index : size_t := Netdb_Data.Names'First; - -- Index of first available location in Netdb_Data.Names - - Stored_Name : C.Strings.chars_ptr; - - begin - if Netdb_Data'Size / 8 > Target_Buffer_Length then - return; - end if; - - -- Copy service name - - Store_Name - (C.Strings.Value (Servent_S_Name (Source_Servent)), - Netdb_Data.Names, Names_Index, - Stored_Name); - Servent_Set_S_Name (Target_Servent, Stored_Name); - - -- Copy aliases (null-terminated string pointer array) - - Servent_Set_S_Aliases - (Target_Servent, - Netdb_Data.Aliases_List - (Netdb_Data.Aliases_List'First)'Unchecked_Access); - - -- Copy port number - - Servent_Set_S_Port (Target_Servent, Servent_S_Port (Source_Servent)); - - -- Copy protocol name - - Store_Name - (C.Strings.Value (Servent_S_Proto (Source_Servent)), - Netdb_Data.Names, Names_Index, - Stored_Name); - Servent_Set_S_Proto (Target_Servent, Stored_Name); - - for J in Netdb_Data.Aliases_List'Range loop - if J = Netdb_Data.Aliases_List'Last then - Netdb_Data.Aliases_List (J) := C.Strings.Null_Ptr; - else - Store_Name - (C.Strings.Value (Source_Aliases (J)), - Netdb_Data.Names, Names_Index, - Netdb_Data.Aliases_List (J)); - end if; - end loop; - end; - - Result := 0; - end Copy_Service_Entry; - - ------------------------ - -- Safe_Gethostbyaddr -- - ------------------------ - - function Safe_Gethostbyaddr - (Addr : System.Address; - Addr_Len : C.int; - Addr_Type : C.int; - Ret : not null access Hostent; - Buf : System.Address; - Buflen : C.int; - H_Errnop : not null access C.int) return C.int - is - HE : Hostent_Access; - Result : C.int; - begin - Result := -1; - GNAT.Task_Lock.Lock; - HE := Nonreentrant_Gethostbyaddr (Addr, Addr_Len, Addr_Type); - - if HE = null then - H_Errnop.all := C.int (Host_Errno); - goto Unlock_Return; - end if; - - -- Now copy the data to the user-provided buffer - - Copy_Host_Entry - (Source_Hostent => HE.all, - Target_Hostent => Ret.all, - Target_Buffer => Buf, - Target_Buffer_Length => Buflen, - Result => Result); - - <> - GNAT.Task_Lock.Unlock; - return Result; - end Safe_Gethostbyaddr; - - ------------------------ - -- Safe_Gethostbyname -- - ------------------------ - - function Safe_Gethostbyname - (Name : C.char_array; - Ret : not null access Hostent; - Buf : System.Address; - Buflen : C.int; - H_Errnop : not null access C.int) return C.int - is - HE : Hostent_Access; - Result : C.int; - begin - Result := -1; - GNAT.Task_Lock.Lock; - HE := Nonreentrant_Gethostbyname (Name); - - if HE = null then - H_Errnop.all := C.int (Host_Errno); - goto Unlock_Return; - end if; - - -- Now copy the data to the user-provided buffer - - Copy_Host_Entry - (Source_Hostent => HE.all, - Target_Hostent => Ret.all, - Target_Buffer => Buf, - Target_Buffer_Length => Buflen, - Result => Result); - - <> - GNAT.Task_Lock.Unlock; - return Result; - end Safe_Gethostbyname; - - ------------------------ - -- Safe_Getservbyname -- - ------------------------ - - function Safe_Getservbyname - (Name : C.char_array; - Proto : C.char_array; - Ret : not null access Servent; - Buf : System.Address; - Buflen : C.int) return C.int - is - SE : Servent_Access; - Result : C.int; - begin - Result := -1; - GNAT.Task_Lock.Lock; - SE := Nonreentrant_Getservbyname (Name, Proto); - - if SE = null then - goto Unlock_Return; - end if; - - -- Now copy the data to the user-provided buffer. We convert Ret to - -- type Servent_Access using the .all'Unchecked_Access trick to avoid - -- an accessibility check. Ret could be pointing to a nested variable, - -- and we don't want to raise an exception in that case. - - Copy_Service_Entry - (Source_Servent => SE, - Target_Servent => Ret.all'Unchecked_Access, - Target_Buffer => Buf, - Target_Buffer_Length => Buflen, - Result => Result); - - <> - GNAT.Task_Lock.Unlock; - return Result; - end Safe_Getservbyname; - - ------------------------ - -- Safe_Getservbyport -- - ------------------------ - - function Safe_Getservbyport - (Port : C.int; - Proto : C.char_array; - Ret : not null access Servent; - Buf : System.Address; - Buflen : C.int) return C.int - is - SE : Servent_Access; - Result : C.int; - - begin - Result := -1; - GNAT.Task_Lock.Lock; - SE := Nonreentrant_Getservbyport (Port, Proto); - - if SE = null then - goto Unlock_Return; - end if; - - -- Now copy the data to the user-provided buffer. See Safe_Getservbyname - -- for comment regarding .all'Unchecked_Access. - - Copy_Service_Entry - (Source_Servent => SE, - Target_Servent => Ret.all'Unchecked_Access, - Target_Buffer => Buf, - Target_Buffer_Length => Buflen, - Result => Result); - - <> - GNAT.Task_Lock.Unlock; - return Result; - end Safe_Getservbyport; - - ---------------- - -- Store_Name -- - ---------------- - - procedure Store_Name - (Name : char_array; - Storage : in out char_array; - Storage_Index : in out size_t; - Stored_Name : out C.Strings.chars_ptr) - is - First : constant C.size_t := Storage_Index; - Last : constant C.size_t := Storage_Index + Name'Length - 1; - begin - Storage (First .. Last) := Name; - Stored_Name := C.Strings.To_Chars_Ptr - (Storage (First .. Last)'Unrestricted_Access); - Storage_Index := Last + 1; - end Store_Name; - -end GNAT.Sockets.Thin.Task_Safe_NetDB; diff --git a/gcc/ada/g-sttsne-locking.ads b/gcc/ada/g-sttsne-locking.ads deleted file mode 100644 index 0032d8066a1..00000000000 --- a/gcc/ada/g-sttsne-locking.ads +++ /dev/null @@ -1,75 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . T H I N . T A S K _ S A F E _ N E T D B -- --- -- --- S p e c -- --- -- --- Copyright (C) 2007, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT 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 distributed with GNAT; see file COPYING. If not, write -- --- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version is used on VMS, LynxOS, and VxWorks. There are two versions of --- the body: one for VMS and LynxOS, the other for VxWorks. - --- This package should not be directly with'ed by an application - -package GNAT.Sockets.Thin.Task_Safe_NetDB is - - ---------------------------------------- - -- Reentrant network databases access -- - ---------------------------------------- - - function Safe_Gethostbyname - (Name : C.char_array; - Ret : not null access Hostent; - Buf : System.Address; - Buflen : C.int; - H_Errnop : not null access C.int) return C.int; - - function Safe_Gethostbyaddr - (Addr : System.Address; - Addr_Len : C.int; - Addr_Type : C.int; - Ret : not null access Hostent; - Buf : System.Address; - Buflen : C.int; - H_Errnop : not null access C.int) return C.int; - - function Safe_Getservbyname - (Name : C.char_array; - Proto : C.char_array; - Ret : not null access Servent; - Buf : System.Address; - Buflen : C.int) return C.int; - - function Safe_Getservbyport - (Port : C.int; - Proto : C.char_array; - Ret : not null access Servent; - Buf : System.Address; - Buflen : C.int) return C.int; - -end GNAT.Sockets.Thin.Task_Safe_NetDB; diff --git a/gcc/ada/g-sttsne-vxworks.adb b/gcc/ada/g-sttsne-vxworks.adb deleted file mode 100644 index a91cd873c3b..00000000000 --- a/gcc/ada/g-sttsne-vxworks.adb +++ /dev/null @@ -1,204 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . T H I N . T A S K _ S A F E _ N E T D B -- --- -- --- B o d y -- --- -- --- Copyright (C) 2007-2008, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT 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 distributed with GNAT; see file COPYING. If not, write -- --- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version is used on VxWorks. Note that the corresponding spec is in --- g-sttsne-locking.ads. - -with Ada.Unchecked_Conversion; -with Interfaces.C; use Interfaces.C; - -package body GNAT.Sockets.Thin.Task_Safe_NetDB is - - -- The following additional data is returned by Safe_Gethostbyname - -- and Safe_Getostbyaddr in the user provided buffer. - - type Netdb_Host_Data (Name_Length : C.size_t) is record - Address : aliased In_Addr; - Addr_List : aliased In_Addr_Access_Array (0 .. 1); - Name : aliased C.char_array (0 .. Name_Length); - end record; - - Alias_Access : constant Chars_Ptr_Pointers.Pointer := - new C.Strings.chars_ptr'(C.Strings.Null_Ptr); - -- Constant used to create a Hostent record manually - - ------------------------ - -- Safe_Gethostbyaddr -- - ------------------------ - - function Safe_Gethostbyaddr - (Addr : System.Address; - Addr_Len : C.int; - Addr_Type : C.int; - Ret : not null access Hostent; - Buf : System.Address; - Buflen : C.int; - H_Errnop : not null access C.int) return C.int - is - type int_Access is access int; - function To_Pointer is - new Ada.Unchecked_Conversion (System.Address, int_Access); - - function VxWorks_hostGetByAddr - (Addr : C.int; Buf : System.Address) return C.int; - pragma Import (C, VxWorks_hostGetByAddr, "hostGetByAddr"); - - Netdb_Data : Netdb_Host_Data (Name_Length => Max_Name_Length); - pragma Import (Ada, Netdb_Data); - for Netdb_Data'Address use Buf; - - begin - pragma Assert (Addr_Type = SOSC.AF_INET); - pragma Assert (Addr_Len = In_Addr'Size / 8); - - -- Check that provided buffer is sufficiently large to hold the - -- data we want to return. - - if Netdb_Data'Size / 8 > Buflen then - H_Errnop.all := SOSC.ERANGE; - return -1; - end if; - - if VxWorks_hostGetByAddr (To_Pointer (Addr).all, - Netdb_Data.Name'Address) - /= SOSC.OK - then - H_Errnop.all := C.int (Host_Errno); - return -1; - end if; - - Netdb_Data.Address := To_In_Addr (To_Pointer (Addr).all); - Netdb_Data.Addr_List := - (0 => Netdb_Data.Address'Unchecked_Access, - 1 => null); - - Ret.H_Name := C.Strings.To_Chars_Ptr - (Netdb_Data.Name'Unrestricted_Access); - Ret.H_Aliases := Alias_Access; - Ret.H_Addrtype := SOSC.AF_INET; - Ret.H_Length := 4; - Ret.H_Addr_List := - Netdb_Data.Addr_List (Netdb_Data.Addr_List'First)'Unchecked_Access; - return 0; - end Safe_Gethostbyaddr; - - ------------------------ - -- Safe_Gethostbyname -- - ------------------------ - - function Safe_Gethostbyname - (Name : C.char_array; - Ret : not null access Hostent; - Buf : System.Address; - Buflen : C.int; - H_Errnop : not null access C.int) return C.int - is - function VxWorks_hostGetByName - (Name : C.char_array) return C.int; - pragma Import (C, VxWorks_hostGetByName, "hostGetByName"); - - Addr : C.int; - - begin - Addr := VxWorks_hostGetByName (Name); - if Addr = SOSC.ERROR then - H_Errnop.all := C.int (Host_Errno); - return -1; - end if; - - declare - Netdb_Data : Netdb_Host_Data (Name_Length => Name'Length); - pragma Import (Ada, Netdb_Data); - for Netdb_Data'Address use Buf; - - begin - -- Check that provided buffer is sufficiently large to hold the - -- data we want to return. - - if Netdb_Data'Size / 8 > Buflen then - H_Errnop.all := SOSC.ERANGE; - return -1; - end if; - - Netdb_Data.Address := To_In_Addr (Addr); - Netdb_Data.Addr_List := - (0 => Netdb_Data.Address'Unchecked_Access, - 1 => null); - Netdb_Data.Name (Netdb_Data.Name'First .. Name'Length - 1) := Name; - - Ret.H_Name := C.Strings.To_Chars_Ptr - (Netdb_Data.Name'Unrestricted_Access); - Ret.H_Aliases := Alias_Access; - Ret.H_Addrtype := SOSC.AF_INET; - Ret.H_Length := 4; - Ret.H_Addr_List := - Netdb_Data.Addr_List (Netdb_Data.Addr_List'First)'Unchecked_Access; - end; - return 0; - end Safe_Gethostbyname; - - ------------------------ - -- Safe_Getservbyname -- - ------------------------ - - function Safe_Getservbyname - (Name : C.char_array; - Proto : C.char_array; - Ret : not null access Servent; - Buf : System.Address; - Buflen : C.int) return C.int - is - pragma Unreferenced (Name, Proto, Ret, Buf, Buflen); - begin - -- Not available under VxWorks - return -1; - end Safe_Getservbyname; - - ------------------------ - -- Safe_Getservbyport -- - ------------------------ - - function Safe_Getservbyport - (Port : C.int; - Proto : C.char_array; - Ret : not null access Servent; - Buf : System.Address; - Buflen : C.int) return C.int - is - pragma Unreferenced (Port, Proto, Ret, Buf, Buflen); - begin - -- Not available under VxWorks - return -1; - end Safe_Getservbyport; - -end GNAT.Sockets.Thin.Task_Safe_NetDB; diff --git a/gcc/ada/g-sttsne.ads b/gcc/ada/g-sttsne.ads deleted file mode 100644 index f438a0aea47..00000000000 --- a/gcc/ada/g-sttsne.ads +++ /dev/null @@ -1,83 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . T H I N . T A S K _ S A F E _ N E T D B -- --- -- --- S p e c -- --- -- --- Copyright (C) 2007, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT 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 distributed with GNAT; see file COPYING. If not, write -- --- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package exports reentrant NetDB subprograms. This is the default --- version, used on most platforms. The routines are implemented by importing --- from C; see gsocket.h for details. Different versions are provided on --- platforms where this functionality is implemented in Ada. - --- This package should not be directly with'ed by an application - -package GNAT.Sockets.Thin.Task_Safe_NetDB is - - ---------------------------------------- - -- Reentrant network databases access -- - ---------------------------------------- - - function Safe_Gethostbyname - (Name : C.char_array; - Ret : not null access Hostent; - Buf : System.Address; - Buflen : C.int; - H_Errnop : not null access C.int) return C.int; - - function Safe_Gethostbyaddr - (Addr : System.Address; - Addr_Len : C.int; - Addr_Type : C.int; - Ret : not null access Hostent; - Buf : System.Address; - Buflen : C.int; - H_Errnop : not null access C.int) return C.int; - - function Safe_Getservbyname - (Name : C.char_array; - Proto : C.char_array; - Ret : not null access Servent; - Buf : System.Address; - Buflen : C.int) return C.int; - - function Safe_Getservbyport - (Port : C.int; - Proto : C.char_array; - Ret : not null access Servent; - Buf : System.Address; - Buflen : C.int) return C.int; - -private - pragma Import (C, Safe_Gethostbyname, "__gnat_safe_gethostbyname"); - pragma Import (C, Safe_Gethostbyaddr, "__gnat_safe_gethostbyaddr"); - pragma Import (C, Safe_Getservbyname, "__gnat_safe_getservbyname"); - pragma Import (C, Safe_Getservbyport, "__gnat_safe_getservbyport"); - -end GNAT.Sockets.Thin.Task_Safe_NetDB; diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index b81952377a3..8db581098dc 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -144,6 +144,7 @@ GNAT_ADA_OBJS = \ ada/exp_aggr.o \ ada/exp_atag.o \ ada/exp_attr.o \ + ada/exp_cg.o \ ada/exp_ch11.o \ ada/exp_ch12.o \ ada/exp_ch13.o \ @@ -188,6 +189,8 @@ GNAT_ADA_OBJS = \ ada/gnatvsn.o \ ada/hlo.o \ ada/hostparm.o \ + ada/i-c.o \ + ada/i-cstrea.o \ ada/impunit.o \ ada/inline.o \ ada/interfac.o \ @@ -263,6 +266,7 @@ GNAT_ADA_OBJS = \ ada/s-wchcon.o \ ada/s-wchjis.o \ ada/scans.o \ + ada/scil_ll.o \ ada/scn.o \ ada/scng.o \ ada/scos.o \ @@ -439,7 +443,9 @@ GNATBIND_OBJS = \ ada/s-wchjis.o \ ada/scng.o \ ada/scans.o \ + ada/scil_ll.o \ ada/sdefault.o \ + ada/sem_aux.o \ ada/sinfo.o \ ada/sinput.o \ ada/sinput-c.o \ @@ -561,15 +567,19 @@ ada/doctools/xgnatugn$(build_exeext): ada/xgnatugn.adb $(CP) $^ ada/doctools cd ada/doctools && $(GNATMAKE) -q xgnatugn -# Note that doc/gnat_ugn.texi does not depend on xgnatugn -# being built so we can distribute a pregenerated doc/gnat_ugn.info +# Note that doc/gnat_ugn.texi and doc/projects.texi do not depend on +# xgnatugn being built so we can distribute a pregenerated doc/gnat_ugn.info doc/gnat_ugn.texi: $(srcdir)/ada/gnat_ugn.texi $(srcdir)/ada/ug_words \ - $(gcc_docdir)/include/gcc-common.texi gcc-vers.texi - $(MAKE) ada/doctools/xgnatugn$(build_exeext) + doc/projects.texi $(gcc_docdir)/include/gcc-common.texi gcc-vers.texi ada/doctools/xgnatugn unw $(srcdir)/ada/gnat_ugn.texi \ $(srcdir)/ada/ug_words doc/gnat_ugn.texi +doc/projects.texi: $(srcdir)/ada/projects.texi + $(MAKE) ada/doctools/xgnatugn$(build_exeext) + ada/doctools/xgnatugn unw $(srcdir)/ada/projects.texi \ + $(srcdir)/ada/ug_words doc/projects.texi + doc/gnat_ugn.info: doc/gnat_ugn.texi \ $(gcc_docdir)/include/fdl.texi $(gcc_docdir)/include/gcc-common.texi \ gcc-vers.texi @@ -1234,7 +1244,7 @@ ada/decl.o : ada/gcc-interface/decl.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ ada/misc.o : ada/gcc-interface/misc.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ $(TM_H) $(TREE_H) $(DIAGNOSTIC_H) $(TARGET_H) $(FUNCTION_H) \ - $(FLAGS_H) debug.h toplev.h $(EXCEPT_H) langhooks.h \ + $(FLAGS_H) debug.h toplev.h langhooks.h \ $(LANGHOOKS_DEF_H) opts.h options.h $(TREE_INLINE_H) $(PLUGIN_H) \ ada/gcc-interface/ada.h ada/adadecode.h ada/types.h ada/atree.h \ ada/elists.h ada/namet.h ada/nlists.h ada/stringt.h ada/uintp.h ada/fe.h \ @@ -1250,7 +1260,7 @@ ada/targtyps.o : ada/gcc-interface/targtyps.c $(CONFIG_H) $(SYSTEM_H) \ $(COMPILER) -c $(ALL_COMPILERFLAGS) -I.. $(ALL_CPPFLAGS) $< -o $@ ada/trans.o : ada/gcc-interface/trans.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ - $(TM_H) $(TREE_H) $(FLAGS_H) output.h tree-iterator.h \ + $(TM_H) $(TREE_H) $(FLAGS_H) output.h tree-iterator.h \ $(GIMPLE_H) ada/gcc-interface/ada.h ada/adadecode.h ada/types.h \ ada/atree.h ada/elists.h ada/namet.h ada/nlists.h ada/snames.h \ ada/stringt.h ada/uintp.h ada/urealp.h ada/fe.h ada/sinfo.h ada/einfo.h \ @@ -1263,8 +1273,9 @@ ada/utils.o : ada/gcc-interface/utils.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ $(TARGET_H) function.h langhooks.h $(CGRAPH_H) \ $(TREE_DUMP_H) $(TREE_INLINE_H) tree-iterator.h \ ada/gcc-interface/ada.h ada/types.h ada/atree.h ada/elists.h ada/namet.h \ - ada/nlists.h ada/stringt.h ada/uintp.h ada/fe.h ada/sinfo.h ada/einfo.h \ - $(ADA_TREE_H) ada/gcc-interface/gigi.h gt-ada-utils.h gtype-ada.h + ada/nlists.h ada/snames.h ada/stringt.h ada/uintp.h ada/fe.h ada/sinfo.h \ + ada/einfo.h $(ADA_TREE_H) ada/gcc-interface/gigi.h gt-ada-utils.h \ + gtype-ada.h $(COMPILER) -c $(ALL_COMPILERFLAGS) -I.. $(ALL_CPPFLAGS) $< -o $@ ada/utils2.o : ada/gcc-interface/utils2.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ @@ -1464,29 +1475,33 @@ ada/checks.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch4.ads \ - ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_dist.ads ada/exp_pakd.ads \ - ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb ada/fname.ads \ - ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ - ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ - ada/itypes.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-load.ads ada/lib-sort.adb ada/namet.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ - ada/rtsfind.adb ada/sem.ads ada/sem_aux.ads ada/sem_cat.ads \ - ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \ + ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_disp.ads ada/exp_dist.ads \ + ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb \ + ada/fname.ads ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads \ + ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads \ + ada/inline.ads ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads \ + ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb \ + ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch3.ads \ + ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads \ ada/sem_dist.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads \ - ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads \ + ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads \ ada/sprint.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ - ada/validsw.ads + ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ + ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/validsw.ads \ + ada/widechar.ads ada/comperr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -1522,20 +1537,19 @@ ada/cstand.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads ada/sem_mech.ads \ - ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ - ada/system.ads ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tree_io.ads ada/ttypef.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ - ada/widechar.ads + ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/style.ads \ + ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ + ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tree_io.ads ada/ttypef.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/widechar.ads ada/debug.o : ada/debug.ads ada/debug.adb ada/system.ads @@ -1561,7 +1575,8 @@ ada/einfo.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ + ada/urealp.adb ada/elists.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/elists.ads \ @@ -1588,16 +1603,16 @@ ada/errout.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/fname.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ ada/gnatvsn.ads ada/hostparm.ads ada/lib.ads ada/lib.adb \ ada/lib-list.adb ada/lib-sort.adb ada/namet.ads ada/nlists.ads \ - ada/nlists.adb ada/opt.ads ada/output.ads ada/scans.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ - ada/stand.ads ada/stringt.ads ada/stylesw.ads ada/system.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/widechar.ads + ada/nlists.adb ada/opt.ads ada/output.ads ada/scans.ads ada/sem_aux.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/stylesw.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/erroutc.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -1650,18 +1665,18 @@ ada/exp_aggr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch3.ads \ ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads \ ada/sem_dist.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads \ - ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \ - ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ - ada/s-exctab.adb ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads \ + ada/sprint.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ + ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-exctab.adb \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ ada/widechar.ads @@ -1705,20 +1720,36 @@ ada/exp_attr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_ch6.ads \ ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads \ - ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ - ada/system.ads ada/s-carun8.ads ada/s-crc32.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ - ada/widechar.ads + ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-carun8.ads \ + ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/types.adb \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/widechar.ads + +ada/exp_cg.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/elists.adb ada/exp_cg.ads ada/exp_cg.adb ada/exp_dbug.ads \ + ada/exp_disp.ads ada/exp_tss.ads ada/gnat.ads ada/g-htable.ads \ + ada/hostparm.ads ada/lib.ads ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads ada/sem_aux.ads \ + ada/sem_aux.adb ada/sem_disp.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/exp_ch11.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -1773,7 +1804,7 @@ ada/exp_ch13.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ ada/table.ads ada/table.adb ada/tbuild.ads ada/tree_io.ads \ ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads + ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/exp_ch2.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -1807,24 +1838,25 @@ ada/exp_ch3.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/lib.ads ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/sem.ads \ - ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch3.ads \ - ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads \ - ada/sem_mech.ads ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \ - ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads + ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_cat.ads \ + ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \ + ada/sem_eval.ads ada/sem_mech.ads ada/sem_res.ads ada/sem_scil.ads \ + ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/sprint.ads \ + ada/stand.ads ada/stringt.ads ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/validsw.ads ada/exp_ch4.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/checks.adb ada/debug.ads \ - ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ + ada/casing.ads ada/checks.ads ada/checks.adb ada/csets.ads \ + ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ ada/exp_aggr.ads ada/exp_atag.ads ada/exp_ch11.ads ada/exp_ch2.ads \ ada/exp_ch3.ads ada/exp_ch4.ads ada/exp_ch4.adb ada/exp_ch6.ads \ @@ -1832,23 +1864,28 @@ ada/exp_ch4.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb \ ada/exp_vfpt.ads ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ ada/get_targ.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ - ada/inline.ads ada/itypes.ads ada/lib.ads ada/namet.ads ada/nlists.ads \ + ada/inline.ads ada/interfac.ads ada/itypes.ads ada/lib.ads \ + ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ - ada/sem.ads ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch13.ads \ - ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_eval.ads \ - ada/sem_eval.adb ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \ - ada/stringt.ads ada/stringt.adb ada/system.ads ada/s-exctab.ads \ + ada/par_sco.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \ + ada/rtsfind.ads ada/scans.ads ada/scil_ll.ads ada/scn.ads ada/scng.ads \ + ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ + ada/sem_cat.ads ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch6.ads \ + ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads ada/sem_eval.adb \ + ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \ + ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ ada/s-exctab.adb ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/validsw.ads + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ + ada/validsw.ads ada/widechar.ads ada/exp_ch5.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -1868,20 +1905,19 @@ ada/exp_ch5.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads \ ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch8.ads \ ada/sem_disp.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads \ - ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \ - ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ - ada/widechar.ads + ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads \ + ada/sprint.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ + ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/widechar.ads ada/exp_ch6.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -1901,21 +1937,21 @@ ada/exp_ch6.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb \ ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ - ada/sem_attr.ads ada/sem_aux.ads ada/sem_ch12.ads ada/sem_ch13.ads \ - ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \ - ada/sem_disp.ads ada/sem_dist.ads ada/sem_eval.ads ada/sem_mech.ads \ - ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \ - ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_ch12.ads \ + ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads \ + ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_eval.ads \ + ada/sem_mech.ads ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads \ + ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/sprint.ads \ + ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ ada/widechar.ads @@ -1933,17 +1969,16 @@ ada/exp_ch7.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/sem.ads \ ada/sem_aux.ads ada/sem_ch3.ads ada/sem_ch7.ads ada/sem_ch8.ads \ - ada/sem_eval.ads ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/validsw.ads + ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/exp_ch8.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -1956,16 +1991,15 @@ ada/exp_ch8.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/lib.ads ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \ ada/rtsfind.ads ada/sem.ads ada/sem_aux.ads ada/sem_ch8.ads \ - ada/sem_eval.ads ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-stalib.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ - ada/validsw.ads + ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/exp_ch9.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -1982,9 +2016,9 @@ ada/exp_ch9.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/scans.ads \ ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_attr.ads \ - ada/sem_aux.ads ada/sem_ch11.ads ada/sem_ch6.ads ada/sem_ch8.ads \ - ada/sem_disp.ads ada/sem_elab.ads ada/sem_eval.ads ada/sem_res.ads \ - ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sem_aux.ads ada/sem_aux.adb ada/sem_ch11.ads ada/sem_ch6.ads \ + ada/sem_ch8.ads ada/sem_disp.ads ada/sem_elab.ads ada/sem_eval.ads \ + ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ @@ -2012,9 +2046,9 @@ ada/exp_code.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ ada/sem_cat.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \ - ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads ada/sem_scil.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads \ + ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-carun8.ads \ ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ @@ -2033,13 +2067,14 @@ ada/exp_dbug.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/exp_dbug.ads ada/exp_dbug.adb ada/gnat.ads ada/g-htable.ads \ ada/hostparm.ads ada/interfac.ads ada/namet.ads ada/namet.adb \ ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/output.ads ada/sem_aux.ads ada/sem_eval.ads ada/sem_util.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/output.ads ada/rident.ads ada/sem_aux.ads ada/sem_eval.ads \ + ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ ada/tbuild.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \ ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ ada/urealp.adb ada/widechar.ads @@ -2049,31 +2084,31 @@ ada/exp_disp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ ada/errout.ads ada/erroutc.ads ada/exp_aggr.ads ada/exp_atag.ads \ - ada/exp_ch11.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_dbug.ads \ - ada/exp_disp.ads ada/exp_disp.adb ada/exp_tss.ads ada/exp_tss.adb \ - ada/exp_util.ads ada/exp_util.adb ada/fname.ads ada/fname-uf.ads \ - ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \ - ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \ - ada/layout.ads ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/output.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \ - ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ - ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_ch6.ads \ + ada/exp_cg.ads ada/exp_ch11.ads ada/exp_ch6.ads ada/exp_ch7.ads \ + ada/exp_dbug.ads ada/exp_disp.ads ada/exp_disp.adb ada/exp_tss.ads \ + ada/exp_tss.adb ada/exp_util.ads ada/exp_util.adb ada/fname.ads \ + ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \ + ada/itypes.ads ada/layout.ads ada/lib.ads ada/lib-xref.ads \ + ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/scans.ads \ + ada/scil_ll.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_ch6.ads \ ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads \ - ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ - ada/system.ads ada/s-carun8.ads ada/s-crc32.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ - ada/widechar.ads + ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-carun8.ads \ + ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/types.adb \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/widechar.ads ada/exp_dist.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -2085,9 +2120,9 @@ ada/exp_dist.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/lib-list.adb ada/lib-sort.adb ada/namet.ads ada/nlists.ads \ ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sem.ads \ - ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch3.ads ada/sem_ch8.ads \ - ada/sem_dist.ads ada/sem_eval.ads ada/sem_util.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/sem_aux.ads ada/sem_aux.adb ada/sem_cat.ads ada/sem_ch3.ads \ + ada/sem_ch8.ads ada/sem_dist.ads ada/sem_eval.ads ada/sem_util.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ ada/stringt.ads ada/stringt.adb ada/system.ads ada/s-exctab.ads \ ada/s-htable.ads ada/s-htable.adb ada/s-imenne.ads ada/s-memory.ads \ ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ @@ -2100,23 +2135,31 @@ ada/exp_dist.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/exp_fixd.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/eval_fat.ads ada/exp_fixd.ads ada/exp_fixd.adb ada/exp_tss.ads \ - ada/exp_util.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ - ada/lib.ads ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ - ada/nmake.adb ada/opt.ads ada/output.ads ada/rtsfind.ads ada/sem.ads \ - ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch6.ads ada/sem_ch8.ads \ + ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/elists.ads ada/err_vars.ads ada/errout.ads \ + ada/erroutc.ads ada/eval_fat.ads ada/exp_ch11.ads ada/exp_disp.ads \ + ada/exp_fixd.ads ada/exp_fixd.adb ada/exp_tss.ads ada/exp_util.ads \ + ada/fname.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/interfac.ads ada/lib.ads \ + ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ + ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ + ada/sem_cat.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \ ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/stringt.adb ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tbuild.ads \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ + ada/widechar.ads ada/exp_imgv.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -2139,7 +2182,7 @@ ada/exp_imgv.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/exp_intr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -2155,18 +2198,17 @@ ada/exp_intr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/sem.ads \ ada/sem_aux.ads ada/sem_ch8.ads ada/sem_eval.ads ada/sem_res.ads \ - ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ - ada/stand.ads ada/stringt.ads ada/system.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/validsw.ads \ - ada/widechar.ads + ada/sem_type.ads ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/sinput.adb ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/urealp.adb ada/validsw.ads ada/widechar.ads ada/exp_pakd.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -2181,18 +2223,17 @@ ada/exp_pakd.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ ada/sem.ads ada/sem_aux.ads ada/sem_ch13.ads ada/sem_ch3.ads \ - ada/sem_ch8.ads ada/sem_eval.ads ada/sem_res.ads ada/sem_scil.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/sprint.ads \ - ada/stand.ads ada/stringt.ads ada/system.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ - ada/validsw.ads + ada/sem_ch8.ads ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads \ + ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/exp_prag.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -2286,29 +2327,34 @@ ada/exp_tss.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/exp_util.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/elists.ads ada/elists.adb ada/err_vars.ads ada/errout.ads \ - ada/erroutc.ads ada/eval_fat.ads ada/exp_aggr.ads ada/exp_ch6.ads \ - ada/exp_ch7.ads ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb \ - ada/fname.ads ada/fname-uf.ads ada/get_targ.ads ada/gnat.ads \ + ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ + ada/errout.ads ada/erroutc.ads ada/eval_fat.ads ada/exp_aggr.ads \ + ada/exp_ch11.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_disp.ads \ + ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb ada/fname.ads \ + ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ - ada/itypes.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-sort.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/sem.ads \ - ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch6.ads ada/sem_ch8.ads \ - ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads ada/sem_scil.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads \ + ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \ + ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ + ada/opt.ads ada/output.ads ada/restrict.ads ada/restrict.adb \ + ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ + ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ + ada/sem_cat.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \ + ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads \ + ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \ ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/stringt.adb ada/system.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/urealp.adb ada/validsw.ads + ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ + ada/validsw.ads ada/widechar.ads ada/exp_vfpt.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -2384,29 +2430,30 @@ ada/freeze.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/exp_ch7.ads ada/exp_disp.ads ada/exp_pakd.ads ada/exp_tss.ads \ ada/exp_util.ads ada/exp_util.adb ada/expander.ads ada/fname.ads \ ada/freeze.ads ada/freeze.adb ada/get_targ.ads ada/gnat.ads \ - ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \ - ada/itypes.ads ada/layout.ads ada/lib.ads ada/lib-xref.ads \ - ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ - ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ - ada/scng.adb ada/sem.ads ada/sem_aggr.ads ada/sem_attr.ads \ - ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch13.ads ada/sem_ch4.ads \ - ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads \ - ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads \ - ada/sem_intr.ads ada/sem_mech.ads ada/sem_prag.ads ada/sem_res.ads \ - ada/sem_res.adb ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ - ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-exctab.adb \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/widechar.ads + ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ + ada/interfac.ads ada/itypes.ads ada/layout.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \ + ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ + ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \ + ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ + ada/sem.ads ada/sem_aggr.ads ada/sem_attr.ads ada/sem_aux.ads \ + ada/sem_cat.ads ada/sem_ch13.ads ada/sem_ch4.ads ada/sem_ch6.ads \ + ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \ + ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_intr.ads \ + ada/sem_mech.ads ada/sem_prag.ads ada/sem_res.ads ada/sem_res.adb \ + ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ + ada/s-exctab.adb ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ + ada/widechar.ads ada/frontend.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -2421,20 +2468,21 @@ ada/frontend.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ ada/osint.ads ada/output.ads ada/par.ads ada/prep.ads ada/prepcomp.ads \ ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ - ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ - ada/sem_aux.ads ada/sem_ch8.ads ada/sem_elab.ads ada/sem_prag.ads \ - ada/sem_scil.ads ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/sinput.adb ada/sinput-l.ads ada/snames.ads \ - ada/sprint.ads ada/stand.ads ada/stringt.ads ada/style.ads \ - ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ - ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + ada/scans.ads ada/scil_ll.ads ada/scn.ads ada/scng.ads ada/scng.adb \ + ada/sem.ads ada/sem_aux.ads ada/sem_ch8.ads ada/sem_elab.ads \ + ada/sem_prag.ads ada/sem_scil.ads ada/sem_warn.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/sinput-l.ads \ + ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ + ada/system.ads ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tbuild.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/widechar.ads ada/g-byorma.o : ada/gnat.ads ada/g-byorma.ads ada/g-byorma.adb \ ada/system.ads @@ -2472,32 +2520,33 @@ ada/gnat1drv.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/back_end.ads ada/casing.ads ada/comperr.ads ada/csets.ads \ ada/debug.ads ada/debug_a.ads ada/einfo.ads ada/einfo.adb \ ada/elists.ads ada/elists.adb ada/err_vars.ads ada/errout.ads \ - ada/erroutc.ads ada/exp_tss.ads ada/expander.ads ada/fmap.ads \ - ada/fname.ads ada/fname-uf.ads ada/frontend.ads ada/get_targ.ads \ - ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/g-table.ads \ - ada/g-table.adb ada/gnat1drv.ads ada/gnat1drv.adb ada/gnatvsn.ads \ - ada/hlo.ads ada/hostparm.ads ada/inline.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-writ.ads \ - ada/lib-xref.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/opt.ads ada/osint.ads ada/output.ads ada/par_sco.ads \ - ada/prepcomp.ads ada/repinfo.ads ada/restrict.ads ada/rident.ads \ - ada/rtsfind.ads ada/scos.ads ada/sem.ads ada/sem.adb ada/sem_attr.ads \ - ada/sem_ch10.ads ada/sem_ch11.ads ada/sem_ch12.ads ada/sem_ch13.ads \ - ada/sem_ch2.ads ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch5.ads \ - ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_ch9.ads \ - ada/sem_elim.ads ada/sem_eval.ads ada/sem_prag.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/sinput.adb ada/sinput-l.ads ada/snames.ads ada/sprint.ads \ - ada/stand.ads ada/stringt.ads ada/stylesw.ads ada/system.ads \ - ada/s-assert.ads ada/s-bitops.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tree_gen.ads ada/tree_io.ads \ - ada/treepr.ads ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ - ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ - ada/usage.ads ada/validsw.ads ada/widechar.ads + ada/erroutc.ads ada/exp_cg.ads ada/exp_tss.ads ada/expander.ads \ + ada/fmap.ads ada/fname.ads ada/fname-uf.ads ada/frontend.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/g-table.ads ada/g-table.adb ada/gnat1drv.ads ada/gnat1drv.adb \ + ada/gnatvsn.ads ada/hlo.ads ada/hostparm.ads ada/inline.ads ada/lib.ads \ + ada/lib.adb ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb \ + ada/lib-writ.ads ada/lib-xref.ads ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/opt.ads ada/osint.ads ada/output.ads \ + ada/par_sco.ads ada/prepcomp.ads ada/repinfo.ads ada/restrict.ads \ + ada/rident.ads ada/rtsfind.ads ada/scos.ads ada/sem.ads ada/sem.adb \ + ada/sem_attr.ads ada/sem_ch10.ads ada/sem_ch11.ads ada/sem_ch12.ads \ + ada/sem_ch13.ads ada/sem_ch2.ads ada/sem_ch3.ads ada/sem_ch4.ads \ + ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \ + ada/sem_ch9.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_prag.ads \ + ada/sem_type.ads ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/sinput.adb ada/sinput-l.ads ada/snames.ads \ + ada/sprint.ads ada/stand.ads ada/stringt.ads ada/stylesw.ads \ + ada/system.ads ada/s-assert.ads ada/s-bitops.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tree_gen.ads \ + ada/tree_io.ads ada/treepr.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/usage.ads ada/validsw.ads \ + ada/widechar.ads ada/gnatbind.o : ada/ada.ads ada/a-comlin.ads ada/a-clrefi.ads \ ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads ada/ali.ads \ @@ -2520,15 +2569,25 @@ ada/gnatvsn.o : ada/ada.ads ada/a-unccon.ads ada/gnatvsn.ads \ ada/gnatvsn.adb ada/system.ads ada/s-secsta.ads ada/s-stoele.ads \ ada/s-stoele.adb -ada/hlo.o : ada/ada.ads ada/a-unccon.ads ada/hlo.ads ada/hlo.adb \ - ada/hostparm.ads ada/output.ads ada/system.ads ada/s-exctab.ads \ - ada/s-stalib.ads ada/s-unstyp.ads ada/types.ads ada/unchconv.ads \ - ada/unchdeal.ads +ada/hlo.o : ada/ada.ads ada/a-unccon.ads ada/a-uncdea.ads ada/hlo.ads \ + ada/hlo.adb ada/hostparm.ads ada/output.ads ada/system.ads \ + ada/s-exctab.ads ada/s-os_lib.ads ada/s-stalib.ads ada/s-string.ads \ + ada/s-unstyp.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads ada/hostparm.o : ada/ada.ads ada/a-unccon.ads ada/hostparm.ads \ ada/system.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads \ ada/types.ads ada/unchconv.ads ada/unchdeal.ads +ada/i-c.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/interfac.ads \ + ada/i-c.ads ada/i-c.adb ada/system.ads ada/s-exctab.ads \ + ada/s-exctab.adb ada/s-htable.ads ada/s-parame.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-traent.ads + +ada/i-cstrea.o : ada/ada.ads ada/a-unccon.ads ada/interfac.ads \ + ada/i-cstrea.ads ada/i-cstrea.adb ada/system.ads ada/s-crtl.ads \ + ada/s-parame.ads + ada/impunit.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ @@ -2614,8 +2673,8 @@ ada/layout.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_ch13.ads \ ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads ada/sem_res.ads \ - ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ @@ -2652,12 +2711,13 @@ ada/lib-load.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/lib-util.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ ada/lib.ads ada/lib-util.ads ada/lib-util.adb ada/namet.ads ada/opt.ads \ - ada/osint.ads ada/osint-c.ads ada/output.ads ada/system.ads \ - ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \ - ada/unchdeal.ads + ada/osint.ads ada/osint-c.ads ada/output.ads ada/stringt.ads \ + ada/stringt.adb ada/system.ads ada/s-carun8.ads ada/s-exctab.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/types.adb ada/uintp.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/lib-writ.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/ali.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -2673,15 +2733,15 @@ ada/lib-writ.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/sem_aux.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-casuti.ads ada/s-carun8.ads \ - ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + ada/stylesw.ads ada/system.ads ada/s-casuti.ads ada/s-crc32.ads \ + ada/s-crc32.adb ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/lib-xref.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -2690,17 +2750,18 @@ ada/lib-xref.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/erroutc.ads ada/gnat.ads ada/g-hesorg.ads ada/g-hesorg.adb \ ada/g-htable.ads ada/hostparm.ads ada/lib.ads ada/lib-util.ads \ ada/lib-util.adb ada/lib-xref.ads ada/lib-xref.adb ada/namet.ads \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads ada/osint.ads \ - ada/osint-c.ads ada/output.ads ada/restrict.ads ada/rident.ads \ - ada/sem.ads ada/sem_aux.ads ada/sem_prag.ads ada/sem_util.ads \ - ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads ada/osint.ads \ + ada/osint-c.ads ada/output.ads ada/restrict.ads ada/rident.ads \ + ada/sem.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_prag.ads \ + ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/sinput.adb ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ + ada/widechar.ads ada/lib.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ ada/alloc.ads ada/atree.ads ada/atree.adb ada/casing.ads ada/debug.ads \ @@ -3128,6 +3189,18 @@ ada/scans.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads +ada/scil_ll.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/hostparm.ads \ + ada/namet.ads ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads \ + ada/scil_ll.ads ada/scil_ll.adb ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/system.ads ada/s-exctab.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads + ada/scn.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ ada/alloc.ads ada/atree.ads ada/atree.adb ada/casing.ads ada/csets.ads \ ada/debug.ads ada/einfo.ads ada/err_vars.ads ada/errout.ads \ @@ -3205,9 +3278,9 @@ ada/sem_aggr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/scng.adb ada/sem.ads ada/sem_aggr.ads ada/sem_aggr.adb \ ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch13.ads \ ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \ - ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads ada/sem_scil.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads \ + ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads \ + ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ ada/sprint.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ @@ -3231,27 +3304,29 @@ ada/sem_attr.o : ada/ada.ads ada/a-charac.ads ada/a-chlat1.ads \ ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb ada/expander.ads \ ada/fname.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ ada/g-htable.ads ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads \ - ada/itypes.ads ada/lib.ads ada/lib-xref.ads ada/namet.ads \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ - ada/scans.ads ada/sdefault.ads ada/sem.ads ada/sem_aggr.ads \ - ada/sem_attr.ads ada/sem_attr.adb ada/sem_aux.ads ada/sem_cat.ads \ - ada/sem_ch10.ads ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch4.ads \ - ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \ - ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_eval.adb \ - ada/sem_intr.ads ada/sem_res.ads ada/sem_res.adb ada/sem_scil.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ - ada/snames.adb ada/sprint.ads ada/stand.ads ada/stringt.ads \ - ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-carun8.ads ada/s-exctab.ads \ - ada/s-exctab.adb ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypef.ads \ - ada/ttypes.ads ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb \ + ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib-xref.ads \ + ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ + ada/scng.adb ada/sdefault.ads ada/sem.ads ada/sem_aggr.ads \ + ada/sem_attr.ads ada/sem_attr.adb ada/sem_aux.ads ada/sem_aux.adb \ + ada/sem_cat.ads ada/sem_ch10.ads ada/sem_ch13.ads ada/sem_ch3.ads \ + ada/sem_ch4.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \ + ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads \ + ada/sem_eval.adb ada/sem_intr.ads ada/sem_res.ads ada/sem_res.adb \ + ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ + ada/snames.ads ada/snames.adb ada/sprint.ads ada/stand.ads \ + ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-carun8.ads \ + ada/s-crc32.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tbuild.adb ada/tree_io.ads ada/ttypef.ads ada/ttypes.ads \ + ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ ada/validsw.ads ada/widechar.ads @@ -3299,19 +3374,18 @@ ada/sem_cat.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/output.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads \ ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ ada/sem_cat.ads ada/sem_cat.adb ada/sem_ch8.ads ada/sem_disp.ads \ - ada/sem_eval.ads ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ - ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/widechar.ads + ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sem_util.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/style.ads \ + ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ + ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/sem_ch10.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -3329,20 +3403,19 @@ ada/sem_ch10.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ ada/sem_ch10.ads ada/sem_ch10.adb ada/sem_ch3.ads ada/sem_ch6.ads \ ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \ - ada/sem_eval.ads ada/sem_prag.ads ada/sem_res.ads ada/sem_scil.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads \ - ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ - ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/widechar.ads + ada/sem_eval.ads ada/sem_prag.ads ada/sem_res.ads ada/sem_type.ads \ + ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads ada/sinput.adb \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/style.ads \ + ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ + ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/sem_ch11.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -3382,20 +3455,20 @@ ada/sem_ch12.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/sem_ch12.adb ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch6.ads \ ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \ ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_res.ads \ - ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads \ - ada/sinput.ads ada/sinput-l.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ - ada/s-exctab.adb ada/s-htable.ads ada/s-htable.adb ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strhas.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/widechar.ads + ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads \ + ada/sinput-l.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ + ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-exctab.adb \ + ada/s-htable.ads ada/s-htable.adb ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-strhas.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/urealp.adb ada/widechar.ads ada/sem_ch13.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -3452,11 +3525,11 @@ ada/sem_ch3.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ - ada/sem_attr.ads ada/sem_aux.ads ada/sem_case.ads ada/sem_case.adb \ - ada/sem_cat.ads ada/sem_cat.adb ada/sem_ch13.ads ada/sem_ch3.ads \ - ada/sem_ch3.adb ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \ - ada/sem_disp.ads ada/sem_dist.ads ada/sem_elim.ads ada/sem_eval.ads \ - ada/sem_eval.adb ada/sem_mech.ads ada/sem_res.ads ada/sem_scil.ads \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_case.ads \ + ada/sem_case.adb ada/sem_cat.ads ada/sem_cat.adb ada/sem_ch13.ads \ + ada/sem_ch3.ads ada/sem_ch3.adb ada/sem_ch6.ads ada/sem_ch7.ads \ + ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_elim.ads \ + ada/sem_eval.ads ada/sem_eval.adb ada/sem_mech.ads ada/sem_res.ads \ ada/sem_smem.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \ @@ -3477,31 +3550,32 @@ ada/sem_ch4.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/exp_ch11.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_disp.ads \ - ada/exp_tss.ads ada/exp_util.ads ada/expander.ads ada/fname.ads \ - ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ - ada/g-htable.ads ada/hostparm.ads ada/interfac.ads ada/itypes.ads \ - ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb \ - ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/namet-sp.ads \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ - ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ - ada/sem_aggr.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads \ + ada/eval_fat.ads ada/exp_ch11.ads ada/exp_ch6.ads ada/exp_ch7.ads \ + ada/exp_disp.ads ada/exp_tss.ads ada/exp_util.ads ada/expander.ads \ + ada/fname.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/interfac.ads \ + ada/itypes.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ + ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads ada/namet.adb \ + ada/namet-sp.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ + ada/scng.adb ada/sem.ads ada/sem_aggr.ads ada/sem_attr.ads \ + ada/sem_aux.ads ada/sem_case.ads ada/sem_case.adb ada/sem_cat.ads \ ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch4.adb \ ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \ - ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_intr.ads \ - ada/sem_res.ads ada/sem_res.adb ada/sem_scil.ads ada/sem_type.ads \ + ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_eval.adb \ + ada/sem_intr.ads ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads \ ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \ ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/sem_ch5.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ @@ -3523,20 +3597,20 @@ ada/sem_ch5.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch5.adb \ ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \ ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_eval.adb \ - ada/sem_intr.ads ada/sem_res.ads ada/sem_res.adb ada/sem_scil.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ - ada/sem_warn.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \ - ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/widechar.ads + ada/sem_intr.ads ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads \ + ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sem_warn.adb \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads \ + ada/sprint.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ + ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/validsw.ads ada/widechar.ads ada/sem_ch6.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -3552,11 +3626,11 @@ ada/sem_ch6.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ ada/output.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \ ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ - ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads \ - ada/sem_ch10.ads ada/sem_ch12.ads ada/sem_ch3.ads ada/sem_ch4.ads \ - ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch6.adb ada/sem_ch8.ads \ - ada/sem_disp.ads ada/sem_dist.ads ada/sem_elim.ads ada/sem_eval.ads \ - ada/sem_mech.ads ada/sem_prag.ads ada/sem_res.ads ada/sem_scil.ads \ + ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb \ + ada/sem_cat.ads ada/sem_ch10.ads ada/sem_ch12.ads ada/sem_ch3.ads \ + ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch6.adb \ + ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_elim.ads \ + ada/sem_eval.ads ada/sem_mech.ads ada/sem_prag.ads ada/sem_res.ads \ ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads \ ada/sinput.adb ada/snames.ads ada/snames.adb ada/stand.ads \ @@ -3588,19 +3662,19 @@ ada/sem_ch7.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/sem_cat.ads ada/sem_ch10.ads ada/sem_ch12.ads ada/sem_ch3.ads \ ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch7.adb ada/sem_ch8.ads \ ada/sem_disp.ads ada/sem_eval.ads ada/sem_prag.ads ada/sem_res.ads \ - ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/sinput.adb ada/snames.ads ada/snames.adb ada/stand.ads \ - ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ + ada/snames.ads ada/snames.adb ada/stand.ads ada/stringt.ads \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ + ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/widechar.ads ada/sem_ch8.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -3621,18 +3695,18 @@ ada/sem_ch8.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch6.ads \ ada/sem_ch8.ads ada/sem_ch8.adb ada/sem_disp.ads ada/sem_dist.ads \ ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_intr.ads \ - ada/sem_res.ads ada/sem_res.adb ada/sem_scil.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads ada/sinput.adb \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/style.ads \ - ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ - ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads \ + ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinfo-cn.ads ada/sinput.ads ada/sinput.adb ada/snames.ads \ + ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/sem_ch9.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ @@ -3654,50 +3728,49 @@ ada/sem_ch9.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_ch9.ads \ ada/sem_ch9.adb ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads \ ada/sem_elim.ads ada/sem_eval.ads ada/sem_intr.ads ada/sem_res.ads \ - ada/sem_res.adb ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/sinput.adb ada/snames.ads ada/sprint.ads \ - ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \ - ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ - ada/widechar.ads + ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/sinput.adb ada/snames.ads ada/sprint.ads ada/stand.ads \ + ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/widechar.ads ada/sem_disp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ ada/errout.ads ada/erroutc.ads ada/exp_aggr.ads ada/exp_atag.ads \ - ada/exp_ch11.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_dbug.ads \ - ada/exp_disp.ads ada/exp_disp.adb ada/exp_tss.ads ada/exp_util.ads \ - ada/exp_util.adb ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ - ada/get_targ.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ - ada/inline.ads ada/interfac.ads ada/itypes.ads ada/layout.ads \ - ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ - ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ - ada/sem_attr.ads ada/sem_aux.ads ada/sem_ch3.ads ada/sem_ch6.ads \ - ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_disp.adb \ - ada/sem_eval.ads ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ - ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/validsw.ads ada/widechar.ads + ada/exp_cg.ads ada/exp_ch11.ads ada/exp_ch6.ads ada/exp_ch7.ads \ + ada/exp_dbug.ads ada/exp_disp.ads ada/exp_disp.adb ada/exp_tss.ads \ + ada/exp_util.ads ada/exp_util.adb ada/fname.ads ada/fname-uf.ads \ + ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \ + ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \ + ada/layout.ads ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \ + ada/rtsfind.ads ada/scans.ads ada/scil_ll.ads ada/scn.ads ada/scng.ads \ + ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ + ada/sem_aux.adb ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads \ + ada/sem_ch8.ads ada/sem_disp.ads ada/sem_disp.adb ada/sem_eval.ads \ + ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/widechar.ads ada/sem_dist.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -3732,18 +3805,18 @@ ada/sem_elab.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads \ ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_elab.ads \ - ada/sem_elab.adb ada/sem_eval.ads ada/sem_res.ads ada/sem_scil.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ - ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \ - ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/sem_elab.adb ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads \ + ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/sinput.adb ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/sem_elim.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ @@ -3753,15 +3826,16 @@ ada/sem_elim.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads \ ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads \ - ada/sem.ads ada/sem_elim.ads ada/sem_elim.adb ada/sem_prag.ads \ - ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-stalib.ads ada/s-strhas.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + ada/sem.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_elim.ads \ + ada/sem_elim.adb ada/sem_prag.ads ada/sem_util.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ + ada/stand.ads ada/stringt.ads ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-htable.adb ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-strhas.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/widechar.ads ada/sem_eval.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -3776,11 +3850,11 @@ ada/sem_eval.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \ ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_aggr.ads \ - ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch13.ads \ - ada/sem_ch4.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \ - ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads \ - ada/sem_eval.adb ada/sem_intr.ads ada/sem_res.ads ada/sem_res.adb \ - ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_cat.ads \ + ada/sem_ch13.ads ada/sem_ch4.ads ada/sem_ch6.ads ada/sem_ch8.ads \ + ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads \ + ada/sem_eval.ads ada/sem_eval.adb ada/sem_intr.ads ada/sem_res.ads \ + ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ ada/snames.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ @@ -3840,30 +3914,30 @@ ada/sem_prag.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb \ ada/lib-writ.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb \ ada/namet-sp.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ - ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/scans.ads \ - ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_aggr.ads \ - ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch12.ads \ - ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch6.ads \ - ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads \ - ada/sem_elim.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_intr.ads \ - ada/sem_mech.ads ada/sem_prag.ads ada/sem_prag.adb ada/sem_res.ads \ - ada/sem_res.adb ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sem_vfpt.ads ada/sem_warn.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads ada/sinput.adb \ - ada/snames.ads ada/snames.adb ada/stand.ads ada/stringt.ads \ - ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-carun8.ads ada/s-crc32.ads \ - ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/types.adb \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/validsw.ads \ - ada/widechar.ads + ada/nmake.adb ada/opt.ads ada/output.ads ada/par_sco.ads \ + ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ + ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ + ada/sem_aggr.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb \ + ada/sem_cat.ads ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch3.ads \ + ada/sem_ch4.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \ + ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads \ + ada/sem_eval.adb ada/sem_intr.ads ada/sem_mech.ads ada/sem_prag.ads \ + ada/sem_prag.adb ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads \ + ada/sem_util.ads ada/sem_util.adb ada/sem_vfpt.ads ada/sem_warn.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads \ + ada/sinput.adb ada/snames.ads ada/snames.adb ada/stand.ads \ + ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-carun8.ads \ + ada/s-crc32.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ + ada/validsw.ads ada/widechar.ads ada/sem_res.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -3886,35 +3960,34 @@ ada/sem_res.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch6.ads \ ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \ ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_eval.adb \ - ada/sem_intr.ads ada/sem_res.ads ada/sem_res.adb ada/sem_scil.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ - ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \ - ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-carun8.ads ada/s-crc32.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb \ - ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ - ada/urealp.adb ada/validsw.ads ada/widechar.ads + ada/sem_intr.ads ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads \ + ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ + ada/sprint.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ + ada/system.ads ada/s-carun8.ads ada/s-crc32.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ + ada/validsw.ads ada/widechar.ads ada/sem_scil.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/gnat.ads \ ada/g-htable.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads ada/rtsfind.ads \ - ada/sem.ads ada/sem_aux.ads ada/sem_scil.ads ada/sem_scil.adb \ - ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/system.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + ada/nlists.adb ada/opt.ads ada/output.ads ada/rtsfind.ads \ + ada/scil_ll.ads ada/sem_aux.ads ada/sem_scil.ads ada/sem_scil.adb \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/sem_smem.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -3944,49 +4017,50 @@ ada/sem_type.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_attr.ads \ ada/sem_aux.ads ada/sem_ch12.ads ada/sem_ch6.ads ada/sem_ch8.ads \ ada/sem_disp.ads ada/sem_dist.ads ada/sem_eval.ads ada/sem_res.ads \ - ada/sem_scil.ads ada/sem_type.ads ada/sem_type.adb ada/sem_util.ads \ - ada/sem_util.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/style.ads \ - ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ - ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + ada/sem_type.ads ada/sem_type.adb ada/sem_util.ads ada/sem_util.adb \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/sem_util.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ ada/casing.ads ada/casing.adb ada/checks.ads ada/csets.ads \ ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ - ada/exp_ch11.ads ada/exp_disp.ads ada/exp_tss.ads ada/exp_util.ads \ - ada/fname.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ - ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/interfac.ads \ - ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb \ - ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \ + ada/exp_ch11.ads ada/exp_disp.ads ada/exp_dist.ads ada/exp_tss.ads \ + ada/exp_util.ads ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads \ + ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb ada/scans.ads \ ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_attr.ads \ - ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch6.ads ada/sem_ch8.ads \ - ada/sem_disp.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads \ - ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-carun8.ads ada/s-crc32.ads \ - ada/s-crc32.adb ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strhas.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ - ada/widechar.ads + ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch6.ads ada/sem_ch7.ads \ + ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_eval.ads \ + ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/sinput.adb ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-carun8.ads \ + ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads ada/s-htable.ads \ + ada/s-htable.adb ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-strhas.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb \ + ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ + ada/urealp.adb ada/widechar.ads ada/sem_vfpt.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -4015,18 +4089,18 @@ ada/sem_warn.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/output.ads ada/par_sco.ads ada/rident.ads ada/rtsfind.ads \ ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ ada/sem_attr.ads ada/sem_aux.ads ada/sem_ch8.ads ada/sem_disp.ads \ - ada/sem_eval.ads ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sem_warn.adb \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/style.ads \ - ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ - ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sem_util.adb ada/sem_warn.ads ada/sem_warn.adb ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ + ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/sinfo-cn.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ @@ -4290,16 +4364,16 @@ ada/treepr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/lib.ads \ ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads ada/output.adb \ - ada/sem_mech.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/treepr.ads \ - ada/treepr.adb ada/treeprs.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/widechar.ads + ada/scil_ll.ads ada/sem_mech.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/sinput.adb ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/treepr.ads ada/treepr.adb ada/treeprs.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/treeprs.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 236903d48b9..ee65cb2fdd1 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -309,7 +309,7 @@ GNATMAKE_OBJS = a-except.o ali.o ali-util.o s-casuti.o \ scans.o scng.o sdefault.o sfn_scan.o s-purexc.o s-htable.o sinfo.o sinput.o \ sinput-c.o sinput-p.o snames.o stand.o stringt.o styleg.o stylesw.o system.o \ validsw.o switch.o switch-m.o table.o targparm.o tempdir.o tree_io.o types.o \ - uintp.o uname.o urealp.o usage.o widechar.o \ + uintp.o uname.o urealp.o usage.o widechar.o scil_ll.o \ $(EXTRA_GNATMAKE_OBJS) # Convert the target variable into a space separated list of architecture, @@ -380,7 +380,7 @@ MLIB_TGT = mlib-tgt # to LIBGNAT_TARGET_PAIRS. GNATRTL_SOCKETS_OBJS = g-soccon$(objext) g-socket$(objext) g-socthi$(objext) \ - g-soliop$(objext) g-sothco$(objext) g-sttsne$(objext) + g-soliop$(objext) g-sothco$(objext) DUMMY_SOCKETS_TARGET_PAIRS = \ g-socket.adb $(RTSDIR)/s.ads $(MV) $(RTSDIR)/s.ads $(RTSDIR)/system.ads $(MAKE) $(FLAGS_TO_PASS) \ @@ -2628,7 +2651,8 @@ gnatlib-sjlj: TARGET_LIBGCC2_CFLAGS="$(TARGET_LIBGCC2_CFLAGS)" gnatlib gnatlib-zcx: - $(MAKE) $(FLAGS_TO_PASS) EH_MECHANISM="-gcc" ../stamp-gnatlib1-$(RTSDIR) + $(MAKE) $(FLAGS_TO_PASS) EH_MECHANISM="-gcc" \ + THREAD_KIND="$(THREAD_KIND)" ../stamp-gnatlib1-$(RTSDIR) sed -e 's/ZCX_By_Default.*/ZCX_By_Default : constant Boolean := True;/' $(RTSDIR)/system.ads > $(RTSDIR)/s.ads $(MV) $(RTSDIR)/s.ads $(RTSDIR)/system.ads $(MAKE) $(FLAGS_TO_PASS) \ diff --git a/gcc/ada/gcc-interface/ada-tree.h b/gcc/ada/gcc-interface/ada-tree.h index 60a5595fe22..5092ff31b78 100644 --- a/gcc/ada/gcc-interface/ada-tree.h +++ b/gcc/ada/gcc-interface/ada-tree.h @@ -32,32 +32,38 @@ union GTY((desc ("0"), desc ("tree_node_structure (&%h)"))) generic; }; -/* Ada uses the lang_decl and lang_type fields to hold a tree. */ -struct GTY(()) lang_type { tree t; }; -struct GTY(()) lang_decl { tree t; }; +/* Ada uses the lang_decl and lang_type fields to hold a tree. + + FIXME: the variable_size annotation here is needed because these types are + variable-sized in some other front-ends. Due to gengtype deficiency, the + GTY options of such types have to agree across all front-ends. */ +struct GTY((variable_size)) lang_type { tree t; }; +struct GTY((variable_size)) lang_decl { tree t; }; /* Macros to get and set the tree in TYPE_LANG_SPECIFIC. */ #define GET_TYPE_LANG_SPECIFIC(NODE) \ (TYPE_LANG_SPECIFIC (NODE) ? TYPE_LANG_SPECIFIC (NODE)->t : NULL_TREE) -#define SET_TYPE_LANG_SPECIFIC(NODE, X) \ -do { \ - tree tmp = (X); \ - if (!TYPE_LANG_SPECIFIC (NODE)) \ - TYPE_LANG_SPECIFIC (NODE) = GGC_NEW (struct lang_type); \ - TYPE_LANG_SPECIFIC (NODE)->t = tmp; \ +#define SET_TYPE_LANG_SPECIFIC(NODE, X) \ +do { \ + tree tmp = (X); \ + if (!TYPE_LANG_SPECIFIC (NODE)) \ + TYPE_LANG_SPECIFIC (NODE) \ + = ggc_alloc_lang_type (sizeof (struct lang_type)); \ + TYPE_LANG_SPECIFIC (NODE)->t = tmp; \ } while (0) /* Macros to get and set the tree in DECL_LANG_SPECIFIC. */ #define GET_DECL_LANG_SPECIFIC(NODE) \ (DECL_LANG_SPECIFIC (NODE) ? DECL_LANG_SPECIFIC (NODE)->t : NULL_TREE) -#define SET_DECL_LANG_SPECIFIC(NODE, X) \ -do { \ - tree tmp = (X); \ - if (!DECL_LANG_SPECIFIC (NODE)) \ - DECL_LANG_SPECIFIC (NODE) = GGC_NEW (struct lang_decl); \ - DECL_LANG_SPECIFIC (NODE)->t = tmp; \ +#define SET_DECL_LANG_SPECIFIC(NODE, X) \ +do { \ + tree tmp = (X); \ + if (!DECL_LANG_SPECIFIC (NODE)) \ + DECL_LANG_SPECIFIC (NODE) \ + = ggc_alloc_lang_decl (sizeof (struct lang_decl)); \ + DECL_LANG_SPECIFIC (NODE)->t = tmp; \ } while (0) diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index 0fd7753e1ae..6952060259d 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -55,10 +55,6 @@ #include "ada-tree.h" #include "gigi.h" -#ifndef MAX_FIXED_MODE_SIZE -#define MAX_FIXED_MODE_SIZE GET_MODE_BITSIZE (DImode) -#endif - /* Convention_Stdcall should be processed in a specific way on Windows targets only. The macro below is a helper to avoid having to check for a Windows specific attribute throughout this unit. */ @@ -158,13 +154,24 @@ static tree make_type_from_size (tree, tree, bool); static unsigned int validate_alignment (Uint, Entity_Id, unsigned int); static unsigned int ceil_alignment (unsigned HOST_WIDE_INT); static void check_ok_for_atomic (tree, Entity_Id, bool); -static int compatible_signatures_p (tree, tree); static tree create_field_decl_from (tree, tree, tree, tree, tree, tree); static tree get_rep_part (tree); static tree get_variant_part (tree); static tree create_variant_part_from (tree, tree, tree, tree, tree); static void copy_and_substitute_in_size (tree, tree, tree); static void rest_of_type_decl_compilation_no_defer (tree); + +/* The relevant constituents of a subprogram binding to a GCC builtin. Used + to pass around calls performing profile compatibilty checks. */ + +typedef struct { + Entity_Id gnat_entity; /* The Ada subprogram entity. */ + tree ada_fntype; /* The corresponding GCC type node. */ + tree btin_fntype; /* The GCC builtin function type node. */ +} intrin_binding_t; + +static bool intrin_profiles_compatible_p (intrin_binding_t *); + /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada entity, return the equivalent GCC tree for that entity (a ..._DECL node) @@ -1040,15 +1047,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) = TYPE_PADDING_P (gnu_type) ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type))) : TYPE_FIELDS (gnu_type); - gnu_expr - = gnat_build_constructor - (gnu_type, - tree_cons - (template_field, - build_template (TREE_TYPE (template_field), - TREE_TYPE (TREE_CHAIN (template_field)), - NULL_TREE), - NULL_TREE)); + VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 1); + tree t = build_template (TREE_TYPE (template_field), + TREE_TYPE (TREE_CHAIN (template_field)), + NULL_TREE); + CONSTRUCTOR_APPEND_ELT (v, template_field, t); + gnu_expr = gnat_build_constructor (gnu_type, v); } /* Convert the expression to the type of the object except in the @@ -3905,14 +3909,23 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) } /* If this subprogram is expectedly bound to a GCC builtin, fetch the - corresponding DECL node. + corresponding DECL node. Proper generation of calls later on need + proper parameter associations so we don't "break;" here. */ + if (Convention (gnat_entity) == Convention_Intrinsic + && Present (Interface_Name (gnat_entity))) + { + gnu_builtin_decl = builtin_decl_for (gnu_ext_name); - We still want the parameter associations to take place because the - proper generation of calls depends on it (a GNAT parameter without - a corresponding GCC tree has a very specific meaning), so we don't - just break here. */ - if (Convention (gnat_entity) == Convention_Intrinsic) - gnu_builtin_decl = builtin_decl_for (gnu_ext_name); + /* Unability to find the builtin decl most often indicates a + genuine mistake, but imports of unregistered intrinsics are + sometimes issued on purpose to allow hooking in alternate + bodies. We post a warning conditioned on Wshadow in this case, + to let developers be notified on demand without risking false + positives with common default sets of options. */ + + if (gnu_builtin_decl == NULL_TREE && warn_shadow) + post_error ("?gcc intrinsic not found for&!", gnat_entity); + } /* ??? What if we don't find the builtin node above ? warn ? err ? In the current state we neither warn nor err, and calls will just @@ -4208,21 +4221,25 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) | (TYPE_QUAL_CONST * const_flag) | (TYPE_QUAL_VOLATILE * volatile_flag)); - /* If we have a builtin decl for that function, check the signatures - compatibilities. If the signatures are compatible, use the builtin - decl. If they are not, we expect the checker predicate to have - posted the appropriate errors, and just continue with what we have - so far. */ + /* If we have a builtin decl for that function, use it. Check if the + profiles are compatible and warn if they are not. The checker is + expected to post extra diagnostics in this case. */ if (gnu_builtin_decl) { - tree gnu_builtin_type = TREE_TYPE (gnu_builtin_decl); + intrin_binding_t inb; - if (compatible_signatures_p (gnu_type, gnu_builtin_type)) - { - gnu_decl = gnu_builtin_decl; - gnu_type = gnu_builtin_type; - break; - } + inb.gnat_entity = gnat_entity; + inb.ada_fntype = gnu_type; + inb.btin_fntype = TREE_TYPE (gnu_builtin_decl); + + if (!intrin_profiles_compatible_p (&inb)) + post_error + ("?profile of& doesn''t match the builtin it binds!", + gnat_entity); + + gnu_decl = gnu_builtin_decl; + gnu_type = TREE_TYPE (gnu_builtin_decl); + break; } /* If there was no specified Interface_Name and the external and @@ -5244,6 +5261,12 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech, gnu_param_type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type)))); + /* For GCC builtins, pass Address integer types as (void *) */ + if (Convention (gnat_subprog) == Convention_Intrinsic + && Present (Interface_Name (gnat_subprog)) + && Is_Descendent_Of_Address (Etype (gnat_param))) + gnu_param_type = ptr_void_type_node; + /* VMS descriptors are themselves passed by reference. */ if (mech == By_Short_Descriptor || (mech == By_Descriptor && TARGET_ABI_OPEN_VMS && !TARGET_MALLOC64)) @@ -7300,7 +7323,7 @@ annotate_value (tree gnu_size) /* Save the result in the cache. */ if (h) { - *h = GGC_NEW (struct tree_int_map); + *h = ggc_alloc_tree_int_map (); (*h)->base.from = gnu_size; (*h)->to = ret; } @@ -8040,32 +8063,154 @@ check_ok_for_atomic (tree object, Entity_Id gnat_entity, bool comp_p) gnat_error_point, gnat_entity); } -/* Check if FTYPE1 and FTYPE2, two potentially different function type nodes, - have compatible signatures so that a call using one type may be safely - issued if the actual target function type is the other. Return 1 if it is - the case, 0 otherwise, and post errors on the incompatibilities. - This is used when an Ada subprogram is mapped onto a GCC builtin, to ensure - that calls to the subprogram will have arguments suitable for the later - underlying builtin expansion. */ +/* Helper for the intrin compatibility checks family. Evaluate whether + two types are definitely incompatible. */ -static int -compatible_signatures_p (tree ftype1, tree ftype2) +static bool +intrin_types_incompatible_p (tree t1, tree t2) { - /* As of now, we only perform very trivial tests and consider it's the - programmer's responsibility to ensure the type correctness in the Ada - declaration, as in the regular Import cases. + enum tree_code code; + + if (TYPE_MAIN_VARIANT (t1) == TYPE_MAIN_VARIANT (t2)) + return false; + + if (TYPE_MODE (t1) != TYPE_MODE (t2)) + return true; + + if (TREE_CODE (t1) != TREE_CODE (t2)) + return true; + + code = TREE_CODE (t1); + + switch (code) + { + case INTEGER_TYPE: + case REAL_TYPE: + return TYPE_PRECISION (t1) != TYPE_PRECISION (t2); + + case POINTER_TYPE: + case REFERENCE_TYPE: + /* Assume designated types are ok. We'd need to account for char * and + void * variants to do better, which could rapidly get messy and isn't + clearly worth the effort. */ + return false; + + default: + break; + } + + return false; +} + +/* Helper for intrin_profiles_compatible_p, to perform compatibility checks + on the Ada/builtin argument lists for the INB binding. */ + +static bool +intrin_arglists_compatible_p (intrin_binding_t * inb) +{ + tree ada_args = TYPE_ARG_TYPES (inb->ada_fntype); + tree btin_args = TYPE_ARG_TYPES (inb->btin_fntype); + + /* Sequence position of the last argument we checked. */ + int argpos = 0; + + while (ada_args != 0 || btin_args != 0) + { + tree ada_type, btin_type; + + /* If one list is shorter than the other, they fail to match. */ + if (ada_args == 0 || btin_args == 0) + return false; + + ada_type = TREE_VALUE (ada_args); + btin_type = TREE_VALUE (btin_args); + + /* If we're done with the Ada args and not with the internal builtin + args, or the other way around, complain. */ + if (ada_type == void_type_node + && btin_type != void_type_node) + { + post_error ("?Ada arguments list too short!", inb->gnat_entity); + return false; + } + + if (btin_type == void_type_node + && ada_type != void_type_node) + { + post_error_ne_num ("?Ada arguments list too long ('> ^)!", + inb->gnat_entity, inb->gnat_entity, argpos); + return false; + } + + /* Otherwise, check that types match for the current argument. */ + argpos ++; + if (intrin_types_incompatible_p (ada_type, btin_type)) + { + post_error_ne_num ("?intrinsic binding type mismatch on argument ^!", + inb->gnat_entity, inb->gnat_entity, argpos); + return false; + } + + ada_args = TREE_CHAIN (ada_args); + btin_args = TREE_CHAIN (btin_args); + } + + return true; +} + +/* Helper for intrin_profiles_compatible_p, to perform compatibility checks + on the Ada/builtin return values for the INB binding. */ + +static bool +intrin_return_compatible_p (intrin_binding_t * inb) +{ + tree ada_return_type = TREE_TYPE (inb->ada_fntype); + tree btin_return_type = TREE_TYPE (inb->btin_fntype); + + /* Accept function imported as procedure, common and convenient. */ + if (VOID_TYPE_P (ada_return_type) + && !VOID_TYPE_P (btin_return_type)) + return true; + + /* Check return types compatibility otherwise. Note that this + handles void/void as well. */ + if (intrin_types_incompatible_p (btin_return_type, ada_return_type)) + { + post_error ("?intrinsic binding type mismatch on return value!", + inb->gnat_entity); + return false; + } + + return true; +} + +/* Check and return whether the Ada and gcc builtin profiles bound by INB are + compatible. Issue relevant warnings when they are not. + + This is intended as a light check to diagnose the most obvious cases, not + as a full fledged type compatiblity predicate. It is the programmer's + responsibility to ensure correctness of the Ada declarations in Imports, + especially when binding straight to a compiler internal. */ + +static bool +intrin_profiles_compatible_p (intrin_binding_t * inb) +{ + /* Check compatibility on return values and argument lists, each responsible + for posting warnings as appropriate. Ensure use of the proper sloc for + this purpose. */ + + bool arglists_compatible_p, return_compatible_p; + location_t saved_location = input_location; + + Sloc_to_locus (Sloc (inb->gnat_entity), &input_location); - Mismatches typically result in either error messages from the builtin - expander, internal compiler errors, or in a real call sequence. This - should be refined to issue diagnostics helping error detection and - correction. */ + return_compatible_p = intrin_return_compatible_p (inb); + arglists_compatible_p = intrin_arglists_compatible_p (inb); - /* Almost fake test, ensuring a use of each argument. */ - if (ftype1 == ftype2) - return 1; + input_location = saved_location; - return 1; + return return_compatible_p && arglists_compatible_p; } /* Return a FIELD_DECL node modeled on OLD_FIELD. FIELD_TYPE is its type diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h index 74a94d73261..767700f6f76 100644 --- a/gcc/ada/gcc-interface/gigi.h +++ b/gcc/ada/gcc-interface/gigi.h @@ -785,9 +785,9 @@ extern tree build_call_0_expr (tree fundecl); (N_Raise_{Constraint,Storage,Program}_Error). */ extern tree build_call_raise (int msg, Node_Id gnat_node, char kind); -/* Return a CONSTRUCTOR of TYPE whose list is LIST. This is not the +/* Return a CONSTRUCTOR of TYPE whose elements are V. This is not the same as build_constructor in the language-independent tree.c. */ -extern tree gnat_build_constructor (tree type, tree list); +extern tree gnat_build_constructor (tree type, VEC(constructor_elt,gc) *v); /* Return a COMPONENT_REF to access a field that is given by COMPONENT, an IDENTIFIER_NODE giving the name of the field, FIELD, a FIELD_DECL, diff --git a/gcc/ada/gcc-interface/lang-specs.h b/gcc/ada/gcc-interface/lang-specs.h index e0c1be9e103..7f37ef58611 100644 --- a/gcc/ada/gcc-interface/lang-specs.h +++ b/gcc/ada/gcc-interface/lang-specs.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * Copyright (C) 1992-2009, Free Software Foundation, Inc. * + * Copyright (C) 1992-2010, Free Software Foundation, Inc. * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * @@ -38,9 +38,6 @@ %{c|S:%{o*:-auxbase-strip %*}%{!o*:-auxbase %b}}%{!c:%{!S:-auxbase %b}} \ %{O*} %{W*} %{w} %{p} %{pg:-p} %{a} %{d*} %{f*}\ %{coverage:-fprofile-arcs -ftest-coverage} " -#if CONFIG_DUAL_EXCEPTIONS - "%{fRTS=sjlj:-fsjlj} " -#endif "%{gnatea:-gnatez} %{g*&m*} " #if defined(TARGET_VXWORKS_RTP) "%{fRTS=rtp:-mrtp} " diff --git a/gcc/ada/gcc-interface/misc.c b/gcc/ada/gcc-interface/misc.c index a80afbdc80e..4033173d782 100644 --- a/gcc/ada/gcc-interface/misc.c +++ b/gcc/ada/gcc-interface/misc.c @@ -25,7 +25,7 @@ /* This file contains parts of the compiler that are required for interfacing with GCC but otherwise do nothing and parts of Gigi that need to know - about RTL. */ + about GIMPLE. */ #include "config.h" #include "system.h" @@ -44,7 +44,6 @@ #include "options.h" #include "plugin.h" #include "function.h" /* For pass_by_reference. */ -#include "except.h" /* For USING_SJLJ_EXCEPTIONS. */ #include "ada.h" #include "adadecode.h" @@ -135,6 +134,9 @@ static tree gnat_eh_personality (void); struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER; +/* This symbol needs to be defined for the front-end. */ +void *callgraph_info_file = NULL; + /* How much we want of our DWARF extensions. Some of our dwarf+ extensions are incompatible with regular GDB versions, so we must make sure to only produce them on explicit request. This is eventually reflected into the @@ -574,7 +576,7 @@ static const char * gnat_printable_name (tree decl, int verbosity) { const char *coded_name = IDENTIFIER_POINTER (DECL_NAME (decl)); - char *ada_name = (char *) ggc_alloc (strlen (coded_name) * 2 + 60); + char *ada_name = (char *) ggc_alloc_atomic (strlen (coded_name) * 2 + 60); __gnat_decode (coded_name, ada_name, 0); diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 1732069b699..46848f230f7 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -153,35 +153,25 @@ struct GTY((chain_next ("%h.next"))) elab_info { static GTY(()) struct elab_info *elab_info_list; -/* Free list of TREE_LIST nodes used for stacks. */ -static GTY((deletable)) tree gnu_stack_free_list; +/* Stack of exception pointer variables. Each entry is the VAR_DECL + that stores the address of the raised exception. Nonzero means we + are in an exception handler. Not used in the zero-cost case. */ +static GTY(()) VEC(tree,gc) *gnu_except_ptr_stack; -/* List of TREE_LIST nodes representing a stack of exception pointer - variables. TREE_VALUE is the VAR_DECL that stores the address of - the raised exception. Nonzero means we are in an exception - handler. Not used in the zero-cost case. */ -static GTY(()) tree gnu_except_ptr_stack; +/* Stack for storing the current elaboration procedure decl. */ +static GTY(()) VEC(tree,gc) *gnu_elab_proc_stack; -/* List of TREE_LIST nodes used to store the current elaboration procedure - decl. TREE_VALUE is the decl. */ -static GTY(()) tree gnu_elab_proc_stack; +/* Stack of labels to be used as a goto target instead of a return in + some functions. See processing for N_Subprogram_Body. */ +static GTY(()) VEC(tree,gc) *gnu_return_label_stack; -/* Variable that stores a list of labels to be used as a goto target instead of - a return in some functions. See processing for N_Subprogram_Body. */ -static GTY(()) tree gnu_return_label_stack; +/* Stack of LOOP_STMT nodes. */ +static GTY(()) VEC(tree,gc) *gnu_loop_label_stack; -/* List of TREE_LIST nodes representing a stack of LOOP_STMT nodes. - TREE_VALUE of each entry is the label of the corresponding LOOP_STMT. */ -static GTY(()) tree gnu_loop_label_stack; - -/* List of TREE_LIST nodes representing labels for switch statements. - TREE_VALUE of each entry is the label at the end of the switch. */ -static GTY(()) tree gnu_switch_label_stack; - -/* List of TREE_LIST nodes containing the stacks for N_{Push,Pop}_*_Label. */ -static GTY(()) tree gnu_constraint_error_label_stack; -static GTY(()) tree gnu_storage_error_label_stack; -static GTY(()) tree gnu_program_error_label_stack; +/* The stacks for N_{Push,Pop}_*_Label. */ +static GTY(()) VEC(tree,gc) *gnu_constraint_error_label_stack; +static GTY(()) VEC(tree,gc) *gnu_storage_error_label_stack; +static GTY(()) VEC(tree,gc) *gnu_program_error_label_stack; /* Map GNAT tree codes to GCC tree codes for simple expressions. */ static enum tree_code gnu_codes[Number_Node_Kinds]; @@ -192,10 +182,8 @@ static void record_code_position (Node_Id); static void insert_code_for (Node_Id); static void add_cleanup (tree, Node_Id); static void add_stmt_list (List_Id); -static void push_exception_label_stack (tree *, Entity_Id); +static void push_exception_label_stack (VEC(tree,gc) **, Entity_Id); static tree build_stmt_group (List_Id, bool); -static void push_stack (tree *, tree, tree); -static void pop_stack (tree *); static enum gimplify_status gnat_gimplify_stmt (tree *); static void elaborate_all_entities (Node_Id); static void process_freeze_entity (Node_Id); @@ -213,6 +201,7 @@ static tree extract_values (tree, tree); static tree pos_to_constructor (Node_Id, tree, Entity_Id); static tree maybe_implicit_deref (tree); static void set_expr_location_from_node (tree, Node_Id); +static void set_gnu_expr_location_from_node (tree, Node_Id); static int lvalue_required_p (Node_Id, tree, bool, bool, bool); /* Hooks for debug info back-ends, only supported and used in a restricted set @@ -555,10 +544,16 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED, if (TARGET_VTABLE_USES_DESCRIPTORS) { tree null_node = fold_convert (ptr_void_ftype, null_pointer_node); - tree field_list = NULL_TREE, null_list = NULL_TREE; + tree field_list = NULL_TREE; int j; + VEC(constructor_elt,gc) *null_vec = NULL; + constructor_elt *elt; fdesc_type_node = make_node (RECORD_TYPE); + VEC_safe_grow (constructor_elt, gc, null_vec, + TARGET_VTABLE_USES_DESCRIPTORS); + elt = (VEC_address (constructor_elt,null_vec) + + TARGET_VTABLE_USES_DESCRIPTORS - 1); for (j = 0; j < TARGET_VTABLE_USES_DESCRIPTORS; j++) { @@ -567,12 +562,14 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED, NULL_TREE, NULL_TREE, 0, 1); TREE_CHAIN (field) = field_list; field_list = field; - null_list = tree_cons (field, null_node, null_list); + elt->index = field; + elt->value = null_node; + elt--; } finish_record_type (fdesc_type_node, nreverse (field_list), 0, false); record_builtin_type ("descriptor", fdesc_type_node); - null_fdesc_node = gnat_build_constructor (fdesc_type_node, null_list); + null_fdesc_node = gnat_build_constructor (fdesc_type_node, null_vec); } long_long_float_type @@ -609,11 +606,10 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED, user available facilities for Intrinsic imports. */ gnat_install_builtins (); - gnu_except_ptr_stack = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE); - gnu_constraint_error_label_stack - = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE); - gnu_storage_error_label_stack = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE); - gnu_program_error_label_stack = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE); + VEC_safe_push (tree, gc, gnu_except_ptr_stack, NULL_TREE); + VEC_safe_push (tree, gc, gnu_constraint_error_label_stack, NULL_TREE); + VEC_safe_push (tree, gc, gnu_storage_error_label_stack, NULL_TREE); + VEC_safe_push (tree, gc, gnu_program_error_label_stack, NULL_TREE); /* Process any Pragma Ident for the main unit. */ #ifdef ASM_OUTPUT_IDENT @@ -973,7 +969,7 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) variables of non-constant size because they are automatically allocated to memory. There might be no way of allocating a proper temporary for them in any case. We only do this for SJLJ though. */ - if (TREE_VALUE (gnu_except_ptr_stack) + if (VEC_last (tree, gnu_except_ptr_stack) && TREE_CODE (gnu_result) == VAR_DECL && TREE_CODE (DECL_SIZE_UNIT (gnu_result)) == INTEGER_CST) TREE_THIS_VOLATILE (gnu_result) = TREE_SIDE_EFFECTS (gnu_result) = 1; @@ -1242,10 +1238,12 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) else if (TARGET_VTABLE_USES_DESCRIPTORS && Is_Dispatch_Table_Entity (Etype (gnat_node))) { - tree gnu_field, gnu_list = NULL_TREE, t; + tree gnu_field, t; /* Descriptors can only be built here for top-level functions. */ bool build_descriptor = (global_bindings_p () != 0); int i; + VEC(constructor_elt,gc) *gnu_vec = NULL; + constructor_elt *elt; gnu_result_type = get_unpadded_type (Etype (gnat_node)); @@ -1260,6 +1258,10 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) gnu_result = build1 (INDIRECT_REF, gnu_result_type, gnu_result); } + VEC_safe_grow (constructor_elt, gc, gnu_vec, + TARGET_VTABLE_USES_DESCRIPTORS); + elt = (VEC_address (constructor_elt, gnu_vec) + + TARGET_VTABLE_USES_DESCRIPTORS - 1); for (gnu_field = TYPE_FIELDS (gnu_result_type), i = 0; i < TARGET_VTABLE_USES_DESCRIPTORS; gnu_field = TREE_CHAIN (gnu_field), i++) @@ -1274,10 +1276,12 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) t = build3 (COMPONENT_REF, ptr_void_ftype, gnu_result, gnu_field, NULL_TREE); - gnu_list = tree_cons (gnu_field, t, gnu_list); + elt->index = gnu_field; + elt->value = t; + elt--; } - gnu_result = gnat_build_constructor (gnu_result_type, gnu_list); + gnu_result = gnat_build_constructor (gnu_result_type, gnu_vec); break; } @@ -1605,7 +1609,7 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) if (!pa) { - pa = GGC_CNEW (struct parm_attr_d); + pa = ggc_alloc_cleared_parm_attr_d (); pa->id = gnat_param; pa->dim = Dimension; VEC_safe_push (parm_attr, gc, f_parm_attr_cache, pa); @@ -1917,9 +1921,9 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) static tree Case_Statement_to_gnu (Node_Id gnat_node) { - tree gnu_result; - tree gnu_expr; + tree gnu_result, gnu_expr, gnu_label; Node_Id gnat_when; + bool may_fallthru = false; gnu_expr = gnat_to_gnu (Expression (gnat_node)); gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr); @@ -1942,10 +1946,9 @@ Case_Statement_to_gnu (Node_Id gnat_node) /* We build a SWITCH_EXPR that contains the code with interspersed CASE_LABEL_EXPRs for each label. */ - - push_stack (&gnu_switch_label_stack, NULL_TREE, - create_artificial_label (input_location)); + gnu_label = create_artificial_label (input_location); start_stmt_group (); + for (gnat_when = First_Non_Pragma (Alternatives (gnat_node)); Present (gnat_when); gnat_when = Next_Non_Pragma (gnat_when)) @@ -2023,18 +2026,22 @@ Case_Statement_to_gnu (Node_Id gnat_node) containing the Case statement. */ if (choices_added_p) { - add_stmt (build_stmt_group (Statements (gnat_when), true)); - add_stmt (build1 (GOTO_EXPR, void_type_node, - TREE_VALUE (gnu_switch_label_stack))); + tree group = build_stmt_group (Statements (gnat_when), true); + bool group_may_fallthru = block_may_fallthru (group); + add_stmt (group); + if (group_may_fallthru) + { + add_stmt (build1 (GOTO_EXPR, void_type_node, gnu_label)); + may_fallthru = true; + } } } - /* Now emit a definition of the label all the cases branched to. */ - add_stmt (build1 (LABEL_EXPR, void_type_node, - TREE_VALUE (gnu_switch_label_stack))); + /* Now emit a definition of the label the cases branch to, if any. */ + if (may_fallthru) + add_stmt (build1 (LABEL_EXPR, void_type_node, gnu_label)); gnu_result = build3 (SWITCH_EXPR, TREE_TYPE (gnu_expr), gnu_expr, end_stmt_group (), NULL_TREE); - pop_stack (&gnu_switch_label_stack); return gnu_result; } @@ -2100,7 +2107,7 @@ Loop_Statement_to_gnu (Node_Id gnat_node) /* Save the end label of this LOOP_STMT in a stack so that a corresponding N_Exit_Statement can find it. */ - push_stack (&gnu_loop_label_stack, NULL_TREE, gnu_loop_label); + VEC_safe_push (tree, gc, gnu_loop_label_stack, gnu_loop_label); /* Set the condition under which the loop must keep going. For the case "LOOP .... END LOOP;" the condition is always true. */ @@ -2317,7 +2324,7 @@ Loop_Statement_to_gnu (Node_Id gnat_node) else gnu_result = gnu_loop_stmt; - pop_stack (&gnu_loop_label_stack); + VEC_pop (tree, gnu_loop_label_stack); return gnu_result; } @@ -2441,7 +2448,7 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) /* Initialize the information structure for the function. */ allocate_struct_function (gnu_subprog_decl, false); DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language - = GGC_CNEW (struct language_function); + = ggc_alloc_cleared_language_function (); set_cfun (NULL); begin_subprog_body (gnu_subprog_decl); @@ -2450,9 +2457,10 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) properly copies them out. We do this by making a new block and converting any inner return into a goto to a label at the end of the block. */ gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type); - push_stack (&gnu_return_label_stack, NULL_TREE, - gnu_cico_list ? create_artificial_label (input_location) - : NULL_TREE); + VEC_safe_push (tree, gc, gnu_return_label_stack, + gnu_cico_list + ? create_artificial_label (input_location) + : NULL_TREE); /* Get a tree corresponding to the code for the subprogram. */ start_stmt_group (); @@ -2470,9 +2478,8 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) { /* Skip any entries that have been already filled in; they must correspond to In Out parameters. */ - for (; gnu_cico_list && TREE_VALUE (gnu_cico_list); - gnu_cico_list = TREE_CHAIN (gnu_cico_list)) - ; + while (gnu_cico_list && TREE_VALUE (gnu_cico_list)) + gnu_cico_list = TREE_CHAIN (gnu_cico_list); /* Do any needed references for padded types. */ TREE_VALUE (gnu_cico_list) @@ -2540,7 +2547,7 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) We need to make a block that contains the definition of that label and the copying of the return value. It first contains the function, then the label and copy statement. */ - if (TREE_VALUE (gnu_return_label_stack)) + if (VEC_last (tree, gnu_return_label_stack)) { tree gnu_retval; @@ -2548,14 +2555,14 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) gnat_pushlevel (); add_stmt (gnu_result); add_stmt (build1 (LABEL_EXPR, void_type_node, - TREE_VALUE (gnu_return_label_stack))); + VEC_last (tree, gnu_return_label_stack))); gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type); if (list_length (gnu_cico_list) == 1) gnu_retval = TREE_VALUE (gnu_cico_list); else - gnu_retval = gnat_build_constructor (TREE_TYPE (gnu_subprog_type), - gnu_cico_list); + gnu_retval = build_constructor_from_list (TREE_TYPE (gnu_subprog_type), + gnu_cico_list); add_stmt_with_node (build_return_expr (gnu_result_decl, gnu_retval), End_Label (Handled_Statement_Sequence (gnat_node))); @@ -2563,7 +2570,7 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) gnu_result = end_stmt_group (); } - pop_stack (&gnu_return_label_stack); + VEC_pop (tree, gnu_return_label_stack); /* Set the end location. */ Sloc_to_locus @@ -2666,7 +2673,7 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) so we can give them the scope of the elaboration routine at top level. */ else if (!current_function_decl) { - current_function_decl = TREE_VALUE (gnu_elab_proc_stack); + current_function_decl = VEC_last (tree, gnu_elab_proc_stack); went_into_elab_proc = true; } @@ -3260,12 +3267,13 @@ Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node) start_stmt_group (); gnat_pushlevel (); - push_stack (&gnu_except_ptr_stack, NULL_TREE, - create_var_decl (get_identifier ("EXCEPT_PTR"), - NULL_TREE, - build_pointer_type (except_type_node), - build_call_0_expr (get_excptr_decl), false, - false, false, false, NULL, gnat_node)); + VEC_safe_push (tree, gc, gnu_except_ptr_stack, + create_var_decl (get_identifier ("EXCEPT_PTR"), + NULL_TREE, + build_pointer_type (except_type_node), + build_call_0_expr (get_excptr_decl), + false, + false, false, false, NULL, gnat_node)); /* Generate code for each handler. The N_Exception_Handler case does the real work and returns a COND_EXPR for each handler, which we chain @@ -3289,7 +3297,7 @@ Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node) /* If none of the exception handlers did anything, re-raise but do not defer abortion. */ gnu_expr = build_call_1_expr (raise_nodefer_decl, - TREE_VALUE (gnu_except_ptr_stack)); + VEC_last (tree, gnu_except_ptr_stack)); set_expr_location_from_node (gnu_expr, Present (End_Label (gnat_node)) ? End_Label (gnat_node) : gnat_node); @@ -3301,7 +3309,7 @@ Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node) /* End the binding level dedicated to the exception handlers and get the whole statement group. */ - pop_stack (&gnu_except_ptr_stack); + VEC_pop (tree, gnu_except_ptr_stack); gnat_poplevel (); gnu_handler = end_stmt_group (); @@ -3385,7 +3393,7 @@ Exception_Handler_to_gnu_sjlj (Node_Id gnat_node) build_component_ref (build_unary_op (INDIRECT_REF, NULL_TREE, - TREE_VALUE (gnu_except_ptr_stack)), + VEC_last (tree, gnu_except_ptr_stack)), get_identifier ("not_handled_by_others"), NULL_TREE, false)), integer_zero_node); @@ -3406,8 +3414,9 @@ Exception_Handler_to_gnu_sjlj (Node_Id gnat_node) this_choice = build_binary_op - (EQ_EXPR, boolean_type_node, TREE_VALUE (gnu_except_ptr_stack), - convert (TREE_TYPE (TREE_VALUE (gnu_except_ptr_stack)), + (EQ_EXPR, boolean_type_node, + VEC_last (tree, gnu_except_ptr_stack), + convert (TREE_TYPE (VEC_last (tree, gnu_except_ptr_stack)), build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr))); /* If this is the distinguished exception "Non_Ada_Error" (and we are @@ -3418,7 +3427,7 @@ Exception_Handler_to_gnu_sjlj (Node_Id gnat_node) tree gnu_comp = build_component_ref (build_unary_op (INDIRECT_REF, NULL_TREE, - TREE_VALUE (gnu_except_ptr_stack)), + VEC_last (tree, gnu_except_ptr_stack)), get_identifier ("lang"), NULL_TREE, false); this_choice @@ -3555,7 +3564,7 @@ Compilation_Unit_to_gnu (Node_Id gnat_node) NULL_TREE, void_ftype, NULL_TREE, false, true, false, NULL, gnat_unit); struct elab_info *info; - push_stack (&gnu_elab_proc_stack, NULL_TREE, gnu_elab_proc_decl); + VEC_safe_push (tree, gc, gnu_elab_proc_stack, gnu_elab_proc_decl); DECL_ELABORATION_PROC_P (gnu_elab_proc_decl) = 1; /* Initialize the information structure for the function. */ @@ -3626,7 +3635,7 @@ Compilation_Unit_to_gnu (Node_Id gnat_node) /* Save away what we've made so far and record this potential elaboration procedure. */ - info = (struct elab_info *) ggc_alloc (sizeof (struct elab_info)); + info = ggc_alloc_elab_info (); set_current_block_context (gnu_elab_proc_decl); gnat_poplevel (); DECL_SAVED_TREE (gnu_elab_proc_decl) = end_stmt_group (); @@ -3642,7 +3651,7 @@ Compilation_Unit_to_gnu (Node_Id gnat_node) /* Generate elaboration code for this unit, if necessary, and say whether we did or not. */ - pop_stack (&gnu_elab_proc_stack); + VEC_pop (tree, gnu_elab_proc_stack); /* Invalidate the global renaming pointers. This is necessary because stabilization of the renamed entities may create SAVE_EXPRs which @@ -3744,7 +3753,7 @@ gnat_to_gnu (Node_Id gnat_node) the elaboration procedure, so mark us as being in that procedure. */ if (!current_function_decl) { - current_function_decl = TREE_VALUE (gnu_elab_proc_stack); + current_function_decl = VEC_last (tree, gnu_elab_proc_stack); went_into_elab_proc = true; } @@ -3755,7 +3764,7 @@ gnat_to_gnu (Node_Id gnat_node) every nested real statement instead. This also avoids triggering spurious errors on dummy (empty) sequences created by the front-end for package bodies in some cases. */ - if (current_function_decl == TREE_VALUE (gnu_elab_proc_stack) + if (current_function_decl == VEC_last (tree, gnu_elab_proc_stack) && kind != N_Handled_Sequence_Of_Statements) Check_Elaboration_Code_Allowed (gnat_node); } @@ -3918,24 +3927,21 @@ gnat_to_gnu (Node_Id gnat_node) String_Id gnat_string = Strval (gnat_node); int length = String_Length (gnat_string); int i; - tree gnu_list = NULL_TREE; tree gnu_idx = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type)); + VEC(constructor_elt,gc) *gnu_vec + = VEC_alloc (constructor_elt, gc, length); for (i = 0; i < length; i++) { - gnu_list - = tree_cons (gnu_idx, - build_int_cst (TREE_TYPE (gnu_result_type), - Get_String_Char (gnat_string, - i + 1)), - gnu_list); + tree t = build_int_cst (TREE_TYPE (gnu_result_type), + Get_String_Char (gnat_string, i + 1)); + CONSTRUCTOR_APPEND_ELT (gnu_vec, gnu_idx, t); gnu_idx = int_const_binop (PLUS_EXPR, gnu_idx, integer_one_node, 0); } - gnu_result - = gnat_build_constructor (gnu_result_type, nreverse (gnu_list)); + gnu_result = gnat_build_constructor (gnu_result_type, gnu_vec); } break; @@ -4323,7 +4329,7 @@ gnat_to_gnu (Node_Id gnat_node) gnu_aggr_type = TYPE_REPRESENTATIVE_ARRAY (gnu_result_type); if (Null_Record_Present (gnat_node)) - gnu_result = gnat_build_constructor (gnu_aggr_type, NULL_TREE); + gnu_result = gnat_build_constructor (gnu_aggr_type, NULL); else if (TREE_CODE (gnu_aggr_type) == RECORD_TYPE || TREE_CODE (gnu_aggr_type) == UNION_TYPE) @@ -4879,7 +4885,7 @@ gnat_to_gnu (Node_Id gnat_node) ? gnat_to_gnu (Condition (gnat_node)) : NULL_TREE), (Present (Name (gnat_node)) ? get_gnu_tree (Entity (Name (gnat_node))) - : TREE_VALUE (gnu_loop_label_stack))); + : VEC_last (tree, gnu_loop_label_stack))); break; case N_Return_Statement: @@ -4888,13 +4894,13 @@ gnat_to_gnu (Node_Id gnat_node) /* If we have a return label defined, convert this into a branch to that label. The return proper will be handled elsewhere. */ - if (TREE_VALUE (gnu_return_label_stack)) + if (VEC_last (tree, gnu_return_label_stack)) { gnu_result = build1 (GOTO_EXPR, void_type_node, - TREE_VALUE (gnu_return_label_stack)); + VEC_last (tree, gnu_return_label_stack)); /* When not optimizing, make sure the return is preserved. */ if (!optimize && Comes_From_Source (gnat_node)) - DECL_ARTIFICIAL (TREE_VALUE (gnu_return_label_stack)) = 0; + DECL_ARTIFICIAL (VEC_last (tree, gnu_return_label_stack)) = 0; break; } @@ -5154,18 +5160,15 @@ gnat_to_gnu (Node_Id gnat_node) break; case N_Pop_Constraint_Error_Label: - gnu_constraint_error_label_stack - = TREE_CHAIN (gnu_constraint_error_label_stack); + VEC_pop (tree, gnu_constraint_error_label_stack); break; case N_Pop_Storage_Error_Label: - gnu_storage_error_label_stack - = TREE_CHAIN (gnu_storage_error_label_stack); + VEC_pop (tree, gnu_storage_error_label_stack); break; case N_Pop_Program_Error_Label: - gnu_program_error_label_stack - = TREE_CHAIN (gnu_program_error_label_stack); + VEC_pop (tree, gnu_program_error_label_stack); break; /******************************/ @@ -5327,6 +5330,19 @@ gnat_to_gnu (Node_Id gnat_node) /* Added Nodes */ /****************/ + case N_Expression_With_Actions: + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + /* This construct doesn't define a scope so we don't wrap the statement + list in a BIND_EXPR; however, we wrap it in a SAVE_EXPR to protect it + from unsharing. */ + gnu_result = build_stmt_group (Actions (gnat_node), false); + gnu_result = build1 (SAVE_EXPR, void_type_node, gnu_result); + TREE_SIDE_EFFECTS (gnu_result) = 1; + gnu_expr = gnat_to_gnu (Expression (gnat_node)); + gnu_result + = build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_result, gnu_expr); + break; + case N_Freeze_Entity: start_stmt_group (); process_freeze_entity (gnat_node); @@ -5546,17 +5562,11 @@ gnat_to_gnu (Node_Id gnat_node) convert (gnu_result_type, boolean_false_node)); - /* Set the location information on the result if it is a real expression. - References can be reused for multiple GNAT nodes and they would get - the location information of their last use. Note that we may have + /* Set the location information on the result. Note that we may have no result if we tried to build a CALL_EXPR node to a procedure with no side-effects and optimization is enabled. */ - if (gnu_result - && EXPR_P (gnu_result) - && TREE_CODE (gnu_result) != NOP_EXPR - && !REFERENCE_CLASS_P (gnu_result) - && !EXPR_HAS_LOCATION (gnu_result)) - set_expr_location_from_node (gnu_result, gnat_node); + if (gnu_result && EXPR_P (gnu_result)) + set_gnu_expr_location_from_node (gnu_result, gnat_node); /* If we're supposed to return something of void_type, it means we have something we're elaborating for effect, so just return. */ @@ -5682,13 +5692,13 @@ gnat_to_gnu (Node_Id gnat_node) label to push onto the stack. */ static void -push_exception_label_stack (tree *gnu_stack, Entity_Id gnat_label) +push_exception_label_stack (VEC(tree,gc) **gnu_stack, Entity_Id gnat_label) { tree gnu_label = (Present (gnat_label) ? gnat_to_gnu_entity (gnat_label, NULL_TREE, 0) : NULL_TREE); - *gnu_stack = tree_cons (NULL_TREE, gnu_label, *gnu_stack); + VEC_safe_push (tree, gc, *gnu_stack, gnu_label); } /* Record the current code position in GNAT_NODE. */ @@ -5722,7 +5732,7 @@ start_stmt_group (void) if (group) stmt_group_free_list = group->previous; else - group = (struct stmt_group *) ggc_alloc (sizeof (struct stmt_group)); + group = ggc_alloc_stmt_group (); group->previous = current_stmt_group; group->stmt_list = group->block = group->cleanups = NULL_TREE; @@ -5938,37 +5948,6 @@ build_stmt_group (List_Id gnat_list, bool binding_p) return end_stmt_group (); } -/* Push and pop routines for stacks. We keep a free list around so we - don't waste tree nodes. */ - -static void -push_stack (tree *gnu_stack_ptr, tree gnu_purpose, tree gnu_value) -{ - tree gnu_node = gnu_stack_free_list; - - if (gnu_node) - { - gnu_stack_free_list = TREE_CHAIN (gnu_node); - TREE_CHAIN (gnu_node) = *gnu_stack_ptr; - TREE_PURPOSE (gnu_node) = gnu_purpose; - TREE_VALUE (gnu_node) = gnu_value; - } - else - gnu_node = tree_cons (gnu_purpose, gnu_value, *gnu_stack_ptr); - - *gnu_stack_ptr = gnu_node; -} - -static void -pop_stack (tree *gnu_stack_ptr) -{ - tree gnu_node = *gnu_stack_ptr; - - *gnu_stack_ptr = TREE_CHAIN (gnu_node); - TREE_CHAIN (gnu_node) = gnu_stack_free_list; - gnu_stack_free_list = gnu_node; -} - /* Generate GIMPLE in place for the expression at *EXPR_P. */ int @@ -7340,9 +7319,9 @@ static tree pos_to_constructor (Node_Id gnat_expr, tree gnu_array_type, Entity_Id gnat_component_type) { - tree gnu_expr_list = NULL_TREE; tree gnu_index = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_array_type)); tree gnu_expr; + VEC(constructor_elt,gc) *gnu_expr_vec = NULL; for ( ; Present (gnat_expr); gnat_expr = Next (gnat_expr)) { @@ -7365,14 +7344,13 @@ pos_to_constructor (Node_Id gnat_expr, tree gnu_array_type, gnu_expr = emit_range_check (gnu_expr, gnat_component_type, Empty); } - gnu_expr_list - = tree_cons (gnu_index, convert (TREE_TYPE (gnu_array_type), gnu_expr), - gnu_expr_list); + CONSTRUCTOR_APPEND_ELT (gnu_expr_vec, gnu_index, + convert (TREE_TYPE (gnu_array_type), gnu_expr)); gnu_index = int_const_binop (PLUS_EXPR, gnu_index, integer_one_node, 0); } - return gnat_build_constructor (gnu_array_type, nreverse (gnu_expr_list)); + return gnat_build_constructor (gnu_array_type, gnu_expr_vec); } /* Subroutine of assoc_to_constructor: VALUES is a list of field associations, @@ -7383,8 +7361,8 @@ pos_to_constructor (Node_Id gnat_expr, tree gnu_array_type, static tree extract_values (tree values, tree record_type) { - tree result = NULL_TREE; tree field, tem; + VEC(constructor_elt,gc) *v = NULL; for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field)) { @@ -7418,10 +7396,10 @@ extract_values (tree values, tree record_type) if (!value) continue; - result = tree_cons (field, value, result); + CONSTRUCTOR_APPEND_ELT (v, field, value); } - return gnat_build_constructor (record_type, nreverse (result)); + return gnat_build_constructor (record_type, v); } /* EXP is to be treated as an array or record. Handle the cases when it is @@ -7491,6 +7469,37 @@ set_expr_location_from_node (tree node, Node_Id gnat_node) SET_EXPR_LOCATION (node, locus); } + +/* More elaborate version of set_expr_location_from_node to be used in more + general contexts, for example the result of the translation of a generic + GNAT node. */ + +static void +set_gnu_expr_location_from_node (tree node, Node_Id gnat_node) +{ + /* Set the location information on the node if it is a real expression. + References can be reused for multiple GNAT nodes and they would get + the location information of their last use. Also make sure not to + overwrite an existing location as it is probably more precise. */ + + switch (TREE_CODE (node)) + { + CASE_CONVERT: + case NON_LVALUE_EXPR: + break; + + case COMPOUND_EXPR: + if (EXPR_P (TREE_OPERAND (node, 1))) + set_gnu_expr_location_from_node (TREE_OPERAND (node, 1), gnat_node); + + /* ... fall through ... */ + + default: + if (!REFERENCE_CLASS_P (node) && !EXPR_HAS_LOCATION (node)) + set_expr_location_from_node (node, gnat_node); + break; + } +} /* Return a colon-separated list of encodings contained in encoded Ada name. */ @@ -7498,7 +7507,7 @@ set_expr_location_from_node (tree node, Node_Id gnat_node) static const char * extract_encoding (const char *name) { - char *encoding = GGC_NEWVEC (char, strlen (name)); + char *encoding = (char *) ggc_alloc_atomic (strlen (name)); get_encoding (name, encoding); return encoding; } @@ -7508,7 +7517,7 @@ extract_encoding (const char *name) static const char * decode_name (const char *name) { - char *decoded = GGC_NEWVEC (char, strlen (name) * 2 + 60); + char *decoded = (char *) ggc_alloc_atomic (strlen (name) * 2 + 60); __gnat_decode (name, decoded, 0); return decoded; } @@ -7641,11 +7650,11 @@ tree get_exception_label (char kind) { if (kind == N_Raise_Constraint_Error) - return TREE_VALUE (gnu_constraint_error_label_stack); + return VEC_last (tree, gnu_constraint_error_label_stack); else if (kind == N_Raise_Storage_Error) - return TREE_VALUE (gnu_storage_error_label_stack); + return VEC_last (tree, gnu_storage_error_label_stack); else if (kind == N_Raise_Program_Error) - return TREE_VALUE (gnu_program_error_label_stack); + return VEC_last (tree, gnu_program_error_label_stack); else return NULL_TREE; } diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c index f10b788fe1a..c5d612da91b 100644 --- a/gcc/ada/gcc-interface/utils.c +++ b/gcc/ada/gcc-interface/utils.c @@ -206,8 +206,7 @@ static void process_attributes (tree, struct attrib *); void init_gnat_to_gnu (void) { - associate_gnat_to_gnu - = (tree *) ggc_alloc_cleared (max_gnat_nodes * sizeof (tree)); + associate_gnat_to_gnu = ggc_alloc_cleared_vec_tree (max_gnat_nodes); } /* GNAT_ENTITY is a GNAT tree node for an entity. GNU_DECL is the GCC tree @@ -257,8 +256,7 @@ present_gnu_tree (Entity_Id gnat_entity) void init_dummy_type (void) { - dummy_node_table - = (tree *) ggc_alloc_cleared (max_gnat_nodes * sizeof (tree)); + dummy_node_table = ggc_alloc_cleared_vec_tree (max_gnat_nodes); } /* Make a dummy type corresponding to GNAT_TYPE. */ @@ -321,9 +319,7 @@ gnat_pushlevel (void) free_binding_level = free_binding_level->chain; } else - newlevel - = (struct gnat_binding_level *) - ggc_alloc (sizeof (struct gnat_binding_level)); + newlevel = ggc_alloc_gnat_binding_level (); /* Use a free BLOCK, if any; otherwise, allocate one. */ if (free_block_chain) @@ -2226,7 +2222,7 @@ max_size (tree exp, bool max_p) tree build_template (tree template_type, tree array_type, tree expr) { - tree template_elts = NULL_TREE; + VEC(constructor_elt,gc) *template_elts = NULL; tree bound_list = NULL_TREE; tree field; @@ -2275,11 +2271,11 @@ build_template (tree template_type, tree array_type, tree expr) min = SUBSTITUTE_PLACEHOLDER_IN_EXPR (min, expr); max = SUBSTITUTE_PLACEHOLDER_IN_EXPR (max, expr); - template_elts = tree_cons (TREE_CHAIN (field), max, - tree_cons (field, min, template_elts)); + CONSTRUCTOR_APPEND_ELT (template_elts, field, min); + CONSTRUCTOR_APPEND_ELT (template_elts, TREE_CHAIN (field), max); } - return gnat_build_constructor (template_type, nreverse (template_elts)); + return gnat_build_constructor (template_type, template_elts); } /* Build a 32-bit VMS descriptor from a Mechanism_Type, which must specify a @@ -2954,6 +2950,7 @@ convert_vms_descriptor64 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog) /* See the head comment of build_vms_descriptor. */ int iklass = TREE_INT_CST_LOW (DECL_INITIAL (klass)); tree lfield, ufield; + VEC(constructor_elt,gc) *v; /* Convert POINTER to the pointer-to-array type. */ gnu_expr64 = convert (p_array_type, gnu_expr64); @@ -2963,14 +2960,15 @@ convert_vms_descriptor64 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog) case 1: /* Class S */ case 15: /* Class SB */ /* Build {1, LENGTH} template; LENGTH64 is the 5th field. */ + v = VEC_alloc (constructor_elt, gc, 2); t = TREE_CHAIN (TREE_CHAIN (klass)); t = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); - t = tree_cons (min_field, - convert (TREE_TYPE (min_field), integer_one_node), - tree_cons (max_field, - convert (TREE_TYPE (max_field), t), - NULL_TREE)); - template_tree = gnat_build_constructor (template_type, t); + CONSTRUCTOR_APPEND_ELT (v, min_field, + convert (TREE_TYPE (min_field), + integer_one_node)); + CONSTRUCTOR_APPEND_ELT (v, max_field, + convert (TREE_TYPE (max_field), t)); + template_tree = gnat_build_constructor (template_type, v); template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template_tree); /* For class S, we are done. */ @@ -2994,10 +2992,11 @@ convert_vms_descriptor64 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog) (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (template_type))), ufield); /* Build the template in the form of a constructor. */ - t = tree_cons (TYPE_FIELDS (template_type), lfield, - tree_cons (TREE_CHAIN (TYPE_FIELDS (template_type)), - ufield, NULL_TREE)); - template_tree = gnat_build_constructor (template_type, t); + v = VEC_alloc (constructor_elt, gc, 2); + CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (template_type), lfield); + CONSTRUCTOR_APPEND_ELT (v, TREE_CHAIN (TYPE_FIELDS (template_type)), + ufield); + template_tree = gnat_build_constructor (template_type, v); /* Otherwise use the {1, LENGTH} template we build above. */ template_addr = build3 (COND_EXPR, p_bounds_type, u, @@ -3041,10 +3040,11 @@ convert_vms_descriptor64 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog) (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (template_type))), ufield); /* Build the template in the form of a constructor. */ - t = tree_cons (TYPE_FIELDS (template_type), lfield, - tree_cons (TREE_CHAIN (TYPE_FIELDS (template_type)), - ufield, NULL_TREE)); - template_tree = gnat_build_constructor (template_type, t); + v = VEC_alloc (constructor_elt, gc, 2); + CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (template_type), lfield); + CONSTRUCTOR_APPEND_ELT (v, TREE_CHAIN (TYPE_FIELDS (template_type)), + ufield); + template_tree = gnat_build_constructor (template_type, v); template_tree = build3 (COND_EXPR, template_type, u, build_call_raise (CE_Length_Check_Failed, Empty, N_Raise_Constraint_Error), @@ -3061,10 +3061,11 @@ convert_vms_descriptor64 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog) } /* Build the fat pointer in the form of a constructor. */ - t = tree_cons (TYPE_FIELDS (gnu_type), gnu_expr64, - tree_cons (TREE_CHAIN (TYPE_FIELDS (gnu_type)), - template_addr, NULL_TREE)); - return gnat_build_constructor (gnu_type, t); + v = VEC_alloc (constructor_elt, gc, 2); + CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (gnu_type), gnu_expr64); + CONSTRUCTOR_APPEND_ELT (v, TREE_CHAIN (TYPE_FIELDS (gnu_type)), + template_addr); + return gnat_build_constructor (gnu_type, v); } else @@ -3102,6 +3103,7 @@ convert_vms_descriptor32 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog) tree template_tree, template_addr, aflags, dimct, t, u; /* See the head comment of build_vms_descriptor. */ int iklass = TREE_INT_CST_LOW (DECL_INITIAL (klass)); + VEC(constructor_elt,gc) *v; /* Convert POINTER to the pointer-to-array type. */ gnu_expr32 = convert (p_array_type, gnu_expr32); @@ -3111,14 +3113,15 @@ convert_vms_descriptor32 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog) case 1: /* Class S */ case 15: /* Class SB */ /* Build {1, LENGTH} template; LENGTH is the 1st field. */ + v = VEC_alloc (constructor_elt, gc, 2); t = TYPE_FIELDS (desc_type); t = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); - t = tree_cons (min_field, - convert (TREE_TYPE (min_field), integer_one_node), - tree_cons (max_field, - convert (TREE_TYPE (max_field), t), - NULL_TREE)); - template_tree = gnat_build_constructor (template_type, t); + CONSTRUCTOR_APPEND_ELT (v, min_field, + convert (TREE_TYPE (min_field), + integer_one_node)); + CONSTRUCTOR_APPEND_ELT (v, max_field, + convert (TREE_TYPE (max_field), t)); + template_tree = gnat_build_constructor (template_type, v); template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template_tree); /* For class S, we are done. */ @@ -3182,11 +3185,12 @@ convert_vms_descriptor32 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog) } /* Build the fat pointer in the form of a constructor. */ - t = tree_cons (TYPE_FIELDS (gnu_type), gnu_expr32, - tree_cons (TREE_CHAIN (TYPE_FIELDS (gnu_type)), - template_addr, NULL_TREE)); + v = VEC_alloc (constructor_elt, gc, 2); + CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (gnu_type), gnu_expr32); + CONSTRUCTOR_APPEND_ELT (v, TREE_CHAIN (TYPE_FIELDS (gnu_type)), + template_addr); - return gnat_build_constructor (gnu_type, t); + return gnat_build_constructor (gnu_type, v); } else @@ -3465,7 +3469,7 @@ update_pointer_to (tree old_type, tree new_type) { tree new_ptr = TYPE_MAIN_VARIANT (TYPE_POINTER_TO (new_type)); tree new_obj_rec = TYPE_OBJECT_RECORD_TYPE (new_type); - tree array_field, bounds_field, new_ref, last; + tree array_field, bounds_field, new_ref, last = NULL_TREE; gcc_assert (TYPE_IS_FAT_POINTER_P (ptr)); @@ -3555,19 +3559,19 @@ convert_to_fat_pointer (tree type, tree expr) tree p_array_type = TREE_TYPE (TYPE_FIELDS (type)); tree etype = TREE_TYPE (expr); tree template_tree; + VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 2); /* If EXPR is null, make a fat pointer that contains null pointers to the template and array. */ if (integer_zerop (expr)) - return - gnat_build_constructor - (type, - tree_cons (TYPE_FIELDS (type), - convert (p_array_type, expr), - tree_cons (TREE_CHAIN (TYPE_FIELDS (type)), - convert (build_pointer_type (template_type), - expr), - NULL_TREE))); + { + CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type), + convert (p_array_type, expr)); + CONSTRUCTOR_APPEND_ELT (v, TREE_CHAIN (TYPE_FIELDS (type)), + convert (build_pointer_type (template_type), + expr)); + return gnat_build_constructor (type, v); + } /* If EXPR is a thin pointer, make template and data from the record.. */ else if (TYPE_IS_THIN_POINTER_P (etype)) @@ -3602,15 +3606,12 @@ convert_to_fat_pointer (tree type, tree expr) Note that the call to "build_template" above is still fine because it will only refer to the provided TEMPLATE_TYPE in this case. */ - return - gnat_build_constructor - (type, - tree_cons (TYPE_FIELDS (type), - convert (p_array_type, expr), - tree_cons (TREE_CHAIN (TYPE_FIELDS (type)), - build_unary_op (ADDR_EXPR, NULL_TREE, - template_tree), - NULL_TREE))); + CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type), + convert (p_array_type, expr)); + CONSTRUCTOR_APPEND_ELT (v, TREE_CHAIN (TYPE_FIELDS (type)), + build_unary_op (ADDR_EXPR, NULL_TREE, + template_tree)); + return gnat_build_constructor (type, v); } /* Convert to a thin pointer type, TYPE. The only thing we know how to convert @@ -3667,6 +3668,8 @@ convert (tree type, tree expr) constructor to build the record, unless a variable size is involved. */ else if (code == RECORD_TYPE && TYPE_PADDING_P (type)) { + VEC(constructor_elt,gc) *v; + /* If we previously converted from another type and our type is of variable size, remove the conversion to avoid the need for variable-sized temporaries. Likewise for a conversion between @@ -3717,13 +3720,10 @@ convert (tree type, tree expr) expr), false); - return - gnat_build_constructor (type, - tree_cons (TYPE_FIELDS (type), - convert (TREE_TYPE - (TYPE_FIELDS (type)), - expr), - NULL_TREE)); + v = VEC_alloc (constructor_elt, gc, 1); + CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type), + convert (TREE_TYPE (TYPE_FIELDS (type)), expr)); + return gnat_build_constructor (type, v); } /* If the input type has padding, remove it and convert to the output type. @@ -3775,20 +3775,19 @@ convert (tree type, tree expr) if (code == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (type)) { tree obj_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type))); + VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 2); /* If the source already has a template, get a reference to the associated array only, as we are going to rebuild a template for the target type anyway. */ expr = maybe_unconstrained_array (expr); - return - gnat_build_constructor - (type, - tree_cons (TYPE_FIELDS (type), - build_template (TREE_TYPE (TYPE_FIELDS (type)), - obj_type, NULL_TREE), - tree_cons (TREE_CHAIN (TYPE_FIELDS (type)), - convert (obj_type, expr), NULL_TREE))); + CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type), + build_template (TREE_TYPE (TYPE_FIELDS (type)), + obj_type, NULL_TREE)); + CONSTRUCTOR_APPEND_ELT (v, TREE_CHAIN (TYPE_FIELDS (type)), + convert (obj_type, expr)); + return gnat_build_constructor (type, v); } /* There are some special cases of expressions that we process @@ -4118,11 +4117,14 @@ convert (tree type, tree expr) case RECORD_TYPE: if (TYPE_JUSTIFIED_MODULAR_P (type) && !AGGREGATE_TYPE_P (etype)) - return - gnat_build_constructor - (type, tree_cons (TYPE_FIELDS (type), - convert (TREE_TYPE (TYPE_FIELDS (type)), expr), - NULL_TREE)); + { + VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 1); + + CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type), + convert (TREE_TYPE (TYPE_FIELDS (type)), + expr)); + return gnat_build_constructor (type, v); + } /* ... fall through ... */ @@ -4414,11 +4416,13 @@ unchecked_convert (tree type, tree expr, bool notrunc_p) tree rec_type = make_node (RECORD_TYPE); tree field = create_field_decl (get_identifier ("OBJ"), etype, rec_type, NULL_TREE, NULL_TREE, 1, 0); + VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 1); TYPE_FIELDS (rec_type) = field; layout_type (rec_type); - expr = gnat_build_constructor (rec_type, build_tree_list (field, expr)); + CONSTRUCTOR_APPEND_ELT (v, field, expr); + expr = gnat_build_constructor (rec_type, v); expr = unchecked_convert (type, expr, notrunc_p); } diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c index 1c224a3ef07..ab3814ec4e0 100644 --- a/gcc/ada/gcc-interface/utils2.c +++ b/gcc/ada/gcc-interface/utils2.c @@ -1521,34 +1521,31 @@ build_call_raise (int msg, Node_Id gnat_node, char kind) static int compare_elmt_bitpos (const PTR rt1, const PTR rt2) { - const_tree const elmt1 = * (const_tree const *) rt1; - const_tree const elmt2 = * (const_tree const *) rt2; - const_tree const field1 = TREE_PURPOSE (elmt1); - const_tree const field2 = TREE_PURPOSE (elmt2); + const constructor_elt * const elmt1 = (const constructor_elt const *) rt1; + const constructor_elt * const elmt2 = (const constructor_elt const *) rt2; + const_tree const field1 = elmt1->index; + const_tree const field2 = elmt2->index; const int ret = tree_int_cst_compare (bit_position (field1), bit_position (field2)); return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2)); } -/* Return a CONSTRUCTOR of TYPE whose list is LIST. */ +/* Return a CONSTRUCTOR of TYPE whose elements are V. */ tree -gnat_build_constructor (tree type, tree list) +gnat_build_constructor (tree type, VEC(constructor_elt,gc) *v) { bool allconstant = (TREE_CODE (TYPE_SIZE (type)) == INTEGER_CST); bool side_effects = false; - tree elmt, result; - int n_elmts; + tree result, obj, val; + unsigned int n_elmts; /* Scan the elements to see if they are all constant or if any has side effects, to let us set global flags on the resulting constructor. Count the elements along the way for possible sorting purposes below. */ - for (n_elmts = 0, elmt = list; elmt; elmt = TREE_CHAIN (elmt), n_elmts ++) + FOR_EACH_CONSTRUCTOR_ELT (v, n_elmts, obj, val) { - tree obj = TREE_PURPOSE (elmt); - tree val = TREE_VALUE (elmt); - /* The predicate must be in keeping with output_constructor. */ if (!TREE_CONSTANT (val) || (TREE_CODE (type) == RECORD_TYPE @@ -1565,27 +1562,10 @@ gnat_build_constructor (tree type, tree list) by increasing bit position. This is necessary to ensure the constructor can be output as static data. */ if (allconstant && TREE_CODE (type) == RECORD_TYPE && n_elmts > 1) - { - /* Fill an array with an element tree per index, and ask qsort to order - them according to what a bitpos comparison function says. */ - tree *gnu_arr = (tree *) alloca (sizeof (tree) * n_elmts); - int i; - - for (i = 0, elmt = list; elmt; elmt = TREE_CHAIN (elmt), i++) - gnu_arr[i] = elmt; + qsort (VEC_address (constructor_elt, v), n_elmts, + sizeof (constructor_elt), compare_elmt_bitpos); - qsort (gnu_arr, n_elmts, sizeof (tree), compare_elmt_bitpos); - - /* Then reconstruct the list from the sorted array contents. */ - list = NULL_TREE; - for (i = n_elmts - 1; i >= 0; i--) - { - TREE_CHAIN (gnu_arr[i]) = list; - list = gnu_arr[i]; - } - } - - result = build_constructor_from_list (type, list); + result = build_constructor (type, v); TREE_CONSTANT (result) = TREE_STATIC (result) = allconstant; TREE_SIDE_EFFECTS (result) = side_effects; TREE_READONLY (result) = TYPE_READONLY (type) || allconstant; @@ -1823,13 +1803,12 @@ maybe_wrap_malloc (tree data_size, tree data_type, Node_Id gnat_node) tree malloc_ptr; - /* On VMS, if 64-bit memory is disabled or pointers are 64-bit and the - allocator size is 32-bit or Convention C, allocate 32-bit memory. */ + /* On VMS, if pointers are 64-bit and the allocator size is 32-bit or + Convention C, allocate 32-bit memory. */ if (TARGET_ABI_OPEN_VMS - && (!TARGET_MALLOC64 - || (POINTER_SIZE == 64 - && (UI_To_Int (Esize (Etype (gnat_node))) == 32 - || Convention (Etype (gnat_node)) == Convention_C)))) + && (POINTER_SIZE == 64 + && (UI_To_Int (Esize (Etype (gnat_node))) == 32 + || Convention (Etype (gnat_node)) == Convention_C))) malloc_ptr = build_call_1_expr (malloc32_decl, size_to_malloc); else malloc_ptr = build_call_1_expr (malloc_decl, size_to_malloc); @@ -1987,7 +1966,6 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc, tree template_type = TREE_TYPE (TYPE_FIELDS (storage_type)); tree storage_ptr_type = build_pointer_type (storage_type); tree storage; - tree template_cons = NULL_TREE; size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (storage_type), init); @@ -2014,12 +1992,12 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc, bounds. */ if (init) { - template_cons = tree_cons (TREE_CHAIN (TYPE_FIELDS (storage_type)), - init, NULL_TREE); - template_cons = tree_cons (TYPE_FIELDS (storage_type), - build_template (template_type, type, - init), - template_cons); + VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 2); + + CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (storage_type), + build_template (template_type, type, init)); + CONSTRUCTOR_APPEND_ELT (v, TREE_CHAIN (TYPE_FIELDS (storage_type)), + init); return convert (result_type, @@ -2028,7 +2006,7 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc, (MODIFY_EXPR, storage_type, build_unary_op (INDIRECT_REF, NULL_TREE, convert (storage_ptr_type, storage)), - gnat_build_constructor (storage_type, template_cons)), + gnat_build_constructor (storage_type, v)), convert (storage_ptr_type, storage))); } else @@ -2101,10 +2079,11 @@ fill_vms_descriptor (tree expr, Entity_Id gnat_formal, Node_Id gnat_actual) { tree parm_decl = get_gnu_tree (gnat_formal); tree record_type = TREE_TYPE (TREE_TYPE (parm_decl)); - tree const_list = NULL_TREE, field; + tree field; const bool do_range_check = strcmp ("MBO", IDENTIFIER_POINTER (DECL_NAME (TYPE_FIELDS (record_type)))); + VEC(constructor_elt,gc) *v = NULL; expr = maybe_unconstrained_array (expr); gnat_mark_addressable (expr); @@ -2136,10 +2115,10 @@ fill_vms_descriptor (tree expr, Entity_Id gnat_formal, Node_Id gnat_actual) N_Raise_Constraint_Error), NULL_TREE)); } - const_list = tree_cons (field, conexpr, const_list); + CONSTRUCTOR_APPEND_ELT (v, field, conexpr); } - return gnat_build_constructor (record_type, nreverse (const_list)); + return gnat_build_constructor (record_type, v); } /* Indicate that we need to take the address of T and that it therefore diff --git a/gcc/ada/get_scos.adb b/gcc/ada/get_scos.adb index da63f90e307..70d77c80b6a 100644 --- a/gcc/ada/get_scos.adb +++ b/gcc/ada/get_scos.adb @@ -54,7 +54,12 @@ procedure Get_SCOs is -- value read. Data_Error is raised for overflow (value greater than -- Int'Last), or if the initial character is not a digit. - procedure Get_Sloc_Range (Loc1, Loc2 : out Source_Location); + procedure Get_Source_Location (Loc : out Source_Location); + -- Reads a source location in the form line:col and places the source + -- location in Loc. Raises Data_Error if the format does not match this + -- requirement. Note that initial spaces are not skipped. + + procedure Get_Source_Location_Range (Loc1, Loc2 : out Source_Location); -- Skips initial spaces, then reads a source location range in the form -- line:col-line:col and places the two source locations in Loc1 and Loc2. -- Raises Data_Error if format does not match this requirement. @@ -129,31 +134,32 @@ procedure Get_SCOs is raise Data_Error; end Get_Int; - -------------------- - -- Get_Sloc_Range -- - -------------------- + ------------------------- + -- Get_Source_Location -- + ------------------------- - procedure Get_Sloc_Range (Loc1, Loc2 : out Source_Location) is + procedure Get_Source_Location (Loc : out Source_Location) is pragma Unsuppress (Range_Check); - begin - Skip_Spaces; - - Loc1.Line := Logical_Line_Number (Get_Int); - Check (':'); - Loc1.Col := Column_Number (Get_Int); - - Check ('-'); - - Loc2.Line := Logical_Line_Number (Get_Int); + Loc.Line := Logical_Line_Number (Get_Int); Check (':'); - Loc2.Col := Column_Number (Get_Int); - + Loc.Col := Column_Number (Get_Int); exception when Constraint_Error => raise Data_Error; - end Get_Sloc_Range; + end Get_Source_Location; + + ------------------------------- + -- Get_Source_Location_Range -- + ------------------------------- + procedure Get_Source_Location_Range (Loc1, Loc2 : out Source_Location) is + begin + Skip_Spaces; + Get_Source_Location (Loc1); + Check ('-'); + Get_Source_Location (Loc2); + end Get_Source_Location_Range; -------------- -- Skip_EOL -- -------------- @@ -222,8 +228,8 @@ begin -- Scan out dependency number and file name declare - Ptr : String_Ptr := new String (1 .. 32768); - N : Integer; + Ptr : String_Ptr := new String (1 .. 32768); + N : Integer; begin Skip_Spaces; @@ -250,14 +256,31 @@ begin -- Statement entry - when 'S' => + when 'S' | 's' => declare Typ : Character; Key : Character; begin + -- If continuation, reset Last indication in last entry + -- stored for previous CS or cs line, and start with key + -- set to s for continuations. + + if C = 's' then + SCO_Table.Table (SCO_Table.Last).Last := False; + Key := 's'; + + -- CS case (first line, so start with key set to S) + + else + Key := 'S'; + end if; + + -- Initialize to scan items on one line + Skip_Spaces; - Key := 'S'; + + -- Loop through items on one line loop Typ := Nextc; @@ -268,7 +291,7 @@ begin Skipc; end if; - Get_Sloc_Range (Loc1, Loc2); + Get_Source_Location_Range (Loc1, Loc2); Add_SCO (C1 => Key, @@ -287,60 +310,81 @@ begin when 'I' | 'E' | 'P' | 'W' | 'X' => Dtyp := C; Skip_Spaces; - C := Getc; - -- Case of simple condition + -- Output header + + declare + Loc : Source_Location; + C2v : Character; + + begin + -- Acquire location information + + if Dtyp = 'X' then + Loc := No_Source_Location; + else + Get_Source_Location (Loc); + end if; + + -- C2 is a space except for pragmas where it is 'e' since + -- clearly the pragma is enabled if it was written out. + + if C = 'P' then + C2v := 'e'; + else + C2v := ' '; + end if; - if C = 'c' or else C = 't' or else C = 'f' then - Cond := C; - Get_Sloc_Range (Loc1, Loc2); Add_SCO (C1 => Dtyp, - C2 => Cond, - From => Loc1, - To => Loc2, - Last => True); + C2 => C2v, + From => Loc, + To => No_Source_Location, + Last => False); + end; - -- Complex expression + -- Loop through terms in complex expression - else - Add_SCO (C1 => Dtyp, Last => False); + C := Nextc; + while C /= CR and then C /= LF loop + if C = 'c' or else C = 't' or else C = 'f' then + Cond := C; + Skipc; + Get_Source_Location_Range (Loc1, Loc2); + Add_SCO + (C2 => Cond, + From => Loc1, + To => Loc2, + Last => False); - -- Loop through terms in complex expression + elsif C = '!' or else + C = '&' or else + C = '|' + then + Skipc; - while C /= CR and then C /= LF loop - if C = 'c' or else C = 't' or else C = 'f' then - Cond := C; - Skipc; - Get_Sloc_Range (Loc1, Loc2); - Add_SCO - (C2 => Cond, - From => Loc1, - To => Loc2, - Last => False); - - elsif C = '!' or else - C = '^' or else - C = '&' or else - C = '|' - then - Skipc; - Add_SCO (C1 => C, Last => False); + declare + Loc : Source_Location; + begin + Get_Source_Location (Loc); + Add_SCO (C1 => C, From => Loc, Last => False); + end; - elsif C = ' ' then - Skip_Spaces; + elsif C = ' ' then + Skip_Spaces; - else - raise Data_Error; - end if; + else + raise Data_Error; + end if; - C := Nextc; - end loop; + C := Nextc; + end loop; - -- Reset Last indication to True for last entry + -- Reset Last indication to True for last entry - SCO_Table.Table (SCO_Table.Last).Last := True; - end if; + SCO_Table.Table (SCO_Table.Last).Last := True; + + -- No other SCO lines are possible when others => raise Data_Error; diff --git a/gcc/ada/gnat-style.texi b/gcc/ada/gnat-style.texi index 37395c722ff..1e2f365f351 100644 --- a/gcc/ada/gnat-style.texi +++ b/gcc/ada/gnat-style.texi @@ -17,7 +17,7 @@ Copyright @copyright{} 1992-2008, 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 +under the terms of the GNU Free Documentation License, Version 1.3 or any later version published by the Free Software Foundation; with no Invariant Sections, with no Front-Cover Texts and with no Back-Cover Texts. A copy of the license is included in the section entitled diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 79824868be5..d3d15ccc3b1 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -30,6 +30,7 @@ with Csets; use Csets; with Debug; use Debug; with Elists; with Errout; use Errout; +with Exp_CG; with Fmap; with Fname; use Fname; with Fname.UF; use Fname.UF; @@ -49,6 +50,7 @@ with Par_SCO; with Prepcomp; with Repinfo; use Repinfo; with Restrict; +with Rident; use Rident; with Rtsfind; with SCOs; with Sem; @@ -168,12 +170,14 @@ procedure Gnat1drv is Optimization_Level := 0; - -- Disable specific expansions for Restrictions pragmas to avoid - -- tree inconsistencies between compilations with different pragmas - -- that will cause different SCIL files to be generated for the - -- same Ada spec. + -- Enable some restrictions systematically to simplify the generated + -- code (and ease analysis). Note that restriction checks are also + -- disabled in CodePeer_Mode, see Restrict.Check_Restriction - Treat_Restrictions_As_Warnings := True; + Restrict.Restrictions.Set (No_Task_Hierarchy) := True; + Restrict.Restrictions.Set (No_Abort_Statements) := True; + Restrict.Restrictions.Set (Max_Asynchronous_Select_Nesting) := True; + Restrict.Restrictions.Value (Max_Asynchronous_Select_Nesting) := 0; -- Suppress overflow, division by zero and access checks since they -- are handled implicitly by CodePeer. @@ -332,6 +336,53 @@ procedure Gnat1drv is else Suppress_Options (Overflow_Check) := True; end if; + + -- Set switch indicating if we can use N_Expression_With_Actions + + -- Debug flag -gnatd.X decisively sets usage on + + if Debug_Flag_Dot_XX then + Use_Expression_With_Actions := True; + + -- Debug flag -gnatd.Y decisively sets usage off + + elsif Debug_Flag_Dot_YY then + Use_Expression_With_Actions := False; + + -- If no debug flags, usage off for SCIL + + elsif Generate_SCIL then + Use_Expression_With_Actions := False; + + -- Otherwise this feature is implemented, so we allow its use + + else + Use_Expression_With_Actions := True; + end if; + + -- Set switch indicating if back end can handle limited types, and + -- guarantee that no incorrect copies are made (e.g. in the context + -- of a conditional expression). + + -- Debug flag -gnatd.L decisively sets usage on + + if Debug_Flag_Dot_LL then + Back_End_Handles_Limited_Types := True; + + -- If no debug flag, usage off for AAMP, VM, SCIL cases + + elsif AAMP_On_Target + or else VM_Target /= No_VM + or else Generate_SCIL + then + Back_End_Handles_Limited_Types := False; + + -- Otherwise normal gcc back end, for now still turn flag off by + -- default, since there are unresolved problems in the front end. + + else + Back_End_Handles_Limited_Types := False; + end if; end Adjust_Global_Switches; -------------------- @@ -549,6 +600,7 @@ begin Nlists.Initialize; Sinput.Initialize; Sem.Initialize; + Exp_CG.Initialize; Csets.Initialize; Uintp.Initialize; Urealp.Initialize; @@ -812,42 +864,28 @@ begin if Subunits_Missing then Write_Str (" (missing subunits)"); Write_Eol; - Write_Str ("to check parent unit"); elsif Main_Kind = N_Subunit then Write_Str (" (subunit)"); Write_Eol; - Write_Str ("to check subunit"); elsif Main_Kind = N_Subprogram_Declaration then Write_Str (" (subprogram spec)"); Write_Eol; - Write_Str ("to check subprogram spec"); -- Generic package body in GNAT implementation mode elsif Main_Kind = N_Package_Body and then GNAT_Mode then Write_Str (" (predefined generic)"); Write_Eol; - Write_Str ("to check predefined generic"); -- Only other case is a package spec else Write_Str (" (package spec)"); Write_Eol; - Write_Str ("to check package spec"); end if; - Write_Str (" for errors, use "); - - if Hostparm.OpenVMS then - Write_Str ("/NOLOAD"); - else - Write_Str ("-gnatc"); - end if; - - Write_Eol; Set_Standard_Output; Sem_Ch13.Validate_Unchecked_Conversions; @@ -938,6 +976,10 @@ begin Namet.Unlock; + -- Generate the call-graph output of dispatching calls + + Exp_CG.Generate_CG_Output; + -- Validate unchecked conversions (using the values for size and -- alignment annotated by the backend where possible). diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 84a95a7e9ab..e4a39e1671b 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -18,7 +18,7 @@ Copyright @copyright{} 1995-2008, 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 +under the terms of the GNU Free Documentation License, Version 1.3 or any later version published by the Free Software Foundation; with no Invariant Sections, with the Front-Cover Texts being ``GNAT Reference Manual'', and with no Back-Cover Texts. A copy of the license is @@ -81,7 +81,6 @@ AdaCore * Interfacing to Other Languages:: * Specialized Needs Annexes:: * Implementation of Specific Ada Features:: -* Project File Reference:: * Obsolescent Features:: * GNU Free Documentation License:: * Index:: @@ -100,6 +99,8 @@ Implementation Defined Pragmas * Pragma Ada_95:: * Pragma Ada_05:: * Pragma Ada_2005:: +* Pragma Ada_12:: +* Pragma Ada_2012:: * Pragma Annotate:: * Pragma Assert:: * Pragma Assume_No_Invalid_Values:: @@ -133,6 +134,7 @@ Implementation Defined Pragmas * Pragma Export_Value:: * Pragma Export_Valued_Procedure:: * Pragma Extend_System:: +* Pragma Extensions_Allowed:: * Pragma External:: * Pragma External_Name_Casing:: * Pragma Fast_Math:: @@ -364,6 +366,8 @@ The GNAT Library * GNAT.IO (g-io.ads):: * GNAT.IO_Aux (g-io_aux.ads):: * GNAT.Lock_Files (g-locfil.ads):: +* GNAT.MBBS_Discrete_Random (g-mbdira.ads):: +* GNAT.MBBS_Float_Random (g-mbflra.ads):: * GNAT.MD5 (g-md5.ads):: * GNAT.Memory_Dump (g-memdum.ads):: * GNAT.Most_Recent_Exception (g-moreex.ads):: @@ -463,8 +467,6 @@ Implementation of Specific Ada Features * The Size of Discriminated Records with Default Discriminants:: * Strict Conformance to the Ada Reference Manual:: -Project File Reference - Obsolescent Features GNU Free Documentation License @@ -581,10 +583,6 @@ of the specialized needs annexes. to GNAT's implementation of machine code insertions, tasking, and several other features. -@item -@ref{Project File Reference}, presents the syntax and semantics -of project files. - @item @ref{Obsolescent Features} documents implementation dependent features, including pragmas and attributes, which are considered obsolescent, since @@ -717,6 +715,8 @@ consideration, the use of these pragmas should be minimized. * Pragma Ada_95:: * Pragma Ada_05:: * Pragma Ada_2005:: +* Pragma Ada_12:: +* Pragma Ada_2012:: * Pragma Annotate:: * Pragma Assert:: * Pragma Assume_No_Invalid_Values:: @@ -750,6 +750,7 @@ consideration, the use of these pragmas should be minimized. * Pragma Export_Value:: * Pragma Export_Valued_Procedure:: * Pragma Extend_System:: +* Pragma Extensions_Allowed:: * Pragma External:: * Pragma External_Name_Casing:: * Pragma Fast_Math:: @@ -908,9 +909,7 @@ pragma Ada_05; @noindent A configuration pragma that establishes Ada 2005 mode for the unit to which it applies, regardless of the mode set by the command line switches. -This mode is set automatically for the @code{Ada} and @code{System} -packages and their children, so you need not specify it in these -contexts. This pragma is useful when writing a reusable component that +This pragma is useful when writing a reusable component that itself uses Ada 2005 features, but which is intended to be usable from either Ada 83 or Ada 95 programs. @@ -927,6 +926,37 @@ pragma Ada_2005; This configuration pragma is a synonym for pragma Ada_05 and has the same syntax and effect. +@node Pragma Ada_12 +@unnumberedsec Pragma Ada_12 +@findex Ada_12 +@noindent +Syntax: +@smallexample @c ada +pragma Ada_12; +@end smallexample + +@noindent +A configuration pragma that establishes Ada 2012 mode for the unit to which +it applies, regardless of the mode set by the command line switches. +This mode is set automatically for the @code{Ada} and @code{System} +packages and their children, so you need not specify it in these +contexts. This pragma is useful when writing a reusable component that +itself uses Ada 2012 features, but which is intended to be usable from +Ada 83, Ada 95, or Ada 2005 programs. + +@node Pragma Ada_2012 +@unnumberedsec Pragma Ada_2012 +@findex Ada_2005 +@noindent +Syntax: +@smallexample @c ada +pragma Ada_2012; +@end smallexample + +@noindent +This configuration pragma is a synonym for pragma Ada_12 and has the +same syntax and effect. + @node Pragma Annotate @unnumberedsec Pragma Annotate @findex Annotate @@ -2179,6 +2209,35 @@ it you will have to use the appropriate switch for compiling system units. @xref{Top, @value{EDITION} User's Guide, About This Guide,, gnat_ugn, @value{EDITION} User's Guide}, for details. +@node Pragma Extensions_Allowed +@unnumberedsec Pragma Extensions_Allowed +@cindex Ada Extensions +@cindex GNAT Extensions +@findex Extensions_Allowed +@noindent +Syntax: + +@smallexample @c ada +pragma Extensions_Allowed (On | Off); +@end smallexample + +@noindent +This configuration pragma enables or disables the implementation +extension mode (the use of Off as a parameter cancels the effect +of the @option{-gnatX} command switch). + +In extension mode, the latest version of the Ada language is +implemented (currently Ada 2012), and in addition a small number +of GNAT specific extensions are recognized as follows: + +@table @asis +@item Constrained attribute for generic objects +The @code{Constrained} attribute is permitted for objects of +generic types. The result indicates if the corresponding actual +is constrained. + +@end table + @node Pragma External @unnumberedsec Pragma External @findex External @@ -2856,7 +2915,12 @@ the standard Ada pragma @code{Import}. It is provided for compatibility with Ada 83. The definition is upwards compatible both with pragma @code{Interface} as defined in the Ada 83 Reference Manual, and also with some extended implementations of this pragma in certain Ada 83 -implementations. +implementations. The only difference between pragma @code{Interface} +and pragma @code{Import} is that there is special circuitry to allow +both pragmas to appear for the same subprogram entity (normally it +is illegal to have multiple @code{Import} pragmas. This is useful in +maintaining Ada 83/Ada 95 compatibility and is compatible with other +Ada 83 compilers. @node Pragma Interface_Name @unnumberedsec Pragma Interface_Name @@ -2923,7 +2987,7 @@ Ada exceptions, or used to implement run-time functions such as the Pragma @code{Interrupt_State} provides a general mechanism for overriding such uses of interrupts. It subsumes the functionality of pragma @code{Unreserve_All_Interrupts}. Pragma @code{Interrupt_State} is not -available on OS/2, Windows or VMS. On all other platforms than VxWorks, +available on Windows or VMS. On all other platforms than VxWorks, it applies to signals; on VxWorks, it applies to vectored hardware interrupts and may be used to mark interrupts required by the board support package as reserved. @@ -3967,8 +4031,6 @@ inlining (-gnatN option set) are accepted and legality-checked by the compiler, but are ignored at run-time even if postcondition checking is enabled. - - @node Pragma Profile (Ravenscar) @unnumberedsec Pragma Profile (Ravenscar) @findex Ravenscar @@ -4533,7 +4595,11 @@ gcc -c -gnatyl @dots{} The form ALL_CHECKS activates all standard checks (its use is equivalent to the use of the @code{gnaty} switch with no options. @xref{Top, @value{EDITION} User's Guide, About This Guide, gnat_ugn, -@value{EDITION} User's Guide}, for details. +@value{EDITION} User's Guide}, for details.) + +Note: the behavior is slightly different in GNAT mode (@option{-gnatg} used). +In this case, ALL_CHECKS implies the standard set of GNAT mode style check +options (i.e. equivalent to -gnatyg). The forms with @code{Off} and @code{On} can be used to temporarily disable style checks @@ -5249,6 +5315,9 @@ used to cause the compiler to entirely ignore all WARNINGS pragmas. This can be useful in checking whether obsolete pragmas in existing programs are hiding real problems. +Note: pragma Warnings does not affect the processing of style messages. See +separate entry for pragma Style_Checks for control of style messages. + @node Pragma Weak_External @unnumberedsec Pragma Weak_External @findex Weak_External @@ -5946,7 +6015,7 @@ end record; @end smallexample @noindent -will have a size of 40 (that is @code{Rec'Size} will be 40. The +will have a size of 40 (that is @code{Rec'Size} will be 40). The alignment will be 4, because of the integer field, and so the default size of record objects for this type will be 64 (8 bytes). @@ -6575,7 +6644,6 @@ For example: for Y'Address use X'Address;>> @end smallexample - @sp 1 @cartouche An implementation need not support a specification for the @code{Size} @@ -8846,7 +8914,7 @@ floating-point. @code{Numerics.Float_Random.Max_Image_Width}. See A.5.2(27). @end cartouche @noindent -Maximum image width is 649, see library file @file{a-numran.ads}. +Maximum image width is 6864, see library file @file{s-rannum.ads}. @sp 1 @cartouche @@ -8855,7 +8923,7 @@ Maximum image width is 649, see library file @file{a-numran.ads}. @code{Numerics.Discrete_Random.Max_Image_Width}. See A.5.2(27). @end cartouche @noindent -Maximum image width is 80, see library file @file{a-nudira.ads}. +Maximum image width is 6864, see library file @file{s-rannum.ads}. @sp 1 @cartouche @@ -8864,8 +8932,9 @@ Maximum image width is 80, see library file @file{a-nudira.ads}. A.5.2(32). @end cartouche @noindent -The algorithm is documented in the source files @file{a-numran.ads} and -@file{a-numran.adb}. +The algorithm is the Mersenne Twister, as documented in the source file +@file{s-rannum.adb}. This version of the algorithm has a period of +2**19937-1. @sp 1 @cartouche @@ -8874,7 +8943,9 @@ The algorithm is documented in the source files @file{a-numran.ads} and state. See A.5.2(38). @end cartouche @noindent -See the documentation contained in the file @file{a-numran.adb}. +The value returned by the Image function is the concatenation of +the fixed-width decimal representations of the 624 32-bit integers +of the state vector. @sp 1 @cartouche @@ -11837,12 +11908,12 @@ This is a predefined instantiation of build the type @code{Complex} and @code{Imaginary}. @item Ada.Numerics.Discrete_Random -This package provides a random number generator suitable for generating -random integer values from a specified range. +This generic package provides a random number generator suitable for generating +uniformly distributed values of a specified discrete subtype. @item Ada.Numerics.Float_Random This package provides a random number generator suitable for generating -uniformly distributed floating point values. +uniformly distributed floating point values in the unit interval. @item Ada.Numerics.Generic_Complex_Elementary_Functions This is a generic version of the package that provides the @@ -12225,8 +12296,6 @@ types are @code{Wide_Character} and @code{Wide_String} instead of @code{Character} and @code{String}. @end table - - @node The Implementation of Standard I/O @chapter The Implementation of Standard I/O @@ -13241,8 +13310,8 @@ package Interfaces.C_Streams is -- Standard C functions -- -------------------------- -- The functions selected below are ones that are - -- available in DOS, OS/2, UNIX and Xenix (but not - -- necessarily in ANSI C). These are very thin interfaces + -- available in UNIX (but not necessarily in ANSI C). + -- These are very thin interfaces -- which copy exactly the C headers. For more -- documentation on these functions, see the Microsoft C -- "Run-Time Library Reference" (Microsoft Press, 1990, @@ -13545,6 +13614,8 @@ of GNAT, and will generate a warning message. * GNAT.IO (g-io.ads):: * GNAT.IO_Aux (g-io_aux.ads):: * GNAT.Lock_Files (g-locfil.ads):: +* GNAT.MBBS_Discrete_Random (g-mbdira.ads):: +* GNAT.MBBS_Float_Random (g-mbflra.ads):: * GNAT.MD5 (g-md5.ads):: * GNAT.Memory_Dump (g-memdum.ads):: * GNAT.Most_Recent_Exception (g-moreex.ads):: @@ -14429,6 +14500,24 @@ for whether a file exists, and functions for reading a line of text. Provides a general interface for using files as locks. Can be used for providing program level synchronization. +@node GNAT.MBBS_Discrete_Random (g-mbdira.ads) +@section @code{GNAT.MBBS_Discrete_Random} (@file{g-mbdira.ads}) +@cindex @code{GNAT.MBBS_Discrete_Random} (@file{g-mbdira.ads}) +@cindex Random number generation + +@noindent +The original implementation of @code{Ada.Numerics.Discrete_Random}. Uses +a modified version of the Blum-Blum-Shub generator. + +@node GNAT.MBBS_Float_Random (g-mbflra.ads) +@section @code{GNAT.MBBS_Float_Random} (@file{g-mbflra.ads}) +@cindex @code{GNAT.MBBS_Float_Random} (@file{g-mbflra.ads}) +@cindex Random number generation + +@noindent +The original implementation of @code{Ada.Numerics.Float_Random}. Uses +a modified version of the Blum-Blum-Shub generator. + @node GNAT.MD5 (g-md5.ads) @section @code{GNAT.MD5} (@file{g-md5.ads}) @cindex @code{GNAT.MD5} (@file{g-md5.ads}) @@ -15477,7 +15566,7 @@ the underlying kernel. Otherwise, some target dependent glue code maps the services offered by the underlying kernel to the semantics expected by GNARL@. -Whatever the underlying OS (VxWorks, UNIX, OS/2, Windows NT, etc.) the +Whatever the underlying OS (VxWorks, UNIX, Windows, etc.) the key point is that each Ada task is mapped on a thread in the underlying kernel. For example, in the case of VxWorks, one Ada task = one VxWorks task. @@ -15822,7 +15911,6 @@ If any of these conditions are violated, the aggregate will be built in a temporary (created either by the front-end or the code generator) and then that temporary will be copied onto the target. - @node The Size of Discriminated Records with Default Discriminants @section The Size of Discriminated Records with Default Discriminants @@ -15939,1135 +16027,6 @@ machines that are not fully compliant with this standard, such as Alpha, the behavior (although at the cost of a significant performance penalty), so infinite and and NaN values are properly generated. - -@node Project File Reference -@chapter Project File Reference - -@noindent -This chapter describes the syntax and semantics of project files. -Project files specify the options to be used when building a system. -Project files can specify global settings for all tools, -as well as tool-specific settings. -@xref{Examples of Project Files,,, gnat_ugn, @value{EDITION} User's Guide}, -for examples of use. - -@menu -* Reserved Words:: -* Lexical Elements:: -* Declarations:: -* Empty declarations:: -* Typed string declarations:: -* Variables:: -* Expressions:: -* Attributes:: -* Project Attributes:: -* Attribute References:: -* External Values:: -* Case Construction:: -* Packages:: -* Package Renamings:: -* Projects:: -* Project Extensions:: -* Project File Elaboration:: -@end menu - -@node Reserved Words -@section Reserved Words - -@noindent -All Ada reserved words are reserved in project files, and cannot be used -as variable names or project names. In addition, the following are -also reserved in project files: - -@itemize -@item @code{extends} - -@item @code{external} - -@item @code{project} - -@end itemize - -@node Lexical Elements -@section Lexical Elements - -@noindent -Rules for identifiers are the same as in Ada. Identifiers -are case-insensitive. Strings are case sensitive, except where noted. -Comments have the same form as in Ada. - -@noindent -Syntax: - -@smallexample -simple_name ::= - identifier - -name ::= - simple_name @{. simple_name@} -@end smallexample - -@node Declarations -@section Declarations - -@noindent -Declarations introduce new entities that denote types, variables, attributes, -and packages. Some declarations can only appear immediately within a project -declaration. Others can appear within a project or within a package. - -Syntax: -@smallexample -declarative_item ::= - simple_declarative_item | - typed_string_declaration | - package_declaration - -simple_declarative_item ::= - variable_declaration | - typed_variable_declaration | - attribute_declaration | - case_construction | - empty_declaration -@end smallexample - -@node Empty declarations -@section Empty declarations - -@smallexample -empty_declaration ::= - @b{null} ; -@end smallexample - -An empty declaration is allowed anywhere a declaration is allowed. -It has no effect. - -@node Typed string declarations -@section Typed string declarations - -@noindent -Typed strings are sequences of string literals. Typed strings are the only -named types in project files. They are used in case constructions, where they -provide support for conditional attribute definitions. - -Syntax: -@smallexample -typed_string_declaration ::= - @b{type} _simple_name @b{is} - ( string_literal @{, string_literal@} ); -@end smallexample - -@noindent -A typed string declaration can only appear immediately within a project -declaration. - -All the string literals in a typed string declaration must be distinct. - -@node Variables -@section Variables - -@noindent -Variables denote values, and appear as constituents of expressions. - -@smallexample -typed_variable_declaration ::= - simple_name : name := string_expression ; - -variable_declaration ::= - simple_name := expression; -@end smallexample - -@noindent -The elaboration of a variable declaration introduces the variable and -assigns to it the value of the expression. The name of the variable is -available after the assignment symbol. - -@noindent -A typed_variable can only be declare once. - -@noindent -a non-typed variable can be declared multiple times. - -@noindent -Before the completion of its first declaration, the value of variable -is the null string. - -@node Expressions -@section Expressions - -@noindent -An expression is a formula that defines a computation or retrieval of a value. -In a project file the value of an expression is either a string or a list -of strings. A string value in an expression is either a literal, the current -value of a variable, an external value, an attribute reference, or a -concatenation operation. - -Syntax: - -@smallexample -expression ::= - term @{& term@} - -term ::= - string_literal | - string_list | - name | - external_value | - attribute_reference - -string_literal ::= - (same as Ada) - -string_list ::= - ( expression @{ , expression @} ) -@end smallexample - -@subsection Concatenation -@noindent -The following concatenation functions are defined: - -@smallexample @c ada - function "&" (X : String; Y : String) return String; - function "&" (X : String_List; Y : String) return String_List; - function "&" (X : String_List; Y : String_List) return String_List; -@end smallexample - -@node Attributes -@section Attributes - -@noindent -An attribute declaration defines a property of a project or package. This -property can later be queried by means of an attribute reference. -Attribute values are strings or string lists. - -Some attributes are associative arrays. These attributes are mappings whose -domain is a set of strings. These attributes are declared one association -at a time, by specifying a point in the domain and the corresponding image -of the attribute. They may also be declared as a full associative array, -getting the same associations as the corresponding attribute in an imported -or extended project. - -Attributes that are not associative arrays are called simple attributes. - -Syntax: -@smallexample -attribute_declaration ::= - full_associative_array_declaration | - @b{for} attribute_designator @b{use} expression ; - -full_associative_array_declaration ::= - @b{for} simple_name @b{use} - simple_name [ . simple_Name ] ' simple_name ; - -attribute_designator ::= - simple_name | - simple_name ( string_literal ) -@end smallexample - -@noindent -Some attributes are project-specific, and can only appear immediately within -a project declaration. Others are package-specific, and can only appear within -the proper package. - -The expression in an attribute definition must be a string or a string_list. -The string literal appearing in the attribute_designator of an associative -array attribute is case-insensitive. - -@node Project Attributes -@section Project Attributes - -@noindent -The following attributes apply to a project. All of them are simple -attributes. - -@table @code -@item Object_Dir -Expression must be a path name. The attribute defines the -directory in which the object files created by the build are to be placed. If -not specified, object files are placed in the project directory. - -@item Exec_Dir -Expression must be a path name. The attribute defines the -directory in which the executables created by the build are to be placed. -If not specified, executables are placed in the object directory. - -@item Source_Dirs -Expression must be a list of path names. The attribute -defines the directories in which the source files for the project are to be -found. If not specified, source files are found in the project directory. -If a string in the list ends with "/**", then the directory that precedes -"/**" and all of its subdirectories (recursively) are included in the list -of source directories. - -@item Excluded_Source_Dirs -Expression must be a list of strings. Each entry designates a directory that -is not to be included in the list of source directories of the project. -This is normally used when there are strings ending with "/**" in the value -of attribute Source_Dirs. - -@item Source_Files -Expression must be a list of file names. The attribute -defines the individual files, in the project directory, which are to be used -as sources for the project. File names are path_names that contain no directory -information. If the project has no sources the attribute must be declared -explicitly with an empty list. - -@item Excluded_Source_Files (Locally_Removed_Files) -Expression must be a list of strings that are legal file names. -Each file name must designate a source that would normally be a source file -in the source directories of the project or, if the project file is an -extending project file, inherited by the current project file. It cannot -designate an immediate source that is not inherited. Each of the source files -in the list are not considered to be sources of the project file: they are not -inherited. Attribute Locally_Removed_Files is obsolescent, attribute -Excluded_Source_Files is preferred. - -@item Source_List_File -Expression must a single path name. The attribute -defines a text file that contains a list of source file names to be used -as sources for the project - -@item Library_Dir -Expression must be a path name. The attribute defines the -directory in which a library is to be built. The directory must exist, must -be distinct from the project's object directory, and must be writable. - -@item Library_Name -Expression must be a string that is a legal file name, -without extension. The attribute defines a string that is used to generate -the name of the library to be built by the project. - -@item Library_Kind -Argument must be a string value that must be one of the -following @code{"static"}, @code{"dynamic"} or @code{"relocatable"}. This -string is case-insensitive. If this attribute is not specified, the library is -a static library. Otherwise, the library may be dynamic or relocatable. This -distinction is operating-system dependent. - -@item Library_Version -Expression must be a string value whose interpretation -is platform dependent. On UNIX, it is used only for dynamic/relocatable -libraries as the internal name of the library (the @code{"soname"}). If the -library file name (built from the @code{Library_Name}) is different from the -@code{Library_Version}, then the library file will be a symbolic link to the -actual file whose name will be @code{Library_Version}. - -@item Library_Interface -Expression must be a string list. Each element of the string list -must designate a unit of the project. -If this attribute is present in a Library Project File, then the project -file is a Stand-alone Library_Project_File. - -@item Library_Auto_Init -Expression must be a single string "true" or "false", case-insensitive. -If this attribute is present in a Stand-alone Library Project File, -it indicates if initialization is automatic when the dynamic library -is loaded. - -@item Library_Options -Expression must be a string list. Indicates additional switches that -are to be used when building a shared library. - -@item Library_GCC -Expression must be a single string. Designates an alternative to "gcc" -for building shared libraries. - -@item Library_Src_Dir -Expression must be a path name. The attribute defines the -directory in which the sources of the interfaces of a Stand-alone Library will -be copied. The directory must exist, must be distinct from the project's -object directory and source directories of all projects in the project tree, -and must be writable. - -@item Library_Src_Dir -Expression must be a path name. The attribute defines the -directory in which the ALI files of a Library will -be copied. The directory must exist, must be distinct from the project's -object directory and source directories of all projects in the project tree, -and must be writable. - -@item Library_Symbol_File -Expression must be a single string. Its value is the single file name of a -symbol file to be created when building a stand-alone library when the -symbol policy is either "compliant", "controlled" or "restricted", -on platforms that support symbol control, such as VMS. When symbol policy -is "direct", then a file with this name must exist in the object directory. - -@item Library_Reference_Symbol_File -Expression must be a single string. Its value is the path name of a -reference symbol file that is read when the symbol policy is either -"compliant" or "controlled", on platforms that support symbol control, -such as VMS, when building a stand-alone library. The path may be an absolute -path or a path relative to the project directory. - -@item Library_Symbol_Policy -Expression must be a single string. Its case-insensitive value can only be -"autonomous", "default", "compliant", "controlled", "restricted" or "direct". - -This attribute is not taken into account on all platforms. It controls the -policy for exported symbols and, on some platforms (like VMS) that have the -notions of major and minor IDs built in the library files, it controls -the setting of these IDs. - -"autonomous" or "default": exported symbols are not controlled. - -"compliant": if attribute Library_Reference_Symbol_File is not defined, then -it is equivalent to policy "autonomous". If there are exported symbols in -the reference symbol file that are not in the object files of the interfaces, -the major ID of the library is increased. If there are symbols in the -object files of the interfaces that are not in the reference symbol file, -these symbols are put at the end of the list in the newly created symbol file -and the minor ID is increased. - -"controlled": the attribute Library_Reference_Symbol_File must be defined. -The library will fail to build if the exported symbols in the object files of -the interfaces do not match exactly the symbol in the symbol file. - -"restricted": The attribute Library_Symbol_File must be defined. The library -will fail to build if there are symbols in the symbol file that are not in -the exported symbols of the object files of the interfaces. Additional symbols -in the object files are not added to the symbol file. - -"direct": The attribute Library_Symbol_File must be defined and must designate -an existing file in the object directory. This symbol file is passed directly -to the underlying linker without any symbol processing. - -@item Main -Expression must be a list of strings that are legal file names. -These file names designate existing compilation units in the source directory -that are legal main subprograms. - -When a project file is elaborated, as part of the execution of a gnatmake -command, one or several executables are built and placed in the Exec_Dir. -If the gnatmake command does not include explicit file names, the executables -that are built correspond to the files specified by this attribute. - -@item Externally_Built -Expression must be a single string. Its value must be either "true" of "false", -case-insensitive. The default is "false". When the value of this attribute is -"true", no attempt is made to compile the sources or to build the library, -when the project is a library project. - -@item Main_Language -This is a simple attribute. Its value is a string that specifies the -language of the main program. - -@item Languages -Expression must be a string list. Each string designates -a programming language that is known to GNAT. The strings are case-insensitive. - -@end table - -@node Attribute References -@section Attribute References - -@noindent -Attribute references are used to retrieve the value of previously defined -attribute for a package or project. -Syntax: -@smallexample -attribute_reference ::= - attribute_prefix ' simple_name [ ( string_literal ) ] - -attribute_prefix ::= - @b{project} | - simple_name . package_identifier -@end smallexample - -@noindent -If an attribute has not been specified for a given package or project, its -value is the null string or the empty list. - -@node External Values -@section External Values - -@noindent -An external value is an expression whose value is obtained from the command -that invoked the processing of the current project file (typically a -gnatmake command). - -Syntax: -@smallexample -external_value ::= - @b{external} ( string_literal [, string_literal] ) -@end smallexample - -@noindent -The first string_literal is the string to be used on the command line or -in the environment to specify the external value. The second string_literal, -if present, is the default to use if there is no specification for this -external value either on the command line or in the environment. - -@node Case Construction -@section Case Construction - -@noindent -A case construction supports attribute and variable declarations that depend -on the value of a previously declared variable. - -Syntax: -@smallexample -case_construction ::= - @b{case} name @b{is} - @{case_item@} - @b{end case} ; - -case_item ::= - @b{when} discrete_choice_list => - @{case_construction | - attribute_declaration | - variable_declaration | - empty_declaration@} - -discrete_choice_list ::= - string_literal @{| string_literal@} | - @b{others} -@end smallexample - -@noindent -Inside a case construction, variable declarations must be for variables that -have already been declared before the case construction. - -All choices in a choice list must be distinct. The choice lists of two -distinct alternatives must be disjoint. Unlike Ada, the choice lists of all -alternatives do not need to include all values of the type. An @code{others} -choice must appear last in the list of alternatives. - -@node Packages -@section Packages - -@noindent -A package provides a grouping of variable declarations and attribute -declarations to be used when invoking various GNAT tools. The name of -the package indicates the tool(s) to which it applies. -Syntax: - -@smallexample -package_declaration ::= - package_spec | package_renaming - -package_spec ::= - @b{package} package_identifier @b{is} - @{simple_declarative_item@} - @b{end} package_identifier ; - -package_identifier ::= - @code{Naming} | @code{Builder} | @code{Compiler} | @code{Binder} | - @code{Linker} | @code{Finder} | @code{Cross_Reference} | - @code{gnatls} | @code{IDE} | @code{Pretty_Printer} | @code{Check} -@end smallexample - -@subsection Package Naming - -@noindent -The attributes of a @code{Naming} package specifies the naming conventions -that apply to the source files in a project. When invoking other GNAT tools, -they will use the sources in the source directories that satisfy these -naming conventions. - -The following attributes apply to a @code{Naming} package: - -@table @code -@item Casing -This is a simple attribute whose value is a string. Legal values of this -string are @code{"lowercase"}, @code{"uppercase"} or @code{"mixedcase"}. -These strings are themselves case insensitive. - -@noindent -If @code{Casing} is not specified, then the default is @code{"lowercase"}. - -@item Dot_Replacement -This is a simple attribute whose string value satisfies the following -requirements: - -@itemize @bullet -@item It must not be empty -@item It cannot start or end with an alphanumeric character -@item It cannot be a single underscore -@item It cannot start with an underscore followed by an alphanumeric -@item It cannot contain a dot @code{'.'} if longer than one character -@end itemize - -@noindent -If @code{Dot_Replacement} is not specified, then the default is @code{"-"}. - -@item Spec_Suffix -This is an associative array attribute, defined on language names, -whose image is a string that must satisfy the following -conditions: - -@itemize @bullet -@item It must not be empty -@item It cannot start with an alphanumeric character -@item It cannot start with an underscore followed by an alphanumeric character -@end itemize - -@noindent -For Ada, the attribute denotes the suffix used in file names that contain -library unit declarations, that is to say units that are package and -subprogram declarations. If @code{Spec_Suffix ("Ada")} is not -specified, then the default is @code{".ads"}. - -For C and C++, the attribute denotes the suffix used in file names that -contain prototypes. - -@item Body_Suffix -This is an associative array attribute defined on language names, -whose image is a string that must satisfy the following -conditions: - -@itemize @bullet -@item It must not be empty -@item It cannot start with an alphanumeric character -@item It cannot start with an underscore followed by an alphanumeric character -@item It cannot be a suffix of @code{Spec_Suffix} -@end itemize - -@noindent -For Ada, the attribute denotes the suffix used in file names that contain -library bodies, that is to say units that are package and subprogram bodies. -If @code{Body_Suffix ("Ada")} is not specified, then the default is -@code{".adb"}. - -For C and C++, the attribute denotes the suffix used in file names that contain -source code. - -@item Separate_Suffix -This is a simple attribute whose value satisfies the same conditions as -@code{Body_Suffix}. - -This attribute is specific to Ada. It denotes the suffix used in file names -that contain separate bodies. If it is not specified, then it defaults to same -value as @code{Body_Suffix ("Ada")}. - -@item Spec -This is an associative array attribute, specific to Ada, defined over -compilation unit names. The image is a string that is the name of the file -that contains that library unit. The file name is case sensitive if the -conventions of the host operating system require it. - -@item Body -This is an associative array attribute, specific to Ada, defined over -compilation unit names. The image is a string that is the name of the file -that contains the library unit body for the named unit. The file name is case -sensitive if the conventions of the host operating system require it. - -@item Specification_Exceptions -This is an associative array attribute defined on language names, -whose value is a list of strings. - -This attribute is not significant for Ada. - -For C and C++, each string in the list denotes the name of a file that -contains prototypes, but whose suffix is not necessarily the -@code{Spec_Suffix} for the language. - -@item Implementation_Exceptions -This is an associative array attribute defined on language names, -whose value is a list of strings. - -This attribute is not significant for Ada. - -For C and C++, each string in the list denotes the name of a file that -contains source code, but whose suffix is not necessarily the -@code{Body_Suffix} for the language. -@end table - -The following attributes of package @code{Naming} are obsolescent. They are -kept as synonyms of other attributes for compatibility with previous versions -of the Project Manager. - -@table @code -@item Specification_Suffix -This is a synonym of @code{Spec_Suffix}. - -@item Implementation_Suffix -This is a synonym of @code{Body_Suffix}. - -@item Specification -This is a synonym of @code{Spec}. - -@item Implementation -This is a synonym of @code{Body}. -@end table - -@subsection package Compiler - -@noindent -The attributes of the @code{Compiler} package specify the compilation options -to be used by the underlying compiler. - -@table @code -@item Default_Switches -This is an associative array attribute. Its -domain is a set of language names. Its range is a string list that -specifies the compilation options to be used when compiling a component -written in that language, for which no file-specific switches have been -specified. - -@item Switches -This is an associative array attribute. Its domain is -a set of file names. Its range is a string list that specifies the -compilation options to be used when compiling the named file. If a file -is not specified in the Switches attribute, it is compiled with the -options specified by Default_Switches of its language, if defined. - -@item Local_Configuration_Pragmas. -This is a simple attribute, whose -value is a path name that designates a file containing configuration pragmas -to be used for all invocations of the compiler for immediate sources of the -project. -@end table - -@subsection package Builder - -@noindent -The attributes of package @code{Builder} specify the compilation, binding, and -linking options to be used when building an executable for a project. The -following attributes apply to package @code{Builder}: - -@table @code -@item Default_Switches -This is an associative array attribute. Its -domain is a set of language names. Its range is a string list that -specifies options to be used when building a main -written in that language, for which no file-specific switches have been -specified. - -@item Switches -This is an associative array attribute. Its domain is -a set of file names. Its range is a string list that specifies -options to be used when building the named main file. If a main file -is not specified in the Switches attribute, it is built with the -options specified by Default_Switches of its language, if defined. - -@item Global_Configuration_Pragmas -This is a simple attribute, whose -value is a path name that designates a file that contains configuration pragmas -to be used in every build of an executable. If both local and global -configuration pragmas are specified, a compilation makes use of both sets. - - -@item Executable -This is an associative array attribute. Its domain is -a set of main source file names. Its range is a simple string that specifies -the executable file name to be used when linking the specified main source. -If a main source is not specified in the Executable attribute, the executable -file name is deducted from the main source file name. -This attribute has no effect if its value is the empty string. - -@item Executable_Suffix -This is a simple attribute whose value is the suffix to be added to -the executables that don't have an attribute Executable specified. -@end table - -@subsection package Gnatls - -@noindent -The attributes of package @code{Gnatls} specify the tool options to be used -when invoking the library browser @command{gnatls}. -The following attributes apply to package @code{Gnatls}: - -@table @code -@item Switches -This is a single attribute with a string list value. Each nonempty string -in the list is an option when invoking @code{gnatls}. -@end table - -@subsection package Binder - -@noindent -The attributes of package @code{Binder} specify the options to be used -when invoking the binder in the construction of an executable. -The following attributes apply to package @code{Binder}: - -@table @code -@item Default_Switches -This is an associative array attribute. Its -domain is a set of language names. Its range is a string list that -specifies options to be used when binding a main -written in that language, for which no file-specific switches have been -specified. - -@item Switches -This is an associative array attribute. Its domain is -a set of file names. Its range is a string list that specifies -options to be used when binding the named main file. If a main file -is not specified in the Switches attribute, it is bound with the -options specified by Default_Switches of its language, if defined. -@end table - -@subsection package Linker - -@noindent -The attributes of package @code{Linker} specify the options to be used when -invoking the linker in the construction of an executable. -The following attributes apply to package @code{Linker}: - -@table @code -@item Default_Switches -This is an associative array attribute. Its -domain is a set of language names. Its range is a string list that -specifies options to be used when linking a main -written in that language, for which no file-specific switches have been -specified. - -@item Switches -This is an associative array attribute. Its domain is -a set of file names. Its range is a string list that specifies -options to be used when linking the named main file. If a main file -is not specified in the Switches attribute, it is linked with the -options specified by Default_Switches of its language, if defined. - -@item Linker_Options -This is a string list attribute. Its value specifies additional options that -be given to the linker when linking an executable. This attribute is not -used in the main project, only in projects imported directly or indirectly. - -@end table - -@subsection package Cross_Reference - -@noindent -The attributes of package @code{Cross_Reference} specify the tool options -to be used -when invoking the library tool @command{gnatxref}. -The following attributes apply to package @code{Cross_Reference}: - -@table @code -@item Default_Switches -This is an associative array attribute. Its -domain is a set of language names. Its range is a string list that -specifies options to be used when calling @command{gnatxref} on a source -written in that language, for which no file-specific switches have been -specified. - -@item Switches -This is an associative array attribute. Its domain is -a set of file names. Its range is a string list that specifies -options to be used when calling @command{gnatxref} on the named main source. -If a source is not specified in the Switches attribute, @command{gnatxref} will -be called with the options specified by Default_Switches of its language, -if defined. -@end table - -@subsection package Finder - -@noindent -The attributes of package @code{Finder} specify the tool options to be used -when invoking the search tool @command{gnatfind}. -The following attributes apply to package @code{Finder}: - -@table @code -@item Default_Switches -This is an associative array attribute. Its -domain is a set of language names. Its range is a string list that -specifies options to be used when calling @command{gnatfind} on a source -written in that language, for which no file-specific switches have been -specified. - -@item Switches -This is an associative array attribute. Its domain is -a set of file names. Its range is a string list that specifies -options to be used when calling @command{gnatfind} on the named main source. -If a source is not specified in the Switches attribute, @command{gnatfind} will -be called with the options specified by Default_Switches of its language, -if defined. -@end table - -@subsection package Check - -@noindent -The attributes of package @code{Check} -specify the checking rule options to be used -when invoking the checking tool @command{gnatcheck}. -The following attributes apply to package @code{Check}: - -@table @code -@item Default_switches -This is an associative array attribute. Its -domain is a set of language names. Its range is a string list that -specifies options to be used when calling @command{gnatcheck} on a source -written in that language. The first string in the range should always be -@code{"-rules"} to specify that all the other options belong to the -@code{-rules} section of the parameters of @command{gnatcheck} call. - -@end table - -@subsection package Pretty_Printer - -@noindent -The attributes of package @code{Pretty_Printer} -specify the tool options to be used -when invoking the formatting tool @command{gnatpp}. -The following attributes apply to package @code{Pretty_Printer}: - -@table @code -@item Default_switches -This is an associative array attribute. Its -domain is a set of language names. Its range is a string list that -specifies options to be used when calling @command{gnatpp} on a source -written in that language, for which no file-specific switches have been -specified. - -@item Switches -This is an associative array attribute. Its domain is -a set of file names. Its range is a string list that specifies -options to be used when calling @command{gnatpp} on the named main source. -If a source is not specified in the Switches attribute, @command{gnatpp} will -be called with the options specified by Default_Switches of its language, -if defined. -@end table - -@subsection package gnatstub - -@noindent -The attributes of package @code{gnatstub} -specify the tool options to be used -when invoking the tool @command{gnatstub}. -The following attributes apply to package @code{gnatstub}: - -@table @code -@item Default_switches -This is an associative array attribute. Its -domain is a set of language names. Its range is a string list that -specifies options to be used when calling @command{gnatstub} on a source -written in that language, for which no file-specific switches have been -specified. - -@item Switches -This is an associative array attribute. Its domain is -a set of file names. Its range is a string list that specifies -options to be used when calling @command{gnatstub} on the named main source. -If a source is not specified in the Switches attribute, @command{gnatpp} will -be called with the options specified by Default_Switches of its language, -if defined. -@end table - -@subsection package Eliminate - -@noindent -The attributes of package @code{Eliminate} -specify the tool options to be used -when invoking the tool @command{gnatelim}. -The following attributes apply to package @code{Eliminate}: - -@table @code -@item Default_switches -This is an associative array attribute. Its -domain is a set of language names. Its range is a string list that -specifies options to be used when calling @command{gnatelim} on a source -written in that language, for which no file-specific switches have been -specified. - -@item Switches -This is an associative array attribute. Its domain is -a set of file names. Its range is a string list that specifies -options to be used when calling @command{gnatelim} on the named main source. -If a source is not specified in the Switches attribute, @command{gnatelim} will -be called with the options specified by Default_Switches of its language, -if defined. -@end table - -@subsection package Metrics - -@noindent -The attributes of package @code{Metrics} -specify the tool options to be used -when invoking the tool @command{gnatmetric}. -The following attributes apply to package @code{Metrics}: - -@table @code -@item Default_switches -This is an associative array attribute. Its -domain is a set of language names. Its range is a string list that -specifies options to be used when calling @command{gnatmetric} on a source -written in that language, for which no file-specific switches have been -specified. - -@item Switches -This is an associative array attribute. Its domain is -a set of file names. Its range is a string list that specifies -options to be used when calling @command{gnatmetric} on the named main source. -If a source is not specified in the Switches attribute, @command{gnatmetric} -will be called with the options specified by Default_Switches of its language, -if defined. -@end table - -@subsection package IDE - -@noindent -The attributes of package @code{IDE} specify the options to be used when using -an Integrated Development Environment such as @command{GPS}. - -@table @code -@item Remote_Host -This is a simple attribute. Its value is a string that designates the remote -host in a cross-compilation environment, to be used for remote compilation and -debugging. This field should not be specified when running on the local -machine. - -@item Program_Host -This is a simple attribute. Its value is a string that specifies the -name of IP address of the embedded target in a cross-compilation environment, -on which the program should execute. - -@item Communication_Protocol -This is a simple string attribute. Its value is the name of the protocol -to use to communicate with the target in a cross-compilation environment, -e.g.@: @code{"wtx"} or @code{"vxworks"}. - -@item Compiler_Command -This is an associative array attribute, whose domain is a language name. Its -value is string that denotes the command to be used to invoke the compiler. -The value of @code{Compiler_Command ("Ada")} is expected to be compatible with -gnatmake, in particular in the handling of switches. - -@item Debugger_Command -This is simple attribute, Its value is a string that specifies the name of -the debugger to be used, such as gdb, powerpc-wrs-vxworks-gdb or gdb-4. - -@item Default_Switches -This is an associative array attribute. Its indexes are the name of the -external tools that the GNAT Programming System (GPS) is supporting. Its -value is a list of switches to use when invoking that tool. - -@item Gnatlist -This is a simple attribute. Its value is a string that specifies the name -of the @command{gnatls} utility to be used to retrieve information about the -predefined path; e.g., @code{"gnatls"}, @code{"powerpc-wrs-vxworks-gnatls"}. - -@item VCS_Kind -This is a simple attribute. Its value is a string used to specify the -Version Control System (VCS) to be used for this project, e.g.@: CVS, RCS -ClearCase or Perforce. - -@item VCS_File_Check -This is a simple attribute. Its value is a string that specifies the -command used by the VCS to check the validity of a file, either -when the user explicitly asks for a check, or as a sanity check before -doing the check-in. - -@item VCS_Log_Check -This is a simple attribute. Its value is a string that specifies -the command used by the VCS to check the validity of a log file. - -@item VCS_Repository_Root -The VCS repository root path. This is used to create tags or branches -of the repository. For subversion the value should be the @code{URL} -as specified to check-out the working copy of the repository. - -@item VCS_Patch_Root -The local root directory to use for building patch file. All patch chunks -will be relative to this path. The root project directory is used if -this value is not defined. - -@end table - -@node Package Renamings -@section Package Renamings - -@noindent -A package can be defined by a renaming declaration. The new package renames -a package declared in a different project file, and has the same attributes -as the package it renames. -Syntax: -@smallexample -package_renaming ::== - @b{package} package_identifier @b{renames} - simple_name.package_identifier ; -@end smallexample - -@noindent -The package_identifier of the renamed package must be the same as the -package_identifier. The project whose name is the prefix of the renamed -package must contain a package declaration with this name. This project -must appear in the context_clause of the enclosing project declaration, -or be the parent project of the enclosing child project. - -@node Projects -@section Projects - -@noindent -A project file specifies a set of rules for constructing a software system. -A project file can be self-contained, or depend on other project files. -Dependencies are expressed through a context clause that names other projects. - -Syntax: - -@smallexample -project ::= - context_clause project_declaration - -project_declaration ::= - simple_project_declaration | project_extension - -simple_project_declaration ::= - @b{project} simple_name @b{is} - @{declarative_item@} - @b{end} simple_name; - -context_clause ::= - @{with_clause@} - -with_clause ::= - [@b{limited}] @b{with} path_name @{ , path_name @} ; - -path_name ::= - string_literal -@end smallexample - -@noindent -A path name denotes a project file. A path name can be absolute or relative. -An absolute path name includes a sequence of directories, in the syntax of -the host operating system, that identifies uniquely the project file in the -file system. A relative path name identifies the project file, relative -to the directory that contains the current project, or relative to a -directory listed in the environment variable ADA_PROJECT_PATH. -Path names are case sensitive if file names in the host operating system -are case sensitive. - -The syntax of the environment variable ADA_PROJECT_PATH is a list of -directory names separated by colons (semicolons on Windows). - -A given project name can appear only once in a context_clause. - -It is illegal for a project imported by a context clause to refer, directly -or indirectly, to the project in which this context clause appears (the -dependency graph cannot contain cycles), except when one of the with_clause -in the cycle is a @code{limited with}. - -@node Project Extensions -@section Project Extensions - -@noindent -A project extension introduces a new project, which inherits the declarations -of another project. -Syntax: -@smallexample - -project_extension ::= - @b{project} simple_name @b{extends} path_name @b{is} - @{declarative_item@} - @b{end} simple_name; -@end smallexample - -@noindent -The project extension declares a child project. The child project inherits -all the declarations and all the files of the parent project, These inherited -declaration can be overridden in the child project, by means of suitable -declarations. - -@node Project File Elaboration -@section Project File Elaboration - -@noindent -A project file is processed as part of the invocation of a gnat tool that -uses the project option. Elaboration of the process file consists in the -sequential elaboration of all its declarations. The computed values of -attributes and variables in the project are then used to establish the -environment in which the gnat tool will execute. - @node Obsolescent Features @chapter Obsolescent Features diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index db8b2ccd1c1..e18baef53d5 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -18,7 +18,7 @@ Copyright @copyright{} 1995-2009 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 +under the terms of the GNU Free Documentation License, Version 1.3 or any later version published by the Free Software Foundation; with no Invariant Sections, with no Front-Cover Texts and with no Back-Cover Texts. A copy of the license is included in the section entitled @@ -107,6 +107,13 @@ Texts. A copy of the license is included in the section entitled @macro ovar{varname} @r{[}@var{\varname\}@r{]}@c @end macro +@c Status as of November 2009: +@c Unfortunately texi2pdf and texi2html treat the trailing "@c" +@c differently, and faulty output is produced by one or the other +@c depending on whether the "@c" is present or absent. +@c As a result, the @ovar macro is not used, and all invocations +@c of the @ovar macro have been expanded inline. + @settitle @value{EDITION} User's Guide @value{PLATFORM} @dircategory GNU Ada tools @@ -169,6 +176,7 @@ AdaCore@* * Configuration Pragmas:: * Handling Arbitrary File Naming Conventions Using gnatname:: * GNAT Project Manager:: +* Tools Supporting Project Files:: * The Cross-Referencing Tools gnatxref and gnatfind:: * The GNAT Pretty-Printer gnatpp:: * The GNAT Metric Tool gnatmetric:: @@ -340,6 +348,7 @@ Performance Considerations Reducing Size of Ada Executables with gnatelim * About gnatelim:: * Running gnatelim:: +* Processing Precompiled Libraries:: * Correcting the List of Eliminate Pragmas:: * Making Your Executables Smaller:: * Summary of the gnatelim Usage Cycle:: @@ -368,26 +377,6 @@ Handling Arbitrary File Naming Conventions Using gnatname * Switches for gnatname:: * Examples of gnatname Usage:: -GNAT Project Manager - -* Introduction:: -* Examples of Project Files:: -* Project File Syntax:: -* Objects and Sources in Project Files:: -* Importing Projects:: -* Project Extension:: -* Project Hierarchy Extension:: -* External References in Project Files:: -* Packages in Project Files:: -* Variables from Imported Projects:: -* Naming Schemes:: -* Library Projects:: -* Stand-alone Library Projects:: -* Switches Related to Project Files:: -* Tools Supporting Project Files:: -* An Extended Example:: -* Project File Complete Syntax:: - The Cross-Referencing Tools gnatxref and gnatfind * Switches for gnatxref:: @@ -523,6 +512,7 @@ Running and Debugging Ada Programs * Ada Exceptions:: * Ada Tasks:: * Debugging Generic Units:: +* Remote Debugging using gdbserver:: * GNAT Abnormal Termination or Failure to Terminate:: * Naming Conventions for GNAT Source Files:: * Getting Internal Debugging Information:: @@ -597,6 +587,8 @@ Platform-Specific Information for the Run-Time Libraries * Linux-Specific Considerations:: * AIX-Specific Considerations:: * Irix-Specific Considerations:: +* RTX-Specific Considerations:: +* HP-UX-Specific Considerations:: Example of Binder Output File @@ -3873,7 +3865,9 @@ without generating code, then use the @option{-gnatc} switch. The basic command for compiling a file containing an Ada unit is @smallexample -$ gcc -c @ovar{switches} @file{file name} +@c $ gcc -c @ovar{switches} @file{file name} +@c Expanding @ovar macro inline (explanation in macro def comments) +$ gcc -c @r{[}@var{switches}@r{]} @file{file name} @end smallexample @noindent @@ -4066,6 +4060,17 @@ Enforce Ada 95 restrictions. @cindex @option{-gnat05} (@command{gcc}) Allow full Ada 2005 features. +@item -gnat2005 +@cindex @option{-gnat2005} (@command{gcc}) +Allow full Ada 2005 features (same as @option{-gnat05} + +@item -gnat12 +@cindex @option{-gnat12} (@command{gcc}) + +@item -gnat2012 +@cindex @option{-gnat2012} (@command{gcc}) +Allow full Ada 2012 features (same as @option{-gnat12} + @item -gnata @cindex @option{-gnata} (@command{gcc}) Assertions enabled. @code{Pragma Assert} and @code{pragma Debug} to be @@ -4188,7 +4193,7 @@ Note that @option{^-gnatg^/GNAT_INTERNAL^} implies @option{^-gnatwae^/WARNINGS=ALL,ERRORS^} and @option{^-gnatyg^/STYLE_CHECKS=GNAT^} so that all standard warnings and all standard style options are turned on. -All warnings and style error messages are treated as errors. +All warnings and style messages are treated as errors. @ifclear vms @item -gnatG=nn @@ -4282,7 +4287,12 @@ controlled by this switch (division by zero checking is on by default). @item -gnatp @cindex @option{-gnatp} (@command{gcc}) -Suppress all checks. See @ref{Run-Time Checks} for details. +Suppress all checks. See @ref{Run-Time Checks} for details. This switch +has no effect if cancelled by a subsequent @option{-gnat-p} switch. + +@item -gnat-p +@cindex @option{-gnat-p} (@command{gcc}) +Cancel effect of previous @option{-gnatp} switch. @item -gnatP @cindex @option{-gnatP} (@command{gcc}) @@ -4360,6 +4370,10 @@ Wide character encoding method @cindex @option{-gnatx} (@command{gcc}) Suppress generation of cross-reference information. +@item -gnatX +@cindex @option{-gnatX} (@command{gcc}) +Enable GNAT implementation extensions and latest Ada version. + @item ^-gnaty^/STYLE_CHECKS=(option,option@dots{})^ @cindex @option{^-gnaty^/STYLE_CHECKS^} (@command{gcc}) Enable built-in style checks (@pxref{Style Checking}). @@ -4419,7 +4433,9 @@ Inhibit the search of the default location for the GNAT Run Time Library (RTL) ALI files. @ifclear vms -@item -O@ovar{n} +@c @item -O@ovar{n} +@c Expanding @ovar macro inline (explanation in macro def comments) +@item -O@r{[}@var{n}@r{]} @cindex @option{-O} (@command{gcc}) @var{n} controls the optimization level. @@ -4577,6 +4593,9 @@ The switches @option{-gnatzc} and @option{-gnatzr} may not be combined with any other switches, and only one of them may appear in the command line. +@item +The switch @option{-gnat-p} may not be combined with any other switch. + @ifclear vms @item Once a ``y'' appears in the string (that is a use of the @option{-gnaty} @@ -5190,12 +5209,14 @@ This switch suppresses warnings for implicit dereferences in indexed components, slices, and selected components. @item -gnatwe -@emph{Treat warnings as errors.} +@emph{Treat warnings and style checks as errors.} @cindex @option{-gnatwe} (@command{gcc}) @cindex Warnings, treat as error -This switch causes warning messages to be treated as errors. +This switch causes warning messages and style check messages to be +treated as errors. The warning string still appears, but the warning messages are counted -as errors, and prevent the generation of an object file. +as errors, and prevent the generation of an object file. Note that this +is the only -gnatw switch that affects the handling of style check messages. @item -gnatw.e @emph{Activate every optional warning} @@ -5558,7 +5579,8 @@ This switch completely suppresses the output of all warning messages from the GNAT front end. Note that it does not suppress warnings from the @command{gcc} back end. To suppress these back end warnings as well, use the switch @option{-w} -in addition to @option{-gnatws}. +in addition to @option{-gnatws}. Also this switch has no effect on the +handling of style check messages. @item -gnatwt @emph{Activate warnings for tracking of deleted conditional code.} @@ -6117,8 +6139,10 @@ causes the compiler to enforce specified style rules. A limited set of style rules has been used in writing the GNAT sources themselves. This switch allows user programs to activate all or some of these checks. If the source program fails a -specified style check, an appropriate warning message is given, preceded by -the character sequence ``(style)''. +specified style check, an appropriate message is given, preceded by +the character sequence ``(style)''. This message does not prevent +successful compilation (unless the @option{-gnatwe} switch is used). + @ifset vms @code{(option,option,@dots{})} is a sequence of keywords @end ifset @@ -6608,6 +6632,16 @@ year). The compiler will generate code based on the assumption that the condition being checked is true, which can result in disaster if that assumption is wrong. +The @option{-gnatp} switch has no effect if a subsequent +@option{-gnat-p} switch appears. + +@item -gnat-p +@cindex @option{-gnat-p} (@command{gcc}) +@cindex Suppressing checks +@cindex Checks, suppressing +@findex Suppress +This switch cancels the effect of a previous @option{gnatp} switch. + @item -gnato @cindex @option{-gnato} (@command{gcc}) @cindex Overflow checks @@ -6881,27 +6915,60 @@ uses of the new Ada 2005 features will cause error messages or warnings. This switch also can be used to cancel the effect of a previous -@option{-gnat83} or @option{-gnat05} switch earlier in the command line. +@option{-gnat83}, @option{-gnat05/2005}, or @option{-gnat12/2012} +switch earlier in the command line. -@item -gnat05 (Ada 2005 mode) +@item -gnat05 or -gnat2005 (Ada 2005 mode) @cindex @option{-gnat05} (@command{gcc}) +@cindex @option{-gnat2005} (@command{gcc}) @cindex Ada 2005 mode @noindent This switch directs the compiler to implement the Ada 2005 version of the -language. +language, as documented in the official Ada standards document. Since Ada 2005 is almost completely upwards compatible with Ada 95 (and thus also with Ada 83), Ada 83 and Ada 95 programs may generally be compiled using this switch (see the description of the @option{-gnat83} and @option{-gnat95} switches for further information). +Note that even though Ada 2005 is the current official version of the +language, GNAT still compiles in Ada 95 mode by default, so if you are +using Ada 2005 features in your program, you must use this switch (or +the equivalent Ada_05 or Ada_2005 configuration pragmas). + +@item -gnat12 or -gnat2012 (Ada 2012 mode) +@cindex @option{-gnat12} (@command{gcc}) +@cindex @option{-gnat2012} (@command{gcc}) +@cindex Ada 2012 mode + +@noindent +This switch directs the compiler to implement the Ada 2012 version of the +language. +Since Ada 2012 is almost completely upwards +compatible with Ada 2005 (and thus also with Ada 83, and Ada 95), +Ada 83 and Ada 95 programs +may generally be compiled using this switch (see the description of the +@option{-gnat83}, @option{-gnat95}, and @option{-gnat05/2005} switches +for further information). + For information about the approved ``Ada Issues'' that have been incorporated -into Ada 2005, see @url{http://www.ada-auth.org/cgi-bin/cvsweb.cgi/AIs}. -Included with GNAT releases is a file @file{features-ada0y} that describes -the set of implemented Ada 2005 features. -@end table +into Ada 2012, see @url{http://www.ada-auth.org/cgi-bin/cvsweb.cgi/AIs}. +Included with GNAT releases is a file @file{features-ada12} that describes +the set of implemented Ada 2012 features. + +@item -gnatX (Enable GNAT Extensions) +@cindex @option{-gnatX} (@command{gcc}) +@cindex Ada language extensions +@cindex GNAT extensions + +@noindent +This switch directs the compiler to implement the latest version of the +language (currently Ada 2012) and also to enable certain GNAT implementation +extensions that are not part of any Ada standard. For a full list of these +extensions, see the GNAT reference manual. +@end table @node Character Set Control @subsection Character Set Control @@ -7187,7 +7254,9 @@ Shows the storage pool associated with a @code{free} statement. Used to list an equivalent declaration for an internally generated type that is referenced elsewhere in the listing. -@item freeze @var{type-name} @ovar{actions} +@c @item freeze @var{type-name} @ovar{actions} +@c Expanding @ovar macro inline (explanation in macro def comments) +@item freeze @var{type-name} @r{[}@var{actions}@r{]} Shows the point at which @var{type-name} is frozen, with possible associated actions to be performed at the freeze point. @@ -7886,12 +7955,14 @@ to be read by the @command{gnatlink} utility used to link the Ada application. The form of the @code{gnatbind} command is @smallexample -$ gnatbind @ovar{switches} @var{mainprog}@r{[}.ali@r{]} @ovar{switches} +@c $ gnatbind @ovar{switches} @var{mainprog}@r{[}.ali@r{]} @ovar{switches} +@c Expanding @ovar macro inline (explanation in macro def comments) +$ gnatbind @r{[}@var{switches}@r{]} @var{mainprog}@r{[}.ali@r{]} @r{[}@var{switches}@r{]} @end smallexample @noindent where @file{@var{mainprog}.adb} is the Ada file containing the main program -unit body. If no switches are specified, @code{gnatbind} constructs an Ada +unit body. @code{gnatbind} constructs an Ada package in two files whose names are @file{b~@var{mainprog}.ads}, and @file{b~@var{mainprog}.adb}. For example, if given the @@ -7962,14 +8033,6 @@ the generated main program. It can also be debugged just like any other Ada code provided the @option{^-g^/DEBUG^} switch is used for @command{gnatbind} and @command{gnatlink}. -However for some purposes it may be convenient to generate the main -program in C rather than Ada. This may for example be helpful when you -are generating a mixed language program with the main program in C. The -GNAT compiler itself is an example. -The use of the @option{^-C^/BIND_FILE=C^} switch -for both @code{gnatbind} and @command{gnatlink} will cause the program to -be generated in C (and compiled using the gnu C compiler). - @node Switches for gnatbind @section Switches for @command{gnatbind} @@ -8013,9 +8076,9 @@ Specify directory to be searched for ALI files. @cindex @option{^-aI^/SOURCE_SEARCH^} (@command{gnatbind}) Specify directory to be searched for source file. -@item ^-A^/BIND_FILE=ADA^ -@cindex @option{^-A^/BIND_FILE=ADA^} (@command{gnatbind}) -Generate binder program in Ada (default) +@item ^-A^/ALI_LIST^@r{[=}@var{filename}@r{]} +@cindex @option{^-A^/ALI_LIST^} (@command{gnatbind}) +Output ALI list (to standard output or to the named file). @item ^-b^/REPORT_ERRORS=BRIEF^ @cindex @option{^-b^/REPORT_ERRORS=BRIEF^} (@command{gnatbind}) @@ -8025,10 +8088,6 @@ Generate brief messages to @file{stderr} even if verbose mode set. @cindex @option{^-c^/NOOUTPUT^} (@command{gnatbind}) Check only, no generation of binder output file. -@item ^-C^/BIND_FILE=C^ -@cindex @option{^-C^/BIND_FILE=C^} (@command{gnatbind}) -Generate binder program in C - @item ^-d^/DEFAULT_STACK_SIZE=^@var{nn}@r{[}k@r{|}m@r{]} @cindex @option{^-d^/DEFAULT_STACK_SIZE=^@var{nn}@r{[}k@r{|}m@r{]}} (@command{gnatbind}) This switch can be used to change the default task stack size value @@ -8173,9 +8232,9 @@ Name the output file @var{file} (default is @file{b~@var{xxx}.adb}). Note that if this option is used, then linking must be done manually, gnatlink cannot be used. -@item ^-O^/OBJECT_LIST^ +@item ^-O^/OBJECT_LIST^@r{[=}@var{filename}@r{]} @cindex @option{^-O^/OBJECT_LIST^} (@command{gnatbind}) -Output object list. +Output object list (to standard output or to the named file). @item ^-p^/PESSIMISTIC_ELABORATION^ @cindex @option{^-p^/PESSIMISTIC_ELABORATION^} (@command{gnatbind}) @@ -8474,24 +8533,11 @@ generated by the binder. @table @option @c !sort! -@item ^-A^/BIND_FILE=ADA^ -@cindex @option{^-A^/BIND_FILE=ADA^} (@code{gnatbind}) -Generate binder program in Ada (default). The binder program is named -@file{b~@var{mainprog}.adb} by default. This can be changed with -@option{^-o^/OUTPUT^} @code{gnatbind} option. - @item ^-c^/NOOUTPUT^ @cindex @option{^-c^/NOOUTPUT^} (@code{gnatbind}) Check only. Do not generate the binder output file. In this mode the binder performs all error checks but does not generate an output file. -@item ^-C^/BIND_FILE=C^ -@cindex @option{^-C^/BIND_FILE=C^} (@code{gnatbind}) -Generate binder program in C. The binder program is named -@file{b_@var{mainprog}.c}. -This can be changed with @option{^-o^/OUTPUT^} @code{gnatbind} -option. - @item ^-e^/ELABORATION_DEPENDENCIES^ @cindex @option{^-e^/ELABORATION_DEPENDENCIES^} (@code{gnatbind}) Output complete list of elaboration-order dependencies, showing the @@ -8526,8 +8572,7 @@ directory names for the run-time units depend on the system configuration. @cindex @option{^-o^/OUTPUT^} (@code{gnatbind}) Set name of output file to @var{file} instead of the normal @file{b~@var{mainprog}.adb} default. Note that @var{file} denote the Ada -binder generated body filename. In C mode you would normally give -@var{file} an extension of @file{.c} because it will be a C source program. +binder generated body filename. Note that if this option is used, then linking must be done manually. It is not possible to use gnatlink in this case, since it cannot locate the binder file. @@ -8601,9 +8646,7 @@ more quite separate groups of Ada units. The binder takes the name of its output file from the last specified ALI file, unless overridden by the use of the @option{^-o file^/OUTPUT=file^}. @cindex @option{^-o^/OUTPUT^} (@command{gnatbind}) -The output is an Ada unit in source form that can -be compiled with GNAT unless the -C switch is used in which case the -output is a C source file, which must be compiled using the C compiler. +The output is an Ada unit in source form that can be compiled with GNAT. This compilation occurs automatically as part of the @command{gnatlink} processing. @@ -8800,39 +8843,8 @@ The main program @code{Hello} (source program in @file{hello.adb}) is bound using the standard switch settings. The generated main program is @file{mainprog.adb} with the associated spec in @file{mainprog.ads}. Note that you must specify the body here not the -spec, in the case where the output is in Ada. Note that if this option -is used, then linking must be done manually, since gnatlink will not -be able to find the generated file. - -@ifclear vms -@item gnatbind main -C -o mainprog.c -x -@end ifclear -@ifset vms -@item gnatbind MAIN.ALI /BIND_FILE=C /OUTPUT=Mainprog.C /READ_SOURCES=NONE -@end ifset -The main program @code{Main} (source program in -@file{main.adb}) is bound, excluding source files from the -consistency checking, generating -the file @file{mainprog.c}. - -@ifclear vms -@item gnatbind -x main_program -C -o mainprog.c -This command is exactly the same as the previous example. Switches may -appear anywhere in the command line, and single letter switches may be -combined into a single switch. -@end ifclear - -@ifclear vms -@item gnatbind -n math dbase -C -o ada-control.c -@end ifclear -@ifset vms -@item gnatbind /NOMAIN math dbase /BIND_FILE=C /OUTPUT=ada-control.c -@end ifset -The main program is in a language other than Ada, but calls to -subprograms in packages @code{Math} and @code{Dbase} appear. This call -to @code{gnatbind} generates the file @file{ada-control.c} containing -the @code{adainit} and @code{adafinal} routines to be called before and -after accessing the Ada units. +spec. Note that if this option is used, then linking must be done manually, +since gnatlink will not be able to find the generated file. @end table @c ------------------------------------ @@ -8865,8 +8877,12 @@ driver (see @ref{The GNAT Driver and Project Files}). The form of the @command{gnatlink} command is @smallexample -$ gnatlink @ovar{switches} @var{mainprog}@r{[}.ali@r{]} - @ovar{non-Ada objects} @ovar{linker options} +@c $ gnatlink @ovar{switches} @var{mainprog}@r{[}.ali@r{]} +@c @ovar{non-Ada objects} @ovar{linker options} +@c Expanding @ovar macro inline (explanation in macro def comments) +$ gnatlink @r{[}@var{switches}@r{]} @var{mainprog}@r{[}.ali@r{]} + @r{[}@var{non-Ada objects}@r{]} @r{[}@var{linker options}@r{]} + @end smallexample @noindent @@ -8947,17 +8963,6 @@ Display Copyright and version, then exit disregarding all other options. If @option{--version} was not used, display usage, then exit disregarding all other options. -@item ^-A^/BIND_FILE=ADA^ -@cindex @option{^-A^/BIND_FILE=ADA^} (@command{gnatlink}) -The binder has generated code in Ada. This is the default. - -@item ^-C^/BIND_FILE=C^ -@cindex @option{^-C^/BIND_FILE=C^} (@command{gnatlink}) -If instead of generating a file in Ada, the binder has generated one in -C, then the linker needs to know about it. Use this switch to signal -to @command{gnatlink} that the binder has generated C code rather than -Ada code. - @item ^-f^/FORCE_OBJECT_FILE_LIST^ @cindex Command line length @cindex @option{^-f^/FORCE_OBJECT_FILE_LIST^} (@command{gnatlink}) @@ -9144,8 +9149,11 @@ dependencies, they will always be tracked exactly correctly by The usual form of the @command{gnatmake} command is @smallexample -$ gnatmake @ovar{switches} @var{file_name} - @ovar{file_names} @ovar{mode_switches} +@c $ gnatmake @ovar{switches} @var{file_name} +@c @ovar{file_names} @ovar{mode_switches} +@c Expanding @ovar macro inline (explanation in macro def comments) +$ gnatmake @r{[}@var{switches}@r{]} @var{file_name} + @r{[}@var{file_names}@r{]} @r{[}@var{mode_switches}@r{]} @end smallexample @noindent @@ -9233,6 +9241,15 @@ itself must not include any embedded spaces. @end ifclear +@item ^--subdirs^/SUBDIRS^=subdir +Actual object directory of each project file is the subdirectory subdir of the +object directory specified or defauted in the project file. + +@item ^--unchecked-shared-lib-imports^/UNCHECKED_SHARED_LIB_IMPORTS^ +By default, shared library projects are not allowed to import static library +projects. When this switch is used on the command line, this restriction is +relaxed. + @item ^-a^/ALL_FILES^ @cindex @option{^-a^/ALL_FILES^} (@command{gnatmake}) Consider all files in the make process, even the GNAT internal system @@ -10670,6 +10687,7 @@ program. @menu * About gnatelim:: * Running gnatelim:: +* Processing Precompiled Libraries:: * Correcting the List of Eliminate Pragmas:: * Making Your Executables Smaller:: * Summary of the gnatelim Usage Cycle:: @@ -10693,20 +10711,24 @@ because the compiler will not generate the code for 'eliminated' subprograms. @xref{Pragma Eliminate,,, gnat_rm, GNAT Reference Manual}, for more information about this pragma. -@code{gnatelim} needs as its input data the name of the main subprogram -and a bind file for a main subprogram. +@code{gnatelim} needs as its input data the name of the main subprogram. + +If a set of source files is specified as @code{gnatelim} arguments, it +treats these files as a complete set of sources making up a program to +analyse, and analyses only these sources. + +After a full successful build of the main subprogram @code{gnatelim} can be +called without specifying sources to analyse, in this case it computes +the source closure of the main unit from the @file{ALI} files. -To create a bind file for @code{gnatelim}, run @code{gnatbind} for -the main subprogram. @code{gnatelim} can work with both Ada and C -bind files; when both are present, it uses the Ada bind file. -The following commands will build the program and create the bind file: +The following command will create the set of @file{ALI} files needed for +@code{gnatelim}: @smallexample $ gnatmake ^-c Main_Prog^/ACTIONS=COMPILE MAIN_PROG^ -$ gnatbind main_prog @end smallexample -Note that @code{gnatelim} needs neither object nor ALI files. +Note that @code{gnatelim} does not need object files. @node Running gnatelim @subsection Running @code{gnatelim} @@ -10715,23 +10737,64 @@ Note that @code{gnatelim} needs neither object nor ALI files. @code{gnatelim} has the following command-line interface: @smallexample -$ gnatelim @ovar{options} name +$ gnatelim [@var{switches}] ^-main^?MAIN^=@var{main_unit_name} @{@var{filename}@} @r{[}-cargs @var{gcc_switches}@r{]} @end smallexample @noindent -@code{name} should be a name of a source file that contains the main subprogram -of a program (partition). +@var{main_unit_name} should be a name of a source file that contains the main +subprogram of a program (partition). + +Each @var{filename} is the name (including the extension) of a source +file to process. ``Wildcards'' are allowed, and +the file name may contain path information. + +@samp{@var{gcc_switches}} is a list of switches for +@command{gcc}. They will be passed on to all compiler invocations made by +@command{gnatelim} to generate the ASIS trees. Here you can provide +@option{^-I^/INCLUDE_DIRS=^} switches to form the source search path, +use the @option{-gnatec} switch to set the configuration file etc. @code{gnatelim} has the following switches: @table @option @c !sort! +@item ^-files^/FILES^=@var{filename} +@cindex @option{^-files^/FILES^} (@code{gnatelim}) +Take the argument source files from the specified file. This file should be an +ordinary text file containing file names separated by spaces or +line breaks. You can use this switch more than once in the same call to +@command{gnatelim}. You also can combine this switch with +an explicit list of files. + +@item ^-log^/LOG^ +@cindex @option{^-log^/LOG^} (@command{gnatelim}) +Duplicate all the output sent to @file{stderr} into a log file. The log file +is named @file{gnatelim.log} and is located in the current directory. + +@item ^-log^/LOGFILE^=@var{filename} +@cindex @option{^-log^/LOGFILE^} (@command{gnatelim}) +Duplicate all the output sent to @file{stderr} into a specified log file. + +@cindex @option{^--no-elim-dispatch^/NO_DISPATCH^} (@command{gnatelim}) +@item ^--no-elim-dispatch^/NO_DISPATCH^ +Do not generate pragmas for dispatching operations. + +@cindex @option{^-o^/OUTPUT^} (@command{gnatelim}) +@item ^-o^/OUTPUT^=@var{report_file} +Put @command{gnatelim} output into a specified file. If this file already exists, +it is overridden. If this switch is not used, @command{gnatelim} outputs its results +into @file{stderr} + @item ^-q^/QUIET^ @cindex @option{^-q^/QUIET^} (@command{gnatelim}) Quiet mode: by default @code{gnatelim} outputs to the standard error stream the number of program units left to be processed. This option turns this trace off. +@cindex @option{^-t^/TIME^} (@command{gnatelim}) +@item ^-t^/TIME^ +Print out execution time. + @item ^-v^/VERBOSE^ @cindex @option{^-v^/VERBOSE^} (@command{gnatelim}) Verbose mode: @code{gnatelim} version information is printed as Ada @@ -10739,67 +10802,24 @@ comments to the standard output stream. Also, in addition to the number of program units left @code{gnatelim} will output the name of the current unit being processed. -@item ^-a^/ALL^ -@cindex @option{^-a^/ALL^} (@command{gnatelim}) -Also look for subprograms from the GNAT run time that can be eliminated. Note -that when @file{gnat.adc} is produced using this switch, the entire program -must be recompiled with switch @option{^-a^/ALL_FILES^} to @command{gnatmake}. - -@item ^-I^/INCLUDE_DIRS=^@var{dir} -@cindex @option{^-I^/INCLUDE_DIRS^} (@command{gnatelim}) -When looking for source files also look in directory @var{dir}. Specifying -@option{^-I-^/INCLUDE_DIRS=-^} instructs @code{gnatelim} not to look for -sources in the current directory. - -@item ^-b^/BIND_FILE=^@var{bind_file} -@cindex @option{^-b^/BIND_FILE^} (@command{gnatelim}) -Specifies @var{bind_file} as the bind file to process. If not set, the name -of the bind file is computed from the full expanded Ada name -of a main subprogram. - -@item ^-C^/CONFIG_FILE=^@var{config_file} -@cindex @option{^-C^/CONFIG_FILE^} (@command{gnatelim}) -Specifies a file @var{config_file} that contains configuration pragmas. The -file must be specified with full path. - -@item ^--GCC^/COMPILER^=@var{compiler_name} -@cindex @option{^-GCC^/COMPILER^} (@command{gnatelim}) -Instructs @code{gnatelim} to use specific @command{gcc} compiler instead of one -available on the path. - -@item ^--GNATMAKE^/GNATMAKE^=@var{gnatmake_name} -@cindex @option{^--GNATMAKE^/GNATMAKE^} (@command{gnatelim}) -Instructs @code{gnatelim} to use specific @command{gnatmake} instead of one -available on the path. +@item ^-wq^/WARNINGS=QUIET^ +@cindex @option{^-wq^/WARNINGS=QUIET^} (@command{gnatelim}) +Quet warning mode - some warnings are suppressed. In particular warnings that +indicate that the analysed set of sources is incomplete to make up a +partition and that some subprogram bodies are missing are not generated. @end table -@noindent -@code{gnatelim} sends its output to the standard output stream, and all the -tracing and debug information is sent to the standard error stream. -In order to produce a proper GNAT configuration file -@file{gnat.adc}, redirection must be used: - -@smallexample -@ifset vms -$ PIPE GNAT ELIM MAIN_PROG.ADB > GNAT.ADC -@end ifset -@ifclear vms -$ gnatelim main_prog.adb > gnat.adc -@end ifclear -@end smallexample - -@ifclear vms -@noindent -or - -@smallexample -$ gnatelim main_prog.adb >> gnat.adc -@end smallexample +@node Processing Precompiled Libraries +@subsection Processing Precompiled Libraries @noindent -in order to append the @code{gnatelim} output to the existing contents of -@file{gnat.adc}. -@end ifclear +If some program uses a precompiled Ada library, it can be processed by +@code{gnatelim} in a usual way. @code{gnatelim} will newer generate an +Eliminate pragma for a subprogram if the body of this subprogram has not +been analysed, this is a typical case for subprograms from precompiled +libraries. Switch @option{^-wq^/WARNINGS=QUIET^} may be used to suppress +warnings about missing source files and non-analyzed subprogram bodies +that can be generated when processing precompiled Ada libraries. @node Correcting the List of Eliminate Pragmas @subsection Correcting the List of Eliminate Pragmas @@ -10810,22 +10830,23 @@ subprograms that are actually called in the program. In this case, the compiler will generate an error message of the form: @smallexample -file.adb:106:07: cannot call eliminated subprogram "My_Prog" +main.adb:4:08: cannot reference subprogram "P" eliminated at elim.out:5 @end smallexample @noindent You will need to manually remove the wrong @code{Eliminate} pragmas from -the @file{gnat.adc} file. You should recompile your program -from scratch after that, because you need a consistent @file{gnat.adc} file -during the entire compilation. +the configuration file indicated in the error message. You should recompile +your program from scratch after that, because you need a consistent +configuration file(s) during the entire compilation. @node Making Your Executables Smaller @subsection Making Your Executables Smaller @noindent In order to get a smaller executable for your program you now have to -recompile the program completely with the new @file{gnat.adc} file -created by @code{gnatelim} in your current directory: +recompile the program completely with the configuration file containing +pragmas Eliminate generated by gnatelim. If these pragmas are placed in +@file{gnat.adc} file located in your current directory, just do: @smallexample $ gnatmake ^-f main_prog^/FORCE_COMPILE MAIN_PROG^ @@ -10839,10 +10860,10 @@ with the set of pragmas @code{Eliminate} that you have obtained with Be aware that the set of @code{Eliminate} pragmas is specific to each program. It is not recommended to merge sets of @code{Eliminate} -pragmas created for different programs in one @file{gnat.adc} file. +pragmas created for different programs in one configuration file. @node Summary of the gnatelim Usage Cycle -@subsection Summary of the gnatelim Usage Cycle +@subsection Summary of the @code{gnatelim} Usage Cycle @noindent Here is a quick summary of the steps to be taken in order to reduce @@ -10852,15 +10873,16 @@ to produce the debugging information, to set search path, etc. @enumerate @item -Produce a bind file +Create a complete set of @file{ALI} files (if the program has not been +built already) @smallexample $ gnatmake ^-c main_prog^/ACTIONS=COMPILE MAIN_PROG^ -$ gnatbind main_prog @end smallexample @item -Generate a list of @code{Eliminate} pragmas +Generate a list of @code{Eliminate} pragmas in default configuration file +@file{gnat.adc} in the current directory @smallexample @ifset vms $ PIPE GNAT ELIM MAIN_PROG > GNAT.ADC @@ -11119,8 +11141,11 @@ in which GNAT processes the ACVC tests. The @code{gnatchop} command has the form: @smallexample +@c $ gnatchop switches @var{file name} @r{[}@var{file name} @dots{}@r{]} +@c @ovar{directory} +@c Expanding @ovar macro inline (explanation in macro def comments) $ gnatchop switches @var{file name} @r{[}@var{file name} @dots{}@r{]} - @ovar{directory} + @r{[}@var{directory}@r{]} @end smallexample @noindent @@ -11376,6 +11401,8 @@ recognized by GNAT: Ada_95 Ada_05 Ada_2005 + Ada_12 + Ada_2012 Assertion_Policy Assume_No_Invalid_Values C_Pass_By_Copy @@ -11419,6 +11446,7 @@ recognized by GNAT: Restrictions Restrictions_Warnings Reviewable + Short_Circuit_And_Or Source_File_Name Source_File_Name_Project Style_Checks @@ -11546,8 +11574,11 @@ set of files. The usual form of the @code{gnatname} command is @smallexample -$ gnatname @ovar{switches} @var{naming_pattern} @ovar{naming_patterns} - @r{[}--and @ovar{switches} @var{naming_pattern} @ovar{naming_patterns}@r{]} +@c $ gnatname @ovar{switches} @var{naming_pattern} @ovar{naming_patterns} +@c @r{[}--and @ovar{switches} @var{naming_pattern} @ovar{naming_patterns}@r{]} +@c Expanding @ovar macro inline (explanation in macro def comments) +$ gnatname @r{[}@var{switches}@r{]} @var{naming_pattern} @r{[}@var{naming_patterns}@r{]} + @r{[}--and @r{[}@var{switches}@r{]} @var{naming_pattern} @r{[}@var{naming_patterns}@r{]}@r{]} @end smallexample @noindent @@ -11563,7 +11594,8 @@ regular files. @noindent One or several Naming Patterns may be given as arguments to @code{gnatname}. -Each Naming Pattern is enclosed between double quotes. +Each Naming Pattern is enclosed between double quotes (or single +quotes on Windows). A Naming Pattern is a regular expression similar to the wildcard patterns used in file names by the Unix shells or the DOS prompt. @@ -11762,11184 +11794,5844 @@ are used in this example. @c ***************************************** @c * G N A T P r o j e c t M a n a g e r * @c ***************************************** -@node GNAT Project Manager -@chapter GNAT Project Manager - -@menu -* Introduction:: -* Examples of Project Files:: -* Project File Syntax:: -* Objects and Sources in Project Files:: -* Importing Projects:: -* Project Extension:: -* Project Hierarchy Extension:: -* External References in Project Files:: -* Packages in Project Files:: -* Variables from Imported Projects:: -* Naming Schemes:: -* Library Projects:: -* Stand-alone Library Projects:: -* Switches Related to Project Files:: -* Tools Supporting Project Files:: -* An Extended Example:: -* Project File Complete Syntax:: -@end menu - -@c **************** -@c * Introduction * -@c **************** -@node Introduction -@section Introduction +@c ------ macros for projects.texi +@c These macros are needed when building the gprbuild documentation, but +@c should have no effect in the gnat user's guide -@noindent -This chapter describes GNAT's @emph{Project Manager}, a facility that allows -you to manage complex builds involving a number of source files, directories, -and compilation options for different system configurations. In particular, -project files allow you to specify: -@itemize @bullet -@item -The directory or set of directories containing the source files, and/or the -names of the specific source files themselves -@item -The directory in which the compiler's output -(@file{ALI} files, object files, tree files) is to be placed -@item -The directory in which the executable programs is to be placed -@item -^Switch^Switch^ settings for any of the project-enabled tools -(@command{gnatmake}, compiler, binder, linker, @code{gnatls}, @code{gnatxref}, -@code{gnatfind}); you can apply these settings either globally or to individual -compilation units. -@item -The source files containing the main subprogram(s) to be built -@item -The source programming language(s) (currently Ada and/or C) -@item -Source file naming conventions; you can specify these either globally or for -individual compilation units -@end itemize +@macro CODESAMPLE{TXT} +@smallexample +@group +\TXT\ +@end group +@end smallexample +@end macro -@menu -* Project Files:: -@end menu +@macro PROJECTFILE{TXT} +@CODESAMPLE{\TXT\} +@end macro -@node Project Files -@subsection Project Files - -@noindent -Project files are written in a syntax close to that of Ada, using familiar -notions such as packages, context clauses, declarations, default values, -assignments, and inheritance. Finally, project files can be built -hierarchically from other project files, simplifying complex system -integration and project reuse. - -A @dfn{project} is a specific set of values for various compilation properties. -The settings for a given project are described by means of -a @dfn{project file}, which is a text file written in an Ada-like syntax. -Property values in project files are either strings or lists of strings. -Properties that are not explicitly set receive default values. A project -file may interrogate the values of @dfn{external variables} (user-defined -command-line switches or environment variables), and it may specify property -settings conditionally, based on the value of such variables. - -In simple cases, a project's source files depend only on other source files -in the same project, or on the predefined libraries. (@emph{Dependence} is -used in -the Ada technical sense; as in one Ada unit @code{with}ing another.) However, -the Project Manager also allows more sophisticated arrangements, -where the source files in one project depend on source files in other -projects: -@itemize @bullet -@item -One project can @emph{import} other projects containing needed source files. -@item -You can organize GNAT projects in a hierarchy: a @emph{child} project -can extend a @emph{parent} project, inheriting the parent's source files and -optionally overriding any of them with alternative versions -@end itemize +@c simulates a newline when in a @CODESAMPLE +@macro NL{} +@end macro +@macro TIP{TXT} +@quotation @noindent -More generally, the Project Manager lets you structure large development -efforts into hierarchical subsystems, where build decisions are delegated -to the subsystem level, and thus different compilation environments -(^switch^switch^ settings) used for different subsystems. +\TXT\ +@end quotation +@end macro -The Project Manager is invoked through the -@option{^-P^/PROJECT_FILE=^@emph{projectfile}} -switch to @command{gnatmake} or to the @command{^gnat^GNAT^} front driver. -@ifclear vms -There may be zero, one or more spaces between @option{-P} and -@option{@emph{projectfile}}. -@end ifclear -If you want to define (on the command line) an external variable that is -queried by the project file, you must use the -@option{^-X^/EXTERNAL_REFERENCE=^@emph{vbl}=@emph{value}} switch. -The Project Manager parses and interprets the project file, and drives the -invoked tool based on the project settings. - -The Project Manager supports a wide range of development strategies, -for systems of all sizes. Here are some typical practices that are -easily handled: -@itemize @bullet -@item -Using a common set of source files, but generating object files in different -directories via different ^switch^switch^ settings -@item -Using a mostly-shared set of source files, but with different versions of -some unit or units -@end itemize +@macro TIPHTML{TXT} +\TXT\ +@end macro +@macro IMPORTANT{TXT} +@quotation @noindent -The destination of an executable can be controlled inside a project file -using the @option{^-o^-o^} -^switch^switch^. -In the absence of such a ^switch^switch^ either inside -the project file or on the command line, any executable files generated by -@command{gnatmake} are placed in the directory @code{Exec_Dir} specified -in the project file. If no @code{Exec_Dir} is specified, they will be placed -in the object directory of the project. - -You can use project files to achieve some of the effects of a source -versioning system (for example, defining separate projects for -the different sets of sources that comprise different releases) but the -Project Manager is independent of any source configuration management tools -that might be used by the developers. - -The next section introduces the main features of GNAT's project facility -through a sequence of examples; subsequent sections will present the syntax -and semantics in more detail. A more formal description of the project -facility appears in @ref{Project File Reference,,, gnat_rm, GNAT -Reference Manual}. +\TXT\ +@end quotation -@c ***************************** -@c * Examples of Project Files * -@c ***************************** +@end macro -@node Examples of Project Files -@section Examples of Project Files +@macro NOTE{TXT} +@quotation @noindent -This section illustrates some of the typical uses of project files and -explains their basic structure and behavior. - -@menu -* Common Sources with Different ^Switches^Switches^ and Directories:: -* Using External Variables:: -* Importing Other Projects:: -* Extending a Project:: -@end menu +\TXT\ +@end quotation +@end macro -@node Common Sources with Different ^Switches^Switches^ and Directories -@subsection Common Sources with Different ^Switches^Switches^ and Directories +@include projects.texi -@menu -* Source Files:: -* Specifying the Object Directory:: -* Specifying the Exec Directory:: -* Project File Packages:: -* Specifying ^Switch^Switch^ Settings:: -* Main Subprograms:: -* Executable File Names:: -* Source File Naming Conventions:: -* Source Language(s):: -@end menu +@c ***************************************** +@c * Cross-referencing tools +@c ***************************************** -@noindent -Suppose that the Ada source files @file{pack.ads}, @file{pack.adb}, and -@file{proc.adb} are in the @file{/common} directory. The file -@file{proc.adb} contains an Ada main subprogram @code{Proc} that @code{with}s -package @code{Pack}. We want to compile these source files under two sets -of ^switches^switches^: -@itemize @bullet -@item -When debugging, we want to pass the @option{-g} switch to @command{gnatmake}, -and the @option{^-gnata^-gnata^}, -@option{^-gnato^-gnato^}, -and @option{^-gnatE^-gnatE^} switches to the -compiler; the compiler's output is to appear in @file{/common/debug} -@item -When preparing a release version, we want to pass the @option{^-O2^O2^} switch -to the compiler; the compiler's output is to appear in @file{/common/release} -@end itemize +@node The Cross-Referencing Tools gnatxref and gnatfind +@chapter The Cross-Referencing Tools @code{gnatxref} and @code{gnatfind} +@findex gnatxref +@findex gnatfind @noindent -The GNAT project files shown below, respectively @file{debug.gpr} and -@file{release.gpr} in the @file{/common} directory, achieve these effects. +The compiler generates cross-referencing information (unless +you set the @samp{-gnatx} switch), which are saved in the @file{.ali} files. +This information indicates where in the source each entity is declared and +referenced. Note that entities in package Standard are not included, but +entities in all other predefined units are included in the output. -Schematically: -@smallexample -@group -^/common^[COMMON]^ - debug.gpr - release.gpr - pack.ads - pack.adb - proc.adb -@end group -@group -^/common/debug^[COMMON.DEBUG]^ - proc.ali, proc.o - pack.ali, pack.o -@end group -@group -^/common/release^[COMMON.RELEASE]^ - proc.ali, proc.o - pack.ali, pack.o -@end group -@end smallexample -Here are the corresponding project files: +Before using any of these two tools, you need to compile successfully your +application, so that GNAT gets a chance to generate the cross-referencing +information. -@smallexample @c projectfile -@group -project Debug is - for Object_Dir use "debug"; - for Main use ("proc"); - - package Builder is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-g^-g^"); - for Executable ("proc.adb") use "proc1"; - end Builder; -@end group +The two tools @code{gnatxref} and @code{gnatfind} take advantage of this +information to provide the user with the capability to easily locate the +declaration and references to an entity. These tools are quite similar, +the difference being that @code{gnatfind} is intended for locating +definitions and/or references to a specified entity or entities, whereas +@code{gnatxref} is oriented to generating a full report of all +cross-references. -@group - package Compiler is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("-fstack-check", - "^-gnata^-gnata^", - "^-gnato^-gnato^", - "^-gnatE^-gnatE^"); - end Compiler; -end Debug; -@end group -@end smallexample +To use these tools, you must not compile your application using the +@option{-gnatx} switch on the @command{gnatmake} command line +(@pxref{The GNAT Make Program gnatmake}). Otherwise, cross-referencing +information will not be generated. -@smallexample @c projectfile -@group -project Release is - for Object_Dir use "release"; - for Exec_Dir use "."; - for Main use ("proc"); - - package Compiler is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-O2^-O2^"); - end Compiler; -end Release; -@end group -@end smallexample +Note: to invoke @code{gnatxref} or @code{gnatfind} with a project file, +use the @code{gnat} driver (see @ref{The GNAT Driver and Project Files}). -@noindent -The name of the project defined by @file{debug.gpr} is @code{"Debug"} (case -insensitive), and analogously the project defined by @file{release.gpr} is -@code{"Release"}. For consistency the file should have the same name as the -project, and the project file's extension should be @code{"gpr"}. These -conventions are not required, but a warning is issued if they are not followed. +@menu +* Switches for gnatxref:: +* Switches for gnatfind:: +* Project Files for gnatxref and gnatfind:: +* Regular Expressions in gnatfind and gnatxref:: +* Examples of gnatxref Usage:: +* Examples of gnatfind Usage:: +@end menu -If the current directory is @file{^/temp^[TEMP]^}, then the command -@smallexample -gnatmake ^-P/common/debug.gpr^/PROJECT_FILE=[COMMON]DEBUG^ -@end smallexample +@node Switches for gnatxref +@section @code{gnatxref} Switches @noindent -generates object and ALI files in @file{^/common/debug^[COMMON.DEBUG]^}, -as well as the @code{^proc1^PROC1.EXE^} executable, -using the ^switch^switch^ settings defined in the project file. - -Likewise, the command +The command invocation for @code{gnatxref} is: @smallexample -gnatmake ^-P/common/release.gpr^/PROJECT_FILE=[COMMON]RELEASE^ +@c $ gnatxref @ovar{switches} @var{sourcefile1} @r{[}@var{sourcefile2} @dots{}@r{]} +@c Expanding @ovar macro inline (explanation in macro def comments) +$ gnatxref @r{[}@var{switches}@r{]} @var{sourcefile1} @r{[}@var{sourcefile2} @dots{}@r{]} @end smallexample @noindent -generates object and ALI files in @file{^/common/release^[COMMON.RELEASE]^}, -and the @code{^proc^PROC.EXE^} -executable in @file{^/common^[COMMON]^}, -using the ^switch^switch^ settings from the project file. - -@node Source Files -@unnumberedsubsubsec Source Files +where -@noindent -If a project file does not explicitly specify a set of source directories or -a set of source files, then by default the project's source files are the -Ada source files in the project file directory. Thus @file{pack.ads}, -@file{pack.adb}, and @file{proc.adb} are the source files for both projects. +@table @var +@item sourcefile1 +@itemx sourcefile2 +identifies the source files for which a report is to be generated. The +``with''ed units will be processed too. You must provide at least one file. -@node Specifying the Object Directory -@unnumberedsubsubsec Specifying the Object Directory +These file names are considered to be regular expressions, so for instance +specifying @file{source*.adb} is the same as giving every file in the current +directory whose name starts with @file{source} and whose extension is +@file{adb}. -@noindent -Several project properties are modeled by Ada-style @emph{attributes}; -a property is defined by supplying the equivalent of an Ada attribute -definition clause in the project file. -A project's object directory is another such a property; the corresponding -attribute is @code{Object_Dir}, and its value is also a string expression, -specified either as absolute or relative. In the later case, -it is relative to the project file directory. Thus the compiler's -output is directed to @file{^/common/debug^[COMMON.DEBUG]^} -(for the @code{Debug} project) -and to @file{^/common/release^[COMMON.RELEASE]^} -(for the @code{Release} project). -If @code{Object_Dir} is not specified, then the default is the project file -directory itself. +You shouldn't specify any directory name, just base names. @command{gnatxref} +and @command{gnatfind} will be able to locate these files by themselves using +the source path. If you specify directories, no result is produced. -@node Specifying the Exec Directory -@unnumberedsubsubsec Specifying the Exec Directory +@end table @noindent -A project's exec directory is another property; the corresponding -attribute is @code{Exec_Dir}, and its value is also a string expression, -either specified as relative or absolute. If @code{Exec_Dir} is not specified, -then the default is the object directory (which may also be the project file -directory if attribute @code{Object_Dir} is not specified). Thus the executable -is placed in @file{^/common/debug^[COMMON.DEBUG]^} -for the @code{Debug} project (attribute @code{Exec_Dir} not specified) -and in @file{^/common^[COMMON]^} for the @code{Release} project. - -@node Project File Packages -@unnumberedsubsubsec Project File Packages +The switches can be: +@table @option +@c !sort! +@item --version +@cindex @option{--version} @command{gnatxref} +Display Copyright and version, then exit disregarding all other options. -@noindent -A GNAT tool that is integrated with the Project Manager is modeled by a -corresponding package in the project file. In the example above, -The @code{Debug} project defines the packages @code{Builder} -(for @command{gnatmake}) and @code{Compiler}; -the @code{Release} project defines only the @code{Compiler} package. +@item --help +@cindex @option{--help} @command{gnatxref} +If @option{--version} was not used, display usage, then exit disregarding +all other options. -The Ada-like package syntax is not to be taken literally. Although packages in -project files bear a surface resemblance to packages in Ada source code, the -notation is simply a way to convey a grouping of properties for a named -entity. Indeed, the package names permitted in project files are restricted -to a predefined set, corresponding to the project-aware tools, and the contents -of packages are limited to a small set of constructs. -The packages in the example above contain attribute definitions. +@item ^-a^/ALL_FILES^ +@cindex @option{^-a^/ALL_FILES^} (@command{gnatxref}) +If this switch is present, @code{gnatfind} and @code{gnatxref} will parse +the read-only files found in the library search path. Otherwise, these files +will be ignored. This option can be used to protect Gnat sources or your own +libraries from being parsed, thus making @code{gnatfind} and @code{gnatxref} +much faster, and their output much smaller. Read-only here refers to access +or permissions status in the file system for the current user. -@node Specifying ^Switch^Switch^ Settings -@unnumberedsubsubsec Specifying ^Switch^Switch^ Settings +@item -aIDIR +@cindex @option{-aIDIR} (@command{gnatxref}) +When looking for source files also look in directory DIR. The order in which +source file search is undertaken is the same as for @command{gnatmake}. -@noindent -^Switch^Switch^ settings for a project-aware tool can be specified through -attributes in the package that corresponds to the tool. -The example above illustrates one of the relevant attributes, -@code{^Default_Switches^Default_Switches^}, which is defined in packages -in both project files. -Unlike simple attributes like @code{Source_Dirs}, -@code{^Default_Switches^Default_Switches^} is -known as an @emph{associative array}. When you define this attribute, you must -supply an ``index'' (a literal string), and the effect of the attribute -definition is to set the value of the array at the specified index. -For the @code{^Default_Switches^Default_Switches^} attribute, -the index is a programming language (in our case, Ada), -and the value specified (after @code{use}) must be a list -of string expressions. +@item -aODIR +@cindex @option{-aODIR} (@command{gnatxref}) +When searching for library and object files, look in directory +DIR. The order in which library files are searched is the same as for +@command{gnatmake}. -The attributes permitted in project files are restricted to a predefined set. -Some may appear at project level, others in packages. -For any attribute that is an associative array, the index must always be a -literal string, but the restrictions on this string (e.g., a file name or a -language name) depend on the individual attribute. -Also depending on the attribute, its specified value will need to be either a -string or a string list. - -In the @code{Debug} project, we set the switches for two tools, -@command{gnatmake} and the compiler, and thus we include the two corresponding -packages; each package defines the @code{^Default_Switches^Default_Switches^} -attribute with index @code{"Ada"}. -Note that the package corresponding to -@command{gnatmake} is named @code{Builder}. The @code{Release} project is -similar, but only includes the @code{Compiler} package. - -In project @code{Debug} above, the ^switches^switches^ starting with -@option{-gnat} that are specified in package @code{Compiler} -could have been placed in package @code{Builder}, since @command{gnatmake} -transmits all such ^switches^switches^ to the compiler. - -@node Main Subprograms -@unnumberedsubsubsec Main Subprograms - -@noindent -One of the specifiable properties of a project is a list of files that contain -main subprograms. This property is captured in the @code{Main} attribute, -whose value is a list of strings. If a project defines the @code{Main} -attribute, it is not necessary to identify the main subprogram(s) when -invoking @command{gnatmake} (@pxref{gnatmake and Project Files}). - -@node Executable File Names -@unnumberedsubsubsec Executable File Names - -@noindent -By default, the executable file name corresponding to a main source is -deduced from the main source file name. Through the attributes -@code{Executable} and @code{Executable_Suffix} of package @code{Builder}, -it is possible to change this default. -In project @code{Debug} above, the executable file name -for main source @file{^proc.adb^PROC.ADB^} is -@file{^proc1^PROC1.EXE^}. -Attribute @code{Executable_Suffix}, when specified, may change the suffix -of the executable files, when no attribute @code{Executable} applies: -its value replace the platform-specific executable suffix. -Attributes @code{Executable} and @code{Executable_Suffix} are the only ways to -specify a non-default executable file name when several mains are built at once -in a single @command{gnatmake} command. - -@node Source File Naming Conventions -@unnumberedsubsubsec Source File Naming Conventions - -@noindent -Since the project files above do not specify any source file naming -conventions, the GNAT defaults are used. The mechanism for defining source -file naming conventions -- a package named @code{Naming} -- -is described below (@pxref{Naming Schemes}). - -@node Source Language(s) -@unnumberedsubsubsec Source Language(s) - -@noindent -Since the project files do not specify a @code{Languages} attribute, by -default the GNAT tools assume that the language of the project file is Ada. -More generally, a project can comprise source files -in Ada, C, and/or other languages. - -@node Using External Variables -@subsection Using External Variables - -@noindent -Instead of supplying different project files for debug and release, we can -define a single project file that queries an external variable (set either -on the command line or via an ^environment variable^logical name^) in order to -conditionally define the appropriate settings. Again, assume that the -source files @file{pack.ads}, @file{pack.adb}, and @file{proc.adb} are -located in directory @file{^/common^[COMMON]^}. The following project file, -@file{build.gpr}, queries the external variable named @code{STYLE} and -defines an object directory and ^switch^switch^ settings based on whether -the value is @code{"deb"} (debug) or @code{"rel"} (release), and where -the default is @code{"deb"}. +@item -nostdinc +@cindex @option{-nostdinc} (@command{gnatxref}) +Do not look for sources in the system default directory. -@smallexample @c projectfile -@group -project Build is - for Main use ("proc"); - - type Style_Type is ("deb", "rel"); - Style : Style_Type := external ("STYLE", "deb"); - - case Style is - when "deb" => - for Object_Dir use "debug"; +@item -nostdlib +@cindex @option{-nostdlib} (@command{gnatxref}) +Do not look for library files in the system default directory. - when "rel" => - for Object_Dir use "release"; - for Exec_Dir use "."; - end case; -@end group +@item --ext=@var{extension} +@cindex @option{--ext} (@command{gnatxref}) +Specify an alternate ali file extension. The default is @code{ali} and other +extensions (e.g. @code{sli} for SPARK library files) may be specified via this +switch. Note that if this switch overrides the default, which means that only +the new extension will be considered. -@group - package Builder is - - case Style is - when "deb" => - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-g^-g^"); - for Executable ("proc") use "proc1"; - when others => - null; - end case; - - end Builder; -@end group +@item --RTS=@var{rts-path} +@cindex @option{--RTS} (@command{gnatxref}) +Specifies the default location of the runtime library. Same meaning as the +equivalent @command{gnatmake} flag (@pxref{Switches for gnatmake}). -@group - package Compiler is +@item ^-d^/DERIVED_TYPES^ +@cindex @option{^-d^/DERIVED_TYPES^} (@command{gnatxref}) +If this switch is set @code{gnatxref} will output the parent type +reference for each matching derived types. - case Style is - when "deb" => - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-gnata^-gnata^", - "^-gnato^-gnato^", - "^-gnatE^-gnatE^"); +@item ^-f^/FULL_PATHNAME^ +@cindex @option{^-f^/FULL_PATHNAME^} (@command{gnatxref}) +If this switch is set, the output file names will be preceded by their +directory (if the file was found in the search path). If this switch is +not set, the directory will not be printed. - when "rel" => - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-O2^-O2^"); - end case; +@item ^-g^/IGNORE_LOCALS^ +@cindex @option{^-g^/IGNORE_LOCALS^} (@command{gnatxref}) +If this switch is set, information is output only for library-level +entities, ignoring local entities. The use of this switch may accelerate +@code{gnatfind} and @code{gnatxref}. - end Compiler; +@item -IDIR +@cindex @option{-IDIR} (@command{gnatxref}) +Equivalent to @samp{-aODIR -aIDIR}. -end Build; -@end group -@end smallexample +@item -pFILE +@cindex @option{-pFILE} (@command{gnatxref}) +Specify a project file to use @xref{GNAT Project Manager}. +If you need to use the @file{.gpr} +project files, you should use gnatxref through the GNAT driver +(@command{gnat xref -Pproject}). -@noindent -@code{Style_Type} is an example of a @emph{string type}, which is the project -file analog of an Ada enumeration type but whose components are string literals -rather than identifiers. @code{Style} is declared as a variable of this type. +By default, @code{gnatxref} and @code{gnatfind} will try to locate a +project file in the current directory. -The form @code{external("STYLE", "deb")} is known as an -@emph{external reference}; its first argument is the name of an -@emph{external variable}, and the second argument is a default value to be -used if the external variable doesn't exist. You can define an external -variable on the command line via the @option{^-X^/EXTERNAL_REFERENCE^} switch, -or you can use ^an environment variable^a logical name^ -as an external variable. +If a project file is either specified or found by the tools, then the content +of the source directory and object directory lines are added as if they +had been specified respectively by @samp{^-aI^/SOURCE_SEARCH^} +and @samp{^-aO^OBJECT_SEARCH^}. +@item ^-u^/UNUSED^ +Output only unused symbols. This may be really useful if you give your +main compilation unit on the command line, as @code{gnatxref} will then +display every unused entity and 'with'ed package. -Each @code{case} construct is expanded by the Project Manager based on the -value of @code{Style}. Thus the command @ifclear vms -@smallexample -gnatmake -P/common/build.gpr -XSTYLE=deb -@end smallexample +@item -v +Instead of producing the default output, @code{gnatxref} will generate a +@file{tags} file that can be used by vi. For examples how to use this +feature, see @ref{Examples of gnatxref Usage}. The tags file is output +to the standard output, thus you will have to redirect it to a file. @end ifclear -@ifset vms -@smallexample -gnatmake /PROJECT_FILE=[COMMON]BUILD.GPR /EXTERNAL_REFERENCE=STYLE=deb -@end smallexample -@end ifset - -@noindent -is equivalent to the @command{gnatmake} invocation using the project file -@file{debug.gpr} in the earlier example. So is the command -@smallexample -gnatmake ^-P/common/build.gpr^/PROJECT_FILE=[COMMON]BUILD.GPR^ -@end smallexample +@end table @noindent -since @code{"deb"} is the default for @code{STYLE}. +All these switches may be in any order on the command line, and may even +appear after the file names. They need not be separated by spaces, thus +you can say @samp{gnatxref ^-ag^/ALL_FILES/IGNORE_LOCALS^} instead of +@samp{gnatxref ^-a -g^/ALL_FILES /IGNORE_LOCALS^}. -Analogously, +@node Switches for gnatfind +@section @code{gnatfind} Switches -@ifclear vms -@smallexample -gnatmake -P/common/build.gpr -XSTYLE=rel -@end smallexample -@end ifclear +@noindent +The command line for @code{gnatfind} is: -@ifset vms @smallexample -GNAT MAKE /PROJECT_FILE=[COMMON]BUILD.GPR /EXTERNAL_REFERENCE=STYLE=rel +@c $ gnatfind @ovar{switches} @var{pattern}@r{[}:@var{sourcefile}@r{[}:@var{line}@r{[}:@var{column}@r{]]]} +@c @r{[}@var{file1} @var{file2} @dots{}] +@c Expanding @ovar macro inline (explanation in macro def comments) +$ gnatfind @r{[}@var{switches}@r{]} @var{pattern}@r{[}:@var{sourcefile}@r{[}:@var{line}@r{[}:@var{column}@r{]]]} + @r{[}@var{file1} @var{file2} @dots{}@r{]} @end smallexample -@end ifset @noindent -is equivalent to the @command{gnatmake} invocation using the project file -@file{release.gpr} in the earlier example. - -@node Importing Other Projects -@subsection Importing Other Projects -@cindex @code{ADA_PROJECT_PATH} -@cindex @code{GPR_PROJECT_PATH} +where -@noindent -A compilation unit in a source file in one project may depend on compilation -units in source files in other projects. To compile this unit under -control of a project file, the -dependent project must @emph{import} the projects containing the needed source -files. -This effect is obtained using syntax similar to an Ada @code{with} clause, -but where @code{with}ed entities are strings that denote project files. +@table @var +@item pattern +An entity will be output only if it matches the regular expression found +in @var{pattern}, see @ref{Regular Expressions in gnatfind and gnatxref}. -As an example, suppose that the two projects @code{GUI_Proj} and -@code{Comm_Proj} are defined in the project files @file{gui_proj.gpr} and -@file{comm_proj.gpr} in directories @file{^/gui^[GUI]^} -and @file{^/comm^[COMM]^}, respectively. -Suppose that the source files for @code{GUI_Proj} are -@file{gui.ads} and @file{gui.adb}, and that the source files for -@code{Comm_Proj} are @file{comm.ads} and @file{comm.adb}, where each set of -files is located in its respective project file directory. Schematically: +Omitting the pattern is equivalent to specifying @samp{*}, which +will match any entity. Note that if you do not provide a pattern, you +have to provide both a sourcefile and a line. -@smallexample -@group -^/gui^[GUI]^ - gui_proj.gpr - gui.ads - gui.adb -@end group +Entity names are given in Latin-1, with uppercase/lowercase equivalence +for matching purposes. At the current time there is no support for +8-bit codes other than Latin-1, or for wide characters in identifiers. -@group -^/comm^[COMM]^ - comm_proj.gpr - comm.ads - comm.adb -@end group -@end smallexample +@item sourcefile +@code{gnatfind} will look for references, bodies or declarations +of symbols referenced in @file{@var{sourcefile}}, at line @var{line} +and column @var{column}. See @ref{Examples of gnatfind Usage} +for syntax examples. -@noindent -We want to develop an application in directory @file{^/app^[APP]^} that -@code{with} the packages @code{GUI} and @code{Comm}, using the properties of -the corresponding project files (e.g.@: the ^switch^switch^ settings -and object directory). -Skeletal code for a main procedure might be something like the following: +@item line +is a decimal integer identifying the line number containing +the reference to the entity (or entities) to be located. -@smallexample @c ada -@group -with GUI, Comm; -procedure App_Main is - @dots{} -begin - @dots{} -end App_Main; -@end group -@end smallexample +@item column +is a decimal integer identifying the exact location on the +line of the first character of the identifier for the +entity reference. Columns are numbered from 1. -@noindent -Here is a project file, @file{app_proj.gpr}, that achieves the desired -effect: +@item file1 file2 @dots{} +The search will be restricted to these source files. If none are given, then +the search will be done for every library file in the search path. +These file must appear only after the pattern or sourcefile. -@smallexample @c projectfile -@group -with "/gui/gui_proj", "/comm/comm_proj"; -project App_Proj is - for Main use ("app_main"); -end App_Proj; -@end group -@end smallexample +These file names are considered to be regular expressions, so for instance +specifying @file{source*.adb} is the same as giving every file in the current +directory whose name starts with @file{source} and whose extension is +@file{adb}. -@noindent -Building an executable is achieved through the command: -@smallexample -gnatmake ^-P/app/app_proj^/PROJECT_FILE=[APP]APP_PROJ^ -@end smallexample -@noindent -which will generate the @code{^app_main^APP_MAIN.EXE^} executable -in the directory where @file{app_proj.gpr} resides. +The location of the spec of the entity will always be displayed, even if it +isn't in one of @file{@var{file1}}, @file{@var{file2}},@enddots{} The +occurrences of the entity in the separate units of the ones given on the +command line will also be displayed. -If an imported project file uses the standard extension (@code{^gpr^GPR^}) then -(as illustrated above) the @code{with} clause can omit the extension. +Note that if you specify at least one file in this part, @code{gnatfind} may +sometimes not be able to find the body of the subprograms. -Our example specified an absolute path for each imported project file. -Alternatively, the directory name of an imported object can be omitted -if either -@itemize @bullet -@item -The imported project file is in the same directory as the importing project -file, or -@item -You have defined one or two ^environment variables^logical names^ -that includes the directory containing -the needed project file. The syntax of @code{GPR_PROJECT_PATH} and -@code{ADA_PROJECT_PATH} is the same as -the syntax of @code{ADA_INCLUDE_PATH} and @code{ADA_OBJECTS_PATH}: a list of -directory names separated by colons (semicolons on Windows). -@end itemize +@end table @noindent -Thus, if we define @code{ADA_PROJECT_PATH} or @code{GPR_PROJECT_PATH} -to include @file{^/gui^[GUI]^} and -@file{^/comm^[COMM]^}, then our project file @file{app_proj.gpr} can be written -as follows: +At least one of 'sourcefile' or 'pattern' has to be present on +the command line. -@smallexample @c projectfile -@group -with "gui_proj", "comm_proj"; -project App_Proj is - for Main use ("app_main"); -end App_Proj; -@end group -@end smallexample +The following switches are available: +@table @option +@c !sort! -@noindent -Importing other projects can create ambiguities. -For example, the same unit might be present in different imported projects, or -it might be present in both the importing project and in an imported project. -Both of these conditions are errors. Note that in the current version of -the Project Manager, it is illegal to have an ambiguous unit even if the -unit is never referenced by the importing project. This restriction may be -relaxed in a future release. +@cindex @option{--version} @command{gnatfind} +Display Copyright and version, then exit disregarding all other options. -@node Extending a Project -@subsection Extending a Project +@item --help +@cindex @option{--help} @command{gnatfind} +If @option{--version} was not used, display usage, then exit disregarding +all other options. -@noindent -In large software systems it is common to have multiple -implementations of a common interface; in Ada terms, multiple versions of a -package body for the same spec. For example, one implementation -might be safe for use in tasking programs, while another might only be used -in sequential applications. This can be modeled in GNAT using the concept -of @emph{project extension}. If one project (the ``child'') @emph{extends} -another project (the ``parent'') then by default all source files of the -parent project are inherited by the child, but the child project can -override any of the parent's source files with new versions, and can also -add new files. This facility is the project analog of a type extension in -Object-Oriented Programming. Project hierarchies are permitted (a child -project may be the parent of yet another project), and a project that -inherits one project can also import other projects. +@item ^-a^/ALL_FILES^ +@cindex @option{^-a^/ALL_FILES^} (@command{gnatfind}) +If this switch is present, @code{gnatfind} and @code{gnatxref} will parse +the read-only files found in the library search path. Otherwise, these files +will be ignored. This option can be used to protect Gnat sources or your own +libraries from being parsed, thus making @code{gnatfind} and @code{gnatxref} +much faster, and their output much smaller. Read-only here refers to access +or permission status in the file system for the current user. -As an example, suppose that directory @file{^/seq^[SEQ]^} contains the project -file @file{seq_proj.gpr} as well as the source files @file{pack.ads}, -@file{pack.adb}, and @file{proc.adb}: +@item -aIDIR +@cindex @option{-aIDIR} (@command{gnatfind}) +When looking for source files also look in directory DIR. The order in which +source file search is undertaken is the same as for @command{gnatmake}. -@smallexample -@group -^/seq^[SEQ]^ - pack.ads - pack.adb - proc.adb - seq_proj.gpr -@end group -@end smallexample +@item -aODIR +@cindex @option{-aODIR} (@command{gnatfind}) +When searching for library and object files, look in directory +DIR. The order in which library files are searched is the same as for +@command{gnatmake}. -@noindent -Note that the project file can simply be empty (that is, no attribute or -package is defined): +@item -nostdinc +@cindex @option{-nostdinc} (@command{gnatfind}) +Do not look for sources in the system default directory. -@smallexample @c projectfile -@group -project Seq_Proj is -end Seq_Proj; -@end group -@end smallexample +@item -nostdlib +@cindex @option{-nostdlib} (@command{gnatfind}) +Do not look for library files in the system default directory. -@noindent -implying that its source files are all the Ada source files in the project -directory. +@item --ext=@var{extension} +@cindex @option{--ext} (@command{gnatfind}) +Specify an alternate ali file extension. The default is @code{ali} and other +extensions (e.g. @code{sli} for SPARK library files) may be specified via this +switch. Note that if this switch overrides the default, which means that only +the new extension will be considered. -Suppose we want to supply an alternate version of @file{pack.adb}, in -directory @file{^/tasking^[TASKING]^}, but use the existing versions of -@file{pack.ads} and @file{proc.adb}. We can define a project -@code{Tasking_Proj} that inherits @code{Seq_Proj}: +@item --RTS=@var{rts-path} +@cindex @option{--RTS} (@command{gnatfind}) +Specifies the default location of the runtime library. Same meaning as the +equivalent @command{gnatmake} flag (@pxref{Switches for gnatmake}). -@smallexample -@group -^/tasking^[TASKING]^ - pack.adb - tasking_proj.gpr -@end group +@item ^-d^/DERIVED_TYPE_INFORMATION^ +@cindex @option{^-d^/DERIVED_TYPE_INFORMATION^} (@code{gnatfind}) +If this switch is set, then @code{gnatfind} will output the parent type +reference for each matching derived types. -@group -project Tasking_Proj extends "/seq/seq_proj" is -end Tasking_Proj; -@end group -@end smallexample +@item ^-e^/EXPRESSIONS^ +@cindex @option{^-e^/EXPRESSIONS^} (@command{gnatfind}) +By default, @code{gnatfind} accept the simple regular expression set for +@samp{pattern}. If this switch is set, then the pattern will be +considered as full Unix-style regular expression. -@noindent -The version of @file{pack.adb} used in a build depends on which project file -is specified. +@item ^-f^/FULL_PATHNAME^ +@cindex @option{^-f^/FULL_PATHNAME^} (@command{gnatfind}) +If this switch is set, the output file names will be preceded by their +directory (if the file was found in the search path). If this switch is +not set, the directory will not be printed. -Note that we could have obtained the desired behavior using project import -rather than project inheritance; a @code{base} project would contain the -sources for @file{pack.ads} and @file{proc.adb}, a sequential project would -import @code{base} and add @file{pack.adb}, and likewise a tasking project -would import @code{base} and add a different version of @file{pack.adb}. The -choice depends on whether other sources in the original project need to be -overridden. If they do, then project extension is necessary, otherwise, -importing is sufficient. +@item ^-g^/IGNORE_LOCALS^ +@cindex @option{^-g^/IGNORE_LOCALS^} (@command{gnatfind}) +If this switch is set, information is output only for library-level +entities, ignoring local entities. The use of this switch may accelerate +@code{gnatfind} and @code{gnatxref}. -@noindent -In a project file that extends another project file, it is possible to -indicate that an inherited source is not part of the sources of the extending -project. This is necessary sometimes when a package spec has been overloaded -and no longer requires a body: in this case, it is necessary to indicate that -the inherited body is not part of the sources of the project, otherwise there -will be a compilation error when compiling the spec. +@item -IDIR +@cindex @option{-IDIR} (@command{gnatfind}) +Equivalent to @samp{-aODIR -aIDIR}. -For that purpose, the attribute @code{Excluded_Source_Files} is used. -Its value is a string list: a list of file names. It is also possible to use -attribute @code{Excluded_Source_List_File}. Its value is a single string: -the file name of a text file containing a list of file names, one per line. +@item -pFILE +@cindex @option{-pFILE} (@command{gnatfind}) +Specify a project file (@pxref{GNAT Project Manager}) to use. +By default, @code{gnatxref} and @code{gnatfind} will try to locate a +project file in the current directory. -@smallexample @c @projectfile -project B extends "a" is - for Source_Files use ("pkg.ads"); - -- New spec of Pkg does not need a completion - for Excluded_Source_Files use ("pkg.adb"); -end B; -@end smallexample +If a project file is either specified or found by the tools, then the content +of the source directory and object directory lines are added as if they +had been specified respectively by @samp{^-aI^/SOURCE_SEARCH^} and +@samp{^-aO^/OBJECT_SEARCH^}. -Attribute @code{Excluded_Source_Files} may also be used to check if a source -is still needed: if it is possible to build using @command{gnatmake} when such -a source is put in attribute @code{Excluded_Source_Files} of a project P, then -it is possible to remove the source completely from a system that includes -project P. - -@c *********************** -@c * Project File Syntax * -@c *********************** - -@node Project File Syntax -@section Project File Syntax - -@menu -* Basic Syntax:: -* Qualified Projects:: -* Packages:: -* Expressions:: -* String Types:: -* Variables:: -* Attributes:: -* Associative Array Attributes:: -* case Constructions:: -@end menu +@item ^-r^/REFERENCES^ +@cindex @option{^-r^/REFERENCES^} (@command{gnatfind}) +By default, @code{gnatfind} will output only the information about the +declaration, body or type completion of the entities. If this switch is +set, the @code{gnatfind} will locate every reference to the entities in +the files specified on the command line (or in every file in the search +path if no file is given on the command line). -@noindent -This section describes the structure of project files. +@item ^-s^/PRINT_LINES^ +@cindex @option{^-s^/PRINT_LINES^} (@command{gnatfind}) +If this switch is set, then @code{gnatfind} will output the content +of the Ada source file lines were the entity was found. -A project may be an @emph{independent project}, entirely defined by a single -project file. Any Ada source file in an independent project depends only -on the predefined library and other Ada source files in the same project. +@item ^-t^/TYPE_HIERARCHY^ +@cindex @option{^-t^/TYPE_HIERARCHY^} (@command{gnatfind}) +If this switch is set, then @code{gnatfind} will output the type hierarchy for +the specified type. It act like -d option but recursively from parent +type to parent type. When this switch is set it is not possible to +specify more than one file. -@noindent -A project may also @dfn{depend on} other projects, in either or both of -the following ways: -@itemize @bullet -@item It may import any number of projects -@item It may extend at most one other project -@end itemize +@end table @noindent -The dependence relation is a directed acyclic graph (the subgraph reflecting -the ``extends'' relation is a tree). - -A project's @dfn{immediate sources} are the source files directly defined by -that project, either implicitly by residing in the project file's directory, -or explicitly through any of the source-related attributes described below. -More generally, a project @var{proj}'s @dfn{sources} are the immediate sources -of @var{proj} together with the immediate sources (unless overridden) of any -project on which @var{proj} depends (either directly or indirectly). - -@node Basic Syntax -@subsection Basic Syntax +All these switches may be in any order on the command line, and may even +appear after the file names. They need not be separated by spaces, thus +you can say @samp{gnatxref ^-ag^/ALL_FILES/IGNORE_LOCALS^} instead of +@samp{gnatxref ^-a -g^/ALL_FILES /IGNORE_LOCALS^}. -@noindent -As seen in the earlier examples, project files have an Ada-like syntax. -The minimal project file is: -@smallexample @c projectfile -@group -project Empty is +As stated previously, gnatfind will search in every directory in the +search path. You can force it to look only in the current directory if +you specify @code{*} at the end of the command line. -end Empty; -@end group -@end smallexample +@node Project Files for gnatxref and gnatfind +@section Project Files for @command{gnatxref} and @command{gnatfind} @noindent -The identifier @code{Empty} is the name of the project. -This project name must be present after the reserved -word @code{end} at the end of the project file, followed by a semi-colon. - -Any name in a project file, such as the project name or a variable name, -has the same syntax as an Ada identifier. +Project files allow a programmer to specify how to compile its +application, where to find sources, etc. These files are used +@ifclear vms +primarily by GPS, but they can also be used +@end ifclear +by the two tools +@code{gnatxref} and @code{gnatfind}. -The reserved words of project files are the Ada 95 reserved words plus -@code{extends}, @code{external}, and @code{project}. Note that the only Ada -reserved words currently used in project file syntax are: +A project file name must end with @file{.gpr}. If a single one is +present in the current directory, then @code{gnatxref} and @code{gnatfind} will +extract the information from it. If multiple project files are found, none of +them is read, and you have to use the @samp{-p} switch to specify the one +you want to use. -@itemize @bullet -@item -@code{all} -@item -@code{at} -@item -@code{case} -@item -@code{end} -@item -@code{for} -@item -@code{is} -@item -@code{limited} -@item -@code{null} -@item -@code{others} -@item -@code{package} -@item -@code{renames} -@item -@code{type} -@item -@code{use} -@item -@code{when} -@item -@code{with} -@end itemize +The following lines can be included, even though most of them have default +values which can be used in most cases. +The lines can be entered in any order in the file. +Except for @file{src_dir} and @file{obj_dir}, you can only have one instance of +each line. If you have multiple instances, only the last one is taken into +account. -@noindent -Comments in project files have the same syntax as in Ada, two consecutive -hyphens through the end of the line. +@table @code +@item src_dir=DIR +[default: @code{"^./^[]^"}] +specifies a directory where to look for source files. Multiple @code{src_dir} +lines can be specified and they will be searched in the order they +are specified. -@node Qualified Projects -@subsection Qualified Projects +@item obj_dir=DIR +[default: @code{"^./^[]^"}] +specifies a directory where to look for object and library files. Multiple +@code{obj_dir} lines can be specified, and they will be searched in the order +they are specified -@noindent -Before the reserved @code{project}, there may be one or two "qualifiers", that -is identifiers or other reserved words, to qualify the project. +@item comp_opt=SWITCHES +[default: @code{""}] +creates a variable which can be referred to subsequently by using +the @code{$@{comp_opt@}} notation. This is intended to store the default +switches given to @command{gnatmake} and @command{gcc}. -The current list of qualifiers is: +@item bind_opt=SWITCHES +[default: @code{""}] +creates a variable which can be referred to subsequently by using +the @samp{$@{bind_opt@}} notation. This is intended to store the default +switches given to @command{gnatbind}. -@itemize @bullet -@item -@code{abstract}: qualify a project with no sources. A qualified abstract -project must either have no declaration of attributes @code{Source_Dirs}, -@code{Source_Files}, @code{Languages} or @code{Source_List_File}, or one of -@code{Source_Dirs}, @code{Source_Files}, or @code{Languages} must be declared -as empty. If it extends another project, the project it extends must also be a -qualified abstract project. +@item link_opt=SWITCHES +[default: @code{""}] +creates a variable which can be referred to subsequently by using +the @samp{$@{link_opt@}} notation. This is intended to store the default +switches given to @command{gnatlink}. -@item -@code{standard}: a standard project is a non library project with sources. +@item main=EXECUTABLE +[default: @code{""}] +specifies the name of the executable for the application. This variable can +be referred to in the following lines by using the @samp{$@{main@}} notation. -@item -@code{aggregate}: for future extension +@ifset vms +@item comp_cmd=COMMAND +[default: @code{"GNAT COMPILE /SEARCH=$@{src_dir@} /DEBUG /TRY_SEMANTICS"}] +@end ifset +@ifclear vms +@item comp_cmd=COMMAND +[default: @code{"gcc -c -I$@{src_dir@} -g -gnatq"}] +@end ifclear +specifies the command used to compile a single file in the application. -@item -@code{aggregate library}: for future extension +@ifset vms +@item make_cmd=COMMAND +[default: @code{"GNAT MAKE $@{main@} +/SOURCE_SEARCH=$@{src_dir@} /OBJECT_SEARCH=$@{obj_dir@} +/DEBUG /TRY_SEMANTICS /COMPILER_QUALIFIERS $@{comp_opt@} +/BINDER_QUALIFIERS $@{bind_opt@} /LINKER_QUALIFIERS $@{link_opt@}"}] +@end ifset +@ifclear vms +@item make_cmd=COMMAND +[default: @code{"gnatmake $@{main@} -aI$@{src_dir@} +-aO$@{obj_dir@} -g -gnatq -cargs $@{comp_opt@} +-bargs $@{bind_opt@} -largs $@{link_opt@}"}] +@end ifclear +specifies the command used to recompile the whole application. -@item -@code{library}: a library project must declare both attributes -@code{Library_Name} and @code{Library_Dir}. +@item run_cmd=COMMAND +[default: @code{"$@{main@}"}] +specifies the command used to run the application. -@item -@code{configuration}: a configuration project cannot be in a project tree. -@end itemize +@item debug_cmd=COMMAND +[default: @code{"gdb $@{main@}"}] +specifies the command used to debug the application -@node Packages -@subsection Packages +@end table @noindent -A project file may contain @emph{packages}. The name of a package must be one -of the identifiers from the following list. A package -with a given name may only appear once in a project file. Package names are -case insensitive. The following package names are legal: +@command{gnatxref} and @command{gnatfind} only take into account the +@code{src_dir} and @code{obj_dir} lines, and ignore the others. -@itemize @bullet -@item -@code{Naming} -@item -@code{Builder} -@item -@code{Compiler} -@item -@code{Binder} -@item -@code{Linker} -@item -@code{Finder} -@item -@code{Cross_Reference} -@item -@code{Check} -@item -@code{Eliminate} -@item -@code{Pretty_Printer} -@item -@code{Metrics} -@item -@code{gnatls} -@item -@code{gnatstub} -@item -@code{IDE} -@item -@code{Language_Processing} -@end itemize +@node Regular Expressions in gnatfind and gnatxref +@section Regular Expressions in @code{gnatfind} and @code{gnatxref} @noindent -In its simplest form, a package may be empty: +As specified in the section about @command{gnatfind}, the pattern can be a +regular expression. Actually, there are to set of regular expressions +which are recognized by the program: -@smallexample @c projectfile +@table @code +@item globbing patterns +These are the most usual regular expression. They are the same that you +generally used in a Unix shell command line, or in a DOS session. + +Here is a more formal grammar: +@smallexample @group -project Simple is - package Builder is - end Builder; -end Simple; +@iftex +@leftskip=.5cm +@end iftex +regexp ::= term +term ::= elmt -- matches elmt +term ::= elmt elmt -- concatenation (elmt then elmt) +term ::= * -- any string of 0 or more characters +term ::= ? -- matches any character +term ::= [char @{char@}] -- matches any character listed +term ::= [char - char] -- matches any character in range @end group @end smallexample -@noindent -A package may contain @emph{attribute declarations}, -@emph{variable declarations} and @emph{case constructions}, as will be -described below. - -When there is ambiguity between a project name and a package name, -the name always designates the project. To avoid possible confusion, it is -always a good idea to avoid naming a project with one of the -names allowed for packages or any name that starts with @code{gnat}. - -@node Expressions -@subsection Expressions - -@noindent -An @emph{expression} is either a @emph{string expression} or a -@emph{string list expression}. - -A @emph{string expression} is either a @emph{simple string expression} or a -@emph{compound string expression}. - -A @emph{simple string expression} is one of the following: -@itemize @bullet -@item A literal string; e.g.@: @code{"comm/my_proj.gpr"} -@item A string-valued variable reference (@pxref{Variables}) -@item A string-valued attribute reference (@pxref{Attributes}) -@item An external reference (@pxref{External References in Project Files}) -@end itemize - -@noindent -A @emph{compound string expression} is a concatenation of string expressions, -using the operator @code{"&"} -@smallexample - Path & "/" & File_Name & ".ads" -@end smallexample +@item full regular expression +The second set of regular expressions is much more powerful. This is the +type of regular expressions recognized by utilities such a @file{grep}. -@noindent -A @emph{string list expression} is either a -@emph{simple string list expression} or a -@emph{compound string list expression}. +The following is the form of a regular expression, expressed in Ada +reference manual style BNF is as follows -A @emph{simple string list expression} is one of the following: -@itemize @bullet -@item A parenthesized list of zero or more string expressions, -separated by commas @smallexample - File_Names := (File_Name, "gnat.adc", File_Name & ".orig"); - Empty_List := (); -@end smallexample -@item A string list-valued variable reference -@item A string list-valued attribute reference -@end itemize +@iftex +@leftskip=.5cm +@end iftex +@group +regexp ::= term @{| term@} -- alternation (term or term @dots{}) -@noindent -A @emph{compound string list expression} is the concatenation (using -@code{"&"}) of a simple string list expression and an expression. Note that -each term in a compound string list expression, except the first, may be -either a string expression or a string list expression. +term ::= item @{item@} -- concatenation (item then item) -@smallexample @c projectfile +item ::= elmt -- match elmt +item ::= elmt * -- zero or more elmt's +item ::= elmt + -- one or more elmt's +item ::= elmt ? -- matches elmt or nothing +@end group @group - File_Name_List := () & File_Name; -- One string in this list - Extended_File_Name_List := File_Name_List & (File_Name & ".orig"); - -- Two strings - Big_List := File_Name_List & Extended_File_Name_List; - -- Concatenation of two string lists: three strings - Illegal_List := "gnat.adc" & Extended_File_Name_List; - -- Illegal: must start with a string list +elmt ::= nschar -- matches given character +elmt ::= [nschar @{nschar@}] -- matches any character listed +elmt ::= [^^^ nschar @{nschar@}] -- matches any character not listed +elmt ::= [char - char] -- matches chars in given range +elmt ::= \ char -- matches given character +elmt ::= . -- matches any single character +elmt ::= ( regexp ) -- parens used for grouping + +char ::= any character, including special characters +nschar ::= any character except ()[].*+?^^^ @end group @end smallexample -@node String Types -@subsection String Types +Following are a few examples: -@noindent -A @emph{string type declaration} introduces a discrete set of string literals. -If a string variable is declared to have this type, its value -is restricted to the given set of literals. +@table @samp +@item abcde|fghi +will match any of the two strings @samp{abcde} and @samp{fghi}, -Here is an example of a string type declaration: +@item abc*d +will match any string like @samp{abd}, @samp{abcd}, @samp{abccd}, +@samp{abcccd}, and so on, -@smallexample @c projectfile - type OS is ("NT", "nt", "Unix", "GNU/Linux", "other OS"); -@end smallexample +@item [a-z]+ +will match any string which has only lowercase characters in it (and at +least one character. -@noindent -Variables of a string type are called @emph{typed variables}; all other -variables are called @emph{untyped variables}. Typed variables are -particularly useful in @code{case} constructions, to support conditional -attribute declarations. -(@pxref{case Constructions}). +@end table +@end table -The string literals in the list are case sensitive and must all be different. -They may include any graphic characters allowed in Ada, including spaces. +@node Examples of gnatxref Usage +@section Examples of @code{gnatxref} Usage -A string type may only be declared at the project level, not inside a package. - -A string type may be referenced by its name if it has been declared in the same -project file, or by an expanded name whose prefix is the name of the project -in which it is declared. - -@node Variables -@subsection Variables +@subsection General Usage @noindent -A variable may be declared at the project file level, or within a package. -Here are some examples of variable declarations: +For the following examples, we will consider the following units: -@smallexample @c projectfile +@smallexample @c ada @group - This_OS : OS := external ("OS"); -- a typed variable declaration - That_OS := "GNU/Linux"; -- an untyped variable declaration +@cartouche +main.ads: +1: with Bar; +2: package Main is +3: procedure Foo (B : in Integer); +4: C : Integer; +5: private +6: D : Integer; +7: end Main; + +main.adb: +1: package body Main is +2: procedure Foo (B : in Integer) is +3: begin +4: C := B; +5: D := B; +6: Bar.Print (B); +7: Bar.Print (C); +8: end Foo; +9: end Main; + +bar.ads: +1: package Bar is +2: procedure Print (B : Integer); +3: end bar; +@end cartouche @end group @end smallexample -@noindent -The syntax of a @emph{typed variable declaration} is identical to the Ada -syntax for an object declaration. By contrast, the syntax of an untyped -variable declaration is identical to an Ada assignment statement. In fact, -variable declarations in project files have some of the characteristics of -an assignment, in that successive declarations for the same variable are -allowed. Untyped variable declarations do establish the expected kind of the -variable (string or string list), and successive declarations for it must -respect the initial kind. +@table @code @noindent -A string variable declaration (typed or untyped) declares a variable -whose value is a string. This variable may be used as a string expression. -@smallexample @c projectfile - File_Name := "readme.txt"; - Saved_File_Name := File_Name & ".saved"; -@end smallexample +The first thing to do is to recompile your application (for instance, in +that case just by doing a @samp{gnatmake main}, so that GNAT generates +the cross-referencing information. +You can then issue any of the following commands: -@noindent -A string list variable declaration declares a variable whose value is a list -of strings. The list may contain any number (zero or more) of strings. +@item gnatxref main.adb +@code{gnatxref} generates cross-reference information for main.adb +and every unit 'with'ed by main.adb. -@smallexample @c projectfile - Empty_List := (); - List_With_One_Element := ("^-gnaty^-gnaty^"); - List_With_Two_Elements := List_With_One_Element & "^-gnatg^-gnatg^"; - Long_List := ("main.ada", "pack1_.ada", "pack1.ada", "pack2_.ada" - "pack2.ada", "util_.ada", "util.ada"); +The output would be: +@smallexample +@iftex +@leftskip=0cm +@end iftex +B Type: Integer + Decl: bar.ads 2:22 +B Type: Integer + Decl: main.ads 3:20 + Body: main.adb 2:20 + Ref: main.adb 4:13 5:13 6:19 +Bar Type: Unit + Decl: bar.ads 1:9 + Ref: main.adb 6:8 7:8 + main.ads 1:6 +C Type: Integer + Decl: main.ads 4:5 + Modi: main.adb 4:8 + Ref: main.adb 7:19 +D Type: Integer + Decl: main.ads 6:5 + Modi: main.adb 5:8 +Foo Type: Unit + Decl: main.ads 3:15 + Body: main.adb 2:15 +Main Type: Unit + Decl: main.ads 2:9 + Body: main.adb 1:14 +Print Type: Unit + Decl: bar.ads 2:15 + Ref: main.adb 6:12 7:12 @end smallexample @noindent -The same typed variable may not be declared more than once at project level, -and it may not be declared more than once in any package; it is in effect -a constant. +that is the entity @code{Main} is declared in main.ads, line 2, column 9, +its body is in main.adb, line 1, column 14 and is not referenced any where. -The same untyped variable may be declared several times. Declarations are -elaborated in the order in which they appear, so the new value replaces -the old one, and any subsequent reference to the variable uses the new value. -However, as noted above, if a variable has been declared as a string, all -subsequent -declarations must give it a string value. Similarly, if a variable has -been declared as a string list, all subsequent declarations -must give it a string list value. +The entity @code{Print} is declared in bar.ads, line 2, column 15 and it +it referenced in main.adb, line 6 column 12 and line 7 column 12. -A @emph{variable reference} may take several forms: +@item gnatxref package1.adb package2.ads +@code{gnatxref} will generates cross-reference information for +package1.adb, package2.ads and any other package 'with'ed by any +of these. -@itemize @bullet -@item The simple variable name, for a variable in the current package (if any) -or in the current project -@item An expanded name, whose prefix is a context name. -@end itemize +@end table -@noindent -A @emph{context} may be one of the following: +@ifclear vms +@subsection Using gnatxref with vi -@itemize @bullet -@item The name of an existing package in the current project -@item The name of an imported project of the current project -@item The name of an ancestor project (i.e., a project extended by the current -project, either directly or indirectly) -@item An expanded name whose prefix is an imported/parent project name, and -whose selector is a package name in that project. -@end itemize +@code{gnatxref} can generate a tags file output, which can be used +directly from @command{vi}. Note that the standard version of @command{vi} +will not work properly with overloaded symbols. Consider using another +free implementation of @command{vi}, such as @command{vim}. -@noindent -A variable reference may be used in an expression. - -@node Attributes -@subsection Attributes - -@noindent -A project (and its packages) may have @emph{attributes} that define -the project's properties. Some attributes have values that are strings; -others have values that are string lists. - -There are two categories of attributes: @emph{simple attributes} -and @emph{associative arrays} (@pxref{Associative Array Attributes}). - -Legal project attribute names, and attribute names for each legal package are -listed below. Attributes names are case-insensitive. - -The following attributes are defined on projects (all are simple attributes): - -@multitable @columnfractions .4 .3 -@item @emph{Attribute Name} -@tab @emph{Value} -@item @code{Source_Files} -@tab string list -@item @code{Source_Dirs} -@tab string list -@item @code{Source_List_File} -@tab string -@item @code{Object_Dir} -@tab string -@item @code{Exec_Dir} -@tab string -@item @code{Excluded_Source_Dirs} -@tab string list -@item @code{Excluded_Source_Files} -@tab string list -@item @code{Excluded_Source_List_File} -@tab string -@item @code{Languages} -@tab string list -@item @code{Main} -@tab string list -@item @code{Library_Dir} -@tab string -@item @code{Library_Name} -@tab string -@item @code{Library_Kind} -@tab string -@item @code{Library_Version} -@tab string -@item @code{Library_Interface} -@tab string -@item @code{Library_Auto_Init} -@tab string -@item @code{Library_Options} -@tab string list -@item @code{Library_Src_Dir} -@tab string -@item @code{Library_ALI_Dir} -@tab string -@item @code{Library_GCC} -@tab string -@item @code{Library_Symbol_File} -@tab string -@item @code{Library_Symbol_Policy} -@tab string -@item @code{Library_Reference_Symbol_File} -@tab string -@item @code{Externally_Built} -@tab string -@end multitable +@smallexample +$ gnatxref -v gnatfind.adb > tags +@end smallexample @noindent -The following attributes are defined for package @code{Naming} -(@pxref{Naming Schemes}): - -@multitable @columnfractions .4 .2 .2 .2 -@item Attribute Name @tab Category @tab Index @tab Value -@item @code{Spec_Suffix} -@tab associative array -@tab language name -@tab string -@item @code{Body_Suffix} -@tab associative array -@tab language name -@tab string -@item @code{Separate_Suffix} -@tab simple attribute -@tab n/a -@tab string -@item @code{Casing} -@tab simple attribute -@tab n/a -@tab string -@item @code{Dot_Replacement} -@tab simple attribute -@tab n/a -@tab string -@item @code{Spec} -@tab associative array -@tab Ada unit name -@tab string -@item @code{Body} -@tab associative array -@tab Ada unit name -@tab string -@item @code{Specification_Exceptions} -@tab associative array -@tab language name -@tab string list -@item @code{Implementation_Exceptions} -@tab associative array -@tab language name -@tab string list -@end multitable +will generate the tags file for @code{gnatfind} itself (if the sources +are in the search path!). -@noindent -The following attributes are defined for packages @code{Builder}, -@code{Compiler}, @code{Binder}, -@code{Linker}, @code{Cross_Reference}, and @code{Finder} -(@pxref{^Switches^Switches^ and Project Files}). - -@multitable @columnfractions .4 .2 .2 .2 -@item Attribute Name @tab Category @tab Index @tab Value -@item @code{^Default_Switches^Default_Switches^} -@tab associative array -@tab language name -@tab string list -@item @code{^Switches^Switches^} -@tab associative array -@tab file name -@tab string list -@end multitable +From @command{vi}, you can then use the command @samp{:tag @var{entity}} +(replacing @var{entity} by whatever you are looking for), and vi will +display a new file with the corresponding declaration of entity. +@end ifclear -@noindent -In addition, package @code{Compiler} has a single string attribute -@code{Local_Configuration_Pragmas} and package @code{Builder} has a single -string attribute @code{Global_Configuration_Pragmas}. +@node Examples of gnatfind Usage +@section Examples of @code{gnatfind} Usage -@noindent -Each simple attribute has a default value: the empty string (for string-valued -attributes) and the empty list (for string list-valued attributes). +@table @code -An attribute declaration defines a new value for an attribute. +@item gnatfind ^-f^/FULL_PATHNAME^ xyz:main.adb +Find declarations for all entities xyz referenced at least once in +main.adb. The references are search in every library file in the search +path. -Examples of simple attribute declarations: +The directories will be printed as well (as the @samp{^-f^/FULL_PATHNAME^} +switch is set) -@smallexample @c projectfile - for Object_Dir use "objects"; - for Source_Dirs use ("units", "test/drivers"); +The output will look like: +@smallexample +^directory/^[directory]^main.ads:106:14: xyz <= declaration +^directory/^[directory]^main.adb:24:10: xyz <= body +^directory/^[directory]^foo.ads:45:23: xyz <= declaration @end smallexample @noindent -The syntax of a @dfn{simple attribute declaration} is similar to that of an -attribute definition clause in Ada. - -Attributes references may be appear in expressions. -The general form for such a reference is @code{'}: -Associative array attributes are functions. Associative -array attribute references must have an argument that is a string literal. - -Examples are: +that is to say, one of the entities xyz found in main.adb is declared at +line 12 of main.ads (and its body is in main.adb), and another one is +declared at line 45 of foo.ads -@smallexample @c projectfile - project'Object_Dir - Naming'Dot_Replacement - Imported_Project'Source_Dirs - Imported_Project.Naming'Casing - Builder'^Default_Switches^Default_Switches^("Ada") -@end smallexample +@item gnatfind ^-fs^/FULL_PATHNAME/SOURCE_LINE^ xyz:main.adb +This is the same command as the previous one, instead @code{gnatfind} will +display the content of the Ada source file lines. -@noindent -The prefix of an attribute may be: -@itemize @bullet -@item @code{project} for an attribute of the current project -@item The name of an existing package of the current project -@item The name of an imported project -@item The name of a parent project that is extended by the current project -@item An expanded name whose prefix is imported/parent project name, -and whose selector is a package name -@end itemize +The output will look like: -@noindent -Example: -@smallexample @c projectfile -@group - project Prj is - for Source_Dirs use project'Source_Dirs & "units"; - for Source_Dirs use project'Source_Dirs & "test/drivers" - end Prj; -@end group +@smallexample +^directory/^[directory]^main.ads:106:14: xyz <= declaration + procedure xyz; +^directory/^[directory]^main.adb:24:10: xyz <= body + procedure xyz is +^directory/^[directory]^foo.ads:45:23: xyz <= declaration + xyz : Integer; @end smallexample @noindent -In the first attribute declaration, initially the attribute @code{Source_Dirs} -has the default value: an empty string list. After this declaration, -@code{Source_Dirs} is a string list of one element: @code{"units"}. -After the second attribute declaration @code{Source_Dirs} is a string list of -two elements: @code{"units"} and @code{"test/drivers"}. - -Note: this example is for illustration only. In practice, -the project file would contain only one attribute declaration: - -@smallexample @c projectfile - for Source_Dirs use ("units", "test/drivers"); -@end smallexample - -@node Associative Array Attributes -@subsection Associative Array Attributes +This can make it easier to find exactly the location your are looking +for. -@noindent -Some attributes are defined as @emph{associative arrays}. An associative -array may be regarded as a function that takes a string as a parameter -and delivers a string or string list value as its result. +@item gnatfind ^-r^/REFERENCES^ "*x*":main.ads:123 foo.adb +Find references to all entities containing an x that are +referenced on line 123 of main.ads. +The references will be searched only in main.ads and foo.adb. -Here are some examples of single associative array attribute associations: +@item gnatfind main.ads:123 +Find declarations and bodies for all entities that are referenced on +line 123 of main.ads. -@smallexample @c projectfile - for Body ("main") use "Main.ada"; - for ^Switches^Switches^ ("main.ada") - use ("^-v^-v^", - "^-gnatv^-gnatv^"); - for ^Switches^Switches^ ("main.ada") - use Builder'^Switches^Switches^ ("main.ada") - & "^-g^-g^"; -@end smallexample +This is the same as @code{gnatfind "*":main.adb:123}. -@noindent -Like untyped variables and simple attributes, associative array attributes -may be declared several times. Each declaration supplies a new value for the -attribute, and replaces the previous setting. +@item gnatfind ^mydir/^[mydir]^main.adb:123:45 +Find the declaration for the entity referenced at column 45 in +line 123 of file main.adb in directory mydir. Note that it +is usual to omit the identifier name when the column is given, +since the column position identifies a unique reference. -@noindent -An associative array attribute may be declared as a full associative array -declaration, with the value of the same attribute in an imported or extended -project. +The column has to be the beginning of the identifier, and should not +point to any character in the middle of the identifier. -@smallexample @c projectfile - package Builder is - for Default_Switches use Default.Builder'Default_Switches; - end Builder; -@end smallexample +@end table -@noindent -In this example, @code{Default} must be either a project imported by the -current project, or the project that the current project extends. If the -attribute is in a package (in this case, in package @code{Builder}), the same -package needs to be specified. +@c ********************************* +@node The GNAT Pretty-Printer gnatpp +@chapter The GNAT Pretty-Printer @command{gnatpp} +@findex gnatpp +@cindex Pretty-Printer @noindent -A full associative array declaration replaces any other declaration for the -attribute, including other full associative array declaration. Single -associative array associations may be declare after a full associative -declaration, modifying the value for a single association of the attribute. +^The @command{gnatpp} tool^GNAT PRETTY^ is an ASIS-based utility +for source reformatting / pretty-printing. +It takes an Ada source file as input and generates a reformatted +version as output. +You can specify various style directives via switches; e.g., +identifier case conventions, rules of indentation, and comment layout. -@node case Constructions -@subsection @code{case} Constructions +To produce a reformatted file, @command{gnatpp} generates and uses the ASIS +tree for the input source and thus requires the input to be syntactically and +semantically legal. +If this condition is not met, @command{gnatpp} will terminate with an +error message; no output file will be generated. -@noindent -A @code{case} construction is used in a project file to effect conditional -behavior. -Here is a typical example: +If the source files presented to @command{gnatpp} contain +preprocessing directives, then the output file will +correspond to the generated source after all +preprocessing is carried out. There is no way +using @command{gnatpp} to obtain pretty printed files that +include the preprocessing directives. -@smallexample @c projectfile -@group -project MyProj is - type OS_Type is ("GNU/Linux", "Unix", "NT", "VMS"); +If the compilation unit +contained in the input source depends semantically upon units located +outside the current directory, you have to provide the source search path +when invoking @command{gnatpp}, if these units are contained in files with +names that do not follow the GNAT file naming rules, you have to provide +the configuration file describing the corresponding naming scheme; +see the description of the @command{gnatpp} +switches below. Another possibility is to use a project file and to +call @command{gnatpp} through the @command{gnat} driver - OS : OS_Type := external ("OS", "GNU/Linux"); -@end group +The @command{gnatpp} command has the form -@group - package Compiler is - case OS is - when "GNU/Linux" | "Unix" => - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-gnath^-gnath^"); - when "NT" => - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-gnatP^-gnatP^"); - when others => - end case; - end Compiler; -end MyProj; -@end group +@smallexample +@c $ gnatpp @ovar{switches} @var{filename} +@c Expanding @ovar macro inline (explanation in macro def comments) +$ gnatpp @r{[}@var{switches}@r{]} @var{filename} @r{[}-cargs @var{gcc_switches}@r{]} @end smallexample @noindent -The syntax of a @code{case} construction is based on the Ada case statement -(although there is no @code{null} construction for empty alternatives). - -The case expression must be a typed string variable. -Each alternative comprises the reserved word @code{when}, either a list of -literal strings separated by the @code{"|"} character or the reserved word -@code{others}, and the @code{"=>"} token. -Each literal string must belong to the string type that is the type of the -case variable. -An @code{others} alternative, if present, must occur last. - -After each @code{=>}, there are zero or more constructions. The only -constructions allowed in a case construction are other case constructions, -attribute declarations and variable declarations. String type declarations and -package declarations are not allowed. Variable declarations are restricted to -variables that have already been declared before the case construction. - -The value of the case variable is often given by an external reference -(@pxref{External References in Project Files}). +where +@itemize @bullet +@item +@var{switches} is an optional sequence of switches defining such properties as +the formatting rules, the source search path, and the destination for the +output source file -@c **************************************** -@c * Objects and Sources in Project Files * -@c **************************************** +@item +@var{filename} is the name (including the extension) of the source file to +reformat; ``wildcards'' or several file names on the same gnatpp command are +allowed. The file name may contain path information; it does not have to +follow the GNAT file naming rules -@node Objects and Sources in Project Files -@section Objects and Sources in Project Files +@item +@samp{@var{gcc_switches}} is a list of switches for +@command{gcc}. They will be passed on to all compiler invocations made by +@command{gnatelim} to generate the ASIS trees. Here you can provide +@option{^-I^/INCLUDE_DIRS=^} switches to form the source search path, +use the @option{-gnatec} switch to set the configuration file etc. +@end itemize @menu -* Object Directory:: -* Exec Directory:: -* Source Directories:: -* Source File Names:: +* Switches for gnatpp:: +* Formatting Rules:: @end menu -@noindent -Each project has exactly one object directory and one or more source -directories. The source directories must contain at least one source file, -unless the project file explicitly specifies that no source files are present -(@pxref{Source File Names}). - -@node Object Directory -@subsection Object Directory - -@noindent -The object directory for a project is the directory containing the compiler's -output (such as @file{ALI} files and object files) for the project's immediate -sources. - -The object directory is given by the value of the attribute @code{Object_Dir} -in the project file. - -@smallexample @c projectfile - for Object_Dir use "objects"; -@end smallexample +@node Switches for gnatpp +@section Switches for @command{gnatpp} @noindent -The attribute @code{Object_Dir} has a string value, the path name of the object -directory. The path name may be absolute or relative to the directory of the -project file. This directory must already exist, and be readable and writable. +The following subsections describe the various switches accepted by +@command{gnatpp}, organized by category. -By default, when the attribute @code{Object_Dir} is not given an explicit value -or when its value is the empty string, the object directory is the same as the -directory containing the project file. +@ifclear vms +You specify a switch by supplying a name and generally also a value. +In many cases the values for a switch with a given name are incompatible with +each other +(for example the switch that controls the casing of a reserved word may have +exactly one value: upper case, lower case, or +mixed case) and thus exactly one such switch can be in effect for an +invocation of @command{gnatpp}. +If more than one is supplied, the last one is used. +However, some values for the same switch are mutually compatible. +You may supply several such switches to @command{gnatpp}, but then +each must be specified in full, with both the name and the value. +Abbreviated forms (the name appearing once, followed by each value) are +not permitted. +For example, to set +the alignment of the assignment delimiter both in declarations and in +assignment statements, you must write @option{-A2A3} +(or @option{-A2 -A3}), but not @option{-A23}. +@end ifclear -@node Exec Directory -@subsection Exec Directory +@ifset vms +In many cases the set of options for a given qualifier are incompatible with +each other (for example the qualifier that controls the casing of a reserved +word may have exactly one option, which specifies either upper case, lower +case, or mixed case), and thus exactly one such option can be in effect for +an invocation of @command{gnatpp}. +If more than one is supplied, the last one is used. +However, some qualifiers have options that are mutually compatible, +and then you may then supply several such options when invoking +@command{gnatpp}. +@end ifset -@noindent -The exec directory for a project is the directory containing the executables -for the project's main subprograms. +In most cases, it is obvious whether or not the +^values for a switch with a given name^options for a given qualifier^ +are compatible with each other. +When the semantics might not be evident, the summaries below explicitly +indicate the effect. -The exec directory is given by the value of the attribute @code{Exec_Dir} -in the project file. +@menu +* Alignment Control:: +* Casing Control:: +* Construct Layout Control:: +* General Text Layout Control:: +* Other Formatting Options:: +* Setting the Source Search Path:: +* Output File Control:: +* Other gnatpp Switches:: +@end menu -@smallexample @c projectfile - for Exec_Dir use "executables"; -@end smallexample +@node Alignment Control +@subsection Alignment Control +@cindex Alignment control in @command{gnatpp} @noindent -The attribute @code{Exec_Dir} has a string value, the path name of the exec -directory. The path name may be absolute or relative to the directory of the -project file. This directory must already exist, and be writable. - -By default, when the attribute @code{Exec_Dir} is not given an explicit value -or when its value is the empty string, the exec directory is the same as the -object directory of the project file. +Programs can be easier to read if certain constructs are vertically aligned. +By default all alignments are set ON. +Through the @option{^-A0^/ALIGN=OFF^} switch you may reset the default to +OFF, and then use one or more of the other +^@option{-A@var{n}} switches^@option{/ALIGN} options^ +to activate alignment for specific constructs. -@node Source Directories -@subsection Source Directories +@table @option +@cindex @option{^-A@var{n}^/ALIGN^} (@command{gnatpp}) -@noindent -The source directories of a project are specified by the project file -attribute @code{Source_Dirs}. +@ifset vms +@item /ALIGN=ON +Set all alignments to ON +@end ifset -This attribute's value is a string list. If the attribute is not given an -explicit value, then there is only one source directory, the one where the -project file resides. +@item ^-A0^/ALIGN=OFF^ +Set all alignments to OFF -A @code{Source_Dirs} attribute that is explicitly defined to be the empty list, -as in +@item ^-A1^/ALIGN=COLONS^ +Align @code{:} in declarations -@smallexample @c projectfile - for Source_Dirs use (); -@end smallexample +@item ^-A2^/ALIGN=DECLARATIONS^ +Align @code{:=} in initializations in declarations -@noindent -indicates that the project contains no source files. +@item ^-A3^/ALIGN=STATEMENTS^ +Align @code{:=} in assignment statements -Otherwise, each string in the string list designates one or more -source directories. +@item ^-A4^/ALIGN=ARROWS^ +Align @code{=>} in associations -@smallexample @c projectfile - for Source_Dirs use ("sources", "test/drivers"); -@end smallexample +@item ^-A5^/ALIGN=COMPONENT_CLAUSES^ +Align @code{at} keywords in the component clauses in record +representation clauses +@end table @noindent -If a string in the list ends with @code{"/**"}, then the directory whose path -name precedes the two asterisks, as well as all its subdirectories -(recursively), are source directories. +The @option{^-A^/ALIGN^} switches are mutually compatible; any combination +is allowed. -@smallexample @c projectfile - for Source_Dirs use ("/system/sources/**"); -@end smallexample +@node Casing Control +@subsection Casing Control +@cindex Casing control in @command{gnatpp} @noindent -Here the directory @code{/system/sources} and all of its subdirectories -(recursively) are source directories. +@command{gnatpp} allows you to specify the casing for reserved words, +pragma names, attribute designators and identifiers. +For identifiers you may define a +general rule for name casing but also override this rule +via a set of dictionary files. -To specify that the source directories are the directory of the project file -and all of its subdirectories, you can declare @code{Source_Dirs} as follows: -@smallexample @c projectfile - for Source_Dirs use ("./**"); -@end smallexample +Three types of casing are supported: lower case, upper case, and mixed case. +Lower and upper case are self-explanatory (but since some letters in +Latin1 and other GNAT-supported character sets +exist only in lower-case form, an upper case conversion will have no +effect on them.) +``Mixed case'' means that the first letter, and also each letter immediately +following an underscore, are converted to their uppercase forms; +all the other letters are converted to their lowercase forms. -@noindent -Each of the source directories must exist and be readable. +@table @option +@cindex @option{^-a@var{x}^/ATTRIBUTE^} (@command{gnatpp}) +@item ^-aL^/ATTRIBUTE_CASING=LOWER_CASE^ +Attribute designators are lower case -@node Source File Names -@subsection Source File Names +@item ^-aU^/ATTRIBUTE_CASING=UPPER_CASE^ +Attribute designators are upper case -@noindent -In a project that contains source files, their names may be specified by the -attributes @code{Source_Files} (a string list) or @code{Source_List_File} -(a string). Source file names never include any directory information. +@item ^-aM^/ATTRIBUTE_CASING=MIXED_CASE^ +Attribute designators are mixed case (this is the default) -If the attribute @code{Source_Files} is given an explicit value, then each -element of the list is a source file name. +@cindex @option{^-k@var{x}^/KEYWORD_CASING^} (@command{gnatpp}) +@item ^-kL^/KEYWORD_CASING=LOWER_CASE^ +Keywords (technically, these are known in Ada as @emph{reserved words}) are +lower case (this is the default) -@smallexample @c projectfile - for Source_Files use ("main.adb"); - for Source_Files use ("main.adb", "pack1.ads", "pack2.adb"); -@end smallexample +@item ^-kU^/KEYWORD_CASING=UPPER_CASE^ +Keywords are upper case -@noindent -If the attribute @code{Source_Files} is not given an explicit value, -but the attribute @code{Source_List_File} is given a string value, -then the source file names are contained in the text file whose path name -(absolute or relative to the directory of the project file) is the -value of the attribute @code{Source_List_File}. +@cindex @option{^-n@var{x}^/NAME_CASING^} (@command{gnatpp}) +@item ^-nD^/NAME_CASING=AS_DECLARED^ +Name casing for defining occurrences are as they appear in the source file +(this is the default) -Each line in the file that is not empty or is not a comment -contains a source file name. +@item ^-nU^/NAME_CASING=UPPER_CASE^ +Names are in upper case -@smallexample @c projectfile - for Source_List_File use "source_list.txt"; -@end smallexample +@item ^-nL^/NAME_CASING=LOWER_CASE^ +Names are in lower case -@noindent -By default, if neither the attribute @code{Source_Files} nor the attribute -@code{Source_List_File} is given an explicit value, then each file in the -source directories that conforms to the project's naming scheme -(@pxref{Naming Schemes}) is an immediate source of the project. +@item ^-nM^/NAME_CASING=MIXED_CASE^ +Names are in mixed case -A warning is issued if both attributes @code{Source_Files} and -@code{Source_List_File} are given explicit values. In this case, the attribute -@code{Source_Files} prevails. +@cindex @option{^-p@var{x}^/PRAGMA_CASING^} (@command{gnatpp}) +@item ^-pL^/PRAGMA_CASING=LOWER_CASE^ +Pragma names are lower case -Each source file name must be the name of one existing source file -in one of the source directories. +@item ^-pU^/PRAGMA_CASING=UPPER_CASE^ +Pragma names are upper case -A @code{Source_Files} attribute whose value is an empty list -indicates that there are no source files in the project. +@item ^-pM^/PRAGMA_CASING=MIXED_CASE^ +Pragma names are mixed case (this is the default) -If the order of the source directories is known statically, that is if -@code{"/**"} is not used in the string list @code{Source_Dirs}, then there may -be several files with the same source file name. In this case, only the file -in the first directory is considered as an immediate source of the project -file. If the order of the source directories is not known statically, it is -an error to have several files with the same source file name. +@item ^-D@var{file}^/DICTIONARY=@var{file}^ +@cindex @option{^-D^/DICTIONARY^} (@command{gnatpp}) +Use @var{file} as a @emph{dictionary file} that defines +the casing for a set of specified names, +thereby overriding the effect on these names by +any explicit or implicit +^-n^/NAME_CASING^ switch. +To supply more than one dictionary file, +use ^several @option{-D} switches^a list of files as options^. -Projects can be specified to have no Ada source -files: the value of @code{Source_Dirs} or @code{Source_Files} may be an empty -list, or the @code{"Ada"} may be absent from @code{Languages}: +@noindent +@option{gnatpp} implicitly uses a @emph{default dictionary file} +to define the casing for the Ada predefined names and +the names declared in the GNAT libraries. -@smallexample @c projectfile - for Source_Dirs use (); - for Source_Files use (); - for Languages use ("C", "C++"); -@end smallexample +@item ^-D-^/SPECIFIC_CASING^ +@cindex @option{^-D-^/SPECIFIC_CASING^} (@command{gnatpp}) +Do not use the default dictionary file; +instead, use the casing +defined by a @option{^-n^/NAME_CASING^} switch and any explicit +dictionary file(s) +@end table @noindent -Otherwise, a project must contain at least one immediate source. - -Projects with no source files are useful as template packages -(@pxref{Packages in Project Files}) for other projects; in particular to -define a package @code{Naming} (@pxref{Naming Schemes}). +The structure of a dictionary file, and details on the conventions +used in the default dictionary file, are defined in @ref{Name Casing}. -@c **************************** -@c * Importing Projects * -@c **************************** +The @option{^-D-^/SPECIFIC_CASING^} and +@option{^-D@var{file}^/DICTIONARY=@var{file}^} switches are mutually +compatible. -@node Importing Projects -@section Importing Projects -@cindex @code{ADA_PROJECT_PATH} -@cindex @code{GPR_PROJECT_PATH} +@node Construct Layout Control +@subsection Construct Layout Control +@cindex Layout control in @command{gnatpp} @noindent -An immediate source of a project P may depend on source files that -are neither immediate sources of P nor in the predefined library. -To get this effect, P must @emph{import} the projects that contain the needed -source files. - -@smallexample @c projectfile -@group - with "project1", "utilities.gpr"; - with "/namings/apex.gpr"; - project Main is - @dots{} -@end group -@end smallexample +This group of @command{gnatpp} switches controls the layout of comments and +complex syntactic constructs. See @ref{Formatting Comments} for details +on their effect. -@noindent -As can be seen in this example, the syntax for importing projects is similar -to the syntax for importing compilation units in Ada. However, project files -use literal strings instead of names, and the @code{with} clause identifies -project files rather than packages. +@table @option +@cindex @option{^-c@var{n}^/COMMENTS_LAYOUT^} (@command{gnatpp}) +@item ^-c0^/COMMENTS_LAYOUT=UNTOUCHED^ +All the comments remain unchanged -Each literal string is the file name or path name (absolute or relative) of a -project file. If a string corresponds to a file name, with no path or a -relative path, then its location is determined by the @emph{project path}. The -latter can be queried using @code{gnatls -v}. It contains: +@item ^-c1^/COMMENTS_LAYOUT=DEFAULT^ +GNAT-style comment line indentation (this is the default). -@itemize @bullet -@item -In first position, the directory containing the current project file. -@item -In last position, the default project directory. This default project directory -is part of the GNAT installation and is the standard place to install project -files giving access to standard support libraries. -@ifclear vms -@ref{Installing a library} -@end ifclear +@item ^-c2^/COMMENTS_LAYOUT=STANDARD_INDENT^ +Reference-manual comment line indentation. -@item -In between, all the directories referenced in the -^environment variables^logical names^ @env{GPR_PROJECT_PATH} -and @env{ADA_PROJECT_PATH} if they exist, and in that order. -@end itemize +@item ^-c3^/COMMENTS_LAYOUT=GNAT_BEGINNING^ +GNAT-style comment beginning -@noindent -If a relative pathname is used, as in +@item ^-c4^/COMMENTS_LAYOUT=REFORMAT^ +Reformat comment blocks -@smallexample @c projectfile - with "tests/proj"; -@end smallexample - -@noindent -then the full path for the project is constructed by concatenating this -relative path to those in the project path, in order, until a matching file is -found. Any symbolic link will be fully resolved in the directory of the -importing project file before the imported project file is examined. - -If the @code{with}'ed project file name does not have an extension, -the default is @file{^.gpr^.GPR^}. If a file with this extension is not found, -then the file name as specified in the @code{with} clause (no extension) will -be used. In the above example, if a file @code{project1.gpr} is found, then it -will be used; otherwise, if a file @code{^project1^PROJECT1^} exists -then it will be used; if neither file exists, this is an error. - -A warning is issued if the name of the project file does not match the -name of the project; this check is case insensitive. - -Any source file that is an immediate source of the imported project can be -used by the immediate sources of the importing project, transitively. Thus -if @code{A} imports @code{B}, and @code{B} imports @code{C}, the immediate -sources of @code{A} may depend on the immediate sources of @code{C}, even if -@code{A} does not import @code{C} explicitly. However, this is not recommended, -because if and when @code{B} ceases to import @code{C}, some sources in -@code{A} will no longer compile. - -A side effect of this capability is that normally cyclic dependencies are not -permitted: if @code{A} imports @code{B} (directly or indirectly) then @code{B} -is not allowed to import @code{A}. However, there are cases when cyclic -dependencies would be beneficial. For these cases, another form of import -between projects exists, the @code{limited with}: a project @code{A} that -imports a project @code{B} with a straight @code{with} may also be imported, -directly or indirectly, by @code{B} on the condition that imports from @code{B} -to @code{A} include at least one @code{limited with}. - -@smallexample @c 0projectfile -with "../b/b.gpr"; -with "../c/c.gpr"; -project A is -end A; - -limited with "../a/a.gpr"; -project B is -end B; +@item ^-c5^/COMMENTS_LAYOUT=KEEP_SPECIAL^ +Keep unchanged special form comments -with "../d/d.gpr"; -project C is -end C; +Reformat comment blocks -limited with "../a/a.gpr"; -project D is -end D; -@end smallexample +@cindex @option{^-l@var{n}^/CONSTRUCT_LAYOUT^} (@command{gnatpp}) +@item ^-l1^/CONSTRUCT_LAYOUT=GNAT^ +GNAT-style layout (this is the default) -@noindent -In the above legal example, there are two project cycles: -@itemize @bullet -@item A-> B-> A -@item A -> C -> D -> A -@end itemize +@item ^-l2^/CONSTRUCT_LAYOUT=COMPACT^ +Compact layout -@noindent -In each of these cycle there is one @code{limited with}: import of @code{A} -from @code{B} and import of @code{A} from @code{D}. +@item ^-l3^/CONSTRUCT_LAYOUT=UNCOMPACT^ +Uncompact layout -The difference between straight @code{with} and @code{limited with} is that -the name of a project imported with a @code{limited with} cannot be used in the -project that imports it. In particular, its packages cannot be renamed and -its variables cannot be referred to. +@cindex @option{^-N^/NOTABS^} (@command{gnatpp}) +@item ^-N^/NOTABS^ +All the VT characters are removed from the comment text. All the HT characters +are expanded with the sequences of space characters to get to the next tab +stops. -An exception to the above rules for @code{limited with} is that for the main -project specified to @command{gnatmake} or to the @command{GNAT} driver a -@code{limited with} is equivalent to a straight @code{with}. For example, -in the example above, projects @code{B} and @code{D} could not be main -projects for @command{gnatmake} or to the @command{GNAT} driver, because they -each have a @code{limited with} that is the only one in a cycle of importing -projects. +@cindex @option{^--no-separate-is^/NO_SEPARATE_IS^} (@command{gnatpp}) +@item ^--no-separate-is^/NO_SEPARATE_IS^ +Do not place the keyword @code{is} on a separate line in a subprogram body in +case if the spec occupies more then one line. -@c ********************* -@c * Project Extension * -@c ********************* +@cindex @option{^--separate-label^/SEPARATE_LABEL^} (@command{gnatpp}) +@item ^--separate-label^/SEPARATE_LABEL^ +Place statement label(s) on a separate line, with the following statement +on the next line. -@node Project Extension -@section Project Extension +@cindex @option{^--separate-loop-then^/SEPARATE_LOOP_THEN^} (@command{gnatpp}) +@item ^--separate-loop-then^/SEPARATE_LOOP_THEN^ +Place the keyword @code{loop} in FOR and WHILE loop statements and the +keyword @code{then} in IF statements on a separate line. -@noindent -During development of a large system, it is sometimes necessary to use -modified versions of some of the source files, without changing the original -sources. This can be achieved through the @emph{project extension} facility. +@cindex @option{^--no-separate-loop-then^/NO_SEPARATE_LOOP_THEN^} (@command{gnatpp}) +@item ^--no-separate-loop-then^/NO_SEPARATE_LOOP_THEN^ +Do not place the keyword @code{loop} in FOR and WHILE loop statements and the +keyword @code{then} in IF statements on a separate line. This option is +incompatible with @option{^--separate-loop-then^/SEPARATE_LOOP_THEN^} option. -@smallexample @c projectfile - project Modified_Utilities extends "/baseline/utilities.gpr" is @dots{} -@end smallexample +@cindex @option{^--use-on-new-line^/USE_ON_NEW_LINE^} (@command{gnatpp}) +@item ^--use-on-new-line^/USE_ON_NEW_LINE^ +Start each USE clause in a context clause from a separate line. -@noindent -A project extension declaration introduces an extending project -(the @emph{child}) and a project being extended (the @emph{parent}). - -By default, a child project inherits all the sources of its parent. -However, inherited sources can be overridden: a unit in a parent is hidden -by a unit of the same name in the child. - -Inherited sources are considered to be sources (but not immediate sources) -of the child project; see @ref{Project File Syntax}. - -An inherited source file retains any switches specified in the parent project. - -For example if the project @code{Utilities} contains the spec and the -body of an Ada package @code{Util_IO}, then the project -@code{Modified_Utilities} can contain a new body for package @code{Util_IO}. -The original body of @code{Util_IO} will not be considered in program builds. -However, the package spec will still be found in the project -@code{Utilities}. - -A child project can have only one parent, except when it is qualified as -abstract. But it may import any number of other projects. - -A project is not allowed to import directly or indirectly at the same time a -child project and any of its ancestors. - -@c ******************************* -@c * Project Hierarchy Extension * -@c ******************************* +@cindex @option{^--separate-stmt-name^/STMT_NAME_ON_NEW_LINE^} (@command{gnatpp}) +@item ^--separate-stmt-name^/STMT_NAME_ON_NEW_LINE^ +Use a separate line for a loop or block statement name, but do not use an extra +indentation level for the statement itself. -@node Project Hierarchy Extension -@section Project Hierarchy Extension +@end table +@ifclear vms @noindent -When extending a large system spanning multiple projects, it is often -inconvenient to extend every project in the hierarchy that is impacted by a -small change introduced. In such cases, it is possible to create a virtual -extension of entire hierarchy using @code{extends all} relationship. - -When the project is extended using @code{extends all} inheritance, all projects -that are imported by it, both directly and indirectly, are considered virtually -extended. That is, the Project Manager creates "virtual projects" -that extend every project in the hierarchy; all these virtual projects have -no sources of their own and have as object directory the object directory of -the root of "extending all" project. - -It is possible to explicitly extend one or more projects in the hierarchy -in order to modify the sources. These extending projects must be imported by -the "extending all" project, which will replace the corresponding virtual -projects with the explicit ones. - -When building such a project hierarchy extension, the Project Manager will -ensure that both modified sources and sources in virtual extending projects -that depend on them, are recompiled. - -By means of example, consider the following hierarchy of projects. +The @option{-c1} and @option{-c2} switches are incompatible. +The @option{-c3} and @option{-c4} switches are compatible with each other and +also with @option{-c1} and @option{-c2}. The @option{-c0} switch disables all +the other comment formatting switches. -@enumerate -@item -project A, containing package P1 -@item -project B importing A and containing package P2 which depends on P1 -@item -project C importing B and containing package P3 which depends on P2 -@end enumerate +The @option{-l1}, @option{-l2}, and @option{-l3} switches are incompatible. +@end ifclear +@ifset vms @noindent -We want to modify packages P1 and P3. - -This project hierarchy will need to be extended as follows: - -@enumerate +For the @option{/COMMENTS_LAYOUT} qualifier: +@itemize @bullet @item -Create project A1 that extends A, placing modified P1 there: - -@smallexample @c 0projectfile -project A1 extends "(@dots{})/A" is -end A1; -@end smallexample - +The @option{DEFAULT} and @option{STANDARD_INDENT} options are incompatible. @item -Create project C1 that "extends all" C and imports A1, placing modified -P3 there: - -@smallexample @c 0projectfile -with "(@dots{})/A1"; -project C1 extends all "(@dots{})/C" is -end C1; -@end smallexample -@end enumerate - -When you build project C1, your entire modified project space will be -recompiled, including the virtual project B1 that has been impacted by the -"extending all" inheritance of project C. - -Note that if a Library Project in the hierarchy is virtually extended, -the virtual project that extends the Library Project is not a Library Project. +The @option{GNAT_BEGINNING} and @option{REFORMAT} options are compatible with +each other and also with @option{DEFAULT} and @option{STANDARD_INDENT}. +@end itemize -@c **************************************** -@c * External References in Project Files * -@c **************************************** +@noindent +The @option{GNAT}, @option{COMPACT}, and @option{UNCOMPACT} options for the +@option{/CONSTRUCT_LAYOUT} qualifier are incompatible. +@end ifset -@node External References in Project Files -@section External References in Project Files +@node General Text Layout Control +@subsection General Text Layout Control @noindent -A project file may contain references to external variables; such references -are called @emph{external references}. +These switches allow control over line length and indentation. -An external variable is either defined as part of the environment (an -environment variable in Unix, for example) or else specified on the command -line via the @option{^-X^/EXTERNAL_REFERENCE=^@emph{vbl}=@emph{value}} switch. -If both, then the command line value is used. +@table @option +@item ^-M@var{nnn}^/LINE_LENGTH_MAX=@var{nnn}^ +@cindex @option{^-M^/LINE_LENGTH^} (@command{gnatpp}) +Maximum line length, @var{nnn} from 32@dots{}256, the default value is 79 -The value of an external reference is obtained by means of the built-in -function @code{external}, which returns a string value. -This function has two forms: -@itemize @bullet -@item @code{external (external_variable_name)} -@item @code{external (external_variable_name, default_value)} -@end itemize +@item ^-i@var{nnn}^/INDENTATION_LEVEL=@var{nnn}^ +@cindex @option{^-i^/INDENTATION_LEVEL^} (@command{gnatpp}) +Indentation level, @var{nnn} from 1@dots{}9, the default value is 3 -@noindent -Each parameter must be a string literal. For example: +@item ^-cl@var{nnn}^/CONTINUATION_INDENT=@var{nnn}^ +@cindex @option{^-cl^/CONTINUATION_INDENT^} (@command{gnatpp}) +Indentation level for continuation lines (relative to the line being +continued), @var{nnn} from 1@dots{}9. +The default +value is one less then the (normal) indentation level, unless the +indentation is set to 1 (in which case the default value for continuation +line indentation is also 1) +@end table -@smallexample @c projectfile - external ("USER") - external ("OS", "GNU/Linux") -@end smallexample +@node Other Formatting Options +@subsection Other Formatting Options @noindent -In the form with one parameter, the function returns the value of -the external variable given as parameter. If this name is not present in the -environment, the function returns an empty string. - -In the form with two string parameters, the second argument is -the value returned when the variable given as the first argument is not -present in the environment. In the example above, if @code{"OS"} is not -the name of ^an environment variable^a logical name^ and is not passed on -the command line, then the returned value is @code{"GNU/Linux"}. +These switches control the inclusion of missing end/exit labels, and +the indentation level in @b{case} statements. -An external reference may be part of a string expression or of a string -list expression, and can therefore appear in a variable declaration or -an attribute declaration. +@table @option +@item ^-e^/NO_MISSED_LABELS^ +@cindex @option{^-e^/NO_MISSED_LABELS^} (@command{gnatpp}) +Do not insert missing end/exit labels. An end label is the name of +a construct that may optionally be repeated at the end of the +construct's declaration; +e.g., the names of packages, subprograms, and tasks. +An exit label is the name of a loop that may appear as target +of an exit statement within the loop. +By default, @command{gnatpp} inserts these end/exit labels when +they are absent from the original source. This option suppresses such +insertion, so that the formatted source reflects the original. -@smallexample @c projectfile -@group - type Mode_Type is ("Debug", "Release"); - Mode : Mode_Type := external ("MODE"); - case Mode is - when "Debug" => - @dots{} -@end group -@end smallexample +@item ^-ff^/FORM_FEED_AFTER_PRAGMA_PAGE^ +@cindex @option{^-ff^/FORM_FEED_AFTER_PRAGMA_PAGE^} (@command{gnatpp}) +Insert a Form Feed character after a pragma Page. -@c ***************************** -@c * Packages in Project Files * -@c ***************************** +@item ^-T@var{nnn}^/MAX_INDENT=@var{nnn}^ +@cindex @option{^-T^/MAX_INDENT^} (@command{gnatpp}) +Do not use an additional indentation level for @b{case} alternatives +and variants if there are @var{nnn} or more (the default +value is 10). +If @var{nnn} is 0, an additional indentation level is +used for @b{case} alternatives and variants regardless of their number. +@end table -@node Packages in Project Files -@section Packages in Project Files +@node Setting the Source Search Path +@subsection Setting the Source Search Path @noindent -A @emph{package} defines the settings for project-aware tools within a -project. -For each such tool one can declare a package; the names for these -packages are preset (@pxref{Packages}). -A package may contain variable declarations, attribute declarations, and case -constructions. - -@smallexample @c projectfile -@group - project Proj is - package Builder is -- used by gnatmake - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-v^-v^", - "^-g^-g^"); - end Builder; - end Proj; -@end group -@end smallexample +To define the search path for the input source file, @command{gnatpp} +uses the same switches as the GNAT compiler, with the same effects. -@noindent -The syntax of package declarations mimics that of package in Ada. +@table @option +@item ^-I^/SEARCH=^@var{dir} +@cindex @option{^-I^/SEARCH^} (@code{gnatpp}) +The same as the corresponding gcc switch -Most of the packages have an attribute -@code{^Default_Switches^Default_Switches^}. -This attribute is an associative array, and its value is a string list. -The index of the associative array is the name of a programming language (case -insensitive). This attribute indicates the ^switch^switch^ -or ^switches^switches^ to be used -with the corresponding tool. +@item ^-I-^/NOCURRENT_DIRECTORY^ +@cindex @option{^-I-^/NOCURRENT_DIRECTORY^} (@code{gnatpp}) +The same as the corresponding gcc switch -Some packages also have another attribute, @code{^Switches^Switches^}, -an associative array whose value is a string list. -The index is the name of a source file. -This attribute indicates the ^switch^switch^ -or ^switches^switches^ to be used by the corresponding -tool when dealing with this specific file. +@item ^-gnatec^/CONFIGURATION_PRAGMAS_FILE^=@var{path} +@cindex @option{^-gnatec^/CONFIGURATION_PRAGMAS_FILE^} (@code{gnatpp}) +The same as the corresponding gcc switch -Further information on these ^switch^switch^-related attributes is found in -@ref{^Switches^Switches^ and Project Files}. +@item ^--RTS^/RUNTIME_SYSTEM^=@var{path} +@cindex @option{^--RTS^/RUNTIME_SYSTEM^} (@code{gnatpp}) +The same as the corresponding gcc switch -A package may be declared as a @emph{renaming} of another package; e.g., from -the project file for an imported project. +@end table -@smallexample @c projectfile -@group - with "/global/apex.gpr"; - project Example is - package Naming renames Apex.Naming; - @dots{} - end Example; -@end group -@end smallexample +@node Output File Control +@subsection Output File Control @noindent -Packages that are renamed in other project files often come from project files -that have no sources: they are just used as templates. Any modification in the -template will be reflected automatically in all the project files that rename -a package from the template. - -In addition to the tool-oriented packages, you can also declare a package -named @code{Naming} to establish specialized source file naming conventions -(@pxref{Naming Schemes}). - -@c ************************************ -@c * Variables from Imported Projects * -@c ************************************ +By default the output is sent to the file whose name is obtained by appending +the ^@file{.pp}^@file{$PP}^ suffix to the name of the input file +(if the file with this name already exists, it is unconditionally overwritten). +Thus if the input file is @file{^my_ada_proc.adb^MY_ADA_PROC.ADB^} then +@command{gnatpp} will produce @file{^my_ada_proc.adb.pp^MY_ADA_PROC.ADB$PP^} +as output file. +The output may be redirected by the following switches: -@node Variables from Imported Projects -@section Variables from Imported Projects +@table @option +@item ^-pipe^/STANDARD_OUTPUT^ +@cindex @option{^-pipe^/STANDARD_OUTPUT^} (@code{gnatpp}) +Send the output to @code{Standard_Output} -@noindent -An attribute or variable defined in an imported or parent project can -be used in expressions in the importing / extending project. -Such an attribute or variable is denoted by an expanded name whose prefix -is either the name of the project or the expanded name of a package within -a project. +@item ^-o @var{output_file}^/OUTPUT=@var{output_file}^ +@cindex @option{^-o^/OUTPUT^} (@code{gnatpp}) +Write the output into @var{output_file}. +If @var{output_file} already exists, @command{gnatpp} terminates without +reading or processing the input file. -@smallexample @c projectfile -@group - with "imported"; - project Main extends "base" is - Var1 := Imported.Var; - Var2 := Base.Var & ".new"; -@end group +@item ^-of ^/FORCED_OUTPUT=^@var{output_file} +@cindex @option{^-of^/FORCED_OUTPUT^} (@code{gnatpp}) +Write the output into @var{output_file}, overwriting the existing file +(if one is present). -@group - package Builder is - for ^Default_Switches^Default_Switches^ ("Ada") - use Imported.Builder'Ada_^Switches^Switches^ & - "^-gnatg^-gnatg^" & - "^-v^-v^"; - end Builder; -@end group +@item ^-r^/REPLACE^ +@cindex @option{^-r^/REPLACE^} (@code{gnatpp}) +Replace the input source file with the reformatted output, and copy the +original input source into the file whose name is obtained by appending the +^@file{.npp}^@file{$NPP}^ suffix to the name of the input file. +If a file with this name already exists, @command{gnatpp} terminates without +reading or processing the input file. -@group - package Compiler is - for ^Default_Switches^Default_Switches^ ("Ada") - use Base.Compiler'Ada_^Switches^Switches^; - end Compiler; - end Main; -@end group -@end smallexample +@item ^-rf^/OVERRIDING_REPLACE^ +@cindex @option{^-rf^/OVERRIDING_REPLACE^} (@code{gnatpp}) +Like @option{^-r^/REPLACE^} except that if the file with the specified name +already exists, it is overwritten. -@noindent -In this example: +@item ^-rnb^/REPLACE_NO_BACKUP^ +@cindex @option{^-rnb^/REPLACE_NO_BACKUP^} (@code{gnatpp}) +Replace the input source file with the reformatted output without +creating any backup copy of the input source. +@item ^--eol=@var{xxx}^/END_OF_LINE=@var{xxx}^ +@cindex @option{^--eol^/END_OF_LINE^} (@code{gnatpp}) +Specifies the format of the reformatted output file. The @var{xxx} +^string specified with the switch^option^ may be either @itemize @bullet -@item -The value of @code{Var1} is a copy of the variable @code{Var} defined -in the project file @file{"imported.gpr"} -@item -the value of @code{Var2} is a copy of the value of variable @code{Var} -defined in the project file @file{base.gpr}, concatenated with @code{".new"} -@item -attribute @code{^Default_Switches^Default_Switches^ ("Ada")} in package -@code{Builder} is a string list that includes in its value a copy of the value -of @code{Ada_^Switches^Switches^} defined in the @code{Builder} package -in project file @file{imported.gpr} plus two new elements: -@option{"^-gnatg^-gnatg^"} -and @option{"^-v^-v^"}; -@item -attribute @code{^Default_Switches^Default_Switches^ ("Ada")} in package -@code{Compiler} is a copy of the variable @code{Ada_^Switches^Switches^} -defined in the @code{Compiler} package in project file @file{base.gpr}, -the project being extended. +@item ``@option{^dos^DOS^}'' MS DOS style, lines end with CR LF characters +@item ``@option{^crlf^CRLF^}'' +the same as @option{^crlf^CRLF^} +@item ``@option{^unix^UNIX^}'' UNIX style, lines end with LF character +@item ``@option{^lf^LF^}'' +the same as @option{^unix^UNIX^} @end itemize -@c ****************** -@c * Naming Schemes * -@c ****************** +@item ^-W^/RESULT_ENCODING=^@var{e} +@cindex @option{^-W^/RESULT_ENCODING=^} (@command{gnatpp}) +Specify the wide character encoding method used to write the code in the +result file +@var{e} is one of the following: -@node Naming Schemes -@section Naming Schemes +@itemize @bullet -@noindent -Sometimes an Ada software system is ported from a foreign compilation -environment to GNAT, and the file names do not use the default GNAT -conventions. Instead of changing all the file names (which for a variety -of reasons might not be possible), you can define the relevant file -naming scheme in the @code{Naming} package in your project file. +@item ^h^HEX^ +Hex encoding -@noindent -Note that the use of pragmas described in -@ref{Alternative File Naming Schemes} by mean of a configuration -pragmas file is not supported when using project files. You must use -the features described in this paragraph. You can however use specify -other configuration pragmas (@pxref{Specifying Configuration Pragmas}). +@item ^u^UPPER^ +Upper half encoding -@ifclear vms -For example, the following -package models the Apex file naming rules: +@item ^s^SHIFT_JIS^ +Shift/JIS encoding -@smallexample @c projectfile -@group - package Naming is - for Casing use "lowercase"; - for Dot_Replacement use "."; - for Spec_Suffix ("Ada") use ".1.ada"; - for Body_Suffix ("Ada") use ".2.ada"; - end Naming; -@end group -@end smallexample -@end ifclear +@item ^e^EUC^ +EUC encoding -@ifset vms -For example, the following package models the HP Ada file naming rules: +@item ^8^UTF8^ +UTF-8 encoding -@smallexample @c projectfile -@group - package Naming is - for Casing use "lowercase"; - for Dot_Replacement use "__"; - for Spec_Suffix ("Ada") use "_.^ada^ada^"; - for Body_Suffix ("Ada") use ".^ada^ada^"; - end Naming; -@end group -@end smallexample +@item ^b^BRACKETS^ +Brackets encoding (default value) +@end itemize -@noindent -(Note that @code{Casing} is @code{"lowercase"} because GNAT gets the file -names in lower case) -@end ifset +@end table @noindent -You can define the following attributes in package @code{Naming}: - -@table @code +Options @option{^-pipe^/STANDARD_OUTPUT^}, +@option{^-o^/OUTPUT^} and +@option{^-of^/FORCED_OUTPUT^} are allowed only if the call to gnatpp +contains only one file to reformat. +Option +@option{^--eol^/END_OF_LINE^} +and +@option{^-W^/RESULT_ENCODING^} +cannot be used together +with @option{^-pipe^/STANDARD_OUTPUT^} option. -@item @code{Casing} -This must be a string with one of the three values @code{"lowercase"}, -@code{"uppercase"} or @code{"mixedcase"}; these strings are case insensitive. +@node Other gnatpp Switches +@subsection Other @code{gnatpp} Switches @noindent -If @code{Casing} is not specified, then the default is @code{"lowercase"}. - -@item @code{Dot_Replacement} -This must be a string whose value satisfies the following conditions: +The additional @command{gnatpp} switches are defined in this subsection. -@itemize @bullet -@item It must not be empty -@item It cannot start or end with an alphanumeric character -@item It cannot be a single underscore -@item It cannot start with an underscore followed by an alphanumeric -@item It cannot contain a dot @code{'.'} except if the entire string -is @code{"."} -@end itemize +@table @option +@item ^-files @var{filename}^/FILES=@var{filename}^ +@cindex @option{^-files^/FILES^} (@code{gnatpp}) +Take the argument source files from the specified file. This file should be an +ordinary text file containing file names separated by spaces or +line breaks. You can use this switch more than once in the same call to +@command{gnatpp}. You also can combine this switch with an explicit list of +files. -@noindent -If @code{Dot_Replacement} is not specified, then the default is @code{"-"}. +@item ^-v^/VERBOSE^ +@cindex @option{^-v^/VERBOSE^} (@code{gnatpp}) +Verbose mode; +@command{gnatpp} generates version information and then +a trace of the actions it takes to produce or obtain the ASIS tree. + +@item ^-w^/WARNINGS^ +@cindex @option{^-w^/WARNINGS^} (@code{gnatpp}) +Warning mode; +@command{gnatpp} generates a warning whenever it cannot provide +a required layout in the result source. +@end table -@item @code{Spec_Suffix} -This is an associative array (indexed by the programming language name, case -insensitive) whose value is a string that must satisfy the following -conditions: +@node Formatting Rules +@section Formatting Rules -@itemize @bullet -@item It must not be empty -@item It must include at least one dot -@end itemize @noindent -If @code{Spec_Suffix ("Ada")} is not specified, then the default is -@code{"^.ads^.ADS^"}. +The following subsections show how @command{gnatpp} treats ``white space'', +comments, program layout, and name casing. +They provide the detailed descriptions of the switches shown above. + +@menu +* White Space and Empty Lines:: +* Formatting Comments:: +* Construct Layout:: +* Name Casing:: +@end menu -@item @code{Body_Suffix} -This is an associative array (indexed by the programming language name, case -insensitive) whose value is a string that must satisfy the following -conditions: +@node White Space and Empty Lines +@subsection White Space and Empty Lines -@itemize @bullet -@item It must not be empty -@item It must include at least one dot -@item It cannot be the same as @code{Spec_Suffix ("Ada")} -@end itemize @noindent -If @code{Body_Suffix ("Ada")} and @code{Spec_Suffix ("Ada")} end with the -same string, then a file name that ends with the longest of these two suffixes -will be a body if the longest suffix is @code{Body_Suffix ("Ada")} or a spec -if the longest suffix is @code{Spec_Suffix ("Ada")}. +@command{gnatpp} does not have an option to control space characters. +It will add or remove spaces according to the style illustrated by the +examples in the @cite{Ada Reference Manual}. -If the suffix does not start with a '.', a file with a name exactly equal -to the suffix will also be part of the project (for instance if you define -the suffix as @code{Makefile}, a file called @file{Makefile} will be part -of the project. This is not interesting in general when using projects to -compile. However, it might become useful when a project is also used to -find the list of source files in an editor, like the GNAT Programming System -(GPS). +The only format effectors +(see @cite{Ada Reference Manual}, paragraph 2.1(13)) +that will appear in the output file are platform-specific line breaks, +and also format effectors within (but not at the end of) comments. +In particular, each horizontal tab character that is not inside +a comment will be treated as a space and thus will appear in the +output file as zero or more spaces depending on +the reformatting of the line in which it appears. +The only exception is a Form Feed character, which is inserted after a +pragma @code{Page} when @option{-ff} is set. -If @code{Body_Suffix ("Ada")} is not specified, then the default is -@code{"^.adb^.ADB^"}. +The output file will contain no lines with trailing ``white space'' (spaces, +format effectors). -@item @code{Separate_Suffix} -This must be a string whose value satisfies the same conditions as -@code{Body_Suffix}. The same "longest suffix" rules apply. +Empty lines in the original source are preserved +only if they separate declarations or statements. +In such contexts, a +sequence of two or more empty lines is replaced by exactly one empty line. +Note that a blank line will be removed if it separates two ``comment blocks'' +(a comment block is a sequence of whole-line comments). +In order to preserve a visual separation between comment blocks, use an +``empty comment'' (a line comprising only hyphens) rather than an empty line. +Likewise, if for some reason you wish to have a sequence of empty lines, +use a sequence of empty comments instead. -@noindent -If @code{Separate_Suffix ("Ada")} is not specified, then it defaults to same -value as @code{Body_Suffix ("Ada")}. +@node Formatting Comments +@subsection Formatting Comments -@item @code{Spec} @noindent -You can use the associative array attribute @code{Spec} to define -the source file name for an individual Ada compilation unit's spec. The array -index must be a string literal that identifies the Ada unit (case insensitive). -The value of this attribute must be a string that identifies the file that -contains this unit's spec (case sensitive or insensitive depending on the -operating system). - -@smallexample @c projectfile - for Spec ("MyPack.MyChild") use "mypack.mychild.spec"; -@end smallexample +Comments in Ada code are of two kinds: +@itemize @bullet +@item +a @emph{whole-line comment}, which appears by itself (possibly preceded by +``white space'') on a line -When the source file contains several units, you can indicate at what -position the unit occurs in the file, with the following. The first unit -in the file has index 1 +@item +an @emph{end-of-line comment}, which follows some other Ada lexical element +on the same line. +@end itemize -@smallexample @c projectfile - for Body ("top") use "foo.a" at 1; - for Body ("foo") use "foo.a" at 2; -@end smallexample +@noindent +The indentation of a whole-line comment is that of either +the preceding or following line in +the formatted source, depending on switch settings as will be described below. -@item @code{Body} +For an end-of-line comment, @command{gnatpp} leaves the same number of spaces +between the end of the preceding Ada lexical element and the beginning +of the comment as appear in the original source, +unless either the comment has to be split to +satisfy the line length limitation, or else the next line contains a +whole line comment that is considered a continuation of this end-of-line +comment (because it starts at the same position). +In the latter two +cases, the start of the end-of-line comment is moved right to the nearest +multiple of the indentation level. +This may result in a ``line overflow'' (the right-shifted comment extending +beyond the maximum line length), in which case the comment is split as +described below. -You can use the associative array attribute @code{Body} to -define the source file name for an individual Ada compilation unit's body -(possibly a subunit). The array index must be a string literal that identifies -the Ada unit (case insensitive). The value of this attribute must be a string -that identifies the file that contains this unit's body or subunit (case -sensitive or insensitive depending on the operating system). +There is a difference between @option{^-c1^/COMMENTS_LAYOUT=DEFAULT^} +(GNAT-style comment line indentation) +and @option{^-c2^/COMMENTS_LAYOUT=STANDARD_INDENT^} +(reference-manual comment line indentation). +With reference-manual style, a whole-line comment is indented as if it +were a declaration or statement at the same place +(i.e., according to the indentation of the preceding line(s)). +With GNAT style, a whole-line comment that is immediately followed by an +@b{if} or @b{case} statement alternative, a record variant, or the reserved +word @b{begin}, is indented based on the construct that follows it. -@smallexample @c projectfile - for Body ("MyPack.MyChild") use "mypack.mychild.body"; +For example: +@smallexample @c ada +@cartouche +if A then + null; + -- some comment +else + null; +end if; +@end cartouche @end smallexample -@end table - -@c ******************** -@c * Library Projects * -@c ******************** - -@node Library Projects -@section Library Projects - -@noindent -@emph{Library projects} are projects whose object code is placed in a library. -(Note that this facility is not yet supported on all platforms). - -@code{gnatmake} or @code{gprbuild} will collect all object files into a -single archive, which might either be a shared or a static library. This -library can later on be linked with multiple executables, potentially -reducing their sizes. - -If your project file specifies languages other than Ada, but you are still -using @code{gnatmake} to compile and link, the latter will not try to -compile your sources other than Ada (you should use @code{gprbuild} if that -is your intent). However, @code{gnatmake} will automatically link all object -files found in the object directory, whether or not they were compiled from -an Ada source file. This specific behavior only applies when multiple -languages are specified. - -To create a library project, you need to define in its project file -two project-level attributes: @code{Library_Name} and @code{Library_Dir}. -Additionally, you may define other library-related attributes such as -@code{Library_Kind}, @code{Library_Version}, @code{Library_Interface}, -@code{Library_Auto_Init}, @code{Library_Options} and @code{Library_GCC}. - -The @code{Library_Name} attribute has a string value. There is no restriction -on the name of a library. It is the responsibility of the developer to -choose a name that will be accepted by the platform. It is recommended to -choose names that could be Ada identifiers; such names are almost guaranteed -to be acceptable on all platforms. - -The @code{Library_Dir} attribute has a string value that designates the path -(absolute or relative) of the directory where the library will reside. -It must designate an existing directory, and this directory must be writable, -different from the project's object directory and from any source directory -in the project tree. - -If both @code{Library_Name} and @code{Library_Dir} are specified and -are legal, then the project file defines a library project. The optional -library-related attributes are checked only for such project files. - -The @code{Library_Kind} attribute has a string value that must be one of the -following (case insensitive): @code{"static"}, @code{"dynamic"} or -@code{"relocatable"} (which is a synonym for @code{"dynamic"}). If this -attribute is not specified, the library is a static library, that is -an archive of object files that can be potentially linked into a -static executable. Otherwise, the library may be dynamic or -relocatable, that is a library that is loaded only at the start of execution. - -If you need to build both a static and a dynamic library, you should use two -different object directories, since in some cases some extra code needs to -be generated for the latter. For such cases, it is recommended to either use -two different project files, or a single one which uses external variables -to indicate what kind of library should be build. - -The @code{Library_ALI_Dir} attribute may be specified to indicate the -directory where the ALI files of the library will be copied. When it is -not specified, the ALI files are copied to the directory specified in -attribute @code{Library_Dir}. The directory specified by @code{Library_ALI_Dir} -must be writable and different from the project's object directory and from -any source directory in the project tree. - -The @code{Library_Version} attribute has a string value whose interpretation -is platform dependent. It has no effect on VMS and Windows. On Unix, it is -used only for dynamic/relocatable libraries as the internal name of the -library (the @code{"soname"}). If the library file name (built from the -@code{Library_Name}) is different from the @code{Library_Version}, then the -library file will be a symbolic link to the actual file whose name will be -@code{Library_Version}. - -Example (on Unix): -@smallexample @c projectfile -@group -project Plib is +@noindent +Reference-manual indentation produces: - Version := "1"; +@smallexample @c ada +@cartouche +if A then + null; + -- some comment +else + null; +end if; +@end cartouche +@end smallexample - for Library_Dir use "lib_dir"; - for Library_Name use "dummy"; - for Library_Kind use "relocatable"; - for Library_Version use "libdummy.so." & Version; +@noindent +while GNAT-style indentation produces: -end Plib; -@end group +@smallexample @c ada +@cartouche +if A then + null; +-- some comment +else + null; +end if; +@end cartouche @end smallexample @noindent -Directory @file{lib_dir} will contain the internal library file whose name -will be @file{libdummy.so.1}, and @file{libdummy.so} will be a symbolic link to -@file{libdummy.so.1}. +The @option{^-c3^/COMMENTS_LAYOUT=GNAT_BEGINNING^} switch +(GNAT style comment beginning) has the following +effect: -When @command{gnatmake} detects that a project file -is a library project file, it will check all immediate sources of the project -and rebuild the library if any of the sources have been recompiled. +@itemize @bullet +@item +For each whole-line comment that does not end with two hyphens, +@command{gnatpp} inserts spaces if necessary after the starting two hyphens +to ensure that there are at least two spaces between these hyphens and the +first non-blank character of the comment. +@end itemize -Standard project files can import library project files. In such cases, -the libraries will only be rebuilt if some of its sources are recompiled -because they are in the closure of some other source in an importing project. -Sources of the library project files that are not in such a closure will -not be checked, unless the full library is checked, because one of its sources -needs to be recompiled. +@noindent +For an end-of-line comment, if in the original source the next line is a +whole-line comment that starts at the same position +as the end-of-line comment, +then the whole-line comment (and all whole-line comments +that follow it and that start at the same position) +will start at this position in the output file. -For instance, assume the project file @code{A} imports the library project file -@code{L}. The immediate sources of A are @file{a1.adb}, @file{a2.ads} and -@file{a2.adb}. The immediate sources of L are @file{l1.ads}, @file{l1.adb}, -@file{l2.ads}, @file{l2.adb}. +@noindent +That is, if in the original source we have: -If @file{l1.adb} has been modified, then the library associated with @code{L} -will be rebuilt when compiling all the immediate sources of @code{A} only -if @file{a1.ads}, @file{a2.ads} or @file{a2.adb} includes a statement -@code{"with L1;"}. +@smallexample @c ada +@cartouche +begin +A := B + C; -- B must be in the range Low1..High1 + -- C must be in the range Low2..High2 + --B+C will be in the range Low1+Low2..High1+High2 +X := X + 1; +@end cartouche +@end smallexample -To be sure that all the sources in the library associated with @code{L} are -up to date, and that all the sources of project @code{A} are also up to date, -the following two commands needs to be used: +@noindent +Then in the formatted source we get -@smallexample -gnatmake -Pl.gpr -gnatmake -Pa.gpr +@smallexample @c ada +@cartouche +begin + A := B + C; -- B must be in the range Low1..High1 + -- C must be in the range Low2..High2 + -- B+C will be in the range Low1+Low2..High1+High2 + X := X + 1; +@end cartouche @end smallexample -When a library is built or rebuilt, an attempt is made first to delete all -files in the library directory. -All @file{ALI} files will also be copied from the object directory to the -library directory. To build executables, @command{gnatmake} will use the -library rather than the individual object files. - -@ifclear vms -It is also possible to create library project files for third-party libraries -that are precompiled and cannot be compiled locally thanks to the -@code{externally_built} attribute. (See @ref{Installing a library}). -@end ifclear +@noindent +A comment that exceeds the line length limit will be split. +Unless switch +@option{^-c4^/COMMENTS_LAYOUT=REFORMAT^} (reformat comment blocks) is set and +the line belongs to a reformattable block, splitting the line generates a +@command{gnatpp} warning. +The @option{^-c4^/COMMENTS_LAYOUT=REFORMAT^} switch specifies that whole-line +comments may be reformatted in typical +word processor style (that is, moving words between lines and putting as +many words in a line as possible). -@c ******************************* -@c * Stand-alone Library Projects * -@c ******************************* +@noindent +The @option{^-c5^/COMMENTS_LAYOUT=KEEP_SPECIAL^} switch specifies, that comments +that has a special format (that is, a character that is neither a letter nor digit +not white space nor line break immediately following the leading @code{--} of +the comment) should be without any change moved from the argument source +into reformatted source. This switch allows to preserve comments that are used +as a special marks in the code (e.g.@: SPARK annotation). -@node Stand-alone Library Projects -@section Stand-alone Library Projects +@node Construct Layout +@subsection Construct Layout @noindent -A Stand-alone Library is a library that contains the necessary code to -elaborate the Ada units that are included in the library. A Stand-alone -Library is suitable to be used in an executable when the main is not -in Ada. However, Stand-alone Libraries may also be used with an Ada main -subprogram. +In several cases the suggested layout in the Ada Reference Manual includes +an extra level of indentation that many programmers prefer to avoid. The +affected cases include: -A Stand-alone Library Project is a Library Project where the library is -a Stand-alone Library. +@itemize @bullet -To be a Stand-alone Library Project, in addition to the two attributes -that make a project a Library Project (@code{Library_Name} and -@code{Library_Dir}, see @ref{Library Projects}), the attribute -@code{Library_Interface} must be defined. +@item Record type declaration (RM 3.8) -@smallexample @c projectfile -@group - for Library_Dir use "lib_dir"; - for Library_Name use "dummy"; - for Library_Interface use ("int1", "int1.child"); -@end group -@end smallexample +@item Record representation clause (RM 13.5.1) -Attribute @code{Library_Interface} has a nonempty string list value, -each string in the list designating a unit contained in an immediate source -of the project file. +@item Loop statement in case if a loop has a statement identifier (RM 5.6) -When a Stand-alone Library is built, first the binder is invoked to build -a package whose name depends on the library name -(^b~dummy.ads/b^B$DUMMY.ADS/B^ in the example above). -This binder-generated package includes initialization and -finalization procedures whose -names depend on the library name (dummyinit and dummyfinal in the example -above). The object corresponding to this package is included in the library. +@item Block statement in case if a block has a statement identifier (RM 5.6) +@end itemize -A dynamic or relocatable Stand-alone Library is automatically initialized -if automatic initialization of Stand-alone Libraries is supported on the -platform and if attribute @code{Library_Auto_Init} is not specified or -is specified with the value "true". A static Stand-alone Library is never -automatically initialized. +@noindent +In compact mode (when GNAT style layout or compact layout is set), +the pretty printer uses one level of indentation instead +of two. This is achieved in the record definition and record representation +clause cases by putting the @code{record} keyword on the same line as the +start of the declaration or representation clause, and in the block and loop +case by putting the block or loop header on the same line as the statement +identifier. -Single string attribute @code{Library_Auto_Init} may be specified with only -two possible values: "false" or "true" (case-insensitive). Specifying -"false" for attribute @code{Library_Auto_Init} will prevent automatic -initialization of dynamic or relocatable libraries. +@noindent +The difference between GNAT style @option{^-l1^/CONSTRUCT_LAYOUT=GNAT^} +and compact @option{^-l2^/CONSTRUCT_LAYOUT=COMPACT^} +layout on the one hand, and uncompact layout +@option{^-l3^/CONSTRUCT_LAYOUT=UNCOMPACT^} on the other hand, +can be illustrated by the following examples: -When a non-automatically initialized Stand-alone Library is used -in an executable, its initialization procedure must be called before -any service of the library is used. -When the main subprogram is in Ada, it may mean that the initialization -procedure has to be called during elaboration of another package. +@iftex +@cartouche +@multitable @columnfractions .5 .5 +@item @i{GNAT style, compact layout} @tab @i{Uncompact layout} -For a Stand-Alone Library, only the @file{ALI} files of the Interface Units -(those that are listed in attribute @code{Library_Interface}) are copied to -the Library Directory. As a consequence, only the Interface Units may be -imported from Ada units outside of the library. If other units are imported, -the binding phase will fail. +@item +@smallexample @c ada +type q is record + a : integer; + b : integer; +end record; +@end smallexample +@tab +@smallexample @c ada +type q is + record + a : integer; + b : integer; + end record; +@end smallexample -When a Stand-Alone Library is bound, the switches that are specified in -the attribute @code{Default_Switches ("Ada")} in package @code{Binder} are -used in the call to @command{gnatbind}. +@item +@smallexample @c ada +for q use record + a at 0 range 0 .. 31; + b at 4 range 0 .. 31; +end record; +@end smallexample +@tab +@smallexample @c ada +for q use + record + a at 0 range 0 .. 31; + b at 4 range 0 .. 31; + end record; +@end smallexample -The string list attribute @code{Library_Options} may be used to specified -additional switches to the call to @command{gcc} to link the library. +@item +@smallexample @c ada +Block : declare + A : Integer := 3; +begin + Proc (A, A); +end Block; +@end smallexample +@tab +@smallexample @c ada +Block : + declare + A : Integer := 3; + begin + Proc (A, A); + end Block; +@end smallexample -The attribute @code{Library_Src_Dir}, may be specified for a -Stand-Alone Library. @code{Library_Src_Dir} is a simple attribute that has a -single string value. Its value must be the path (absolute or relative to the -project directory) of an existing directory. This directory cannot be the -object directory or one of the source directories, but it can be the same as -the library directory. The sources of the Interface -Units of the library, necessary to an Ada client of the library, will be -copied to the designated directory, called Interface Copy directory. -These sources includes the specs of the Interface Units, but they may also -include bodies and subunits, when pragmas @code{Inline} or @code{Inline_Always} -are used, or when there is a generic units in the spec. Before the sources -are copied to the Interface Copy directory, an attempt is made to delete all -files in the Interface Copy directory. +@item +@smallexample @c ada +Clear : for J in 1 .. 10 loop + A (J) := 0; +end loop Clear; +@end smallexample +@tab +@smallexample @c ada +Clear : + for J in 1 .. 10 loop + A (J) := 0; + end loop Clear; +@end smallexample +@end multitable +@end cartouche +@end iftex -@c ************************************* -@c * Switches Related to Project Files * -@c ************************************* -@node Switches Related to Project Files -@section Switches Related to Project Files +@ifnottex +@smallexample +@cartouche +GNAT style, compact layout Uncompact layout -@noindent -The following switches are used by GNAT tools that support project files: +type q is record type q is + a : integer; record + b : integer; a : integer; +end record; b : integer; + end record; -@table @option +for q use record for q use + a at 0 range 0 .. 31; record + b at 4 range 0 .. 31; a at 0 range 0 .. 31; +end record; b at 4 range 0 .. 31; + end record; -@item ^-P^/PROJECT_FILE=^@var{project} -@cindex @option{^-P^/PROJECT_FILE^} (any project-aware tool) -Indicates the name of a project file. This project file will be parsed with -the verbosity indicated by @option{^-vP^MESSAGE_PROJECT_FILES=^@emph{x}}, -if any, and using the external references indicated -by @option{^-X^/EXTERNAL_REFERENCE^} switches, if any. -@ifclear vms -There may zero, one or more spaces between @option{-P} and @var{project}. -@end ifclear +Block : declare Block : + A : Integer := 3; declare +begin A : Integer := 3; + Proc (A, A); begin +end Block; Proc (A, A); + end Block; -@noindent -There must be only one @option{^-P^/PROJECT_FILE^} switch on the command line. +Clear : for J in 1 .. 10 loop Clear : + A (J) := 0; for J in 1 .. 10 loop +end loop Clear; A (J) := 0; + end loop Clear; +@end cartouche +@end smallexample +@end ifnottex @noindent -Since the Project Manager parses the project file only after all the switches -on the command line are checked, the order of the switches -@option{^-P^/PROJECT_FILE^}, -@option{^-vP^/MESSAGES_PROJECT_FILE=^@emph{x}} -or @option{^-X^/EXTERNAL_REFERENCE^} is not significant. - -@item ^-X^/EXTERNAL_REFERENCE=^@var{name=value} -@cindex @option{^-X^/EXTERNAL_REFERENCE^} (any project-aware tool) -Indicates that external variable @var{name} has the value @var{value}. -The Project Manager will use this value for occurrences of -@code{external(name)} when parsing the project file. +A further difference between GNAT style layout and compact layout is that +GNAT style layout inserts empty lines as separation for +compound statements, return statements and bodies. -@ifclear vms -@noindent -If @var{name} or @var{value} includes a space, then @var{name=value} should be -put between quotes. -@smallexample - -XOS=NT - -X"user=John Doe" -@end smallexample -@end ifclear +Note that the layout specified by +@option{^--separate-stmt-name^/STMT_NAME_ON_NEW_LINE^} +for named block and loop statements overrides the layout defined by these +constructs by @option{^-l1^/CONSTRUCT_LAYOUT=GNAT^}, +@option{^-l2^/CONSTRUCT_LAYOUT=COMPACT^} or +@option{^-l3^/CONSTRUCT_LAYOUT=UNCOMPACT^} option. -@noindent -Several @option{^-X^/EXTERNAL_REFERENCE^} switches can be used simultaneously. -If several @option{^-X^/EXTERNAL_REFERENCE^} switches specify the same -@var{name}, only the last one is used. +@node Name Casing +@subsection Name Casing @noindent -An external variable specified with a @option{^-X^/EXTERNAL_REFERENCE^} switch -takes precedence over the value of the same name in the environment. - -@item ^-vP^/MESSAGES_PROJECT_FILE=^@emph{x} -@cindex @option{^-vP^/MESSAGES_PROJECT_FILE^} (any project-aware tool) -Indicates the verbosity of the parsing of GNAT project files. +@command{gnatpp} always converts the usage occurrence of a (simple) name to +the same casing as the corresponding defining identifier. +You control the casing for defining occurrences via the +@option{^-n^/NAME_CASING^} switch. @ifclear vms -@option{-vP0} means Default; -@option{-vP1} means Medium; -@option{-vP2} means High. +With @option{-nD} (``as declared'', which is the default), @end ifclear - @ifset vms -There are three possible options for this qualifier: DEFAULT, MEDIUM and -HIGH. +With @option{/NAME_CASING=AS_DECLARED}, which is the default, @end ifset +defining occurrences appear exactly as in the source file +where they are declared. +The other ^values for this switch^options for this qualifier^ --- +@option{^-nU^UPPER_CASE^}, +@option{^-nL^LOWER_CASE^}, +@option{^-nM^MIXED_CASE^} --- +result in +^upper, lower, or mixed case, respectively^the corresponding casing^. +If @command{gnatpp} changes the casing of a defining +occurrence, it analogously changes the casing of all the +usage occurrences of this name. -@noindent -The default is ^Default^DEFAULT^: no output for syntactically correct -project files. -@noindent -If several @option{^-vP^/MESSAGES_PROJECT_FILE=^@emph{x}} switches are present, -only the last one is used. - -@item ^-aP^/ADD_PROJECT_SEARCH_DIR=^ -@cindex @option{^-aP^/ADD_PROJECT_SEARCH_DIR=^} (any project-aware tool) -Add directory at the beginning of the project search path, in order, -after the current working directory. +If the defining occurrence of a name is not in the source compilation unit +currently being processed by @command{gnatpp}, the casing of each reference to +this name is changed according to the value of the @option{^-n^/NAME_CASING^} +switch (subject to the dictionary file mechanism described below). +Thus @command{gnatpp} acts as though the @option{^-n^/NAME_CASING^} switch +had affected the +casing for the defining occurrence of the name. -@ifclear vms -@item -eL -@cindex @option{-eL} (any project-aware tool) -Follow all symbolic links when processing project files. -@end ifclear +Some names may need to be spelled with casing conventions that are not +covered by the upper-, lower-, and mixed-case transformations. +You can arrange correct casing by placing such names in a +@emph{dictionary file}, +and then supplying a @option{^-D^/DICTIONARY^} switch. +The casing of names from dictionary files overrides +any @option{^-n^/NAME_CASING^} switch. -@item ^--subdirs^/SUBDIRS^= -@cindex @option{^--subdirs^/SUBDIRS^=} (gnatmake and gnatclean) -This switch is recognized by gnatmake and gnatclean. It indicate that the real -directories (except the source directories) are the subdirectories -of the directories specified in the project files. This applies in particular -to object directories, library directories and exec directories. If the -subdirectories do not exist, they are created automatically. +To handle the casing of Ada predefined names and the names from GNAT libraries, +@command{gnatpp} assumes a default dictionary file. +The name of each predefined entity is spelled with the same casing as is used +for the entity in the @cite{Ada Reference Manual}. +The name of each entity in the GNAT libraries is spelled with the same casing +as is used in the declaration of that entity. -@end table +The @w{@option{^-D-^/SPECIFIC_CASING^}} switch suppresses the use of the +default dictionary file. +Instead, the casing for predefined and GNAT-defined names will be established +by the @option{^-n^/NAME_CASING^} switch or explicit dictionary files. +For example, by default the names @code{Ada.Text_IO} and @code{GNAT.OS_Lib} +will appear as just shown, +even in the presence of a @option{^-nU^/NAME_CASING=UPPER_CASE^} switch. +To ensure that even such names are rendered in uppercase, +additionally supply the @w{@option{^-D-^/SPECIFIC_CASING^}} switch +(or else, less conveniently, place these names in upper case in a dictionary +file). -@c ********************************** -@c * Tools Supporting Project Files * -@c ********************************** +A dictionary file is +a plain text file; each line in this file can be either a blank line +(containing only space characters and ASCII.HT characters), an Ada comment +line, or the specification of exactly one @emph{casing schema}. -@node Tools Supporting Project Files -@section Tools Supporting Project Files +A casing schema is a string that has the following syntax: -@menu -* gnatmake and Project Files:: -* The GNAT Driver and Project Files:: -@end menu +@smallexample +@cartouche + @var{casing_schema} ::= @var{identifier} | *@var{simple_identifier}* -@node gnatmake and Project Files -@subsection gnatmake and Project Files + @var{simple_identifier} ::= @var{letter}@{@var{letter_or_digit}@} +@end cartouche +@end smallexample @noindent -This section covers several topics related to @command{gnatmake} and -project files: defining ^switches^switches^ for @command{gnatmake} -and for the tools that it invokes; specifying configuration pragmas; -the use of the @code{Main} attribute; building and rebuilding library project -files. - -@menu -* ^Switches^Switches^ and Project Files:: -* Specifying Configuration Pragmas:: -* Project Files and Main Subprograms:: -* Library Project Files:: -@end menu +(See @cite{Ada Reference Manual}, Section 2.3) for the definition of the +@var{identifier} lexical element and the @var{letter_or_digit} category.) -@node ^Switches^Switches^ and Project Files -@subsubsection ^Switches^Switches^ and Project Files +The casing schema string can be followed by white space and/or an Ada-style +comment; any amount of white space is allowed before the string. +If a dictionary file is passed as +@ifclear vms +the value of a @option{-D@var{file}} switch +@end ifclear @ifset vms -It is not currently possible to specify VMS style qualifiers in the project -files; only Unix style ^switches^switches^ may be specified. +an option to the @option{/DICTIONARY} qualifier @end ifset - -@noindent -For each of the packages @code{Builder}, @code{Compiler}, @code{Binder}, and -@code{Linker}, you can specify a @code{^Default_Switches^Default_Switches^} -attribute, a @code{^Switches^Switches^} attribute, or both; -as their names imply, these ^switch^switch^-related -attributes affect the ^switches^switches^ that are used for each of these GNAT -components when -@command{gnatmake} is invoked. As will be explained below, these -component-specific ^switches^switches^ precede -the ^switches^switches^ provided on the @command{gnatmake} command line. - -The @code{^Default_Switches^Default_Switches^} attribute is an associative -array indexed by language name (case insensitive) whose value is a string list. -For example: - -@smallexample @c projectfile -@group -package Compiler is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-gnaty^-gnaty^", - "^-v^-v^"); -end Compiler; -@end group -@end smallexample - -@noindent -The @code{^Switches^Switches^} attribute is also an associative array, -indexed by a file name (which may or may not be case sensitive, depending -on the operating system) whose value is a string list. For example: - -@smallexample @c projectfile -@group -package Builder is - for ^Switches^Switches^ ("main1.adb") - use ("^-O2^-O2^"); - for ^Switches^Switches^ ("main2.adb") - use ("^-g^-g^"); -end Builder; -@end group -@end smallexample - -@noindent -For the @code{Builder} package, the file names must designate source files -for main subprograms. For the @code{Binder} and @code{Linker} packages, the -file names must designate @file{ALI} or source files for main subprograms. -In each case just the file name without an explicit extension is acceptable. - -For each tool used in a program build (@command{gnatmake}, the compiler, the -binder, and the linker), the corresponding package @dfn{contributes} a set of -^switches^switches^ for each file on which the tool is invoked, based on the -^switch^switch^-related attributes defined in the package. -In particular, the ^switches^switches^ -that each of these packages contributes for a given file @var{f} comprise: +then for every +simple name and every identifier, @command{gnatpp} checks if the dictionary +defines the casing for the name or for some of its parts (the term ``subword'' +is used below to denote the part of a name which is delimited by ``_'' or by +the beginning or end of the word and which does not contain any ``_'' inside): @itemize @bullet @item -the value of attribute @code{^Switches^Switches^ (@var{f})}, -if it is specified in the package for the given file, -@item -otherwise, the value of @code{^Default_Switches^Default_Switches^ ("Ada")}, -if it is specified in the package. -@end itemize - -@noindent -If neither of these attributes is defined in the package, then the package does -not contribute any ^switches^switches^ for the given file. - -When @command{gnatmake} is invoked on a file, the ^switches^switches^ comprise -two sets, in the following order: those contributed for the file -by the @code{Builder} package; -and the switches passed on the command line. - -When @command{gnatmake} invokes a tool (compiler, binder, linker) on a file, -the ^switches^switches^ passed to the tool comprise three sets, -in the following order: +if the whole name is in the dictionary, @command{gnatpp} uses for this name +the casing defined by the dictionary; no subwords are checked for this word -@enumerate @item -the applicable ^switches^switches^ contributed for the file -by the @code{Builder} package in the project file supplied on the command line; +for every subword @command{gnatpp} checks if the dictionary contains the +corresponding string of the form @code{*@var{simple_identifier}*}, +and if it does, the casing of this @var{simple_identifier} is used +for this subword @item -those contributed for the file by the package (in the relevant project file -- -see below) corresponding to the tool; and - -@item -the applicable switches passed on the command line. -@end enumerate +if the whole name does not contain any ``_'' inside, and if for this name +the dictionary contains two entries - one of the form @var{identifier}, +and another - of the form *@var{simple_identifier}*, then the first one +is applied to define the casing of this name -@noindent -The term @emph{applicable ^switches^switches^} reflects the fact that -@command{gnatmake} ^switches^switches^ may or may not be passed to individual -tools, depending on the individual ^switch^switch^. +@item +if more than one dictionary file is passed as @command{gnatpp} switches, each +dictionary adds new casing exceptions and overrides all the existing casing +exceptions set by the previous dictionaries -@command{gnatmake} may invoke the compiler on source files from different -projects. The Project Manager will use the appropriate project file to -determine the @code{Compiler} package for each source file being compiled. -Likewise for the @code{Binder} and @code{Linker} packages. +@item +when @command{gnatpp} checks if the word or subword is in the dictionary, +this check is not case sensitive +@end itemize -As an example, consider the following package in a project file: +@noindent +For example, suppose we have the following source to reformat: -@smallexample @c projectfile -@group -project Proj1 is - package Compiler is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-g^-g^"); - for ^Switches^Switches^ ("a.adb") - use ("^-O1^-O1^"); - for ^Switches^Switches^ ("b.adb") - use ("^-O2^-O2^", - "^-gnaty^-gnaty^"); - end Compiler; -end Proj1; -@end group +@smallexample @c ada +@cartouche +procedure test is + name1 : integer := 1; + name4_name3_name2 : integer := 2; + name2_name3_name4 : Boolean; + name1_var : Float; +begin + name2_name3_name4 := name4_name3_name2 > name1; +end; +@end cartouche @end smallexample @noindent -If @command{gnatmake} is invoked with this project file, and it needs to -compile, say, the files @file{a.adb}, @file{b.adb}, and @file{c.adb}, then -@file{a.adb} will be compiled with the ^switch^switch^ -@option{^-O1^-O1^}, -@file{b.adb} with ^switches^switches^ -@option{^-O2^-O2^} -and @option{^-gnaty^-gnaty^}, -and @file{c.adb} with @option{^-g^-g^}. - -The following example illustrates the ordering of the ^switches^switches^ -contributed by different packages: +And suppose we have two dictionaries: -@smallexample @c projectfile -@group -project Proj2 is - package Builder is - for ^Switches^Switches^ ("main.adb") - use ("^-g^-g^", - "^-O1^-)1^", - "^-f^-f^"); - end Builder; -@end group +@smallexample +@cartouche +@i{dict1:} + NAME1 + *NaMe3* + *Name1* +@end cartouche -@group - package Compiler is - for ^Switches^Switches^ ("main.adb") - use ("^-O2^-O2^"); - end Compiler; -end Proj2; -@end group +@cartouche +@i{dict2:} + *NAME3* +@end cartouche @end smallexample @noindent -If you issue the command: +If @command{gnatpp} is called with the following switches: @smallexample - gnatmake ^-Pproj2^/PROJECT_FILE=PROJ2^ -O0 main +@ifclear vms +@command{gnatpp -nM -D dict1 -D dict2 test.adb} +@end ifclear +@ifset vms +@command{gnatpp test.adb /NAME_CASING=MIXED_CASE /DICTIONARY=(dict1, dict2)} +@end ifset @end smallexample @noindent -then the compiler will be invoked on @file{main.adb} with the following -sequence of ^switches^switches^ +then we will get the following name casing in the @command{gnatpp} output: -@smallexample - ^-g -O1 -O2 -O0^-g -O1 -O2 -O0^ +@smallexample @c ada +@cartouche +procedure Test is + NAME1 : Integer := 1; + Name4_NAME3_Name2 : Integer := 2; + Name2_NAME3_Name4 : Boolean; + Name1_Var : Float; +begin + Name2_NAME3_Name4 := Name4_NAME3_Name2 > NAME1; +end Test; +@end cartouche @end smallexample -with the last @option{^-O^-O^} -^switch^switch^ having precedence over the earlier ones; -several other ^switches^switches^ -(such as @option{^-c^-c^}) are added implicitly. - -The ^switches^switches^ -@option{^-g^-g^} -and @option{^-O1^-O1^} are contributed by package -@code{Builder}, @option{^-O2^-O2^} is contributed -by the package @code{Compiler} -and @option{^-O0^-O0^} comes from the command line. - -The @option{^-g^-g^} -^switch^switch^ will also be passed in the invocation of -@command{Gnatlink.} +@c ********************************* +@node The GNAT Metric Tool gnatmetric +@chapter The GNAT Metric Tool @command{gnatmetric} +@findex gnatmetric +@cindex Metric tool -A final example illustrates switch contributions from packages in different -project files: +@noindent +^The @command{gnatmetric} tool^@command{GNAT METRIC}^ is an ASIS-based utility +for computing various program metrics. +It takes an Ada source file as input and generates a file containing the +metrics data as output. Various switches control which +metrics are computed and output. -@smallexample @c projectfile -@group -project Proj3 is - for Source_Files use ("pack.ads", "pack.adb"); - package Compiler is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-gnata^-gnata^"); - end Compiler; -end Proj3; -@end group +@command{gnatmetric} generates and uses the ASIS +tree for the input source and thus requires the input to be syntactically and +semantically legal. +If this condition is not met, @command{gnatmetric} will generate +an error message; no metric information for this file will be +computed and reported. -@group -with "Proj3"; -project Proj4 is - for Source_Files use ("foo_main.adb", "bar_main.adb"); - package Builder is - for ^Switches^Switches^ ("foo_main.adb") - use ("^-s^-s^", - "^-g^-g^"); - end Builder; -end Proj4; -@end group +If the compilation unit contained in the input source depends semantically +upon units in files located outside the current directory, you have to provide +the source search path when invoking @command{gnatmetric}. +If it depends semantically upon units that are contained +in files with names that do not follow the GNAT file naming rules, you have to +provide the configuration file describing the corresponding naming scheme (see +the description of the @command{gnatmetric} switches below.) +Alternatively, you may use a project file and invoke @command{gnatmetric} +through the @command{gnat} driver. -@group --- Ada source file: -with Pack; -procedure Foo_Main is - @dots{} -end Foo_Main; -@end group -@end smallexample +The @command{gnatmetric} command has the form -If the command is @smallexample -gnatmake ^-PProj4^/PROJECT_FILE=PROJ4^ foo_main.adb -cargs -gnato +@c $ gnatmetric @ovar{switches} @{@var{filename}@} @r{[}-cargs @var{gcc_switches}@r{]} +@c Expanding @ovar macro inline (explanation in macro def comments) +$ gnatmetric @r{[}@var{switches}@r{]} @{@var{filename}@} @r{[}-cargs @var{gcc_switches}@r{]} @end smallexample @noindent -then the ^switches^switches^ passed to the compiler for @file{foo_main.adb} are -@option{^-g^-g^} (contributed by the package @code{Proj4.Builder}) and -@option{^-gnato^-gnato^} (passed on the command line). -When the imported package @code{Pack} is compiled, the ^switches^switches^ used -are @option{^-g^-g^} from @code{Proj4.Builder}, -@option{^-gnata^-gnata^} (contributed from package @code{Proj3.Compiler}, -and @option{^-gnato^-gnato^} from the command line. - -@noindent -When using @command{gnatmake} with project files, some ^switches^switches^ or -arguments may be expressed as relative paths. As the working directory where -compilation occurs may change, these relative paths are converted to absolute -paths. For the ^switches^switches^ found in a project file, the relative paths -are relative to the project file directory, for the switches on the command -line, they are relative to the directory where @command{gnatmake} is invoked. -The ^switches^switches^ for which this occurs are: -^-I^-I^, -^-A^-A^, -^-L^-L^, -^-aO^-aO^, -^-aL^-aL^, -^-aI^-aI^, as well as all arguments that are not switches (arguments to -^switch^switch^ -^-o^-o^, object files specified in package @code{Linker} or after --largs on the command line). The exception to this rule is the ^switch^switch^ -^--RTS=^--RTS=^ for which a relative path argument is never converted. - -@node Specifying Configuration Pragmas -@subsubsection Specifying Configuration Pragmas - -When using @command{gnatmake} with project files, if there exists a file -@file{gnat.adc} that contains configuration pragmas, this file will be -ignored. +where +@itemize @bullet +@item +@var{switches} specify the metrics to compute and define the destination for +the output -Configuration pragmas can be defined by means of the following attributes in -project files: @code{Global_Configuration_Pragmas} in package @code{Builder} -and @code{Local_Configuration_Pragmas} in package @code{Compiler}. +@item +Each @var{filename} is the name (including the extension) of a source +file to process. ``Wildcards'' are allowed, and +the file name may contain path information. +If no @var{filename} is supplied, then the @var{switches} list must contain +at least one +@option{-files} switch (@pxref{Other gnatmetric Switches}). +Including both a @option{-files} switch and one or more +@var{filename} arguments is permitted. -Both these attributes are single string attributes. Their values is the path -name of a file containing configuration pragmas. If a path name is relative, -then it is relative to the project directory of the project file where the -attribute is defined. +@item +@samp{@var{gcc_switches}} is a list of switches for +@command{gcc}. They will be passed on to all compiler invocations made by +@command{gnatmetric} to generate the ASIS trees. Here you can provide +@option{^-I^/INCLUDE_DIRS=^} switches to form the source search path, +and use the @option{-gnatec} switch to set the configuration file. +@end itemize -When compiling a source, the configuration pragmas used are, in order, -those listed in the file designated by attribute -@code{Global_Configuration_Pragmas} in package @code{Builder} of the main -project file, if it is specified, and those listed in the file designated by -attribute @code{Local_Configuration_Pragmas} in package @code{Compiler} of -the project file of the source, if it exists. +@menu +* Switches for gnatmetric:: +@end menu -@node Project Files and Main Subprograms -@subsubsection Project Files and Main Subprograms +@node Switches for gnatmetric +@section Switches for @command{gnatmetric} @noindent -When using a project file, you can invoke @command{gnatmake} -with one or several main subprograms, by specifying their source files on the -command line. +The following subsections describe the various switches accepted by +@command{gnatmetric}, organized by category. -@smallexample - gnatmake ^-P^/PROJECT_FILE=^prj main1 main2 main3 -@end smallexample +@menu +* Output Files Control:: +* Disable Metrics For Local Units:: +* Specifying a set of metrics to compute:: +* Other gnatmetric Switches:: +* Generate project-wide metrics:: +@end menu -@noindent -Each of these needs to be a source file of the same project, except -when the switch ^-u^/UNIQUE^ is used. +@node Output Files Control +@subsection Output File Control +@cindex Output file control in @command{gnatmetric} @noindent -When ^-u^/UNIQUE^ is not used, all the mains need to be sources of the -same project, one of the project in the tree rooted at the project specified -on the command line. The package @code{Builder} of this common project, the -"main project" is the one that is considered by @command{gnatmake}. +@command{gnatmetric} has two output formats. It can generate a +textual (human-readable) form, and also XML. By default only textual +output is generated. -@noindent -When ^-u^/UNIQUE^ is used, the specified source files may be in projects -imported directly or indirectly by the project specified on the command line. -Note that if such a source file is not part of the project specified on the -command line, the ^switches^switches^ found in package @code{Builder} of the -project specified on the command line, if any, that are transmitted -to the compiler will still be used, not those found in the project file of -the source file. +When generating the output in textual form, @command{gnatmetric} creates +for each Ada source file a corresponding text file +containing the computed metrics, except for the case when the set of metrics +specified by gnatmetric parameters consists only of metrics that are computed +for the whole set of analyzed sources, but not for each Ada source. +By default, this file is placed in the same directory as where the source +file is located, and its name is obtained +by appending the ^@file{.metrix}^@file{$METRIX}^ suffix to the name of the +input file. -@noindent -When using a project file, you can also invoke @command{gnatmake} without -explicitly specifying any main, and the effect depends on whether you have -defined the @code{Main} attribute. This attribute has a string list value, -where each element in the list is the name of a source file (the file -extension is optional) that contains a unit that can be a main subprogram. +All the output information generated in XML format is placed in a single +file. By default this file is placed in the current directory and has the +name ^@file{metrix.xml}^@file{METRIX$XML}^. -If the @code{Main} attribute is defined in a project file as a non-empty -string list and the switch @option{^-u^/UNIQUE^} is not used on the command -line, then invoking @command{gnatmake} with this project file but without any -main on the command line is equivalent to invoking @command{gnatmake} with all -the file names in the @code{Main} attribute on the command line. +Some of the computed metrics are summed over the units passed to +@command{gnatmetric}; for example, the total number of lines of code. +By default this information is sent to @file{stdout}, but a file +can be specified with the @option{-og} switch. -Example: -@smallexample @c projectfile -@group - project Prj is - for Main use ("main1", "main2", "main3"); - end Prj; -@end group -@end smallexample +The following switches control the @command{gnatmetric} output: -@noindent -With this project file, @code{"gnatmake ^-Pprj^/PROJECT_FILE=PRJ^"} -is equivalent to -@code{"gnatmake ^-Pprj^/PROJECT_FILE=PRJ^ main1 main2 main3"}. +@table @option +@cindex @option{^-x^/XML^} (@command{gnatmetric}) +@item ^-x^/XML^ +Generate the XML output -When the project attribute @code{Main} is not specified, or is specified -as an empty string list, or when the switch @option{-u} is used on the command -line, then invoking @command{gnatmake} with no main on the command line will -result in all immediate sources of the project file being checked, and -potentially recompiled. Depending on the presence of the switch @option{-u}, -sources from other project files on which the immediate sources of the main -project file depend are also checked and potentially recompiled. In other -words, the @option{-u} switch is applied to all of the immediate sources of the -main project file. +@cindex @option{^-xs^/XSD^} (@command{gnatmetric}) +@item ^-xs^/XSD^ +Generate the XML output and the XML schema file that describes the structure +of the XML metric report, this schema is assigned to the XML file. The schema +file has the same name as the XML output file with @file{.xml} suffix replaced +with @file{.xsd} + +@cindex @option{^-nt^/NO_TEXT^} (@command{gnatmetric}) +@item ^-nt^/NO_TEXT^ +Do not generate the output in text form (implies @option{^-x^/XML^}) -When no main is specified on the command line and attribute @code{Main} exists -and includes several mains, or when several mains are specified on the -command line, the default ^switches^switches^ in package @code{Builder} will -be used for all mains, even if there are specific ^switches^switches^ -specified for one or several mains. +@cindex @option{^-d^/DIRECTORY^} (@command{gnatmetric}) +@item ^-d @var{output_dir}^/DIRECTORY=@var{output_dir}^ +Put text files with detailed metrics into @var{output_dir} -But the ^switches^switches^ from package @code{Binder} or @code{Linker} will be -the specific ^switches^switches^ for each main, if they are specified. +@cindex @option{^-o^/SUFFIX_DETAILS^} (@command{gnatmetric}) +@item ^-o @var{file_suffix}^/SUFFIX_DETAILS=@var{file_suffix}^ +Use @var{file_suffix}, instead of ^@file{.metrix}^@file{$METRIX}^ +in the name of the output file. -@node Library Project Files -@subsubsection Library Project Files +@cindex @option{^-og^/GLOBAL_OUTPUT^} (@command{gnatmetric}) +@item ^-og @var{file_name}^/GLOBAL_OUTPUT=@var{file_name}^ +Put global metrics into @var{file_name} -@noindent -When @command{gnatmake} is invoked with a main project file that is a library -project file, it is not allowed to specify one or more mains on the command -line. +@cindex @option{^-ox^/XML_OUTPUT^} (@command{gnatmetric}) +@item ^-ox @var{file_name}^/XML_OUTPUT=@var{file_name}^ +Put the XML output into @var{file_name} (also implies @option{^-x^/XML^}) -@noindent -When a library project file is specified, switches ^-b^/ACTION=BIND^ and -^-l^/ACTION=LINK^ have special meanings. +@cindex @option{^-sfn^/SHORT_SOURCE_FILE_NAME^} (@command{gnatmetric}) +@item ^-sfn^/SHORT_SOURCE_FILE_NAME^ +Use ``short'' source file names in the output. (The @command{gnatmetric} +output includes the name(s) of the Ada source file(s) from which the metrics +are computed. By default each name includes the absolute path. The +@option{^-sfn^/SHORT_SOURCE_FILE_NAME^} switch causes @command{gnatmetric} +to exclude all directory information from the file names that are output.) -@itemize @bullet -@item ^-b^/ACTION=BIND^ is only allowed for stand-alone libraries. It indicates -to @command{gnatmake} that @command{gnatbind} should be invoked for the -library. +@end table -@item ^-l^/ACTION=LINK^ may be used for all library projects. It indicates -to @command{gnatmake} that the binder generated file should be compiled -(in the case of a stand-alone library) and that the library should be built. +@node Disable Metrics For Local Units +@subsection Disable Metrics For Local Units +@cindex Disable Metrics For Local Units in @command{gnatmetric} -@end itemize +@noindent +@command{gnatmetric} relies on the GNAT compilation model @minus{} +one compilation +unit per one source file. It computes line metrics for the whole source +file, and it also computes syntax +and complexity metrics for the file's outermost unit. -@node The GNAT Driver and Project Files -@subsection The GNAT Driver and Project Files - -@noindent -A number of GNAT tools, other than @command{^gnatmake^gnatmake^} -can benefit from project files: -@command{^gnatbind^gnatbind^}, -@command{^gnatcheck^gnatcheck^}), -@command{^gnatclean^gnatclean^}), -@command{^gnatelim^gnatelim^}, -@command{^gnatfind^gnatfind^}, -@command{^gnatlink^gnatlink^}, -@command{^gnatls^gnatls^}, -@command{^gnatmetric^gnatmetric^}, -@command{^gnatpp^gnatpp^}, -@command{^gnatstub^gnatstub^}, -and @command{^gnatxref^gnatxref^}. However, none of these tools can be invoked -directly with a project file switch (@option{^-P^/PROJECT_FILE=^}). -They must be invoked through the @command{gnat} driver. - -The @command{gnat} driver is a wrapper that accepts a number of commands and -calls the corresponding tool. It was designed initially for VMS platforms (to -convert VMS qualifiers to Unix-style switches), but it is now available on all -GNAT platforms. - -On non-VMS platforms, the @command{gnat} driver accepts the following commands -(case insensitive): +By default, @command{gnatmetric} will also compute all metrics for certain +kinds of locally declared program units: @itemize @bullet @item -BIND to invoke @command{^gnatbind^gnatbind^} -@item -CHOP to invoke @command{^gnatchop^gnatchop^} -@item -CLEAN to invoke @command{^gnatclean^gnatclean^} -@item -COMP or COMPILE to invoke the compiler -@item -ELIM to invoke @command{^gnatelim^gnatelim^} -@item -FIND to invoke @command{^gnatfind^gnatfind^} -@item -KR or KRUNCH to invoke @command{^gnatkr^gnatkr^} -@item -LINK to invoke @command{^gnatlink^gnatlink^} -@item -LS or LIST to invoke @command{^gnatls^gnatls^} -@item -MAKE to invoke @command{^gnatmake^gnatmake^} -@item -NAME to invoke @command{^gnatname^gnatname^} -@item -PREP or PREPROCESS to invoke @command{^gnatprep^gnatprep^} -@item -PP or PRETTY to invoke @command{^gnatpp^gnatpp^} -@item -METRIC to invoke @command{^gnatmetric^gnatmetric^} -@item -STUB to invoke @command{^gnatstub^gnatstub^} -@item -XREF to invoke @command{^gnatxref^gnatxref^} -@end itemize - -@noindent -(note that the compiler is invoked using the command -@command{^gnatmake -f -u -c^gnatmake -f -u -c^}). +subprogram (and generic subprogram) bodies; -@noindent -On non-VMS platforms, between @command{gnat} and the command, two -special switches may be used: +@item +package (and generic package) specs and bodies; -@itemize @bullet @item -@command{-v} to display the invocation of the tool. +task object and type specifications and bodies; + @item -@command{-dn} to prevent the @command{gnat} driver from removing -the temporary files it has created. These temporary files are -configuration files and temporary file list files. +protected object and type specifications and bodies. @end itemize @noindent -The command may be followed by switches and arguments for the invoked -tool. +These kinds of entities will be referred to as +@emph{eligible local program units}, or simply @emph{eligible local units}, +@cindex Eligible local unit (for @command{gnatmetric}) +in the discussion below. -@smallexample - gnat bind -C main.ali - gnat ls -a main - gnat chop foo.txt -@end smallexample +Note that a subprogram declaration, generic instantiation, +or renaming declaration only receives metrics +computation when it appear as the outermost entity +in a source file. -@noindent -Switches may also be put in text files, one switch per line, and the text -files may be specified with their path name preceded by '@@'. +Suppression of metrics computation for eligible local units can be +obtained via the following switch: -@smallexample - gnat bind @@args.txt main.ali -@end smallexample +@table @option +@cindex @option{^-n@var{x}^/SUPPRESS^} (@command{gnatmetric}) +@item ^-nolocal^/SUPPRESS=LOCAL_DETAILS^ +Do not compute detailed metrics for eligible local program units -@noindent -In addition, for commands BIND, COMP or COMPILE, FIND, ELIM, LS or LIST, LINK, -METRIC, PP or PRETTY, STUB and XREF, the project file related switches -(@option{^-P^/PROJECT_FILE^}, -@option{^-X^/EXTERNAL_REFERENCE^} and -@option{^-vP^/MESSAGES_PROJECT_FILE=^x}) may be used in addition to -the switches of the invoking tool. +@end table -@noindent -When GNAT PP or GNAT PRETTY is used with a project file, but with no source -specified on the command line, it invokes @command{^gnatpp^gnatpp^} with all -the immediate sources of the specified project file. +@node Specifying a set of metrics to compute +@subsection Specifying a set of metrics to compute @noindent -When GNAT METRIC is used with a project file, but with no source -specified on the command line, it invokes @command{^gnatmetric^gnatmetric^} -with all the immediate sources of the specified project file and with -@option{^-d^/DIRECTORY^} with the parameter pointing to the object directory -of the project. +By default all the metrics are computed and reported. The switches +described in this subsection allow you to control, on an individual +basis, whether metrics are computed and +reported. If at least one positive metric +switch is specified (that is, a switch that defines that a given +metric or set of metrics is to be computed), then only +explicitly specified metrics are reported. -@noindent -In addition, when GNAT PP, GNAT PRETTY or GNAT METRIC is used with -a project file, no source is specified on the command line and -switch ^-U^/ALL_PROJECTS^ is specified on the command line, then -the underlying tool (^gnatpp^gnatpp^ or -^gnatmetric^gnatmetric^) is invoked for all sources of all projects, -not only for the immediate sources of the main project. -@ifclear vms -(-U stands for Universal or Union of the project files of the project tree) -@end ifclear +@menu +* Line Metrics Control:: +* Syntax Metrics Control:: +* Complexity Metrics Control:: +* Object-Oriented Metrics Control:: +@end menu + +@node Line Metrics Control +@subsubsection Line Metrics Control +@cindex Line metrics control in @command{gnatmetric} @noindent -For each of the following commands, there is optionally a corresponding -package in the main project. +For any (legal) source file, and for each of its +eligible local program units, @command{gnatmetric} computes the following +metrics: @itemize @bullet @item -package @code{Binder} for command BIND (invoking @code{^gnatbind^gnatbind^}) +the total number of lines; @item -package @code{Check} for command CHECK (invoking -@code{^gnatcheck^gnatcheck^}) +the total number of code lines (i.e., non-blank lines that are not comments) @item -package @code{Compiler} for command COMP or COMPILE (invoking the compiler) +the number of comment lines @item -package @code{Cross_Reference} for command XREF (invoking -@code{^gnatxref^gnatxref^}) +the number of code lines containing end-of-line comments; @item -package @code{Eliminate} for command ELIM (invoking -@code{^gnatelim^gnatelim^}) +the comment percentage: the ratio between the number of lines that contain +comments and the number of all non-blank lines, expressed as a percentage; @item -package @code{Finder} for command FIND (invoking @code{^gnatfind^gnatfind^}) +the number of empty lines and lines containing only space characters and/or +format effectors (blank lines) @item -package @code{Gnatls} for command LS or LIST (invoking @code{^gnatls^gnatls^}) +the average number of code lines in subprogram bodies, task bodies, entry +bodies and statement sequences in package bodies (this metric is only computed +across the whole set of the analyzed units) -@item -package @code{Gnatstub} for command STUB -(invoking @code{^gnatstub^gnatstub^}) +@end itemize -@item -package @code{Linker} for command LINK (invoking @code{^gnatlink^gnatlink^}) +@noindent +@command{gnatmetric} sums the values of the line metrics for all the +files being processed and then generates the cumulative results. The tool +also computes for all the files being processed the average number of code +lines in bodies. -@item -package @code{Check} for command CHECK -(invoking @code{^gnatcheck^gnatcheck^}) +You can use the following switches to select the specific line metrics +to be computed and reported. -@item -package @code{Metrics} for command METRIC -(invoking @code{^gnatmetric^gnatmetric^}) +@table @option +@cindex @option{^--lines@var{x}^/LINE_COUNT_METRICS^} (@command{gnatmetric}) -@item -package @code{Pretty_Printer} for command PP or PRETTY -(invoking @code{^gnatpp^gnatpp^}) +@ifclear vms +@cindex @option{--no-lines@var{x}} +@end ifclear -@end itemize +@item ^--lines-all^/LINE_COUNT_METRICS=ALL^ +Report all the line metrics -@noindent -Package @code{Gnatls} has a unique attribute @code{^Switches^Switches^}, -a simple variable with a string list value. It contains ^switches^switches^ -for the invocation of @code{^gnatls^gnatls^}. +@item ^--no-lines-all^/LINE_COUNT_METRICS=NONE^ +Do not report any of line metrics -@smallexample @c projectfile -@group -project Proj1 is - package gnatls is - for ^Switches^Switches^ - use ("^-a^-a^", - "^-v^-v^"); - end gnatls; -end Proj1; -@end group -@end smallexample +@item ^--lines^/LINE_COUNT_METRICS=ALL_LINES^ +Report the number of all lines -@noindent -All other packages have two attribute @code{^Switches^Switches^} and -@code{^Default_Switches^Default_Switches^}. +@item ^--no-lines^/LINE_COUNT_METRICS=NOALL_LINES^ +Do not report the number of all lines -@noindent -@code{^Switches^Switches^} is an associative array attribute, indexed by the -source file name, that has a string list value: the ^switches^switches^ to be -used when the tool corresponding to the package is invoked for the specific -source file. +@item ^--lines-code^/LINE_COUNT_METRICS=CODE_LINES^ +Report the number of code lines -@noindent -@code{^Default_Switches^Default_Switches^} is an associative array attribute, -indexed by the programming language that has a string list value. -@code{^Default_Switches^Default_Switches^ ("Ada")} contains the -^switches^switches^ for the invocation of the tool corresponding -to the package, except if a specific @code{^Switches^Switches^} attribute -is specified for the source file. +@item ^--no-lines-code^/LINE_COUNT_METRICS=NOCODE_LINES^ +Do not report the number of code lines -@smallexample @c projectfile -@group -project Proj is +@item ^--lines-comment^/LINE_COUNT_METRICS=COMMENT_LINES^ +Report the number of comment lines - for Source_Dirs use ("./**"); +@item ^--no-lines-comment^/LINE_COUNT_METRICS=NOCOMMENT_LINES^ +Do not report the number of comment lines - package gnatls is - for ^Switches^Switches^ use - ("^-a^-a^", - "^-v^-v^"); - end gnatls; -@end group -@group +@item ^--lines-eol-comment^/LINE_COUNT_METRICS=CODE_COMMENT_LINES^ +Report the number of code lines containing +end-of-line comments - package Compiler is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-gnatv^-gnatv^", - "^-gnatwa^-gnatwa^"); - end Binder; -@end group -@group +@item ^--no-lines-eol-comment^/LINE_COUNT_METRICS=NOCODE_COMMENT_LINES^ +Do not report the number of code lines containing +end-of-line comments - package Binder is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-C^-C^", - "^-e^-e^"); - end Binder; -@end group -@group +@item ^--lines-ratio^/LINE_COUNT_METRICS=COMMENT_PERCENTAGE^ +Report the comment percentage in the program text - package Linker is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-C^-C^"); - for ^Switches^Switches^ ("main.adb") - use ("^-C^-C^", - "^-v^-v^", - "^-v^-v^"); - end Linker; -@end group -@group +@item ^--no-lines-ratio^/LINE_COUNT_METRICS=NOCOMMENT_PERCENTAGE^ +Do not report the comment percentage in the program text - package Finder is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-a^-a^", - "^-f^-f^"); - end Finder; -@end group -@group +@item ^--lines-blank^/LINE_COUNT_METRICS=BLANK_LINES^ +Report the number of blank lines - package Cross_Reference is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-a^-a^", - "^-f^-f^", - "^-d^-d^", - "^-u^-u^"); - end Cross_Reference; -end Proj; -@end group -@end smallexample +@item ^--no-lines-blank^/LINE_COUNT_METRICS=NOBLANK_LINES^ +Do not report the number of blank lines -@noindent -With the above project file, commands such as +@item ^--lines-average^/LINE_COUNT_METRICS=AVERAGE_BODY_LINES^ +Report the average number of code lines in subprogram bodies, task bodies, +entry bodies and statement sequences in package bodies. The metric is computed +and reported for the whole set of processed Ada sources only. -@smallexample - ^gnat comp -Pproj main^GNAT COMP /PROJECT_FILE=PROJ MAIN^ - ^gnat ls -Pproj main^GNAT LIST /PROJECT_FILE=PROJ MAIN^ - ^gnat xref -Pproj main^GNAT XREF /PROJECT_FILE=PROJ MAIN^ - ^gnat bind -Pproj main.ali^GNAT BIND /PROJECT_FILE=PROJ MAIN.ALI^ - ^gnat link -Pproj main.ali^GNAT LINK /PROJECT_FILE=PROJ MAIN.ALI^ -@end smallexample +@item ^--no-lines-average^/LINE_COUNT_METRICS=NOAVERAGE_BODY_LINES^ +Do not report the average number of code lines in subprogram bodies, +task bodies, entry bodies and statement sequences in package bodies. -@noindent -will set up the environment properly and invoke the tool with the switches -found in the package corresponding to the tool: -@code{^Default_Switches^Default_Switches^ ("Ada")} for all tools, -except @code{^Switches^Switches^ ("main.adb")} -for @code{^gnatlink^gnatlink^}. -It is also possible to invoke some of the tools, -@code{^gnatcheck^gnatcheck^}), -@code{^gnatmetric^gnatmetric^}), -and @code{^gnatpp^gnatpp^}) -on a set of project units thanks to the combination of the switches -@option{-P}, @option{-U} and possibly the main unit when one is interested -in its closure. For instance, -@smallexample -gnat metric -Pproj -@end smallexample -will compute the metrics for all the immediate units of project -@code{proj}. -@smallexample -gnat metric -Pproj -U -@end smallexample -will compute the metrics for all the units of the closure of projects -rooted at @code{proj}. -@smallexample -gnat metric -Pproj -U main_unit -@end smallexample -will compute the metrics for the closure of units rooted at -@code{main_unit}. This last possibility relies implicitly -on @command{gnatbind}'s option @option{-R}. +@end table -@c ********************** -@node An Extended Example -@section An Extended Example +@node Syntax Metrics Control +@subsubsection Syntax Metrics Control +@cindex Syntax metrics control in @command{gnatmetric} @noindent -Suppose that we have two programs, @var{prog1} and @var{prog2}, -whose sources are in corresponding directories. We would like -to build them with a single @command{gnatmake} command, and we want to place -their object files into @file{build} subdirectories of the source directories. -Furthermore, we want to have to have two separate subdirectories -in @file{build} -- @file{release} and @file{debug} -- which will contain -the object files compiled with different set of compilation flags. +@command{gnatmetric} computes various syntactic metrics for the +outermost unit and for each eligible local unit: -In other words, we have the following structure: +@table @emph +@item LSLOC (``Logical Source Lines Of Code'') +The total number of declarations and the total number of statements -@smallexample -@group - main - |- prog1 - | |- build - | | debug - | | release - |- prog2 - |- build - | debug - | release -@end group -@end smallexample +@item Maximal static nesting level of inner program units +According to +@cite{Ada Reference Manual}, 10.1(1), ``A program unit is either a +package, a task unit, a protected unit, a +protected entry, a generic unit, or an explicitly declared subprogram other +than an enumeration literal.'' + +@item Maximal nesting level of composite syntactic constructs +This corresponds to the notion of the +maximum nesting level in the GNAT built-in style checks +(@pxref{Style Checking}) +@end table @noindent -Here are the project files that we must place in a directory @file{main} -to maintain this structure: +For the outermost unit in the file, @command{gnatmetric} additionally computes +the following metrics: -@enumerate +@table @emph +@item Public subprograms +This metric is computed for package specs. It is the +number of subprograms and generic subprograms declared in the visible +part (including the visible part of nested packages, protected objects, and +protected types). -@item We create a @code{Common} project with a package @code{Compiler} that -specifies the compilation ^switches^switches^: +@item All subprograms +This metric is computed for bodies and subunits. The +metric is equal to a total number of subprogram bodies in the compilation +unit. +Neither generic instantiations nor renamings-as-a-body nor body stubs +are counted. Any subprogram body is counted, independently of its nesting +level and enclosing constructs. Generic bodies and bodies of protected +subprograms are counted in the same way as ``usual'' subprogram bodies. -@smallexample -File "common.gpr": -@group -@b{project} Common @b{is} +@item Public types +This metric is computed for package specs and +generic package declarations. It is the total number of types +that can be referenced from outside this compilation unit, plus the +number of types from all the visible parts of all the visible generic +packages. Generic formal types are not counted. Only types, not subtypes, +are included. - @b{for} Source_Dirs @b{use} (); -- No source files -@end group +@noindent +Along with the total number of public types, the following +types are counted and reported separately: -@group - @b{type} Build_Type @b{is} ("release", "debug"); - Build : Build_Type := External ("BUILD", "debug"); -@end group -@group - @b{package} Compiler @b{is} - @b{case} Build @b{is} - @b{when} "release" => - @b{for} ^Default_Switches^Default_Switches^ ("Ada") - @b{use} ("^-O2^-O2^"); - @b{when} "debug" => - @b{for} ^Default_Switches^Default_Switches^ ("Ada") - @b{use} ("^-g^-g^"); - @b{end case}; - @b{end} Compiler; - -@b{end} Common; -@end group -@end smallexample +@itemize @bullet +@item +Abstract types -@item We create separate projects for the two programs: +@item +Root tagged types (abstract, non-abstract, private, non-private). Type +extensions are @emph{not} counted -@smallexample -@group -File "prog1.gpr": +@item +Private types (including private extensions) -@b{with} "common"; -@b{project} Prog1 @b{is} +@item +Task types - @b{for} Source_Dirs @b{use} ("prog1"); - @b{for} Object_Dir @b{use} "prog1/build/" & Common.Build; +@item +Protected types - @b{package} Compiler @b{renames} Common.Compiler; +@end itemize -@b{end} Prog1; -@end group -@end smallexample +@item All types +This metric is computed for any compilation unit. It is equal to the total +number of the declarations of different types given in the compilation unit. +The private and the corresponding full type declaration are counted as one +type declaration. Incomplete type declarations and generic formal types +are not counted. +No distinction is made among different kinds of types (abstract, +private etc.); the total number of types is computed and reported. -@smallexample -@group -File "prog2.gpr": +@end table -@b{with} "common"; -@b{project} Prog2 @b{is} +@noindent +By default, all the syntax metrics are computed and reported. You can use the +following switches to select specific syntax metrics. - @b{for} Source_Dirs @b{use} ("prog2"); - @b{for} Object_Dir @b{use} "prog2/build/" & Common.Build; +@table @option - @b{package} Compiler @b{renames} Common.Compiler; +@cindex @option{^--syntax@var{x}^/SYNTAX_METRICS^} (@command{gnatmetric}) -@end group -@b{end} Prog2; -@end smallexample +@ifclear vms +@cindex @option{--no-syntax@var{x}} (@command{gnatmetric}) +@end ifclear -@item We create a wrapping project @code{Main}: +@item ^--syntax-all^/SYNTAX_METRICS=ALL^ +Report all the syntax metrics -@smallexample -@group -File "main.gpr": +@item ^--no-syntax-all^/SYNTAX_METRICS=NONE^ +Do not report any of syntax metrics -@b{with} "common"; -@b{with} "prog1"; -@b{with} "prog2"; -@b{project} Main @b{is} +@item ^--declarations^/SYNTAX_METRICS=DECLARATIONS^ +Report the total number of declarations - @b{package} Compiler @b{renames} Common.Compiler; +@item ^--no-declarations^/SYNTAX_METRICS=NODECLARATIONS^ +Do not report the total number of declarations -@b{end} Main; -@end group -@end smallexample +@item ^--statements^/SYNTAX_METRICS=STATEMENTS^ +Report the total number of statements -@item Finally we need to create a dummy procedure that @code{with}s (either -explicitly or implicitly) all the sources of our two programs. +@item ^--no-statements^/SYNTAX_METRICS=NOSTATEMENTS^ +Do not report the total number of statements -@end enumerate +@item ^--public-subprograms^/SYNTAX_METRICS=PUBLIC_SUBPROGRAMS^ +Report the number of public subprograms in a compilation unit -@noindent -Now we can build the programs using the command +@item ^--no-public-subprograms^/SYNTAX_METRICS=NOPUBLIC_SUBPROGRAMS^ +Do not report the number of public subprograms in a compilation unit -@smallexample - gnatmake ^-P^/PROJECT_FILE=^main dummy -@end smallexample +@item ^--all-subprograms^/SYNTAX_METRICS=ALL_SUBPROGRAMS^ +Report the number of all the subprograms in a compilation unit -@noindent -for the Debug mode, or +@item ^--no-all-subprograms^/SYNTAX_METRICS=NOALL_SUBPROGRAMS^ +Do not report the number of all the subprograms in a compilation unit -@ifclear vms -@smallexample - gnatmake -Pmain -XBUILD=release -@end smallexample -@end ifclear +@item ^--public-types^/SYNTAX_METRICS=PUBLIC_TYPES^ +Report the number of public types in a compilation unit -@ifset vms -@smallexample - GNAT MAKE /PROJECT_FILE=main /EXTERNAL_REFERENCE=BUILD=release -@end smallexample -@end ifset +@item ^--no-public-types^/SYNTAX_METRICS=NOPUBLIC_TYPES^ +Do not report the number of public types in a compilation unit -@noindent -for the Release mode. +@item ^--all-types^/SYNTAX_METRICS=ALL_TYPES^ +Report the number of all the types in a compilation unit -@c ******************************** -@c * Project File Complete Syntax * -@c ******************************** +@item ^--no-all-types^/SYNTAX_METRICS=NOALL_TYPES^ +Do not report the number of all the types in a compilation unit -@node Project File Complete Syntax -@section Project File Complete Syntax +@item ^--unit-nesting^/SYNTAX_METRICS=UNIT_NESTING^ +Report the maximal program unit nesting level -@smallexample -project ::= - context_clause project_declaration +@item ^--no-unit-nesting^/SYNTAX_METRICS=UNIT_NESTING_OFF^ +Do not report the maximal program unit nesting level -context_clause ::= - @{with_clause@} +@item ^--construct-nesting^/SYNTAX_METRICS=CONSTRUCT_NESTING^ +Report the maximal construct nesting level -with_clause ::= - @b{with} path_name @{ , path_name @} ; +@item ^--no-construct-nesting^/SYNTAX_METRICS=NOCONSTRUCT_NESTING^ +Do not report the maximal construct nesting level -path_name ::= - string_literal +@end table -project_declaration ::= - simple_project_declaration | project_extension +@node Complexity Metrics Control +@subsubsection Complexity Metrics Control +@cindex Complexity metrics control in @command{gnatmetric} -simple_project_declaration ::= - @b{project} simple_name @b{is} - @{declarative_item@} - @b{end} simple_name; +@noindent +For a program unit that is an executable body (a subprogram body (including +generic bodies), task body, entry body or a package body containing +its own statement sequence) @command{gnatmetric} computes the following +complexity metrics: -project_extension ::= - @b{project} simple_name @b{extends} path_name @b{is} - @{declarative_item@} - @b{end} simple_name; +@itemize @bullet +@item +McCabe cyclomatic complexity; -declarative_item ::= - package_declaration | - typed_string_declaration | - other_declarative_item +@item +McCabe essential complexity; -package_declaration ::= - package_spec | package_renaming +@item +maximal loop nesting level -package_spec ::= - @b{package} package_identifier @b{is} - @{simple_declarative_item@} - @b{end} package_identifier ; +@end itemize -package_identifier ::= - @code{Naming} | @code{Builder} | @code{Compiler} | @code{Binder} | - @code{Linker} | @code{Finder} | @code{Cross_Reference} | - @code{^gnatls^gnatls^} | @code{IDE} | @code{Pretty_Printer} +@noindent +The McCabe complexity metrics are defined +in @url{http://www.mccabe.com/pdf/nist235r.pdf} -package_renaming ::== - @b{package} package_identifier @b{renames} - simple_name.package_identifier ; +According to McCabe, both control statements and short-circuit control forms +should be taken into account when computing cyclomatic complexity. For each +body, we compute three metric values: -typed_string_declaration ::= - @b{type} _simple_name @b{is} - ( string_literal @{, string_literal@} ); +@itemize @bullet +@item +the complexity introduced by control +statements only, without taking into account short-circuit forms, -other_declarative_item ::= - attribute_declaration | - typed_variable_declaration | - variable_declaration | - case_construction +@item +the complexity introduced by short-circuit control forms only, and -attribute_declaration ::= - full_associative_array_declaration | - @b{for} attribute_designator @b{use} expression ; +@item +the total +cyclomatic complexity, which is the sum of these two values. +@end itemize -full_associative_array_declaration ::= - @b{for} simple_name @b{use} - simple_name [ . simple_Name ] ' simple_name ; +@noindent +When computing cyclomatic and essential complexity, @command{gnatmetric} skips +the code in the exception handlers and in all the nested program units. -attribute_designator ::= - simple_name | - simple_name ( string_literal ) +By default, all the complexity metrics are computed and reported. +For more fine-grained control you can use +the following switches: -typed_variable_declaration ::= - simple_name : name := string_expression ; +@table @option +@cindex @option{^-complexity@var{x}^/COMPLEXITY_METRICS^} (@command{gnatmetric}) -variable_declaration ::= - simple_name := expression; +@ifclear vms +@cindex @option{--no-complexity@var{x}} +@end ifclear -expression ::= - term @{& term@} +@item ^--complexity-all^/COMPLEXITY_METRICS=ALL^ +Report all the complexity metrics -term ::= - literal_string | - string_list | - name | - external_value | - attribute_reference +@item ^--no-complexity-all^/COMPLEXITY_METRICS=NONE^ +Do not report any of complexity metrics -string_literal ::= - (same as Ada) +@item ^--complexity-cyclomatic^/COMPLEXITY_METRICS=CYCLOMATIC^ +Report the McCabe Cyclomatic Complexity -string_list ::= - ( expression @{ , expression @} ) +@item ^--no-complexity-cyclomatic^/COMPLEXITY_METRICS=NOCYCLOMATIC^ +Do not report the McCabe Cyclomatic Complexity -external_value ::= - @b{external} ( string_literal [, string_literal] ) +@item ^--complexity-essential^/COMPLEXITY_METRICS=ESSENTIAL^ +Report the Essential Complexity -attribute_reference ::= - attribute_prefix ' simple_name [ ( literal_string ) ] +@item ^--no-complexity-essential^/COMPLEXITY_METRICS=NOESSENTIAL^ +Do not report the Essential Complexity -attribute_prefix ::= - @b{project} | - simple_name | package_identifier | - simple_name . package_identifier +@item ^--loop-nesting^/COMPLEXITY_METRICS=LOOP_NESTING_ON^ +Report maximal loop nesting level -case_construction ::= - @b{case} name @b{is} - @{case_item@} - @b{end case} ; +@item ^--no-loop-nesting^/COMPLEXITY_METRICS=NOLOOP_NESTING^ +Do not report maximal loop nesting level -case_item ::= - @b{when} discrete_choice_list => - @{case_construction | attribute_declaration@} +@item ^--complexity-average^/COMPLEXITY_METRICS=AVERAGE_COMPLEXITY^ +Report the average McCabe Cyclomatic Complexity for all the subprogram bodies, +task bodies, entry bodies and statement sequences in package bodies. +The metric is computed and reported for whole set of processed Ada sources +only. -discrete_choice_list ::= - string_literal @{| string_literal@} | - @b{others} +@item ^--no-complexity-average^/COMPLEXITY_METRICS=NOAVERAGE_COMPLEXITY^ +Do not report the average McCabe Cyclomatic Complexity for all the subprogram +bodies, task bodies, entry bodies and statement sequences in package bodies -name ::= - simple_name @{. simple_name@} +@cindex @option{^-ne^/NO_EXITS_AS_GOTOS^} (@command{gnatmetric}) +@item ^-ne^/NO_EXITS_AS_GOTOS^ +Do not consider @code{exit} statements as @code{goto}s when +computing Essential Complexity -simple_name ::= - identifier (same as Ada) +@item ^--extra-exit-points^/EXTRA_EXIT_POINTS^ +Report the extra exit points for subprogram bodies. As an exit point, this +metric counts @code{return} statements and raise statements in case when the +raised exception is not handled in the same body. In case of a function this +metric subtracts 1 from the number of exit points, because a function body +must contain at least one @code{return} statement. -@end smallexample +@item ^--no-extra-exit-points^/NOEXTRA_EXIT_POINTS^ +Do not report the extra exit points for subprogram bodies +@end table -@node The Cross-Referencing Tools gnatxref and gnatfind -@chapter The Cross-Referencing Tools @code{gnatxref} and @code{gnatfind} -@findex gnatxref -@findex gnatfind + +@node Object-Oriented Metrics Control +@subsubsection Object-Oriented Metrics Control +@cindex Object-Oriented metrics control in @command{gnatmetric} @noindent -The compiler generates cross-referencing information (unless -you set the @samp{-gnatx} switch), which are saved in the @file{.ali} files. -This information indicates where in the source each entity is declared and -referenced. Note that entities in package Standard are not included, but -entities in all other predefined units are included in the output. +@cindex Coupling metrics (in in @command{gnatmetric}) +Coupling metrics are object-oriented metrics that measure the +dependencies between a given class (or a group of classes) and the +``external world'' (that is, the other classes in the program). In this +subsection the term ``class'' is used in its +traditional object-oriented programming sense +(an instantiable module that contains data and/or method members). +A @emph{category} (of classes) +is a group of closely related classes that are reused and/or +modified together. -Before using any of these two tools, you need to compile successfully your -application, so that GNAT gets a chance to generate the cross-referencing -information. +A class @code{K}'s @emph{efferent coupling} is the number of classes +that @code{K} depends upon. +A category's efferent coupling is the number of classes outside the +category that the classes inside the category depend upon. -The two tools @code{gnatxref} and @code{gnatfind} take advantage of this -information to provide the user with the capability to easily locate the -declaration and references to an entity. These tools are quite similar, -the difference being that @code{gnatfind} is intended for locating -definitions and/or references to a specified entity or entities, whereas -@code{gnatxref} is oriented to generating a full report of all -cross-references. +A class @code{K}'s @emph{afferent coupling} is the number of classes +that depend upon @code{K}. +A category's afferent coupling is the number of classes outside the +category that depend on classes belonging to the category. -To use these tools, you must not compile your application using the -@option{-gnatx} switch on the @command{gnatmake} command line -(@pxref{The GNAT Make Program gnatmake}). Otherwise, cross-referencing -information will not be generated. +Ada's implementation of the object-oriented paradigm does not use the +traditional class notion, so the definition of the coupling +metrics for Ada maps the class and class category notions +onto Ada constructs. -Note: to invoke @code{gnatxref} or @code{gnatfind} with a project file, -use the @code{gnat} driver (see @ref{The GNAT Driver and Project Files}). +For the coupling metrics, several kinds of modules -- a library package, +a library generic package, and a library generic package instantiation -- +that define a tagged type or an interface type are +considered to be a class. A category consists of a library package (or +a library generic package) that defines a tagged or an interface type, +together with all its descendant (generic) packages that define tagged +or interface types. For any package counted as a class, +its body and subunits (if any) are considered +together with its spec when counting the dependencies, and coupling +metrics are reported for spec units only. For dependencies +between classes, the Ada semantic dependencies are considered. +For coupling metrics, only dependencies on units that are considered as +classes, are considered. -@menu -* Switches for gnatxref:: -* Switches for gnatfind:: -* Project Files for gnatxref and gnatfind:: -* Regular Expressions in gnatfind and gnatxref:: -* Examples of gnatxref Usage:: -* Examples of gnatfind Usage:: -@end menu +When computing coupling metrics, @command{gnatmetric} counts only +dependencies between units that are arguments of the gnatmetric call. +Coupling metrics are program-wide (or project-wide) metrics, so to +get a valid result, you should call @command{gnatmetric} for +the whole set of sources that make up your program. It can be done +by calling @command{gnatmetric} from the GNAT driver with @option{-U} +option (see See @ref{The GNAT Driver and Project Files} for details. -@node Switches for gnatxref -@section @code{gnatxref} Switches +By default, all the coupling metrics are disabled. You can use the following +switches to specify the coupling metrics to be computed and reported: -@noindent -The command invocation for @code{gnatxref} is: -@smallexample -$ gnatxref @ovar{switches} @var{sourcefile1} @r{[}@var{sourcefile2} @dots{}@r{]} -@end smallexample +@table @option -@noindent -where +@ifclear vms +@cindex @option{--package@var{x}} (@command{gnatmetric}) +@cindex @option{--no-package@var{x}} (@command{gnatmetric}) +@cindex @option{--category@var{x}} (@command{gnatmetric}) +@cindex @option{--no-category@var{x}} (@command{gnatmetric}) +@end ifclear -@table @var -@item sourcefile1 -@itemx sourcefile2 -identifies the source files for which a report is to be generated. The -``with''ed units will be processed too. You must provide at least one file. +@ifset vms +@cindex @option{/COUPLING_METRICS} (@command{gnatmetric}) +@end ifset -These file names are considered to be regular expressions, so for instance -specifying @file{source*.adb} is the same as giving every file in the current -directory whose name starts with @file{source} and whose extension is -@file{adb}. +@item ^--coupling-all^/COUPLING_METRICS=ALL^ +Report all the coupling metrics -You shouldn't specify any directory name, just base names. @command{gnatxref} -and @command{gnatfind} will be able to locate these files by themselves using -the source path. If you specify directories, no result is produced. +@item ^--no-coupling-all^/COUPLING_METRICS=NONE^ +Do not report any of metrics -@end table +@item ^--package-efferent-coupling^/COUPLING_METRICS=PACKAGE_EFFERENT^ +Report package efferent coupling -@noindent -The switches can be: -@table @option -@c !sort! -@item --version -@cindex @option{--version} @command{gnatxref} -Display Copyright and version, then exit disregarding all other options. +@item ^--no-package-efferent-coupling^/COUPLING_METRICS=NOPACKAGE_EFFERENT^ +Do not report package efferent coupling -@item --help -@cindex @option{--help} @command{gnatxref} -If @option{--version} was not used, display usage, then exit disregarding -all other options. - -@item ^-a^/ALL_FILES^ -@cindex @option{^-a^/ALL_FILES^} (@command{gnatxref}) -If this switch is present, @code{gnatfind} and @code{gnatxref} will parse -the read-only files found in the library search path. Otherwise, these files -will be ignored. This option can be used to protect Gnat sources or your own -libraries from being parsed, thus making @code{gnatfind} and @code{gnatxref} -much faster, and their output much smaller. Read-only here refers to access -or permissions status in the file system for the current user. - -@item -aIDIR -@cindex @option{-aIDIR} (@command{gnatxref}) -When looking for source files also look in directory DIR. The order in which -source file search is undertaken is the same as for @command{gnatmake}. - -@item -aODIR -@cindex @option{-aODIR} (@command{gnatxref}) -When searching for library and object files, look in directory -DIR. The order in which library files are searched is the same as for -@command{gnatmake}. +@item ^--package-afferent-coupling^/COUPLING_METRICS=PACKAGE_AFFERENT^ +Report package afferent coupling -@item -nostdinc -@cindex @option{-nostdinc} (@command{gnatxref}) -Do not look for sources in the system default directory. +@item ^--no-package-afferent-coupling^/COUPLING_METRICS=NOPACKAGE_AFFERENT^ +Do not report package afferent coupling -@item -nostdlib -@cindex @option{-nostdlib} (@command{gnatxref}) -Do not look for library files in the system default directory. +@item ^--category-efferent-coupling^/COUPLING_METRICS=CATEGORY_EFFERENT^ +Report category efferent coupling -@item --RTS=@var{rts-path} -@cindex @option{--RTS} (@command{gnatxref}) -Specifies the default location of the runtime library. Same meaning as the -equivalent @command{gnatmake} flag (@pxref{Switches for gnatmake}). +@item ^--no-category-efferent-coupling^/COUPLING_METRICS=NOCATEGORY_EFFERENT^ +Do not report category efferent coupling -@item ^-d^/DERIVED_TYPES^ -@cindex @option{^-d^/DERIVED_TYPES^} (@command{gnatxref}) -If this switch is set @code{gnatxref} will output the parent type -reference for each matching derived types. +@item ^--category-afferent-coupling^/COUPLING_METRICS=CATEGORY_AFFERENT^ +Report category afferent coupling -@item ^-f^/FULL_PATHNAME^ -@cindex @option{^-f^/FULL_PATHNAME^} (@command{gnatxref}) -If this switch is set, the output file names will be preceded by their -directory (if the file was found in the search path). If this switch is -not set, the directory will not be printed. +@item ^--no-category-afferent-coupling^/COUPLING_METRICS=NOCATEGORY_AFFERENT^ +Do not report category afferent coupling -@item ^-g^/IGNORE_LOCALS^ -@cindex @option{^-g^/IGNORE_LOCALS^} (@command{gnatxref}) -If this switch is set, information is output only for library-level -entities, ignoring local entities. The use of this switch may accelerate -@code{gnatfind} and @code{gnatxref}. +@end table -@item -IDIR -@cindex @option{-IDIR} (@command{gnatxref}) -Equivalent to @samp{-aODIR -aIDIR}. +@node Other gnatmetric Switches +@subsection Other @code{gnatmetric} Switches -@item -pFILE -@cindex @option{-pFILE} (@command{gnatxref}) -Specify a project file to use @xref{Project Files}. -If you need to use the @file{.gpr} -project files, you should use gnatxref through the GNAT driver -(@command{gnat xref -Pproject}). +@noindent +Additional @command{gnatmetric} switches are as follows: -By default, @code{gnatxref} and @code{gnatfind} will try to locate a -project file in the current directory. +@table @option +@item ^-files @var{filename}^/FILES=@var{filename}^ +@cindex @option{^-files^/FILES^} (@code{gnatmetric}) +Take the argument source files from the specified file. This file should be an +ordinary text file containing file names separated by spaces or +line breaks. You can use this switch more than once in the same call to +@command{gnatmetric}. You also can combine this switch with +an explicit list of files. -If a project file is either specified or found by the tools, then the content -of the source directory and object directory lines are added as if they -had been specified respectively by @samp{^-aI^/SOURCE_SEARCH^} -and @samp{^-aO^OBJECT_SEARCH^}. -@item ^-u^/UNUSED^ -Output only unused symbols. This may be really useful if you give your -main compilation unit on the command line, as @code{gnatxref} will then -display every unused entity and 'with'ed package. +@item ^-v^/VERBOSE^ +@cindex @option{^-v^/VERBOSE^} (@code{gnatmetric}) +Verbose mode; +@command{gnatmetric} generates version information and then +a trace of sources being processed. -@ifclear vms -@item -v -Instead of producing the default output, @code{gnatxref} will generate a -@file{tags} file that can be used by vi. For examples how to use this -feature, see @ref{Examples of gnatxref Usage}. The tags file is output -to the standard output, thus you will have to redirect it to a file. -@end ifclear +@item ^-dv^/DEBUG_OUTPUT^ +@cindex @option{^-dv^/DEBUG_OUTPUT^} (@code{gnatmetric}) +Debug mode; +@command{gnatmetric} generates various messages useful to understand what +happens during the metrics computation +@item ^-q^/QUIET^ +@cindex @option{^-q^/QUIET^} (@code{gnatmetric}) +Quiet mode. @end table -@noindent -All these switches may be in any order on the command line, and may even -appear after the file names. They need not be separated by spaces, thus -you can say @samp{gnatxref ^-ag^/ALL_FILES/IGNORE_LOCALS^} instead of -@samp{gnatxref ^-a -g^/ALL_FILES /IGNORE_LOCALS^}. +@node Generate project-wide metrics +@subsection Generate project-wide metrics -@node Switches for gnatfind -@section @code{gnatfind} Switches +In order to compute metrics on all units of a given project, you can use +the @command{gnat} driver along with the @option{-P} option: +@smallexample + gnat metric -Pproj +@end smallexample @noindent -The command line for @code{gnatfind} is: - +If the project @code{proj} depends upon other projects, you can compute +the metrics on the project closure using the @option{-U} option: @smallexample -$ gnatfind @ovar{switches} @var{pattern}@r{[}:@var{sourcefile}@r{[}:@var{line}@r{[}:@var{column}@r{]]]} - @r{[}@var{file1} @var{file2} @dots{}] + gnat metric -Pproj -U @end smallexample @noindent -where +Finally, if not all the units are relevant to a particular main +program in the project closure, you can generate metrics for the set +of units needed to create a given main program (unit closure) using +the @option{-U} option followed by the name of the main unit: +@smallexample + gnat metric -Pproj -U main +@end smallexample -@table @var -@item pattern -An entity will be output only if it matches the regular expression found -in @var{pattern}, see @ref{Regular Expressions in gnatfind and gnatxref}. -Omitting the pattern is equivalent to specifying @samp{*}, which -will match any entity. Note that if you do not provide a pattern, you -have to provide both a sourcefile and a line. +@c *********************************** +@node File Name Krunching Using gnatkr +@chapter File Name Krunching Using @code{gnatkr} +@findex gnatkr -Entity names are given in Latin-1, with uppercase/lowercase equivalence -for matching purposes. At the current time there is no support for -8-bit codes other than Latin-1, or for wide characters in identifiers. +@noindent +This chapter discusses the method used by the compiler to shorten +the default file names chosen for Ada units so that they do not +exceed the maximum length permitted. It also describes the +@code{gnatkr} utility that can be used to determine the result of +applying this shortening. +@menu +* About gnatkr:: +* Using gnatkr:: +* Krunching Method:: +* Examples of gnatkr Usage:: +@end menu -@item sourcefile -@code{gnatfind} will look for references, bodies or declarations -of symbols referenced in @file{@var{sourcefile}}, at line @var{line} -and column @var{column}. See @ref{Examples of gnatfind Usage} -for syntax examples. +@node About gnatkr +@section About @code{gnatkr} -@item line -is a decimal integer identifying the line number containing -the reference to the entity (or entities) to be located. +@noindent +The default file naming rule in GNAT +is that the file name must be derived from +the unit name. The exact default rule is as follows: +@itemize @bullet +@item +Take the unit name and replace all dots by hyphens. +@item +If such a replacement occurs in the +second character position of a name, and the first character is +^@samp{a}, @samp{g}, @samp{s}, or @samp{i}, ^@samp{A}, @samp{G}, @samp{S}, or @samp{I},^ +then replace the dot by the character +^@samp{~} (tilde)^@samp{$} (dollar sign)^ +instead of a minus. +@end itemize +The reason for this exception is to avoid clashes +with the standard names for children of System, Ada, Interfaces, +and GNAT, which use the prefixes +^@samp{s-}, @samp{a-}, @samp{i-}, and @samp{g-},^@samp{S-}, @samp{A-}, @samp{I-}, and @samp{G-},^ +respectively. -@item column -is a decimal integer identifying the exact location on the -line of the first character of the identifier for the -entity reference. Columns are numbered from 1. +The @option{^-gnatk^/FILE_NAME_MAX_LENGTH=^@var{nn}} +switch of the compiler activates a ``krunching'' +circuit that limits file names to nn characters (where nn is a decimal +integer). For example, using OpenVMS, +where the maximum file name length is +39, the value of nn is usually set to 39, but if you want to generate +a set of files that would be usable if ported to a system with some +different maximum file length, then a different value can be specified. +The default value of 39 for OpenVMS need not be specified. -@item file1 file2 @dots{} -The search will be restricted to these source files. If none are given, then -the search will be done for every library file in the search path. -These file must appear only after the pattern or sourcefile. +The @code{gnatkr} utility can be used to determine the krunched name for +a given file, when krunched to a specified maximum length. -These file names are considered to be regular expressions, so for instance -specifying @file{source*.adb} is the same as giving every file in the current -directory whose name starts with @file{source} and whose extension is -@file{adb}. +@node Using gnatkr +@section Using @code{gnatkr} -The location of the spec of the entity will always be displayed, even if it -isn't in one of @file{@var{file1}}, @file{@var{file2}},@enddots{} The -occurrences of the entity in the separate units of the ones given on the -command line will also be displayed. +@noindent +The @code{gnatkr} command has the form -Note that if you specify at least one file in this part, @code{gnatfind} may -sometimes not be able to find the body of the subprograms. +@ifclear vms +@smallexample +@c $ gnatkr @var{name} @ovar{length} +@c Expanding @ovar macro inline (explanation in macro def comments) +$ gnatkr @var{name} @r{[}@var{length}@r{]} +@end smallexample +@end ifclear -@end table +@ifset vms +@smallexample +$ gnatkr @var{name} /COUNT=nn +@end smallexample +@end ifset @noindent -At least one of 'sourcefile' or 'pattern' has to be present on -the command line. - -The following switches are available: -@table @option -@c !sort! +@var{name} is the uncrunched file name, derived from the name of the unit +in the standard manner described in the previous section (i.e., in particular +all dots are replaced by hyphens). The file name may or may not have an +extension (defined as a suffix of the form period followed by arbitrary +characters other than period). If an extension is present then it will +be preserved in the output. For example, when krunching @file{hellofile.ads} +to eight characters, the result will be hellofil.ads. -@cindex @option{--version} @command{gnatfind} -Display Copyright and version, then exit disregarding all other options. +Note: for compatibility with previous versions of @code{gnatkr} dots may +appear in the name instead of hyphens, but the last dot will always be +taken as the start of an extension. So if @code{gnatkr} is given an argument +such as @file{Hello.World.adb} it will be treated exactly as if the first +period had been a hyphen, and for example krunching to eight characters +gives the result @file{hellworl.adb}. -@item --help -@cindex @option{--help} @command{gnatfind} -If @option{--version} was not used, display usage, then exit disregarding -all other options. - -@item ^-a^/ALL_FILES^ -@cindex @option{^-a^/ALL_FILES^} (@command{gnatfind}) -If this switch is present, @code{gnatfind} and @code{gnatxref} will parse -the read-only files found in the library search path. Otherwise, these files -will be ignored. This option can be used to protect Gnat sources or your own -libraries from being parsed, thus making @code{gnatfind} and @code{gnatxref} -much faster, and their output much smaller. Read-only here refers to access -or permission status in the file system for the current user. - -@item -aIDIR -@cindex @option{-aIDIR} (@command{gnatfind}) -When looking for source files also look in directory DIR. The order in which -source file search is undertaken is the same as for @command{gnatmake}. - -@item -aODIR -@cindex @option{-aODIR} (@command{gnatfind}) -When searching for library and object files, look in directory -DIR. The order in which library files are searched is the same as for -@command{gnatmake}. - -@item -nostdinc -@cindex @option{-nostdinc} (@command{gnatfind}) -Do not look for sources in the system default directory. - -@item -nostdlib -@cindex @option{-nostdlib} (@command{gnatfind}) -Do not look for library files in the system default directory. - -@item --ext=@var{extension} -@cindex @option{--ext} (@command{gnatfind}) -Specify an alternate ali file extension. The default is @code{ali} and other -extensions (e.g. @code{sli} for SPARK library files) may be specified via this -switch. Note that if this switch overrides the default, which means that only -the new extension will be considered. - -@item --RTS=@var{rts-path} -@cindex @option{--RTS} (@command{gnatfind}) -Specifies the default location of the runtime library. Same meaning as the -equivalent @command{gnatmake} flag (@pxref{Switches for gnatmake}). - -@item ^-d^/DERIVED_TYPE_INFORMATION^ -@cindex @option{^-d^/DERIVED_TYPE_INFORMATION^} (@code{gnatfind}) -If this switch is set, then @code{gnatfind} will output the parent type -reference for each matching derived types. - -@item ^-e^/EXPRESSIONS^ -@cindex @option{^-e^/EXPRESSIONS^} (@command{gnatfind}) -By default, @code{gnatfind} accept the simple regular expression set for -@samp{pattern}. If this switch is set, then the pattern will be -considered as full Unix-style regular expression. - -@item ^-f^/FULL_PATHNAME^ -@cindex @option{^-f^/FULL_PATHNAME^} (@command{gnatfind}) -If this switch is set, the output file names will be preceded by their -directory (if the file was found in the search path). If this switch is -not set, the directory will not be printed. - -@item ^-g^/IGNORE_LOCALS^ -@cindex @option{^-g^/IGNORE_LOCALS^} (@command{gnatfind}) -If this switch is set, information is output only for library-level -entities, ignoring local entities. The use of this switch may accelerate -@code{gnatfind} and @code{gnatxref}. - -@item -IDIR -@cindex @option{-IDIR} (@command{gnatfind}) -Equivalent to @samp{-aODIR -aIDIR}. - -@item -pFILE -@cindex @option{-pFILE} (@command{gnatfind}) -Specify a project file (@pxref{Project Files}) to use. -By default, @code{gnatxref} and @code{gnatfind} will try to locate a -project file in the current directory. - -If a project file is either specified or found by the tools, then the content -of the source directory and object directory lines are added as if they -had been specified respectively by @samp{^-aI^/SOURCE_SEARCH^} and -@samp{^-aO^/OBJECT_SEARCH^}. - -@item ^-r^/REFERENCES^ -@cindex @option{^-r^/REFERENCES^} (@command{gnatfind}) -By default, @code{gnatfind} will output only the information about the -declaration, body or type completion of the entities. If this switch is -set, the @code{gnatfind} will locate every reference to the entities in -the files specified on the command line (or in every file in the search -path if no file is given on the command line). - -@item ^-s^/PRINT_LINES^ -@cindex @option{^-s^/PRINT_LINES^} (@command{gnatfind}) -If this switch is set, then @code{gnatfind} will output the content -of the Ada source file lines were the entity was found. - -@item ^-t^/TYPE_HIERARCHY^ -@cindex @option{^-t^/TYPE_HIERARCHY^} (@command{gnatfind}) -If this switch is set, then @code{gnatfind} will output the type hierarchy for -the specified type. It act like -d option but recursively from parent -type to parent type. When this switch is set it is not possible to -specify more than one file. - -@end table - -@noindent -All these switches may be in any order on the command line, and may even -appear after the file names. They need not be separated by spaces, thus -you can say @samp{gnatxref ^-ag^/ALL_FILES/IGNORE_LOCALS^} instead of -@samp{gnatxref ^-a -g^/ALL_FILES /IGNORE_LOCALS^}. - -As stated previously, gnatfind will search in every directory in the -search path. You can force it to look only in the current directory if -you specify @code{*} at the end of the command line. - -@node Project Files for gnatxref and gnatfind -@section Project Files for @command{gnatxref} and @command{gnatfind} - -@noindent -Project files allow a programmer to specify how to compile its -application, where to find sources, etc. These files are used -@ifclear vms -primarily by GPS, but they can also be used -@end ifclear -by the two tools -@code{gnatxref} and @code{gnatfind}. - -A project file name must end with @file{.gpr}. If a single one is -present in the current directory, then @code{gnatxref} and @code{gnatfind} will -extract the information from it. If multiple project files are found, none of -them is read, and you have to use the @samp{-p} switch to specify the one -you want to use. - -The following lines can be included, even though most of them have default -values which can be used in most cases. -The lines can be entered in any order in the file. -Except for @file{src_dir} and @file{obj_dir}, you can only have one instance of -each line. If you have multiple instances, only the last one is taken into -account. - -@table @code -@item src_dir=DIR -[default: @code{"^./^[]^"}] -specifies a directory where to look for source files. Multiple @code{src_dir} -lines can be specified and they will be searched in the order they -are specified. - -@item obj_dir=DIR -[default: @code{"^./^[]^"}] -specifies a directory where to look for object and library files. Multiple -@code{obj_dir} lines can be specified, and they will be searched in the order -they are specified - -@item comp_opt=SWITCHES -[default: @code{""}] -creates a variable which can be referred to subsequently by using -the @code{$@{comp_opt@}} notation. This is intended to store the default -switches given to @command{gnatmake} and @command{gcc}. - -@item bind_opt=SWITCHES -[default: @code{""}] -creates a variable which can be referred to subsequently by using -the @samp{$@{bind_opt@}} notation. This is intended to store the default -switches given to @command{gnatbind}. - -@item link_opt=SWITCHES -[default: @code{""}] -creates a variable which can be referred to subsequently by using -the @samp{$@{link_opt@}} notation. This is intended to store the default -switches given to @command{gnatlink}. - -@item main=EXECUTABLE -[default: @code{""}] -specifies the name of the executable for the application. This variable can -be referred to in the following lines by using the @samp{$@{main@}} notation. - -@ifset vms -@item comp_cmd=COMMAND -[default: @code{"GNAT COMPILE /SEARCH=$@{src_dir@} /DEBUG /TRY_SEMANTICS"}] -@end ifset -@ifclear vms -@item comp_cmd=COMMAND -[default: @code{"gcc -c -I$@{src_dir@} -g -gnatq"}] -@end ifclear -specifies the command used to compile a single file in the application. - -@ifset vms -@item make_cmd=COMMAND -[default: @code{"GNAT MAKE $@{main@} -/SOURCE_SEARCH=$@{src_dir@} /OBJECT_SEARCH=$@{obj_dir@} -/DEBUG /TRY_SEMANTICS /COMPILER_QUALIFIERS $@{comp_opt@} -/BINDER_QUALIFIERS $@{bind_opt@} /LINKER_QUALIFIERS $@{link_opt@}"}] -@end ifset -@ifclear vms -@item make_cmd=COMMAND -[default: @code{"gnatmake $@{main@} -aI$@{src_dir@} --aO$@{obj_dir@} -g -gnatq -cargs $@{comp_opt@} --bargs $@{bind_opt@} -largs $@{link_opt@}"}] -@end ifclear -specifies the command used to recompile the whole application. - -@item run_cmd=COMMAND -[default: @code{"$@{main@}"}] -specifies the command used to run the application. - -@item debug_cmd=COMMAND -[default: @code{"gdb $@{main@}"}] -specifies the command used to debug the application - -@end table - -@noindent -@command{gnatxref} and @command{gnatfind} only take into account the -@code{src_dir} and @code{obj_dir} lines, and ignore the others. - -@node Regular Expressions in gnatfind and gnatxref -@section Regular Expressions in @code{gnatfind} and @code{gnatxref} - -@noindent -As specified in the section about @command{gnatfind}, the pattern can be a -regular expression. Actually, there are to set of regular expressions -which are recognized by the program: - -@table @code -@item globbing patterns -These are the most usual regular expression. They are the same that you -generally used in a Unix shell command line, or in a DOS session. - -Here is a more formal grammar: -@smallexample -@group -@iftex -@leftskip=.5cm -@end iftex -regexp ::= term -term ::= elmt -- matches elmt -term ::= elmt elmt -- concatenation (elmt then elmt) -term ::= * -- any string of 0 or more characters -term ::= ? -- matches any character -term ::= [char @{char@}] -- matches any character listed -term ::= [char - char] -- matches any character in range -@end group -@end smallexample - -@item full regular expression -The second set of regular expressions is much more powerful. This is the -type of regular expressions recognized by utilities such a @file{grep}. - -The following is the form of a regular expression, expressed in Ada -reference manual style BNF is as follows - -@smallexample -@iftex -@leftskip=.5cm -@end iftex -@group -regexp ::= term @{| term@} -- alternation (term or term @dots{}) - -term ::= item @{item@} -- concatenation (item then item) - -item ::= elmt -- match elmt -item ::= elmt * -- zero or more elmt's -item ::= elmt + -- one or more elmt's -item ::= elmt ? -- matches elmt or nothing -@end group -@group -elmt ::= nschar -- matches given character -elmt ::= [nschar @{nschar@}] -- matches any character listed -elmt ::= [^^^ nschar @{nschar@}] -- matches any character not listed -elmt ::= [char - char] -- matches chars in given range -elmt ::= \ char -- matches given character -elmt ::= . -- matches any single character -elmt ::= ( regexp ) -- parens used for grouping - -char ::= any character, including special characters -nschar ::= any character except ()[].*+?^^^ -@end group -@end smallexample - -Following are a few examples: - -@table @samp -@item abcde|fghi -will match any of the two strings @samp{abcde} and @samp{fghi}, - -@item abc*d -will match any string like @samp{abd}, @samp{abcd}, @samp{abccd}, -@samp{abcccd}, and so on, - -@item [a-z]+ -will match any string which has only lowercase characters in it (and at -least one character. - -@end table -@end table - -@node Examples of gnatxref Usage -@section Examples of @code{gnatxref} Usage - -@subsection General Usage - -@noindent -For the following examples, we will consider the following units: - -@smallexample @c ada -@group -@cartouche -main.ads: -1: with Bar; -2: package Main is -3: procedure Foo (B : in Integer); -4: C : Integer; -5: private -6: D : Integer; -7: end Main; - -main.adb: -1: package body Main is -2: procedure Foo (B : in Integer) is -3: begin -4: C := B; -5: D := B; -6: Bar.Print (B); -7: Bar.Print (C); -8: end Foo; -9: end Main; - -bar.ads: -1: package Bar is -2: procedure Print (B : Integer); -3: end bar; -@end cartouche -@end group -@end smallexample - -@table @code - -@noindent -The first thing to do is to recompile your application (for instance, in -that case just by doing a @samp{gnatmake main}, so that GNAT generates -the cross-referencing information. -You can then issue any of the following commands: - -@item gnatxref main.adb -@code{gnatxref} generates cross-reference information for main.adb -and every unit 'with'ed by main.adb. - -The output would be: -@smallexample -@iftex -@leftskip=0cm -@end iftex -B Type: Integer - Decl: bar.ads 2:22 -B Type: Integer - Decl: main.ads 3:20 - Body: main.adb 2:20 - Ref: main.adb 4:13 5:13 6:19 -Bar Type: Unit - Decl: bar.ads 1:9 - Ref: main.adb 6:8 7:8 - main.ads 1:6 -C Type: Integer - Decl: main.ads 4:5 - Modi: main.adb 4:8 - Ref: main.adb 7:19 -D Type: Integer - Decl: main.ads 6:5 - Modi: main.adb 5:8 -Foo Type: Unit - Decl: main.ads 3:15 - Body: main.adb 2:15 -Main Type: Unit - Decl: main.ads 2:9 - Body: main.adb 1:14 -Print Type: Unit - Decl: bar.ads 2:15 - Ref: main.adb 6:12 7:12 -@end smallexample - -@noindent -that is the entity @code{Main} is declared in main.ads, line 2, column 9, -its body is in main.adb, line 1, column 14 and is not referenced any where. - -The entity @code{Print} is declared in bar.ads, line 2, column 15 and it -it referenced in main.adb, line 6 column 12 and line 7 column 12. - -@item gnatxref package1.adb package2.ads -@code{gnatxref} will generates cross-reference information for -package1.adb, package2.ads and any other package 'with'ed by any -of these. - -@end table - -@ifclear vms -@subsection Using gnatxref with vi - -@code{gnatxref} can generate a tags file output, which can be used -directly from @command{vi}. Note that the standard version of @command{vi} -will not work properly with overloaded symbols. Consider using another -free implementation of @command{vi}, such as @command{vim}. - -@smallexample -$ gnatxref -v gnatfind.adb > tags -@end smallexample - -@noindent -will generate the tags file for @code{gnatfind} itself (if the sources -are in the search path!). - -From @command{vi}, you can then use the command @samp{:tag @var{entity}} -(replacing @var{entity} by whatever you are looking for), and vi will -display a new file with the corresponding declaration of entity. -@end ifclear - -@node Examples of gnatfind Usage -@section Examples of @code{gnatfind} Usage - -@table @code - -@item gnatfind ^-f^/FULL_PATHNAME^ xyz:main.adb -Find declarations for all entities xyz referenced at least once in -main.adb. The references are search in every library file in the search -path. - -The directories will be printed as well (as the @samp{^-f^/FULL_PATHNAME^} -switch is set) - -The output will look like: -@smallexample -^directory/^[directory]^main.ads:106:14: xyz <= declaration -^directory/^[directory]^main.adb:24:10: xyz <= body -^directory/^[directory]^foo.ads:45:23: xyz <= declaration -@end smallexample - -@noindent -that is to say, one of the entities xyz found in main.adb is declared at -line 12 of main.ads (and its body is in main.adb), and another one is -declared at line 45 of foo.ads - -@item gnatfind ^-fs^/FULL_PATHNAME/SOURCE_LINE^ xyz:main.adb -This is the same command as the previous one, instead @code{gnatfind} will -display the content of the Ada source file lines. - -The output will look like: - -@smallexample -^directory/^[directory]^main.ads:106:14: xyz <= declaration - procedure xyz; -^directory/^[directory]^main.adb:24:10: xyz <= body - procedure xyz is -^directory/^[directory]^foo.ads:45:23: xyz <= declaration - xyz : Integer; -@end smallexample - -@noindent -This can make it easier to find exactly the location your are looking -for. - -@item gnatfind ^-r^/REFERENCES^ "*x*":main.ads:123 foo.adb -Find references to all entities containing an x that are -referenced on line 123 of main.ads. -The references will be searched only in main.ads and foo.adb. - -@item gnatfind main.ads:123 -Find declarations and bodies for all entities that are referenced on -line 123 of main.ads. - -This is the same as @code{gnatfind "*":main.adb:123}. - -@item gnatfind ^mydir/^[mydir]^main.adb:123:45 -Find the declaration for the entity referenced at column 45 in -line 123 of file main.adb in directory mydir. Note that it -is usual to omit the identifier name when the column is given, -since the column position identifies a unique reference. - -The column has to be the beginning of the identifier, and should not -point to any character in the middle of the identifier. - -@end table - -@c ********************************* -@node The GNAT Pretty-Printer gnatpp -@chapter The GNAT Pretty-Printer @command{gnatpp} -@findex gnatpp -@cindex Pretty-Printer - -@noindent -^The @command{gnatpp} tool^GNAT PRETTY^ is an ASIS-based utility -for source reformatting / pretty-printing. -It takes an Ada source file as input and generates a reformatted -version as output. -You can specify various style directives via switches; e.g., -identifier case conventions, rules of indentation, and comment layout. - -To produce a reformatted file, @command{gnatpp} generates and uses the ASIS -tree for the input source and thus requires the input to be syntactically and -semantically legal. -If this condition is not met, @command{gnatpp} will terminate with an -error message; no output file will be generated. - -If the source files presented to @command{gnatpp} contain -preprocessing directives, then the output file will -correspond to the generated source after all -preprocessing is carried out. There is no way -using @command{gnatpp} to obtain pretty printed files that -include the preprocessing directives. - -If the compilation unit -contained in the input source depends semantically upon units located -outside the current directory, you have to provide the source search path -when invoking @command{gnatpp}, if these units are contained in files with -names that do not follow the GNAT file naming rules, you have to provide -the configuration file describing the corresponding naming scheme; -see the description of the @command{gnatpp} -switches below. Another possibility is to use a project file and to -call @command{gnatpp} through the @command{gnat} driver - -The @command{gnatpp} command has the form - -@smallexample -$ gnatpp @ovar{switches} @var{filename} -@end smallexample - -@noindent -where -@itemize @bullet -@item -@var{switches} is an optional sequence of switches defining such properties as -the formatting rules, the source search path, and the destination for the -output source file - -@item -@var{filename} is the name (including the extension) of the source file to -reformat; ``wildcards'' or several file names on the same gnatpp command are -allowed. The file name may contain path information; it does not have to -follow the GNAT file naming rules -@end itemize - -@menu -* Switches for gnatpp:: -* Formatting Rules:: -@end menu - -@node Switches for gnatpp -@section Switches for @command{gnatpp} - -@noindent -The following subsections describe the various switches accepted by -@command{gnatpp}, organized by category. - -@ifclear vms -You specify a switch by supplying a name and generally also a value. -In many cases the values for a switch with a given name are incompatible with -each other -(for example the switch that controls the casing of a reserved word may have -exactly one value: upper case, lower case, or -mixed case) and thus exactly one such switch can be in effect for an -invocation of @command{gnatpp}. -If more than one is supplied, the last one is used. -However, some values for the same switch are mutually compatible. -You may supply several such switches to @command{gnatpp}, but then -each must be specified in full, with both the name and the value. -Abbreviated forms (the name appearing once, followed by each value) are -not permitted. -For example, to set -the alignment of the assignment delimiter both in declarations and in -assignment statements, you must write @option{-A2A3} -(or @option{-A2 -A3}), but not @option{-A23}. -@end ifclear - -@ifset vms -In many cases the set of options for a given qualifier are incompatible with -each other (for example the qualifier that controls the casing of a reserved -word may have exactly one option, which specifies either upper case, lower -case, or mixed case), and thus exactly one such option can be in effect for -an invocation of @command{gnatpp}. -If more than one is supplied, the last one is used. -However, some qualifiers have options that are mutually compatible, -and then you may then supply several such options when invoking -@command{gnatpp}. -@end ifset - -In most cases, it is obvious whether or not the -^values for a switch with a given name^options for a given qualifier^ -are compatible with each other. -When the semantics might not be evident, the summaries below explicitly -indicate the effect. - -@menu -* Alignment Control:: -* Casing Control:: -* Construct Layout Control:: -* General Text Layout Control:: -* Other Formatting Options:: -* Setting the Source Search Path:: -* Output File Control:: -* Other gnatpp Switches:: -@end menu - -@node Alignment Control -@subsection Alignment Control -@cindex Alignment control in @command{gnatpp} - -@noindent -Programs can be easier to read if certain constructs are vertically aligned. -By default all alignments are set ON. -Through the @option{^-A0^/ALIGN=OFF^} switch you may reset the default to -OFF, and then use one or more of the other -^@option{-A@var{n}} switches^@option{/ALIGN} options^ -to activate alignment for specific constructs. - -@table @option -@cindex @option{^-A@var{n}^/ALIGN^} (@command{gnatpp}) - -@ifset vms -@item /ALIGN=ON -Set all alignments to ON -@end ifset - -@item ^-A0^/ALIGN=OFF^ -Set all alignments to OFF - -@item ^-A1^/ALIGN=COLONS^ -Align @code{:} in declarations - -@item ^-A2^/ALIGN=DECLARATIONS^ -Align @code{:=} in initializations in declarations - -@item ^-A3^/ALIGN=STATEMENTS^ -Align @code{:=} in assignment statements - -@item ^-A4^/ALIGN=ARROWS^ -Align @code{=>} in associations - -@item ^-A5^/ALIGN=COMPONENT_CLAUSES^ -Align @code{at} keywords in the component clauses in record -representation clauses -@end table - -@noindent -The @option{^-A^/ALIGN^} switches are mutually compatible; any combination -is allowed. - -@node Casing Control -@subsection Casing Control -@cindex Casing control in @command{gnatpp} - -@noindent -@command{gnatpp} allows you to specify the casing for reserved words, -pragma names, attribute designators and identifiers. -For identifiers you may define a -general rule for name casing but also override this rule -via a set of dictionary files. - -Three types of casing are supported: lower case, upper case, and mixed case. -Lower and upper case are self-explanatory (but since some letters in -Latin1 and other GNAT-supported character sets -exist only in lower-case form, an upper case conversion will have no -effect on them.) -``Mixed case'' means that the first letter, and also each letter immediately -following an underscore, are converted to their uppercase forms; -all the other letters are converted to their lowercase forms. - -@table @option -@cindex @option{^-a@var{x}^/ATTRIBUTE^} (@command{gnatpp}) -@item ^-aL^/ATTRIBUTE_CASING=LOWER_CASE^ -Attribute designators are lower case - -@item ^-aU^/ATTRIBUTE_CASING=UPPER_CASE^ -Attribute designators are upper case - -@item ^-aM^/ATTRIBUTE_CASING=MIXED_CASE^ -Attribute designators are mixed case (this is the default) - -@cindex @option{^-k@var{x}^/KEYWORD_CASING^} (@command{gnatpp}) -@item ^-kL^/KEYWORD_CASING=LOWER_CASE^ -Keywords (technically, these are known in Ada as @emph{reserved words}) are -lower case (this is the default) - -@item ^-kU^/KEYWORD_CASING=UPPER_CASE^ -Keywords are upper case - -@cindex @option{^-n@var{x}^/NAME_CASING^} (@command{gnatpp}) -@item ^-nD^/NAME_CASING=AS_DECLARED^ -Name casing for defining occurrences are as they appear in the source file -(this is the default) - -@item ^-nU^/NAME_CASING=UPPER_CASE^ -Names are in upper case - -@item ^-nL^/NAME_CASING=LOWER_CASE^ -Names are in lower case - -@item ^-nM^/NAME_CASING=MIXED_CASE^ -Names are in mixed case - -@cindex @option{^-p@var{x}^/PRAGMA_CASING^} (@command{gnatpp}) -@item ^-pL^/PRAGMA_CASING=LOWER_CASE^ -Pragma names are lower case - -@item ^-pU^/PRAGMA_CASING=UPPER_CASE^ -Pragma names are upper case - -@item ^-pM^/PRAGMA_CASING=MIXED_CASE^ -Pragma names are mixed case (this is the default) - -@item ^-D@var{file}^/DICTIONARY=@var{file}^ -@cindex @option{^-D^/DICTIONARY^} (@command{gnatpp}) -Use @var{file} as a @emph{dictionary file} that defines -the casing for a set of specified names, -thereby overriding the effect on these names by -any explicit or implicit -^-n^/NAME_CASING^ switch. -To supply more than one dictionary file, -use ^several @option{-D} switches^a list of files as options^. - -@noindent -@option{gnatpp} implicitly uses a @emph{default dictionary file} -to define the casing for the Ada predefined names and -the names declared in the GNAT libraries. - -@item ^-D-^/SPECIFIC_CASING^ -@cindex @option{^-D-^/SPECIFIC_CASING^} (@command{gnatpp}) -Do not use the default dictionary file; -instead, use the casing -defined by a @option{^-n^/NAME_CASING^} switch and any explicit -dictionary file(s) -@end table - -@noindent -The structure of a dictionary file, and details on the conventions -used in the default dictionary file, are defined in @ref{Name Casing}. - -The @option{^-D-^/SPECIFIC_CASING^} and -@option{^-D@var{file}^/DICTIONARY=@var{file}^} switches are mutually -compatible. - -@node Construct Layout Control -@subsection Construct Layout Control -@cindex Layout control in @command{gnatpp} - -@noindent -This group of @command{gnatpp} switches controls the layout of comments and -complex syntactic constructs. See @ref{Formatting Comments} for details -on their effect. - -@table @option -@cindex @option{^-c@var{n}^/COMMENTS_LAYOUT^} (@command{gnatpp}) -@item ^-c0^/COMMENTS_LAYOUT=UNTOUCHED^ -All the comments remain unchanged - -@item ^-c1^/COMMENTS_LAYOUT=DEFAULT^ -GNAT-style comment line indentation (this is the default). - -@item ^-c2^/COMMENTS_LAYOUT=STANDARD_INDENT^ -Reference-manual comment line indentation. - -@item ^-c3^/COMMENTS_LAYOUT=GNAT_BEGINNING^ -GNAT-style comment beginning - -@item ^-c4^/COMMENTS_LAYOUT=REFORMAT^ -Reformat comment blocks - -@item ^-c5^/COMMENTS_LAYOUT=KEEP_SPECIAL^ -Keep unchanged special form comments - -Reformat comment blocks - -@cindex @option{^-l@var{n}^/CONSTRUCT_LAYOUT^} (@command{gnatpp}) -@item ^-l1^/CONSTRUCT_LAYOUT=GNAT^ -GNAT-style layout (this is the default) - -@item ^-l2^/CONSTRUCT_LAYOUT=COMPACT^ -Compact layout - -@item ^-l3^/CONSTRUCT_LAYOUT=UNCOMPACT^ -Uncompact layout - -@cindex @option{^-N^/NOTABS^} (@command{gnatpp}) -@item ^-N^/NOTABS^ -All the VT characters are removed from the comment text. All the HT characters -are expanded with the sequences of space characters to get to the next tab -stops. - -@cindex @option{^--no-separate-is^/NO_SEPARATE_IS^} (@command{gnatpp}) -@item ^--no-separate-is^/NO_SEPARATE_IS^ -Do not place the keyword @code{is} on a separate line in a subprogram body in -case if the spec occupies more then one line. - -@cindex @option{^--separate-label^/SEPARATE_LABEL^} (@command{gnatpp}) -@item ^--separate-label^/SEPARATE_LABEL^ -Place statement label(s) on a separate line, with the following statement -on the next line. - -@cindex @option{^--separate-loop-then^/SEPARATE_LOOP_THEN^} (@command{gnatpp}) -@item ^--separate-loop-then^/SEPARATE_LOOP_THEN^ -Place the keyword @code{loop} in FOR and WHILE loop statements and the -keyword @code{then} in IF statements on a separate line. - -@cindex @option{^--no-separate-loop-then^/NO_SEPARATE_LOOP_THEN^} (@command{gnatpp}) -@item ^--no-separate-loop-then^/NO_SEPARATE_LOOP_THEN^ -Do not place the keyword @code{loop} in FOR and WHILE loop statements and the -keyword @code{then} in IF statements on a separate line. This option is -incompatible with @option{^--separate-loop-then^/SEPARATE_LOOP_THEN^} option. - -@cindex @option{^--use-on-new-line^/USE_ON_NEW_LINE^} (@command{gnatpp}) -@item ^--use-on-new-line^/USE_ON_NEW_LINE^ -Start each USE clause in a context clause from a separate line. - -@cindex @option{^--separate-stmt-name^/STMT_NAME_ON_NEW_LINE^} (@command{gnatpp}) -@item ^--separate-stmt-name^/STMT_NAME_ON_NEW_LINE^ -Use a separate line for a loop or block statement name, but do not use an extra -indentation level for the statement itself. - -@end table - -@ifclear vms -@noindent -The @option{-c1} and @option{-c2} switches are incompatible. -The @option{-c3} and @option{-c4} switches are compatible with each other and -also with @option{-c1} and @option{-c2}. The @option{-c0} switch disables all -the other comment formatting switches. - -The @option{-l1}, @option{-l2}, and @option{-l3} switches are incompatible. -@end ifclear - -@ifset vms -@noindent -For the @option{/COMMENTS_LAYOUT} qualifier: -@itemize @bullet -@item -The @option{DEFAULT} and @option{STANDARD_INDENT} options are incompatible. -@item -The @option{GNAT_BEGINNING} and @option{REFORMAT} options are compatible with -each other and also with @option{DEFAULT} and @option{STANDARD_INDENT}. -@end itemize - -@noindent -The @option{GNAT}, @option{COMPACT}, and @option{UNCOMPACT} options for the -@option{/CONSTRUCT_LAYOUT} qualifier are incompatible. -@end ifset - -@node General Text Layout Control -@subsection General Text Layout Control - -@noindent -These switches allow control over line length and indentation. - -@table @option -@item ^-M@var{nnn}^/LINE_LENGTH_MAX=@var{nnn}^ -@cindex @option{^-M^/LINE_LENGTH^} (@command{gnatpp}) -Maximum line length, @var{nnn} from 32@dots{}256, the default value is 79 - -@item ^-i@var{nnn}^/INDENTATION_LEVEL=@var{nnn}^ -@cindex @option{^-i^/INDENTATION_LEVEL^} (@command{gnatpp}) -Indentation level, @var{nnn} from 1@dots{}9, the default value is 3 - -@item ^-cl@var{nnn}^/CONTINUATION_INDENT=@var{nnn}^ -@cindex @option{^-cl^/CONTINUATION_INDENT^} (@command{gnatpp}) -Indentation level for continuation lines (relative to the line being -continued), @var{nnn} from 1@dots{}9. -The default -value is one less then the (normal) indentation level, unless the -indentation is set to 1 (in which case the default value for continuation -line indentation is also 1) -@end table - -@node Other Formatting Options -@subsection Other Formatting Options - -@noindent -These switches control the inclusion of missing end/exit labels, and -the indentation level in @b{case} statements. - -@table @option -@item ^-e^/NO_MISSED_LABELS^ -@cindex @option{^-e^/NO_MISSED_LABELS^} (@command{gnatpp}) -Do not insert missing end/exit labels. An end label is the name of -a construct that may optionally be repeated at the end of the -construct's declaration; -e.g., the names of packages, subprograms, and tasks. -An exit label is the name of a loop that may appear as target -of an exit statement within the loop. -By default, @command{gnatpp} inserts these end/exit labels when -they are absent from the original source. This option suppresses such -insertion, so that the formatted source reflects the original. - -@item ^-ff^/FORM_FEED_AFTER_PRAGMA_PAGE^ -@cindex @option{^-ff^/FORM_FEED_AFTER_PRAGMA_PAGE^} (@command{gnatpp}) -Insert a Form Feed character after a pragma Page. - -@item ^-T@var{nnn}^/MAX_INDENT=@var{nnn}^ -@cindex @option{^-T^/MAX_INDENT^} (@command{gnatpp}) -Do not use an additional indentation level for @b{case} alternatives -and variants if there are @var{nnn} or more (the default -value is 10). -If @var{nnn} is 0, an additional indentation level is -used for @b{case} alternatives and variants regardless of their number. -@end table - -@node Setting the Source Search Path -@subsection Setting the Source Search Path - -@noindent -To define the search path for the input source file, @command{gnatpp} -uses the same switches as the GNAT compiler, with the same effects. - -@table @option -@item ^-I^/SEARCH=^@var{dir} -@cindex @option{^-I^/SEARCH^} (@code{gnatpp}) -The same as the corresponding gcc switch - -@item ^-I-^/NOCURRENT_DIRECTORY^ -@cindex @option{^-I-^/NOCURRENT_DIRECTORY^} (@code{gnatpp}) -The same as the corresponding gcc switch - -@item ^-gnatec^/CONFIGURATION_PRAGMAS_FILE^=@var{path} -@cindex @option{^-gnatec^/CONFIGURATION_PRAGMAS_FILE^} (@code{gnatpp}) -The same as the corresponding gcc switch - -@item ^--RTS^/RUNTIME_SYSTEM^=@var{path} -@cindex @option{^--RTS^/RUNTIME_SYSTEM^} (@code{gnatpp}) -The same as the corresponding gcc switch - -@end table - -@node Output File Control -@subsection Output File Control - -@noindent -By default the output is sent to the file whose name is obtained by appending -the ^@file{.pp}^@file{$PP}^ suffix to the name of the input file -(if the file with this name already exists, it is unconditionally overwritten). -Thus if the input file is @file{^my_ada_proc.adb^MY_ADA_PROC.ADB^} then -@command{gnatpp} will produce @file{^my_ada_proc.adb.pp^MY_ADA_PROC.ADB$PP^} -as output file. -The output may be redirected by the following switches: - -@table @option -@item ^-pipe^/STANDARD_OUTPUT^ -@cindex @option{^-pipe^/STANDARD_OUTPUT^} (@code{gnatpp}) -Send the output to @code{Standard_Output} - -@item ^-o @var{output_file}^/OUTPUT=@var{output_file}^ -@cindex @option{^-o^/OUTPUT^} (@code{gnatpp}) -Write the output into @var{output_file}. -If @var{output_file} already exists, @command{gnatpp} terminates without -reading or processing the input file. - -@item ^-of ^/FORCED_OUTPUT=^@var{output_file} -@cindex @option{^-of^/FORCED_OUTPUT^} (@code{gnatpp}) -Write the output into @var{output_file}, overwriting the existing file -(if one is present). - -@item ^-r^/REPLACE^ -@cindex @option{^-r^/REPLACE^} (@code{gnatpp}) -Replace the input source file with the reformatted output, and copy the -original input source into the file whose name is obtained by appending the -^@file{.npp}^@file{$NPP}^ suffix to the name of the input file. -If a file with this name already exists, @command{gnatpp} terminates without -reading or processing the input file. - -@item ^-rf^/OVERRIDING_REPLACE^ -@cindex @option{^-rf^/OVERRIDING_REPLACE^} (@code{gnatpp}) -Like @option{^-r^/REPLACE^} except that if the file with the specified name -already exists, it is overwritten. - -@item ^-rnb^/REPLACE_NO_BACKUP^ -@cindex @option{^-rnb^/REPLACE_NO_BACKUP^} (@code{gnatpp}) -Replace the input source file with the reformatted output without -creating any backup copy of the input source. - -@item ^--eol=@var{xxx}^/END_OF_LINE=@var{xxx}^ -@cindex @option{^--eol^/END_OF_LINE^} (@code{gnatpp}) -Specifies the format of the reformatted output file. The @var{xxx} -^string specified with the switch^option^ may be either -@itemize @bullet -@item ``@option{^dos^DOS^}'' MS DOS style, lines end with CR LF characters -@item ``@option{^crlf^CRLF^}'' -the same as @option{^crlf^CRLF^} -@item ``@option{^unix^UNIX^}'' UNIX style, lines end with LF character -@item ``@option{^lf^LF^}'' -the same as @option{^unix^UNIX^} -@end itemize - -@item ^-W^/RESULT_ENCODING=^@var{e} -@cindex @option{^-W^/RESULT_ENCODING=^} (@command{gnatpp}) -Specify the wide character encoding method used to write the code in the -result file -@var{e} is one of the following: - -@itemize @bullet - -@item ^h^HEX^ -Hex encoding - -@item ^u^UPPER^ -Upper half encoding - -@item ^s^SHIFT_JIS^ -Shift/JIS encoding - -@item ^e^EUC^ -EUC encoding - -@item ^8^UTF8^ -UTF-8 encoding - -@item ^b^BRACKETS^ -Brackets encoding (default value) -@end itemize - -@end table - -@noindent -Options @option{^-pipe^/STANDARD_OUTPUT^}, -@option{^-o^/OUTPUT^} and -@option{^-of^/FORCED_OUTPUT^} are allowed only if the call to gnatpp -contains only one file to reformat. -Option -@option{^--eol^/END_OF_LINE^} -and -@option{^-W^/RESULT_ENCODING^} -cannot be used together -with @option{^-pipe^/STANDARD_OUTPUT^} option. - -@node Other gnatpp Switches -@subsection Other @code{gnatpp} Switches - -@noindent -The additional @command{gnatpp} switches are defined in this subsection. - -@table @option -@item ^-files @var{filename}^/FILES=@var{output_file}^ -@cindex @option{^-files^/FILES^} (@code{gnatpp}) -Take the argument source files from the specified file. This file should be an -ordinary textual file containing file names separated by spaces or -line breaks. You can use this switch more then once in the same call to -@command{gnatpp}. You also can combine this switch with explicit list of -files. - -@item ^-v^/VERBOSE^ -@cindex @option{^-v^/VERBOSE^} (@code{gnatpp}) -Verbose mode; -@command{gnatpp} generates version information and then -a trace of the actions it takes to produce or obtain the ASIS tree. - -@item ^-w^/WARNINGS^ -@cindex @option{^-w^/WARNINGS^} (@code{gnatpp}) -Warning mode; -@command{gnatpp} generates a warning whenever it cannot provide -a required layout in the result source. -@end table - -@node Formatting Rules -@section Formatting Rules - -@noindent -The following subsections show how @command{gnatpp} treats ``white space'', -comments, program layout, and name casing. -They provide the detailed descriptions of the switches shown above. - -@menu -* White Space and Empty Lines:: -* Formatting Comments:: -* Construct Layout:: -* Name Casing:: -@end menu - -@node White Space and Empty Lines -@subsection White Space and Empty Lines - -@noindent -@command{gnatpp} does not have an option to control space characters. -It will add or remove spaces according to the style illustrated by the -examples in the @cite{Ada Reference Manual}. - -The only format effectors -(see @cite{Ada Reference Manual}, paragraph 2.1(13)) -that will appear in the output file are platform-specific line breaks, -and also format effectors within (but not at the end of) comments. -In particular, each horizontal tab character that is not inside -a comment will be treated as a space and thus will appear in the -output file as zero or more spaces depending on -the reformatting of the line in which it appears. -The only exception is a Form Feed character, which is inserted after a -pragma @code{Page} when @option{-ff} is set. - -The output file will contain no lines with trailing ``white space'' (spaces, -format effectors). - -Empty lines in the original source are preserved -only if they separate declarations or statements. -In such contexts, a -sequence of two or more empty lines is replaced by exactly one empty line. -Note that a blank line will be removed if it separates two ``comment blocks'' -(a comment block is a sequence of whole-line comments). -In order to preserve a visual separation between comment blocks, use an -``empty comment'' (a line comprising only hyphens) rather than an empty line. -Likewise, if for some reason you wish to have a sequence of empty lines, -use a sequence of empty comments instead. - -@node Formatting Comments -@subsection Formatting Comments - -@noindent -Comments in Ada code are of two kinds: -@itemize @bullet -@item -a @emph{whole-line comment}, which appears by itself (possibly preceded by -``white space'') on a line - -@item -an @emph{end-of-line comment}, which follows some other Ada lexical element -on the same line. -@end itemize - -@noindent -The indentation of a whole-line comment is that of either -the preceding or following line in -the formatted source, depending on switch settings as will be described below. - -For an end-of-line comment, @command{gnatpp} leaves the same number of spaces -between the end of the preceding Ada lexical element and the beginning -of the comment as appear in the original source, -unless either the comment has to be split to -satisfy the line length limitation, or else the next line contains a -whole line comment that is considered a continuation of this end-of-line -comment (because it starts at the same position). -In the latter two -cases, the start of the end-of-line comment is moved right to the nearest -multiple of the indentation level. -This may result in a ``line overflow'' (the right-shifted comment extending -beyond the maximum line length), in which case the comment is split as -described below. - -There is a difference between @option{^-c1^/COMMENTS_LAYOUT=DEFAULT^} -(GNAT-style comment line indentation) -and @option{^-c2^/COMMENTS_LAYOUT=STANDARD_INDENT^} -(reference-manual comment line indentation). -With reference-manual style, a whole-line comment is indented as if it -were a declaration or statement at the same place -(i.e., according to the indentation of the preceding line(s)). -With GNAT style, a whole-line comment that is immediately followed by an -@b{if} or @b{case} statement alternative, a record variant, or the reserved -word @b{begin}, is indented based on the construct that follows it. - -For example: -@smallexample @c ada -@cartouche -if A then - null; - -- some comment -else - null; -end if; -@end cartouche -@end smallexample - -@noindent -Reference-manual indentation produces: - -@smallexample @c ada -@cartouche -if A then - null; - -- some comment -else - null; -end if; -@end cartouche -@end smallexample - -@noindent -while GNAT-style indentation produces: - -@smallexample @c ada -@cartouche -if A then - null; --- some comment -else - null; -end if; -@end cartouche -@end smallexample - -@noindent -The @option{^-c3^/COMMENTS_LAYOUT=GNAT_BEGINNING^} switch -(GNAT style comment beginning) has the following -effect: - -@itemize @bullet -@item -For each whole-line comment that does not end with two hyphens, -@command{gnatpp} inserts spaces if necessary after the starting two hyphens -to ensure that there are at least two spaces between these hyphens and the -first non-blank character of the comment. -@end itemize - -@noindent -For an end-of-line comment, if in the original source the next line is a -whole-line comment that starts at the same position -as the end-of-line comment, -then the whole-line comment (and all whole-line comments -that follow it and that start at the same position) -will start at this position in the output file. - -@noindent -That is, if in the original source we have: - -@smallexample @c ada -@cartouche -begin -A := B + C; -- B must be in the range Low1..High1 - -- C must be in the range Low2..High2 - --B+C will be in the range Low1+Low2..High1+High2 -X := X + 1; -@end cartouche -@end smallexample - -@noindent -Then in the formatted source we get - -@smallexample @c ada -@cartouche -begin - A := B + C; -- B must be in the range Low1..High1 - -- C must be in the range Low2..High2 - -- B+C will be in the range Low1+Low2..High1+High2 - X := X + 1; -@end cartouche -@end smallexample - -@noindent -A comment that exceeds the line length limit will be split. -Unless switch -@option{^-c4^/COMMENTS_LAYOUT=REFORMAT^} (reformat comment blocks) is set and -the line belongs to a reformattable block, splitting the line generates a -@command{gnatpp} warning. -The @option{^-c4^/COMMENTS_LAYOUT=REFORMAT^} switch specifies that whole-line -comments may be reformatted in typical -word processor style (that is, moving words between lines and putting as -many words in a line as possible). - -@noindent -The @option{^-c5^/COMMENTS_LAYOUT=KEEP_SPECIAL^} switch specifies, that comments -that has a special format (that is, a character that is neither a letter nor digit -not white space nor line break immediately following the leading @code{--} of -the comment) should be without any change moved from the argument source -into reformatted source. This switch allows to preserve comments that are used -as a special marks in the code (e.g.@: SPARK annotation). - -@node Construct Layout -@subsection Construct Layout - -@noindent -In several cases the suggested layout in the Ada Reference Manual includes -an extra level of indentation that many programmers prefer to avoid. The -affected cases include: - -@itemize @bullet - -@item Record type declaration (RM 3.8) - -@item Record representation clause (RM 13.5.1) - -@item Loop statement in case if a loop has a statement identifier (RM 5.6) - -@item Block statement in case if a block has a statement identifier (RM 5.6) -@end itemize - -@noindent -In compact mode (when GNAT style layout or compact layout is set), -the pretty printer uses one level of indentation instead -of two. This is achieved in the record definition and record representation -clause cases by putting the @code{record} keyword on the same line as the -start of the declaration or representation clause, and in the block and loop -case by putting the block or loop header on the same line as the statement -identifier. - -@noindent -The difference between GNAT style @option{^-l1^/CONSTRUCT_LAYOUT=GNAT^} -and compact @option{^-l2^/CONSTRUCT_LAYOUT=COMPACT^} -layout on the one hand, and uncompact layout -@option{^-l3^/CONSTRUCT_LAYOUT=UNCOMPACT^} on the other hand, -can be illustrated by the following examples: - -@iftex -@cartouche -@multitable @columnfractions .5 .5 -@item @i{GNAT style, compact layout} @tab @i{Uncompact layout} - -@item -@smallexample @c ada -type q is record - a : integer; - b : integer; -end record; -@end smallexample -@tab -@smallexample @c ada -type q is - record - a : integer; - b : integer; - end record; -@end smallexample - -@item -@smallexample @c ada -for q use record - a at 0 range 0 .. 31; - b at 4 range 0 .. 31; -end record; -@end smallexample -@tab -@smallexample @c ada -for q use - record - a at 0 range 0 .. 31; - b at 4 range 0 .. 31; - end record; -@end smallexample - -@item -@smallexample @c ada -Block : declare - A : Integer := 3; -begin - Proc (A, A); -end Block; -@end smallexample -@tab -@smallexample @c ada -Block : - declare - A : Integer := 3; - begin - Proc (A, A); - end Block; -@end smallexample - -@item -@smallexample @c ada -Clear : for J in 1 .. 10 loop - A (J) := 0; -end loop Clear; -@end smallexample -@tab -@smallexample @c ada -Clear : - for J in 1 .. 10 loop - A (J) := 0; - end loop Clear; -@end smallexample -@end multitable -@end cartouche -@end iftex - -@ifnottex -@smallexample -@cartouche -GNAT style, compact layout Uncompact layout - -type q is record type q is - a : integer; record - b : integer; a : integer; -end record; b : integer; - end record; - -for q use record for q use - a at 0 range 0 .. 31; record - b at 4 range 0 .. 31; a at 0 range 0 .. 31; -end record; b at 4 range 0 .. 31; - end record; - -Block : declare Block : - A : Integer := 3; declare -begin A : Integer := 3; - Proc (A, A); begin -end Block; Proc (A, A); - end Block; - -Clear : for J in 1 .. 10 loop Clear : - A (J) := 0; for J in 1 .. 10 loop -end loop Clear; A (J) := 0; - end loop Clear; -@end cartouche -@end smallexample -@end ifnottex - -@noindent -A further difference between GNAT style layout and compact layout is that -GNAT style layout inserts empty lines as separation for -compound statements, return statements and bodies. - -Note that the layout specified by -@option{^--separate-stmt-name^/STMT_NAME_ON_NEW_LINE^} -for named block and loop statements overrides the layout defined by these -constructs by @option{^-l1^/CONSTRUCT_LAYOUT=GNAT^}, -@option{^-l2^/CONSTRUCT_LAYOUT=COMPACT^} or -@option{^-l3^/CONSTRUCT_LAYOUT=UNCOMPACT^} option. - -@node Name Casing -@subsection Name Casing - -@noindent -@command{gnatpp} always converts the usage occurrence of a (simple) name to -the same casing as the corresponding defining identifier. - -You control the casing for defining occurrences via the -@option{^-n^/NAME_CASING^} switch. -@ifclear vms -With @option{-nD} (``as declared'', which is the default), -@end ifclear -@ifset vms -With @option{/NAME_CASING=AS_DECLARED}, which is the default, -@end ifset -defining occurrences appear exactly as in the source file -where they are declared. -The other ^values for this switch^options for this qualifier^ --- -@option{^-nU^UPPER_CASE^}, -@option{^-nL^LOWER_CASE^}, -@option{^-nM^MIXED_CASE^} --- -result in -^upper, lower, or mixed case, respectively^the corresponding casing^. -If @command{gnatpp} changes the casing of a defining -occurrence, it analogously changes the casing of all the -usage occurrences of this name. - -If the defining occurrence of a name is not in the source compilation unit -currently being processed by @command{gnatpp}, the casing of each reference to -this name is changed according to the value of the @option{^-n^/NAME_CASING^} -switch (subject to the dictionary file mechanism described below). -Thus @command{gnatpp} acts as though the @option{^-n^/NAME_CASING^} switch -had affected the -casing for the defining occurrence of the name. - -Some names may need to be spelled with casing conventions that are not -covered by the upper-, lower-, and mixed-case transformations. -You can arrange correct casing by placing such names in a -@emph{dictionary file}, -and then supplying a @option{^-D^/DICTIONARY^} switch. -The casing of names from dictionary files overrides -any @option{^-n^/NAME_CASING^} switch. - -To handle the casing of Ada predefined names and the names from GNAT libraries, -@command{gnatpp} assumes a default dictionary file. -The name of each predefined entity is spelled with the same casing as is used -for the entity in the @cite{Ada Reference Manual}. -The name of each entity in the GNAT libraries is spelled with the same casing -as is used in the declaration of that entity. - -The @w{@option{^-D-^/SPECIFIC_CASING^}} switch suppresses the use of the -default dictionary file. -Instead, the casing for predefined and GNAT-defined names will be established -by the @option{^-n^/NAME_CASING^} switch or explicit dictionary files. -For example, by default the names @code{Ada.Text_IO} and @code{GNAT.OS_Lib} -will appear as just shown, -even in the presence of a @option{^-nU^/NAME_CASING=UPPER_CASE^} switch. -To ensure that even such names are rendered in uppercase, -additionally supply the @w{@option{^-D-^/SPECIFIC_CASING^}} switch -(or else, less conveniently, place these names in upper case in a dictionary -file). - -A dictionary file is -a plain text file; each line in this file can be either a blank line -(containing only space characters and ASCII.HT characters), an Ada comment -line, or the specification of exactly one @emph{casing schema}. - -A casing schema is a string that has the following syntax: - -@smallexample -@cartouche - @var{casing_schema} ::= @var{identifier} | *@var{simple_identifier}* - - @var{simple_identifier} ::= @var{letter}@{@var{letter_or_digit}@} -@end cartouche -@end smallexample - -@noindent -(See @cite{Ada Reference Manual}, Section 2.3) for the definition of the -@var{identifier} lexical element and the @var{letter_or_digit} category.) - -The casing schema string can be followed by white space and/or an Ada-style -comment; any amount of white space is allowed before the string. - -If a dictionary file is passed as -@ifclear vms -the value of a @option{-D@var{file}} switch -@end ifclear -@ifset vms -an option to the @option{/DICTIONARY} qualifier -@end ifset -then for every -simple name and every identifier, @command{gnatpp} checks if the dictionary -defines the casing for the name or for some of its parts (the term ``subword'' -is used below to denote the part of a name which is delimited by ``_'' or by -the beginning or end of the word and which does not contain any ``_'' inside): - -@itemize @bullet -@item -if the whole name is in the dictionary, @command{gnatpp} uses for this name -the casing defined by the dictionary; no subwords are checked for this word - -@item -for every subword @command{gnatpp} checks if the dictionary contains the -corresponding string of the form @code{*@var{simple_identifier}*}, -and if it does, the casing of this @var{simple_identifier} is used -for this subword - -@item -if the whole name does not contain any ``_'' inside, and if for this name -the dictionary contains two entries - one of the form @var{identifier}, -and another - of the form *@var{simple_identifier}*, then the first one -is applied to define the casing of this name - -@item -if more than one dictionary file is passed as @command{gnatpp} switches, each -dictionary adds new casing exceptions and overrides all the existing casing -exceptions set by the previous dictionaries - -@item -when @command{gnatpp} checks if the word or subword is in the dictionary, -this check is not case sensitive -@end itemize - -@noindent -For example, suppose we have the following source to reformat: - -@smallexample @c ada -@cartouche -procedure test is - name1 : integer := 1; - name4_name3_name2 : integer := 2; - name2_name3_name4 : Boolean; - name1_var : Float; -begin - name2_name3_name4 := name4_name3_name2 > name1; -end; -@end cartouche -@end smallexample - -@noindent -And suppose we have two dictionaries: - -@smallexample -@cartouche -@i{dict1:} - NAME1 - *NaMe3* - *Name1* -@end cartouche - -@cartouche -@i{dict2:} - *NAME3* -@end cartouche -@end smallexample - -@noindent -If @command{gnatpp} is called with the following switches: - -@smallexample -@ifclear vms -@command{gnatpp -nM -D dict1 -D dict2 test.adb} -@end ifclear -@ifset vms -@command{gnatpp test.adb /NAME_CASING=MIXED_CASE /DICTIONARY=(dict1, dict2)} -@end ifset -@end smallexample - -@noindent -then we will get the following name casing in the @command{gnatpp} output: - -@smallexample @c ada -@cartouche -procedure Test is - NAME1 : Integer := 1; - Name4_NAME3_Name2 : Integer := 2; - Name2_NAME3_Name4 : Boolean; - Name1_Var : Float; -begin - Name2_NAME3_Name4 := Name4_NAME3_Name2 > NAME1; -end Test; -@end cartouche -@end smallexample - -@c ********************************* -@node The GNAT Metric Tool gnatmetric -@chapter The GNAT Metric Tool @command{gnatmetric} -@findex gnatmetric -@cindex Metric tool - -@noindent -^The @command{gnatmetric} tool^@command{GNAT METRIC}^ is an ASIS-based utility -for computing various program metrics. -It takes an Ada source file as input and generates a file containing the -metrics data as output. Various switches control which -metrics are computed and output. - -@command{gnatmetric} generates and uses the ASIS -tree for the input source and thus requires the input to be syntactically and -semantically legal. -If this condition is not met, @command{gnatmetric} will generate -an error message; no metric information for this file will be -computed and reported. - -If the compilation unit contained in the input source depends semantically -upon units in files located outside the current directory, you have to provide -the source search path when invoking @command{gnatmetric}. -If it depends semantically upon units that are contained -in files with names that do not follow the GNAT file naming rules, you have to -provide the configuration file describing the corresponding naming scheme (see -the description of the @command{gnatmetric} switches below.) -Alternatively, you may use a project file and invoke @command{gnatmetric} -through the @command{gnat} driver. - -The @command{gnatmetric} command has the form - -@smallexample -$ gnatmetric @ovar{switches} @{@var{filename}@} @r{[}-cargs @var{gcc_switches}@r{]} -@end smallexample - -@noindent -where -@itemize @bullet -@item -@var{switches} specify the metrics to compute and define the destination for -the output - -@item -Each @var{filename} is the name (including the extension) of a source -file to process. ``Wildcards'' are allowed, and -the file name may contain path information. -If no @var{filename} is supplied, then the @var{switches} list must contain -at least one -@option{-files} switch (@pxref{Other gnatmetric Switches}). -Including both a @option{-files} switch and one or more -@var{filename} arguments is permitted. - -@item -@samp{-cargs @var{gcc_switches}} is a list of switches for -@command{gcc}. They will be passed on to all compiler invocations made by -@command{gnatmetric} to generate the ASIS trees. Here you can provide -@option{^-I^/INCLUDE_DIRS=^} switches to form the source search path, -and use the @option{-gnatec} switch to set the configuration file. -@end itemize - -@menu -* Switches for gnatmetric:: -@end menu - -@node Switches for gnatmetric -@section Switches for @command{gnatmetric} - -@noindent -The following subsections describe the various switches accepted by -@command{gnatmetric}, organized by category. - -@menu -* Output Files Control:: -* Disable Metrics For Local Units:: -* Specifying a set of metrics to compute:: -* Other gnatmetric Switches:: -* Generate project-wide metrics:: -@end menu - -@node Output Files Control -@subsection Output File Control -@cindex Output file control in @command{gnatmetric} - -@noindent -@command{gnatmetric} has two output formats. It can generate a -textual (human-readable) form, and also XML. By default only textual -output is generated. - -When generating the output in textual form, @command{gnatmetric} creates -for each Ada source file a corresponding text file -containing the computed metrics, except for the case when the set of metrics -specified by gnatmetric parameters consists only of metrics that are computed -for the whole set of analyzed sources, but not for each Ada source. -By default, this file is placed in the same directory as where the source -file is located, and its name is obtained -by appending the ^@file{.metrix}^@file{$METRIX}^ suffix to the name of the -input file. - -All the output information generated in XML format is placed in a single -file. By default this file is placed in the current directory and has the -name ^@file{metrix.xml}^@file{METRIX$XML}^. - -Some of the computed metrics are summed over the units passed to -@command{gnatmetric}; for example, the total number of lines of code. -By default this information is sent to @file{stdout}, but a file -can be specified with the @option{-og} switch. - -The following switches control the @command{gnatmetric} output: - -@table @option -@cindex @option{^-x^/XML^} (@command{gnatmetric}) -@item ^-x^/XML^ -Generate the XML output - -@cindex @option{^-xs^/XSD^} (@command{gnatmetric}) -@item ^-xs^/XSD^ -Generate the XML output and the XML schema file that describes the structure -of the XML metric report, this schema is assigned to the XML file. The schema -file has the same name as the XML output file with @file{.xml} suffix replaced -with @file{.xsd} - -@cindex @option{^-nt^/NO_TEXT^} (@command{gnatmetric}) -@item ^-nt^/NO_TEXT^ -Do not generate the output in text form (implies @option{^-x^/XML^}) - -@cindex @option{^-d^/DIRECTORY^} (@command{gnatmetric}) -@item ^-d @var{output_dir}^/DIRECTORY=@var{output_dir}^ -Put textual files with detailed metrics into @var{output_dir} - -@cindex @option{^-o^/SUFFIX_DETAILS^} (@command{gnatmetric}) -@item ^-o @var{file_suffix}^/SUFFIX_DETAILS=@var{file_suffix}^ -Use @var{file_suffix}, instead of ^@file{.metrix}^@file{$METRIX}^ -in the name of the output file. - -@cindex @option{^-og^/GLOBAL_OUTPUT^} (@command{gnatmetric}) -@item ^-og @var{file_name}^/GLOBAL_OUTPUT=@var{file_name}^ -Put global metrics into @var{file_name} - -@cindex @option{^-ox^/XML_OUTPUT^} (@command{gnatmetric}) -@item ^-ox @var{file_name}^/XML_OUTPUT=@var{file_name}^ -Put the XML output into @var{file_name} (also implies @option{^-x^/XML^}) - -@cindex @option{^-sfn^/SHORT_SOURCE_FILE_NAME^} (@command{gnatmetric}) -@item ^-sfn^/SHORT_SOURCE_FILE_NAME^ -Use ``short'' source file names in the output. (The @command{gnatmetric} -output includes the name(s) of the Ada source file(s) from which the metrics -are computed. By default each name includes the absolute path. The -@option{^-sfn^/SHORT_SOURCE_FILE_NAME^} switch causes @command{gnatmetric} -to exclude all directory information from the file names that are output.) - -@end table - -@node Disable Metrics For Local Units -@subsection Disable Metrics For Local Units -@cindex Disable Metrics For Local Units in @command{gnatmetric} - -@noindent -@command{gnatmetric} relies on the GNAT compilation model @minus{} -one compilation -unit per one source file. It computes line metrics for the whole source -file, and it also computes syntax -and complexity metrics for the file's outermost unit. - -By default, @command{gnatmetric} will also compute all metrics for certain -kinds of locally declared program units: - -@itemize @bullet -@item -subprogram (and generic subprogram) bodies; - -@item -package (and generic package) specs and bodies; - -@item -task object and type specifications and bodies; - -@item -protected object and type specifications and bodies. -@end itemize - -@noindent -These kinds of entities will be referred to as -@emph{eligible local program units}, or simply @emph{eligible local units}, -@cindex Eligible local unit (for @command{gnatmetric}) -in the discussion below. - -Note that a subprogram declaration, generic instantiation, -or renaming declaration only receives metrics -computation when it appear as the outermost entity -in a source file. - -Suppression of metrics computation for eligible local units can be -obtained via the following switch: - -@table @option -@cindex @option{^-n@var{x}^/SUPPRESS^} (@command{gnatmetric}) -@item ^-nolocal^/SUPPRESS=LOCAL_DETAILS^ -Do not compute detailed metrics for eligible local program units - -@end table - -@node Specifying a set of metrics to compute -@subsection Specifying a set of metrics to compute - -@noindent -By default all the metrics are computed and reported. The switches -described in this subsection allow you to control, on an individual -basis, whether metrics are computed and -reported. If at least one positive metric -switch is specified (that is, a switch that defines that a given -metric or set of metrics is to be computed), then only -explicitly specified metrics are reported. - -@menu -* Line Metrics Control:: -* Syntax Metrics Control:: -* Complexity Metrics Control:: -* Object-Oriented Metrics Control:: -@end menu - -@node Line Metrics Control -@subsubsection Line Metrics Control -@cindex Line metrics control in @command{gnatmetric} - -@noindent -For any (legal) source file, and for each of its -eligible local program units, @command{gnatmetric} computes the following -metrics: - -@itemize @bullet -@item -the total number of lines; - -@item -the total number of code lines (i.e., non-blank lines that are not comments) - -@item -the number of comment lines - -@item -the number of code lines containing end-of-line comments; - -@item -the comment percentage: the ratio between the number of lines that contain -comments and the number of all non-blank lines, expressed as a percentage; - -@item -the number of empty lines and lines containing only space characters and/or -format effectors (blank lines) - -@item -the average number of code lines in subprogram bodies, task bodies, entry -bodies and statement sequences in package bodies (this metric is only computed -across the whole set of the analyzed units) - -@end itemize - -@noindent -@command{gnatmetric} sums the values of the line metrics for all the -files being processed and then generates the cumulative results. The tool -also computes for all the files being processed the average number of code -lines in bodies. - -You can use the following switches to select the specific line metrics -to be computed and reported. - -@table @option -@cindex @option{^--lines@var{x}^/LINE_COUNT_METRICS^} (@command{gnatmetric}) - -@ifclear vms -@cindex @option{--no-lines@var{x}} -@end ifclear - -@item ^--lines-all^/LINE_COUNT_METRICS=ALL^ -Report all the line metrics - -@item ^--no-lines-all^/LINE_COUNT_METRICS=NONE^ -Do not report any of line metrics - -@item ^--lines^/LINE_COUNT_METRICS=ALL_LINES^ -Report the number of all lines - -@item ^--no-lines^/LINE_COUNT_METRICS=NOALL_LINES^ -Do not report the number of all lines - -@item ^--lines-code^/LINE_COUNT_METRICS=CODE_LINES^ -Report the number of code lines - -@item ^--no-lines-code^/LINE_COUNT_METRICS=NOCODE_LINES^ -Do not report the number of code lines - -@item ^--lines-comment^/LINE_COUNT_METRICS=COMMENT_LINES^ -Report the number of comment lines - -@item ^--no-lines-comment^/LINE_COUNT_METRICS=NOCOMMENT_LINES^ -Do not report the number of comment lines - -@item ^--lines-eol-comment^/LINE_COUNT_METRICS=CODE_COMMENT_LINES^ -Report the number of code lines containing -end-of-line comments - -@item ^--no-lines-eol-comment^/LINE_COUNT_METRICS=NOCODE_COMMENT_LINES^ -Do not report the number of code lines containing -end-of-line comments - -@item ^--lines-ratio^/LINE_COUNT_METRICS=COMMENT_PERCENTAGE^ -Report the comment percentage in the program text - -@item ^--no-lines-ratio^/LINE_COUNT_METRICS=NOCOMMENT_PERCENTAGE^ -Do not report the comment percentage in the program text - -@item ^--lines-blank^/LINE_COUNT_METRICS=BLANK_LINES^ -Report the number of blank lines - -@item ^--no-lines-blank^/LINE_COUNT_METRICS=NOBLANK_LINES^ -Do not report the number of blank lines - -@item ^--lines-average^/LINE_COUNT_METRICS=AVERAGE_BODY_LINES^ -Report the average number of code lines in subprogram bodies, task bodies, -entry bodies and statement sequences in package bodies. The metric is computed -and reported for the whole set of processed Ada sources only. - -@item ^--no-lines-average^/LINE_COUNT_METRICS=NOAVERAGE_BODY_LINES^ -Do not report the average number of code lines in subprogram bodies, -task bodies, entry bodies and statement sequences in package bodies. - -@end table - -@node Syntax Metrics Control -@subsubsection Syntax Metrics Control -@cindex Syntax metrics control in @command{gnatmetric} - -@noindent -@command{gnatmetric} computes various syntactic metrics for the -outermost unit and for each eligible local unit: - -@table @emph -@item LSLOC (``Logical Source Lines Of Code'') -The total number of declarations and the total number of statements - -@item Maximal static nesting level of inner program units -According to -@cite{Ada Reference Manual}, 10.1(1), ``A program unit is either a -package, a task unit, a protected unit, a -protected entry, a generic unit, or an explicitly declared subprogram other -than an enumeration literal.'' - -@item Maximal nesting level of composite syntactic constructs -This corresponds to the notion of the -maximum nesting level in the GNAT built-in style checks -(@pxref{Style Checking}) -@end table - -@noindent -For the outermost unit in the file, @command{gnatmetric} additionally computes -the following metrics: - -@table @emph -@item Public subprograms -This metric is computed for package specs. It is the -number of subprograms and generic subprograms declared in the visible -part (including the visible part of nested packages, protected objects, and -protected types). - -@item All subprograms -This metric is computed for bodies and subunits. The -metric is equal to a total number of subprogram bodies in the compilation -unit. -Neither generic instantiations nor renamings-as-a-body nor body stubs -are counted. Any subprogram body is counted, independently of its nesting -level and enclosing constructs. Generic bodies and bodies of protected -subprograms are counted in the same way as ``usual'' subprogram bodies. - -@item Public types -This metric is computed for package specs and -generic package declarations. It is the total number of types -that can be referenced from outside this compilation unit, plus the -number of types from all the visible parts of all the visible generic -packages. Generic formal types are not counted. Only types, not subtypes, -are included. - -@noindent -Along with the total number of public types, the following -types are counted and reported separately: - -@itemize @bullet -@item -Abstract types - -@item -Root tagged types (abstract, non-abstract, private, non-private). Type -extensions are @emph{not} counted - -@item -Private types (including private extensions) - -@item -Task types - -@item -Protected types - -@end itemize - -@item All types -This metric is computed for any compilation unit. It is equal to the total -number of the declarations of different types given in the compilation unit. -The private and the corresponding full type declaration are counted as one -type declaration. Incomplete type declarations and generic formal types -are not counted. -No distinction is made among different kinds of types (abstract, -private etc.); the total number of types is computed and reported. - -@end table - -@noindent -By default, all the syntax metrics are computed and reported. You can use the -following switches to select specific syntax metrics. - -@table @option - -@cindex @option{^--syntax@var{x}^/SYNTAX_METRICS^} (@command{gnatmetric}) - -@ifclear vms -@cindex @option{--no-syntax@var{x}} (@command{gnatmetric}) -@end ifclear - -@item ^--syntax-all^/SYNTAX_METRICS=ALL^ -Report all the syntax metrics - -@item ^--no-syntax-all^/SYNTAX_METRICS=NONE^ -Do not report any of syntax metrics - -@item ^--declarations^/SYNTAX_METRICS=DECLARATIONS^ -Report the total number of declarations - -@item ^--no-declarations^/SYNTAX_METRICS=NODECLARATIONS^ -Do not report the total number of declarations - -@item ^--statements^/SYNTAX_METRICS=STATEMENTS^ -Report the total number of statements - -@item ^--no-statements^/SYNTAX_METRICS=NOSTATEMENTS^ -Do not report the total number of statements - -@item ^--public-subprograms^/SYNTAX_METRICS=PUBLIC_SUBPROGRAMS^ -Report the number of public subprograms in a compilation unit - -@item ^--no-public-subprograms^/SYNTAX_METRICS=NOPUBLIC_SUBPROGRAMS^ -Do not report the number of public subprograms in a compilation unit - -@item ^--all-subprograms^/SYNTAX_METRICS=ALL_SUBPROGRAMS^ -Report the number of all the subprograms in a compilation unit - -@item ^--no-all-subprograms^/SYNTAX_METRICS=NOALL_SUBPROGRAMS^ -Do not report the number of all the subprograms in a compilation unit - -@item ^--public-types^/SYNTAX_METRICS=PUBLIC_TYPES^ -Report the number of public types in a compilation unit - -@item ^--no-public-types^/SYNTAX_METRICS=NOPUBLIC_TYPES^ -Do not report the number of public types in a compilation unit - -@item ^--all-types^/SYNTAX_METRICS=ALL_TYPES^ -Report the number of all the types in a compilation unit - -@item ^--no-all-types^/SYNTAX_METRICS=NOALL_TYPES^ -Do not report the number of all the types in a compilation unit - -@item ^--unit-nesting^/SYNTAX_METRICS=UNIT_NESTING^ -Report the maximal program unit nesting level - -@item ^--no-unit-nesting^/SYNTAX_METRICS=UNIT_NESTING_OFF^ -Do not report the maximal program unit nesting level - -@item ^--construct-nesting^/SYNTAX_METRICS=CONSTRUCT_NESTING^ -Report the maximal construct nesting level - -@item ^--no-construct-nesting^/SYNTAX_METRICS=NOCONSTRUCT_NESTING^ -Do not report the maximal construct nesting level - -@end table - -@node Complexity Metrics Control -@subsubsection Complexity Metrics Control -@cindex Complexity metrics control in @command{gnatmetric} - -@noindent -For a program unit that is an executable body (a subprogram body (including -generic bodies), task body, entry body or a package body containing -its own statement sequence) @command{gnatmetric} computes the following -complexity metrics: - -@itemize @bullet -@item -McCabe cyclomatic complexity; - -@item -McCabe essential complexity; - -@item -maximal loop nesting level - -@end itemize - -@noindent -The McCabe complexity metrics are defined -in @url{http://www.mccabe.com/pdf/nist235r.pdf} - -According to McCabe, both control statements and short-circuit control forms -should be taken into account when computing cyclomatic complexity. For each -body, we compute three metric values: - -@itemize @bullet -@item -the complexity introduced by control -statements only, without taking into account short-circuit forms, - -@item -the complexity introduced by short-circuit control forms only, and - -@item -the total -cyclomatic complexity, which is the sum of these two values. -@end itemize - -@noindent -When computing cyclomatic and essential complexity, @command{gnatmetric} skips -the code in the exception handlers and in all the nested program units. - -By default, all the complexity metrics are computed and reported. -For more fine-grained control you can use -the following switches: - -@table @option -@cindex @option{^-complexity@var{x}^/COMPLEXITY_METRICS^} (@command{gnatmetric}) - -@ifclear vms -@cindex @option{--no-complexity@var{x}} -@end ifclear - -@item ^--complexity-all^/COMPLEXITY_METRICS=ALL^ -Report all the complexity metrics - -@item ^--no-complexity-all^/COMPLEXITY_METRICS=NONE^ -Do not report any of complexity metrics - -@item ^--complexity-cyclomatic^/COMPLEXITY_METRICS=CYCLOMATIC^ -Report the McCabe Cyclomatic Complexity - -@item ^--no-complexity-cyclomatic^/COMPLEXITY_METRICS=NOCYCLOMATIC^ -Do not report the McCabe Cyclomatic Complexity - -@item ^--complexity-essential^/COMPLEXITY_METRICS=ESSENTIAL^ -Report the Essential Complexity - -@item ^--no-complexity-essential^/COMPLEXITY_METRICS=NOESSENTIAL^ -Do not report the Essential Complexity - -@item ^--loop-nesting^/COMPLEXITY_METRICS=LOOP_NESTING_ON^ -Report maximal loop nesting level - -@item ^--no-loop-nesting^/COMPLEXITY_METRICS=NOLOOP_NESTING^ -Do not report maximal loop nesting level - -@item ^--complexity-average^/COMPLEXITY_METRICS=AVERAGE_COMPLEXITY^ -Report the average McCabe Cyclomatic Complexity for all the subprogram bodies, -task bodies, entry bodies and statement sequences in package bodies. -The metric is computed and reported for whole set of processed Ada sources -only. - -@item ^--no-complexity-average^/COMPLEXITY_METRICS=NOAVERAGE_COMPLEXITY^ -Do not report the average McCabe Cyclomatic Complexity for all the subprogram -bodies, task bodies, entry bodies and statement sequences in package bodies - -@cindex @option{^-ne^/NO_EXITS_AS_GOTOS^} (@command{gnatmetric}) -@item ^-ne^/NO_EXITS_AS_GOTOS^ -Do not consider @code{exit} statements as @code{goto}s when -computing Essential Complexity - -@item ^--extra-exit-points^/EXTRA_EXIT_POINTS^ -Report the extra exit points for subprogram bodies. As an exit point, this -metric counts @code{return} statements and raise statements in case when the -raised exception is not handled in the same body. In case of a function this -metric subtracts 1 from the number of exit points, because a function body -must contain at least one @code{return} statement. - -@item ^--no-extra-exit-points^/NOEXTRA_EXIT_POINTS^ -Do not report the extra exit points for subprogram bodies -@end table - - -@node Object-Oriented Metrics Control -@subsubsection Object-Oriented Metrics Control -@cindex Object-Oriented metrics control in @command{gnatmetric} - -@noindent -@cindex Coupling metrics (in in @command{gnatmetric}) -Coupling metrics are object-oriented metrics that measure the -dependencies between a given class (or a group of classes) and the -``external world'' (that is, the other classes in the program). In this -subsection the term ``class'' is used in its -traditional object-oriented programming sense -(an instantiable module that contains data and/or method members). -A @emph{category} (of classes) -is a group of closely related classes that are reused and/or -modified together. - -A class @code{K}'s @emph{efferent coupling} is the number of classes -that @code{K} depends upon. -A category's efferent coupling is the number of classes outside the -category that the classes inside the category depend upon. - -A class @code{K}'s @emph{afferent coupling} is the number of classes -that depend upon @code{K}. -A category's afferent coupling is the number of classes outside the -category that depend on classes belonging to the category. - -Ada's implementation of the object-oriented paradigm does not use the -traditional class notion, so the definition of the coupling -metrics for Ada maps the class and class category notions -onto Ada constructs. - -For the coupling metrics, several kinds of modules -- a library package, -a library generic package, and a library generic package instantiation -- -that define a tagged type or an interface type are -considered to be a class. A category consists of a library package (or -a library generic package) that defines a tagged or an interface type, -together with all its descendant (generic) packages that define tagged -or interface types. For any package counted as a class, -its body and subunits (if any) are considered -together with its spec when counting the dependencies, and coupling -metrics are reported for spec units only. For dependencies -between classes, the Ada semantic dependencies are considered. -For coupling metrics, only dependencies on units that are considered as -classes, are considered. - -When computing coupling metrics, @command{gnatmetric} counts only -dependencies between units that are arguments of the gnatmetric call. -Coupling metrics are program-wide (or project-wide) metrics, so to -get a valid result, you should call @command{gnatmetric} for -the whole set of sources that make up your program. It can be done -by calling @command{gnatmetric} from the GNAT driver with @option{-U} -option (see See @ref{The GNAT Driver and Project Files} for details. - -By default, all the coupling metrics are disabled. You can use the following -switches to specify the coupling metrics to be computed and reported: - -@table @option - -@ifclear vms -@cindex @option{--package@var{x}} (@command{gnatmetric}) -@cindex @option{--no-package@var{x}} (@command{gnatmetric}) -@cindex @option{--category@var{x}} (@command{gnatmetric}) -@cindex @option{--no-category@var{x}} (@command{gnatmetric}) -@end ifclear - -@ifset vms -@cindex @option{/COUPLING_METRICS} (@command{gnatmetric}) -@end ifset - -@item ^--coupling-all^/COUPLING_METRICS=ALL^ -Report all the coupling metrics - -@item ^--no-coupling-all^/COUPLING_METRICS=NONE^ -Do not report any of metrics - -@item ^--package-efferent-coupling^/COUPLING_METRICS=PACKAGE_EFFERENT^ -Report package efferent coupling - -@item ^--no-package-efferent-coupling^/COUPLING_METRICS=NOPACKAGE_EFFERENT^ -Do not report package efferent coupling - -@item ^--package-afferent-coupling^/COUPLING_METRICS=PACKAGE_AFFERENT^ -Report package afferent coupling - -@item ^--no-package-afferent-coupling^/COUPLING_METRICS=NOPACKAGE_AFFERENT^ -Do not report package afferent coupling - -@item ^--category-efferent-coupling^/COUPLING_METRICS=CATEGORY_EFFERENT^ -Report category efferent coupling - -@item ^--no-category-efferent-coupling^/COUPLING_METRICS=NOCATEGORY_EFFERENT^ -Do not report category efferent coupling - -@item ^--category-afferent-coupling^/COUPLING_METRICS=CATEGORY_AFFERENT^ -Report category afferent coupling - -@item ^--no-category-afferent-coupling^/COUPLING_METRICS=NOCATEGORY_AFFERENT^ -Do not report category afferent coupling - -@end table - -@node Other gnatmetric Switches -@subsection Other @code{gnatmetric} Switches - -@noindent -Additional @command{gnatmetric} switches are as follows: - -@table @option -@item ^-files @var{filename}^/FILES=@var{filename}^ -@cindex @option{^-files^/FILES^} (@code{gnatmetric}) -Take the argument source files from the specified file. This file should be an -ordinary text file containing file names separated by spaces or -line breaks. You can use this switch more then once in the same call to -@command{gnatmetric}. You also can combine this switch with -an explicit list of files. - -@item ^-v^/VERBOSE^ -@cindex @option{^-v^/VERBOSE^} (@code{gnatmetric}) -Verbose mode; -@command{gnatmetric} generates version information and then -a trace of sources being processed. - -@item ^-dv^/DEBUG_OUTPUT^ -@cindex @option{^-dv^/DEBUG_OUTPUT^} (@code{gnatmetric}) -Debug mode; -@command{gnatmetric} generates various messages useful to understand what -happens during the metrics computation - -@item ^-q^/QUIET^ -@cindex @option{^-q^/QUIET^} (@code{gnatmetric}) -Quiet mode. -@end table - -@node Generate project-wide metrics -@subsection Generate project-wide metrics - -In order to compute metrics on all units of a given project, you can use -the @command{gnat} driver along with the @option{-P} option: -@smallexample - gnat metric -Pproj -@end smallexample - -@noindent -If the project @code{proj} depends upon other projects, you can compute -the metrics on the project closure using the @option{-U} option: -@smallexample - gnat metric -Pproj -U -@end smallexample - -@noindent -Finally, if not all the units are relevant to a particular main -program in the project closure, you can generate metrics for the set -of units needed to create a given main program (unit closure) using -the @option{-U} option followed by the name of the main unit: -@smallexample - gnat metric -Pproj -U main -@end smallexample - - -@c *********************************** -@node File Name Krunching Using gnatkr -@chapter File Name Krunching Using @code{gnatkr} -@findex gnatkr - -@noindent -This chapter discusses the method used by the compiler to shorten -the default file names chosen for Ada units so that they do not -exceed the maximum length permitted. It also describes the -@code{gnatkr} utility that can be used to determine the result of -applying this shortening. -@menu -* About gnatkr:: -* Using gnatkr:: -* Krunching Method:: -* Examples of gnatkr Usage:: -@end menu - -@node About gnatkr -@section About @code{gnatkr} - -@noindent -The default file naming rule in GNAT -is that the file name must be derived from -the unit name. The exact default rule is as follows: -@itemize @bullet -@item -Take the unit name and replace all dots by hyphens. -@item -If such a replacement occurs in the -second character position of a name, and the first character is -^@samp{a}, @samp{g}, @samp{s}, or @samp{i}, ^@samp{A}, @samp{G}, @samp{S}, or @samp{I},^ -then replace the dot by the character -^@samp{~} (tilde)^@samp{$} (dollar sign)^ -instead of a minus. -@end itemize -The reason for this exception is to avoid clashes -with the standard names for children of System, Ada, Interfaces, -and GNAT, which use the prefixes -^@samp{s-}, @samp{a-}, @samp{i-}, and @samp{g-},^@samp{S-}, @samp{A-}, @samp{I-}, and @samp{G-},^ -respectively. - -The @option{^-gnatk^/FILE_NAME_MAX_LENGTH=^@var{nn}} -switch of the compiler activates a ``krunching'' -circuit that limits file names to nn characters (where nn is a decimal -integer). For example, using OpenVMS, -where the maximum file name length is -39, the value of nn is usually set to 39, but if you want to generate -a set of files that would be usable if ported to a system with some -different maximum file length, then a different value can be specified. -The default value of 39 for OpenVMS need not be specified. - -The @code{gnatkr} utility can be used to determine the krunched name for -a given file, when krunched to a specified maximum length. - -@node Using gnatkr -@section Using @code{gnatkr} - -@noindent -The @code{gnatkr} command has the form - -@ifclear vms -@smallexample -$ gnatkr @var{name} @ovar{length} -@end smallexample -@end ifclear - -@ifset vms -@smallexample -$ gnatkr @var{name} /COUNT=nn -@end smallexample -@end ifset - -@noindent -@var{name} is the uncrunched file name, derived from the name of the unit -in the standard manner described in the previous section (i.e., in particular -all dots are replaced by hyphens). The file name may or may not have an -extension (defined as a suffix of the form period followed by arbitrary -characters other than period). If an extension is present then it will -be preserved in the output. For example, when krunching @file{hellofile.ads} -to eight characters, the result will be hellofil.ads. - -Note: for compatibility with previous versions of @code{gnatkr} dots may -appear in the name instead of hyphens, but the last dot will always be -taken as the start of an extension. So if @code{gnatkr} is given an argument -such as @file{Hello.World.adb} it will be treated exactly as if the first -period had been a hyphen, and for example krunching to eight characters -gives the result @file{hellworl.adb}. - -Note that the result is always all lower case (except on OpenVMS where it is -all upper case). Characters of the other case are folded as required. - -@var{length} represents the length of the krunched name. The default -when no argument is given is ^8^39^ characters. A length of zero stands for -unlimited, in other words do not chop except for system files where the -implied crunching length is always eight characters. - -@noindent -The output is the krunched name. The output has an extension only if the -original argument was a file name with an extension. - -@node Krunching Method -@section Krunching Method - -@noindent -The initial file name is determined by the name of the unit that the file -contains. The name is formed by taking the full expanded name of the -unit and replacing the separating dots with hyphens and -using ^lowercase^uppercase^ -for all letters, except that a hyphen in the second character position is -replaced by a ^tilde^dollar sign^ if the first character is -^@samp{a}, @samp{i}, @samp{g}, or @samp{s}^@samp{A}, @samp{I}, @samp{G}, or @samp{S}^. -The extension is @code{.ads} for a -spec and @code{.adb} for a body. -Krunching does not affect the extension, but the file name is shortened to -the specified length by following these rules: - -@itemize @bullet -@item -The name is divided into segments separated by hyphens, tildes or -underscores and all hyphens, tildes, and underscores are -eliminated. If this leaves the name short enough, we are done. - -@item -If the name is too long, the longest segment is located (left-most -if there are two of equal length), and shortened by dropping -its last character. This is repeated until the name is short enough. - -As an example, consider the krunching of @*@file{our-strings-wide_fixed.adb} -to fit the name into 8 characters as required by some operating systems. - -@smallexample -our-strings-wide_fixed 22 -our strings wide fixed 19 -our string wide fixed 18 -our strin wide fixed 17 -our stri wide fixed 16 -our stri wide fixe 15 -our str wide fixe 14 -our str wid fixe 13 -our str wid fix 12 -ou str wid fix 11 -ou st wid fix 10 -ou st wi fix 9 -ou st wi fi 8 -Final file name: oustwifi.adb -@end smallexample - -@item -The file names for all predefined units are always krunched to eight -characters. The krunching of these predefined units uses the following -special prefix replacements: - -@table @file -@item ada- -replaced by @file{^a^A^-} - -@item gnat- -replaced by @file{^g^G^-} - -@item interfaces- -replaced by @file{^i^I^-} - -@item system- -replaced by @file{^s^S^-} -@end table - -These system files have a hyphen in the second character position. That -is why normal user files replace such a character with a -^tilde^dollar sign^, to -avoid confusion with system file names. - -As an example of this special rule, consider -@*@file{ada-strings-wide_fixed.adb}, which gets krunched as follows: - -@smallexample -ada-strings-wide_fixed 22 -a- strings wide fixed 18 -a- string wide fixed 17 -a- strin wide fixed 16 -a- stri wide fixed 15 -a- stri wide fixe 14 -a- str wide fixe 13 -a- str wid fixe 12 -a- str wid fix 11 -a- st wid fix 10 -a- st wi fix 9 -a- st wi fi 8 -Final file name: a-stwifi.adb -@end smallexample -@end itemize - -Of course no file shortening algorithm can guarantee uniqueness over all -possible unit names, and if file name krunching is used then it is your -responsibility to ensure that no name clashes occur. The utility -program @code{gnatkr} is supplied for conveniently determining the -krunched name of a file. - -@node Examples of gnatkr Usage -@section Examples of @code{gnatkr} Usage - -@smallexample -@iftex -@leftskip=0cm -@end iftex -@ifclear vms -$ gnatkr very_long_unit_name.ads --> velounna.ads -$ gnatkr grandparent-parent-child.ads --> grparchi.ads -$ gnatkr Grandparent.Parent.Child.ads --> grparchi.ads -$ gnatkr grandparent-parent-child --> grparchi -@end ifclear -$ gnatkr very_long_unit_name.ads/count=6 --> vlunna.ads -$ gnatkr very_long_unit_name.ads/count=0 --> very_long_unit_name.ads -@end smallexample - -@node Preprocessing Using gnatprep -@chapter Preprocessing Using @code{gnatprep} -@findex gnatprep - -@noindent -This chapter discusses how to use GNAT's @code{gnatprep} utility for simple -preprocessing. -Although designed for use with GNAT, @code{gnatprep} does not depend on any -special GNAT features. -For further discussion of conditional compilation in general, see -@ref{Conditional Compilation}. - -@menu -* Preprocessing Symbols:: -* Using gnatprep:: -* Switches for gnatprep:: -* Form of Definitions File:: -* Form of Input Text for gnatprep:: -@end menu - -@node Preprocessing Symbols -@section Preprocessing Symbols - -@noindent -Preprocessing symbols are defined in definition files and referred to in -sources to be preprocessed. A Preprocessing symbol is an identifier, following -normal Ada (case-insensitive) rules for its syntax, with the restriction that -all characters need to be in the ASCII set (no accented letters). - -@node Using gnatprep -@section Using @code{gnatprep} - -@noindent -To call @code{gnatprep} use - -@smallexample -$ gnatprep @ovar{switches} @var{infile} @var{outfile} @ovar{deffile} -@end smallexample - -@noindent -where -@table @var -@item switches -is an optional sequence of switches as described in the next section. - -@item infile -is the full name of the input file, which is an Ada source -file containing preprocessor directives. - -@item outfile -is the full name of the output file, which is an Ada source -in standard Ada form. When used with GNAT, this file name will -normally have an ads or adb suffix. - -@item deffile -is the full name of a text file containing definitions of -preprocessing symbols to be referenced by the preprocessor. This argument is -optional, and can be replaced by the use of the @option{-D} switch. - -@end table - -@node Switches for gnatprep -@section Switches for @code{gnatprep} - -@table @option -@c !sort! - -@item ^-b^/BLANK_LINES^ -@cindex @option{^-b^/BLANK_LINES^} (@command{gnatprep}) -Causes both preprocessor lines and the lines deleted by -preprocessing to be replaced by blank lines in the output source file, -preserving line numbers in the output file. - -@item ^-c^/COMMENTS^ -@cindex @option{^-c^/COMMENTS^} (@command{gnatprep}) -Causes both preprocessor lines and the lines deleted -by preprocessing to be retained in the output source as comments marked -with the special string @code{"--! "}. This option will result in line numbers -being preserved in the output file. - -@item ^-C^/REPLACE_IN_COMMENTS^ -@cindex @option{^-C^/REPLACE_IN_COMMENTS^} (@command{gnatprep}) -Causes comments to be scanned. Normally comments are ignored by gnatprep. -If this option is specified, then comments are scanned and any $symbol -substitutions performed as in program text. This is particularly useful -when structured comments are used (e.g., when writing programs in the -SPARK dialect of Ada). Note that this switch is not available when -doing integrated preprocessing (it would be useless in this context -since comments are ignored by the compiler in any case). - -@item ^-Dsymbol=value^/ASSOCIATE="symbol=value"^ -@cindex @option{^-D^/ASSOCIATE^} (@command{gnatprep}) -Defines a new preprocessing symbol, associated with value. If no value is given -on the command line, then symbol is considered to be @code{True}. This switch -can be used in place of a definition file. - -@ifset vms -@item /REMOVE -@cindex @option{/REMOVE} (@command{gnatprep}) -This is the default setting which causes lines deleted by preprocessing -to be entirely removed from the output file. -@end ifset - -@item ^-r^/REFERENCE^ -@cindex @option{^-r^/REFERENCE^} (@command{gnatprep}) -Causes a @code{Source_Reference} pragma to be generated that -references the original input file, so that error messages will use -the file name of this original file. The use of this switch implies -that preprocessor lines are not to be removed from the file, so its -use will force @option{^-b^/BLANK_LINES^} mode if -@option{^-c^/COMMENTS^} -has not been specified explicitly. - -Note that if the file to be preprocessed contains multiple units, then -it will be necessary to @code{gnatchop} the output file from -@code{gnatprep}. If a @code{Source_Reference} pragma is present -in the preprocessed file, it will be respected by -@code{gnatchop ^-r^/REFERENCE^} -so that the final chopped files will correctly refer to the original -input source file for @code{gnatprep}. - -@item ^-s^/SYMBOLS^ -@cindex @option{^-s^/SYMBOLS^} (@command{gnatprep}) -Causes a sorted list of symbol names and values to be -listed on the standard output file. - -@item ^-u^/UNDEFINED^ -@cindex @option{^-u^/UNDEFINED^} (@command{gnatprep}) -Causes undefined symbols to be treated as having the value FALSE in the context -of a preprocessor test. In the absence of this option, an undefined symbol in -a @code{#if} or @code{#elsif} test will be treated as an error. - -@end table - -@ifclear vms -@noindent -Note: if neither @option{-b} nor @option{-c} is present, -then preprocessor lines and -deleted lines are completely removed from the output, unless -r is -specified, in which case -b is assumed. -@end ifclear - -@node Form of Definitions File -@section Form of Definitions File - -@noindent -The definitions file contains lines of the form - -@smallexample -symbol := value -@end smallexample - -@noindent -where symbol is a preprocessing symbol, and value is one of the following: - -@itemize @bullet -@item -Empty, corresponding to a null substitution -@item -A string literal using normal Ada syntax -@item -Any sequence of characters from the set -(letters, digits, period, underline). -@end itemize - -@noindent -Comment lines may also appear in the definitions file, starting with -the usual @code{--}, -and comments may be added to the definitions lines. - -@node Form of Input Text for gnatprep -@section Form of Input Text for @code{gnatprep} - -@noindent -The input text may contain preprocessor conditional inclusion lines, -as well as general symbol substitution sequences. - -The preprocessor conditional inclusion commands have the form - -@smallexample -@group -@cartouche -#if @i{expression} @r{[}then@r{]} - lines -#elsif @i{expression} @r{[}then@r{]} - lines -#elsif @i{expression} @r{[}then@r{]} - lines -@dots{} -#else - lines -#end if; -@end cartouche -@end group -@end smallexample - -@noindent -In this example, @i{expression} is defined by the following grammar: -@smallexample -@i{expression} ::= -@i{expression} ::= = "" -@i{expression} ::= = -@i{expression} ::= 'Defined -@i{expression} ::= not @i{expression} -@i{expression} ::= @i{expression} and @i{expression} -@i{expression} ::= @i{expression} or @i{expression} -@i{expression} ::= @i{expression} and then @i{expression} -@i{expression} ::= @i{expression} or else @i{expression} -@i{expression} ::= ( @i{expression} ) -@end smallexample - -The following restriction exists: it is not allowed to have "and" or "or" -following "not" in the same expression without parentheses. For example, this -is not allowed: - -@smallexample - not X or Y -@end smallexample - -This should be one of the following: - -@smallexample - (not X) or Y - not (X or Y) -@end smallexample - -@noindent -For the first test (@i{expression} ::= ) the symbol must have -either the value true or false, that is to say the right-hand of the -symbol definition must be one of the (case-insensitive) literals -@code{True} or @code{False}. If the value is true, then the -corresponding lines are included, and if the value is false, they are -excluded. - -The test (@i{expression} ::= @code{'Defined}) is true only if -the symbol has been defined in the definition file or by a @option{-D} -switch on the command line. Otherwise, the test is false. - -The equality tests are case insensitive, as are all the preprocessor lines. - -If the symbol referenced is not defined in the symbol definitions file, -then the effect depends on whether or not switch @option{-u} -is specified. If so, then the symbol is treated as if it had the value -false and the test fails. If this switch is not specified, then -it is an error to reference an undefined symbol. It is also an error to -reference a symbol that is defined with a value other than @code{True} -or @code{False}. - -The use of the @code{not} operator inverts the sense of this logical test. -The @code{not} operator cannot be combined with the @code{or} or @code{and} -operators, without parentheses. For example, "if not X or Y then" is not -allowed, but "if (not X) or Y then" and "if not (X or Y) then" are. - -The @code{then} keyword is optional as shown - -The @code{#} must be the first non-blank character on a line, but -otherwise the format is free form. Spaces or tabs may appear between -the @code{#} and the keyword. The keywords and the symbols are case -insensitive as in normal Ada code. Comments may be used on a -preprocessor line, but other than that, no other tokens may appear on a -preprocessor line. Any number of @code{elsif} clauses can be present, -including none at all. The @code{else} is optional, as in Ada. - -The @code{#} marking the start of a preprocessor line must be the first -non-blank character on the line, i.e., it must be preceded only by -spaces or horizontal tabs. - -Symbol substitution outside of preprocessor lines is obtained by using -the sequence - -@smallexample -$symbol -@end smallexample - -@noindent -anywhere within a source line, except in a comment or within a -string literal. The identifier -following the @code{$} must match one of the symbols defined in the symbol -definition file, and the result is to substitute the value of the -symbol in place of @code{$symbol} in the output file. - -Note that although the substitution of strings within a string literal -is not possible, it is possible to have a symbol whose defined value is -a string literal. So instead of setting XYZ to @code{hello} and writing: - -@smallexample -Header : String := "$XYZ"; -@end smallexample - -@noindent -you should set XYZ to @code{"hello"} and write: - -@smallexample -Header : String := $XYZ; -@end smallexample - -@noindent -and then the substitution will occur as desired. - -@ifset vms -@node The GNAT Run-Time Library Builder gnatlbr -@chapter The GNAT Run-Time Library Builder @code{gnatlbr} -@findex gnatlbr -@cindex Library builder - -@noindent -@code{gnatlbr} is a tool for rebuilding the GNAT run time with user -supplied configuration pragmas. - -@menu -* Running gnatlbr:: -* Switches for gnatlbr:: -* Examples of gnatlbr Usage:: -@end menu - -@node Running gnatlbr -@section Running @code{gnatlbr} - -@noindent -The @code{gnatlbr} command has the form - -@smallexample -$ GNAT LIBRARY /@r{[}CREATE@r{|}SET@r{|}DELETE@r{]}=directory @r{[}/CONFIG=file@r{]} -@end smallexample - -@node Switches for gnatlbr -@section Switches for @code{gnatlbr} - -@noindent -@code{gnatlbr} recognizes the following switches: - -@table @option -@c !sort! -@item /CREATE=directory -@cindex @code{/CREATE} (@code{gnatlbr}) -Create the new run-time library in the specified directory. - -@item /SET=directory -@cindex @code{/SET} (@code{gnatlbr}) -Make the library in the specified directory the current run-time library. - -@item /DELETE=directory -@cindex @code{/DELETE} (@code{gnatlbr}) -Delete the run-time library in the specified directory. - -@item /CONFIG=file -@cindex @code{/CONFIG} (@code{gnatlbr}) -With /CREATE: Use the configuration pragmas in the specified file when -building the library. - -With /SET: Use the configuration pragmas in the specified file when -compiling. - -@end table - -@node Examples of gnatlbr Usage -@section Example of @code{gnatlbr} Usage - -@smallexample -Contents of VAXFLOAT.ADC: -pragma Float_Representation (VAX_Float); - -$ GNAT LIBRARY /CREATE=[.VAXFLOAT] /CONFIG=VAXFLOAT.ADC - -GNAT LIBRARY rebuilds the run-time library in directory [.VAXFLOAT] - -@end smallexample -@end ifset - -@node The GNAT Library Browser gnatls -@chapter The GNAT Library Browser @code{gnatls} -@findex gnatls -@cindex Library browser - -@noindent -@code{gnatls} is a tool that outputs information about compiled -units. It gives the relationship between objects, unit names and source -files. It can also be used to check the source dependencies of a unit -as well as various characteristics. - -Note: to invoke @code{gnatls} with a project file, use the @code{gnat} -driver (see @ref{The GNAT Driver and Project Files}). - -@menu -* Running gnatls:: -* Switches for gnatls:: -* Examples of gnatls Usage:: -@end menu - -@node Running gnatls -@section Running @code{gnatls} - -@noindent -The @code{gnatls} command has the form - -@smallexample -$ gnatls switches @var{object_or_ali_file} -@end smallexample - -@noindent -The main argument is the list of object or @file{ali} files -(@pxref{The Ada Library Information Files}) -for which information is requested. - -In normal mode, without additional option, @code{gnatls} produces a -four-column listing. Each line represents information for a specific -object. The first column gives the full path of the object, the second -column gives the name of the principal unit in this object, the third -column gives the status of the source and the fourth column gives the -full path of the source representing this unit. -Here is a simple example of use: - -@smallexample -$ gnatls *.o -^./^[]^demo1.o demo1 DIF demo1.adb -^./^[]^demo2.o demo2 OK demo2.adb -^./^[]^hello.o h1 OK hello.adb -^./^[]^instr-child.o instr.child MOK instr-child.adb -^./^[]^instr.o instr OK instr.adb -^./^[]^tef.o tef DIF tef.adb -^./^[]^text_io_example.o text_io_example OK text_io_example.adb -^./^[]^tgef.o tgef DIF tgef.adb -@end smallexample - -@noindent -The first line can be interpreted as follows: the main unit which is -contained in -object file @file{demo1.o} is demo1, whose main source is in -@file{demo1.adb}. Furthermore, the version of the source used for the -compilation of demo1 has been modified (DIF). Each source file has a status -qualifier which can be: - -@table @code -@item OK (unchanged) -The version of the source file used for the compilation of the -specified unit corresponds exactly to the actual source file. - -@item MOK (slightly modified) -The version of the source file used for the compilation of the -specified unit differs from the actual source file but not enough to -require recompilation. If you use gnatmake with the qualifier -@option{^-m (minimal recompilation)^/MINIMAL_RECOMPILATION^}, a file marked -MOK will not be recompiled. - -@item DIF (modified) -No version of the source found on the path corresponds to the source -used to build this object. - -@item ??? (file not found) -No source file was found for this unit. - -@item HID (hidden, unchanged version not first on PATH) -The version of the source that corresponds exactly to the source used -for compilation has been found on the path but it is hidden by another -version of the same source that has been modified. - -@end table - -@node Switches for gnatls -@section Switches for @code{gnatls} - -@noindent -@code{gnatls} recognizes the following switches: - -@table @option -@c !sort! -@cindex @option{--version} @command{gnatls} -Display Copyright and version, then exit disregarding all other options. - -@item --help -@cindex @option{--help} @command{gnatls} -If @option{--version} was not used, display usage, then exit disregarding -all other options. - -@item ^-a^/ALL_UNITS^ -@cindex @option{^-a^/ALL_UNITS^} (@code{gnatls}) -Consider all units, including those of the predefined Ada library. -Especially useful with @option{^-d^/DEPENDENCIES^}. - -@item ^-d^/DEPENDENCIES^ -@cindex @option{^-d^/DEPENDENCIES^} (@code{gnatls}) -List sources from which specified units depend on. - -@item ^-h^/OUTPUT=OPTIONS^ -@cindex @option{^-h^/OUTPUT=OPTIONS^} (@code{gnatls}) -Output the list of options. - -@item ^-o^/OUTPUT=OBJECTS^ -@cindex @option{^-o^/OUTPUT=OBJECTS^} (@code{gnatls}) -Only output information about object files. - -@item ^-s^/OUTPUT=SOURCES^ -@cindex @option{^-s^/OUTPUT=SOURCES^} (@code{gnatls}) -Only output information about source files. - -@item ^-u^/OUTPUT=UNITS^ -@cindex @option{^-u^/OUTPUT=UNITS^} (@code{gnatls}) -Only output information about compilation units. - -@item ^-files^/FILES^=@var{file} -@cindex @option{^-files^/FILES^} (@code{gnatls}) -Take as arguments the files listed in text file @var{file}. -Text file @var{file} may contain empty lines that are ignored. -Each nonempty line should contain the name of an existing file. -Several such switches may be specified simultaneously. - -@item ^-aO^/OBJECT_SEARCH=^@var{dir} -@itemx ^-aI^/SOURCE_SEARCH=^@var{dir} -@itemx ^-I^/SEARCH=^@var{dir} -@itemx ^-I-^/NOCURRENT_DIRECTORY^ -@itemx -nostdinc -@cindex @option{^-aO^/OBJECT_SEARCH^} (@code{gnatls}) -@cindex @option{^-aI^/SOURCE_SEARCH^} (@code{gnatls}) -@cindex @option{^-I^/SEARCH^} (@code{gnatls}) -@cindex @option{^-I-^/NOCURRENT_DIRECTORY^} (@code{gnatls}) -Source path manipulation. Same meaning as the equivalent @command{gnatmake} -flags (@pxref{Switches for gnatmake}). - -@item --RTS=@var{rts-path} -@cindex @option{--RTS} (@code{gnatls}) -Specifies the default location of the runtime library. Same meaning as the -equivalent @command{gnatmake} flag (@pxref{Switches for gnatmake}). - -@item ^-v^/OUTPUT=VERBOSE^ -@cindex @option{^-v^/OUTPUT=VERBOSE^} (@code{gnatls}) -Verbose mode. Output the complete source, object and project paths. Do not use -the default column layout but instead use long format giving as much as -information possible on each requested units, including special -characteristics such as: - -@table @code -@item Preelaborable -The unit is preelaborable in the Ada sense. - -@item No_Elab_Code -No elaboration code has been produced by the compiler for this unit. - -@item Pure -The unit is pure in the Ada sense. - -@item Elaborate_Body -The unit contains a pragma Elaborate_Body. - -@item Remote_Types -The unit contains a pragma Remote_Types. - -@item Shared_Passive -The unit contains a pragma Shared_Passive. - -@item Predefined -This unit is part of the predefined environment and cannot be modified -by the user. - -@item Remote_Call_Interface -The unit contains a pragma Remote_Call_Interface. - -@end table - -@end table - -@node Examples of gnatls Usage -@section Example of @code{gnatls} Usage -@ifclear vms - -@noindent -Example of using the verbose switch. Note how the source and -object paths are affected by the -I switch. - -@smallexample -$ gnatls -v -I.. demo1.o - -GNATLS 5.03w (20041123-34) -Copyright 1997-2004 Free Software Foundation, Inc. - -Source Search Path: - - ../ - /home/comar/local/adainclude/ - -Object Search Path: - - ../ - /home/comar/local/lib/gcc-lib/x86-linux/3.4.3/adalib/ - -Project Search Path: - - /home/comar/local/lib/gnat/ - -./demo1.o - Unit => - Name => demo1 - Kind => subprogram body - Flags => No_Elab_Code - Source => demo1.adb modified -@end smallexample - -@noindent -The following is an example of use of the dependency list. -Note the use of the -s switch -which gives a straight list of source files. This can be useful for -building specialized scripts. - -@smallexample -$ gnatls -d demo2.o -./demo2.o demo2 OK demo2.adb - OK gen_list.ads - OK gen_list.adb - OK instr.ads - OK instr-child.ads - -$ gnatls -d -s -a demo1.o -demo1.adb -/home/comar/local/adainclude/ada.ads -/home/comar/local/adainclude/a-finali.ads -/home/comar/local/adainclude/a-filico.ads -/home/comar/local/adainclude/a-stream.ads -/home/comar/local/adainclude/a-tags.ads -gen_list.ads -gen_list.adb -/home/comar/local/adainclude/gnat.ads -/home/comar/local/adainclude/g-io.ads -instr.ads -/home/comar/local/adainclude/system.ads -/home/comar/local/adainclude/s-exctab.ads -/home/comar/local/adainclude/s-finimp.ads -/home/comar/local/adainclude/s-finroo.ads -/home/comar/local/adainclude/s-secsta.ads -/home/comar/local/adainclude/s-stalib.ads -/home/comar/local/adainclude/s-stoele.ads -/home/comar/local/adainclude/s-stratt.ads -/home/comar/local/adainclude/s-tasoli.ads -/home/comar/local/adainclude/s-unstyp.ads -/home/comar/local/adainclude/unchconv.ads -@end smallexample -@end ifclear - -@ifset vms -@smallexample -GNAT LIST /DEPENDENCIES /OUTPUT=SOURCES /ALL_UNITS DEMO1.ADB - -GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]ada.ads -GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]a-finali.ads -GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]a-filico.ads -GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]a-stream.ads -GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]a-tags.ads -demo1.adb -gen_list.ads -gen_list.adb -GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]gnat.ads -GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]g-io.ads -instr.ads -GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]system.ads -GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]s-exctab.ads -GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]s-finimp.ads -GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]s-finroo.ads -GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]s-secsta.ads -GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]s-stalib.ads -GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]s-stoele.ads -GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]s-stratt.ads -GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]s-tasoli.ads -GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]s-unstyp.ads -GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]unchconv.ads -@end smallexample -@end ifset - -@node Cleaning Up Using gnatclean -@chapter Cleaning Up Using @code{gnatclean} -@findex gnatclean -@cindex Cleaning tool - -@noindent -@code{gnatclean} is a tool that allows the deletion of files produced by the -compiler, binder and linker, including ALI files, object files, tree files, -expanded source files, library files, interface copy source files, binder -generated files and executable files. - -@menu -* Running gnatclean:: -* Switches for gnatclean:: -@c * Examples of gnatclean Usage:: -@end menu - -@node Running gnatclean -@section Running @code{gnatclean} - -@noindent -The @code{gnatclean} command has the form: - -@smallexample -$ gnatclean switches @var{names} -@end smallexample - -@noindent -@var{names} is a list of source file names. Suffixes @code{.^ads^ADS^} and -@code{^adb^ADB^} may be omitted. If a project file is specified using switch -@code{^-P^/PROJECT_FILE=^}, then @var{names} may be completely omitted. - -@noindent -In normal mode, @code{gnatclean} delete the files produced by the compiler and, -if switch @code{^-c^/COMPILER_FILES_ONLY^} is not specified, by the binder and -the linker. In informative-only mode, specified by switch -@code{^-n^/NODELETE^}, the list of files that would have been deleted in -normal mode is listed, but no file is actually deleted. - -@node Switches for gnatclean -@section Switches for @code{gnatclean} - -@noindent -@code{gnatclean} recognizes the following switches: - -@table @option -@c !sort! -@cindex @option{--version} @command{gnatclean} -Display Copyright and version, then exit disregarding all other options. - -@item --help -@cindex @option{--help} @command{gnatclean} -If @option{--version} was not used, display usage, then exit disregarding -all other options. - -@item ^-c^/COMPILER_FILES_ONLY^ -@cindex @option{^-c^/COMPILER_FILES_ONLY^} (@code{gnatclean}) -Only attempt to delete the files produced by the compiler, not those produced -by the binder or the linker. The files that are not to be deleted are library -files, interface copy files, binder generated files and executable files. - -@item ^-D ^/DIRECTORY_OBJECTS=^@var{dir} -@cindex @option{^-D^/DIRECTORY_OBJECTS^} (@code{gnatclean}) -Indicate that ALI and object files should normally be found in directory -@var{dir}. - -@item ^-F^/FULL_PATH_IN_BRIEF_MESSAGES^ -@cindex @option{^-F^/FULL_PATH_IN_BRIEF_MESSAGES^} (@code{gnatclean}) -When using project files, if some errors or warnings are detected during -parsing and verbose mode is not in effect (no use of switch -^-v^/VERBOSE^), then error lines start with the full path name of the project -file, rather than its simple file name. - -@item ^-h^/HELP^ -@cindex @option{^-h^/HELP^} (@code{gnatclean}) -Output a message explaining the usage of @code{^gnatclean^gnatclean^}. - -@item ^-n^/NODELETE^ -@cindex @option{^-n^/NODELETE^} (@code{gnatclean}) -Informative-only mode. Do not delete any files. Output the list of the files -that would have been deleted if this switch was not specified. - -@item ^-P^/PROJECT_FILE=^@var{project} -@cindex @option{^-P^/PROJECT_FILE^} (@code{gnatclean}) -Use project file @var{project}. Only one such switch can be used. -When cleaning a project file, the files produced by the compilation of the -immediate sources or inherited sources of the project files are to be -deleted. This is not depending on the presence or not of executable names -on the command line. - -@item ^-q^/QUIET^ -@cindex @option{^-q^/QUIET^} (@code{gnatclean}) -Quiet output. If there are no errors, do not output anything, except in -verbose mode (switch ^-v^/VERBOSE^) or in informative-only mode -(switch ^-n^/NODELETE^). - -@item ^-r^/RECURSIVE^ -@cindex @option{^-r^/RECURSIVE^} (@code{gnatclean}) -When a project file is specified (using switch ^-P^/PROJECT_FILE=^), -clean all imported and extended project files, recursively. If this switch -is not specified, only the files related to the main project file are to be -deleted. This switch has no effect if no project file is specified. - -@item ^-v^/VERBOSE^ -@cindex @option{^-v^/VERBOSE^} (@code{gnatclean}) -Verbose mode. - -@item ^-vP^/MESSAGES_PROJECT_FILE=^@emph{x} -@cindex @option{^-vP^/MESSAGES_PROJECT_FILE^} (@code{gnatclean}) -Indicates the verbosity of the parsing of GNAT project files. -@xref{Switches Related to Project Files}. - -@item ^-X^/EXTERNAL_REFERENCE=^@var{name=value} -@cindex @option{^-X^/EXTERNAL_REFERENCE^} (@code{gnatclean}) -Indicates that external variable @var{name} has the value @var{value}. -The Project Manager will use this value for occurrences of -@code{external(name)} when parsing the project file. -@xref{Switches Related to Project Files}. - -@item ^-aO^/OBJECT_SEARCH=^@var{dir} -@cindex @option{^-aO^/OBJECT_SEARCH^} (@code{gnatclean}) -When searching for ALI and object files, look in directory -@var{dir}. - -@item ^-I^/SEARCH=^@var{dir} -@cindex @option{^-I^/SEARCH^} (@code{gnatclean}) -Equivalent to @option{^-aO^/OBJECT_SEARCH=^@var{dir}}. - -@item ^-I-^/NOCURRENT_DIRECTORY^ -@cindex @option{^-I-^/NOCURRENT_DIRECTORY^} (@code{gnatclean}) -@cindex Source files, suppressing search -Do not look for ALI or object files in the directory -where @code{gnatclean} was invoked. - -@end table - -@c @node Examples of gnatclean Usage -@c @section Examples of @code{gnatclean} Usage - -@ifclear vms -@node GNAT and Libraries -@chapter GNAT and Libraries -@cindex Library, building, installing, using - -@noindent -This chapter describes how to build and use libraries with GNAT, and also shows -how to recompile the GNAT run-time library. You should be familiar with the -Project Manager facility (@pxref{GNAT Project Manager}) before reading this -chapter. - -@menu -* Introduction to Libraries in GNAT:: -* General Ada Libraries:: -* Stand-alone Ada Libraries:: -* Rebuilding the GNAT Run-Time Library:: -@end menu - -@node Introduction to Libraries in GNAT -@section Introduction to Libraries in GNAT - -@noindent -A library is, conceptually, a collection of objects which does not have its -own main thread of execution, but rather provides certain services to the -applications that use it. A library can be either statically linked with the -application, in which case its code is directly included in the application, -or, on platforms that support it, be dynamically linked, in which case -its code is shared by all applications making use of this library. - -GNAT supports both types of libraries. -In the static case, the compiled code can be provided in different ways. The -simplest approach is to provide directly the set of objects resulting from -compilation of the library source files. Alternatively, you can group the -objects into an archive using whatever commands are provided by the operating -system. For the latter case, the objects are grouped into a shared library. - -In the GNAT environment, a library has three types of components: -@itemize @bullet -@item -Source files. -@item -@file{ALI} files. -@xref{The Ada Library Information Files}. -@item -Object files, an archive or a shared library. -@end itemize - -@noindent -A GNAT library may expose all its source files, which is useful for -documentation purposes. Alternatively, it may expose only the units needed by -an external user to make use of the library. That is to say, the specs -reflecting the library services along with all the units needed to compile -those specs, which can include generic bodies or any body implementing an -inlined routine. In the case of @emph{stand-alone libraries} those exposed -units are called @emph{interface units} (@pxref{Stand-alone Ada Libraries}). - -All compilation units comprising an application, including those in a library, -need to be elaborated in an order partially defined by Ada's semantics. GNAT -computes the elaboration order from the @file{ALI} files and this is why they -constitute a mandatory part of GNAT libraries. -@emph{Stand-alone libraries} are the exception to this rule because a specific -library elaboration routine is produced independently of the application(s) -using the library. - -@node General Ada Libraries -@section General Ada Libraries - -@menu -* Building a library:: -* Installing a library:: -* Using a library:: -@end menu - -@node Building a library -@subsection Building a library - -@noindent -The easiest way to build a library is to use the Project Manager, -which supports a special type of project called a @emph{Library Project} -(@pxref{Library Projects}). - -A project is considered a library project, when two project-level attributes -are defined in it: @code{Library_Name} and @code{Library_Dir}. In order to -control different aspects of library configuration, additional optional -project-level attributes can be specified: -@table @code -@item Library_Kind -This attribute controls whether the library is to be static or dynamic - -@item Library_Version -This attribute specifies the library version; this value is used -during dynamic linking of shared libraries to determine if the currently -installed versions of the binaries are compatible. - -@item Library_Options -@item Library_GCC -These attributes specify additional low-level options to be used during -library generation, and redefine the actual application used to generate -library. -@end table - -@noindent -The GNAT Project Manager takes full care of the library maintenance task, -including recompilation of the source files for which objects do not exist -or are not up to date, assembly of the library archive, and installation of -the library (i.e., copying associated source, object and @file{ALI} files -to the specified location). - -Here is a simple library project file: -@smallexample @c ada -project My_Lib is - for Source_Dirs use ("src1", "src2"); - for Object_Dir use "obj"; - for Library_Name use "mylib"; - for Library_Dir use "lib"; - for Library_Kind use "dynamic"; -end My_lib; -@end smallexample - -@noindent -and the compilation command to build and install the library: - -@smallexample @c ada - $ gnatmake -Pmy_lib -@end smallexample - -@noindent -It is not entirely trivial to perform manually all the steps required to -produce a library. We recommend that you use the GNAT Project Manager -for this task. In special cases where this is not desired, the necessary -steps are discussed below. - -There are various possibilities for compiling the units that make up the -library: for example with a Makefile (@pxref{Using the GNU make Utility}) or -with a conventional script. For simple libraries, it is also possible to create -a dummy main program which depends upon all the packages that comprise the -interface of the library. This dummy main program can then be given to -@command{gnatmake}, which will ensure that all necessary objects are built. - -After this task is accomplished, you should follow the standard procedure -of the underlying operating system to produce the static or shared library. - -Here is an example of such a dummy program: -@smallexample @c ada -@group -with My_Lib.Service1; -with My_Lib.Service2; -with My_Lib.Service3; -procedure My_Lib_Dummy is -begin - null; -end; -@end group -@end smallexample - -@noindent -Here are the generic commands that will build an archive or a shared library. - -@smallexample -# compiling the library -$ gnatmake -c my_lib_dummy.adb - -# we don't need the dummy object itself -$ rm my_lib_dummy.o my_lib_dummy.ali - -# create an archive with the remaining objects -$ ar rc libmy_lib.a *.o -# some systems may require "ranlib" to be run as well - -# or create a shared library -$ gcc -shared -o libmy_lib.so *.o -# some systems may require the code to have been compiled with -fPIC - -# remove the object files that are now in the library -$ rm *.o - -# Make the ALI files read-only so that gnatmake will not try to -# regenerate the objects that are in the library -$ chmod -w *.ali -@end smallexample - -@noindent -Please note that the library must have a name of the form @file{lib@var{xxx}.a} -or @file{lib@var{xxx}.so} (or @file{lib@var{xxx}.dll} on Windows) in order to -be accessed by the directive @option{-l@var{xxx}} at link time. - -@node Installing a library -@subsection Installing a library -@cindex @code{ADA_PROJECT_PATH} -@cindex @code{GPR_PROJECT_PATH} - -@noindent -If you use project files, library installation is part of the library build -process. Thus no further action is needed in order to make use of the -libraries that are built as part of the general application build. A usable -version of the library is installed in the directory specified by the -@code{Library_Dir} attribute of the library project file. - -You may want to install a library in a context different from where the library -is built. This situation arises with third party suppliers, who may want -to distribute a library in binary form where the user is not expected to be -able to recompile the library. The simplest option in this case is to provide -a project file slightly different from the one used to build the library, by -using the @code{externally_built} attribute. For instance, the project -file used to build the library in the previous section can be changed into the -following one when the library is installed: - -@smallexample @c projectfile -project My_Lib is - for Source_Dirs use ("src1", "src2"); - for Library_Name use "mylib"; - for Library_Dir use "lib"; - for Library_Kind use "dynamic"; - for Externally_Built use "true"; -end My_lib; -@end smallexample - -@noindent -This project file assumes that the directories @file{src1}, -@file{src2}, and @file{lib} exist in -the directory containing the project file. The @code{externally_built} -attribute makes it clear to the GNAT builder that it should not attempt to -recompile any of the units from this library. It allows the library provider to -restrict the source set to the minimum necessary for clients to make use of the -library as described in the first section of this chapter. It is the -responsibility of the library provider to install the necessary sources, ALI -files and libraries in the directories mentioned in the project file. For -convenience, the user's library project file should be installed in a location -that will be searched automatically by the GNAT -builder. These are the directories referenced in the @env{GPR_PROJECT_PATH} -environment variable (@pxref{Importing Projects}), and also the default GNAT -library location that can be queried with @command{gnatls -v} and is usually of -the form $gnat_install_root/lib/gnat. - -When project files are not an option, it is also possible, but not recommended, -to install the library so that the sources needed to use the library are on the -Ada source path and the ALI files & libraries be on the Ada Object path (see -@ref{Search Paths and the Run-Time Library (RTL)}. Alternatively, the system -administrator can place general-purpose libraries in the default compiler -paths, by specifying the libraries' location in the configuration files -@file{ada_source_path} and @file{ada_object_path}. These configuration files -must be located in the GNAT installation tree at the same place as the gcc spec -file. The location of the gcc spec file can be determined as follows: -@smallexample -$ gcc -v -@end smallexample - -@noindent -The configuration files mentioned above have a simple format: each line -must contain one unique directory name. -Those names are added to the corresponding path -in their order of appearance in the file. The names can be either absolute -or relative; in the latter case, they are relative to where theses files -are located. - -The files @file{ada_source_path} and @file{ada_object_path} might not be -present in a -GNAT installation, in which case, GNAT will look for its run-time library in -the directories @file{adainclude} (for the sources) and @file{adalib} (for the -objects and @file{ALI} files). When the files exist, the compiler does not -look in @file{adainclude} and @file{adalib}, and thus the -@file{ada_source_path} file -must contain the location for the GNAT run-time sources (which can simply -be @file{adainclude}). In the same way, the @file{ada_object_path} file must -contain the location for the GNAT run-time objects (which can simply -be @file{adalib}). - -You can also specify a new default path to the run-time library at compilation -time with the switch @option{--RTS=rts-path}. You can thus choose / change -the run-time library you want your program to be compiled with. This switch is -recognized by @command{gcc}, @command{gnatmake}, @command{gnatbind}, -@command{gnatls}, @command{gnatfind} and @command{gnatxref}. - -It is possible to install a library before or after the standard GNAT -library, by reordering the lines in the configuration files. In general, a -library must be installed before the GNAT library if it redefines -any part of it. - -@node Using a library -@subsection Using a library - -@noindent Once again, the project facility greatly simplifies the use of -libraries. In this context, using a library is just a matter of adding a -@code{with} clause in the user project. For instance, to make use of the -library @code{My_Lib} shown in examples in earlier sections, you can -write: - -@smallexample @c projectfile -with "my_lib"; -project My_Proj is - @dots{} -end My_Proj; -@end smallexample - -Even if you have a third-party, non-Ada library, you can still use GNAT's -Project Manager facility to provide a wrapper for it. For example, the -following project, when @code{with}ed by your main project, will link with the -third-party library @file{liba.a}: - -@smallexample @c projectfile -@group -project Liba is - for Externally_Built use "true"; - for Source_Files use (); - for Library_Dir use "lib"; - for Library_Name use "a"; - for Library_Kind use "static"; -end Liba; -@end group -@end smallexample -This is an alternative to the use of @code{pragma Linker_Options}. It is -especially interesting in the context of systems with several interdependent -static libraries where finding a proper linker order is not easy and best be -left to the tools having visibility over project dependence information. - -@noindent -In order to use an Ada library manually, you need to make sure that this -library is on both your source and object path -(see @ref{Search Paths and the Run-Time Library (RTL)} -and @ref{Search Paths for gnatbind}). Furthermore, when the objects are grouped -in an archive or a shared library, you need to specify the desired -library at link time. - -For example, you can use the library @file{mylib} installed in -@file{/dir/my_lib_src} and @file{/dir/my_lib_obj} with the following commands: - -@smallexample -$ gnatmake -aI/dir/my_lib_src -aO/dir/my_lib_obj my_appl \ - -largs -lmy_lib -@end smallexample - -@noindent -This can be expressed more simply: -@smallexample -$ gnatmake my_appl -@end smallexample -@noindent -when the following conditions are met: -@itemize @bullet -@item -@file{/dir/my_lib_src} has been added by the user to the environment -variable @env{ADA_INCLUDE_PATH}, or by the administrator to the file -@file{ada_source_path} -@item -@file{/dir/my_lib_obj} has been added by the user to the environment -variable @env{ADA_OBJECTS_PATH}, or by the administrator to the file -@file{ada_object_path} -@item -a pragma @code{Linker_Options} has been added to one of the sources. -For example: - -@smallexample @c ada -pragma Linker_Options ("-lmy_lib"); -@end smallexample -@end itemize - -@node Stand-alone Ada Libraries -@section Stand-alone Ada Libraries -@cindex Stand-alone library, building, using - -@menu -* Introduction to Stand-alone Libraries:: -* Building a Stand-alone Library:: -* Creating a Stand-alone Library to be used in a non-Ada context:: -* Restrictions in Stand-alone Libraries:: -@end menu - -@node Introduction to Stand-alone Libraries -@subsection Introduction to Stand-alone Libraries - -@noindent -A Stand-alone Library (abbreviated ``SAL'') is a library that contains the -necessary code to -elaborate the Ada units that are included in the library. In contrast with -an ordinary library, which consists of all sources, objects and @file{ALI} -files of the -library, a SAL may specify a restricted subset of compilation units -to serve as a library interface. In this case, the fully -self-sufficient set of files will normally consist of an objects -archive, the sources of interface units' specs, and the @file{ALI} -files of interface units. -If an interface spec contains a generic unit or an inlined subprogram, -the body's -source must also be provided; if the units that must be provided in the source -form depend on other units, the source and @file{ALI} files of those must -also be provided. - -The main purpose of a SAL is to minimize the recompilation overhead of client -applications when a new version of the library is installed. Specifically, -if the interface sources have not changed, client applications do not need to -be recompiled. If, furthermore, a SAL is provided in the shared form and its -version, controlled by @code{Library_Version} attribute, is not changed, -then the clients do not need to be relinked. - -SALs also allow the library providers to minimize the amount of library source -text exposed to the clients. Such ``information hiding'' might be useful or -necessary for various reasons. - -Stand-alone libraries are also well suited to be used in an executable whose -main routine is not written in Ada. - -@node Building a Stand-alone Library -@subsection Building a Stand-alone Library - -@noindent -GNAT's Project facility provides a simple way of building and installing -stand-alone libraries; see @ref{Stand-alone Library Projects}. -To be a Stand-alone Library Project, in addition to the two attributes -that make a project a Library Project (@code{Library_Name} and -@code{Library_Dir}; see @ref{Library Projects}), the attribute -@code{Library_Interface} must be defined. For example: - -@smallexample @c projectfile -@group - for Library_Dir use "lib_dir"; - for Library_Name use "dummy"; - for Library_Interface use ("int1", "int1.child"); -@end group -@end smallexample - -@noindent -Attribute @code{Library_Interface} has a non-empty string list value, -each string in the list designating a unit contained in an immediate source -of the project file. - -When a Stand-alone Library is built, first the binder is invoked to build -a package whose name depends on the library name -(@file{^b~dummy.ads/b^B$DUMMY.ADS/B^} in the example above). -This binder-generated package includes initialization and -finalization procedures whose -names depend on the library name (@code{dummyinit} and @code{dummyfinal} -in the example -above). The object corresponding to this package is included in the library. - -You must ensure timely (e.g., prior to any use of interfaces in the SAL) -calling of these procedures if a static SAL is built, or if a shared SAL -is built -with the project-level attribute @code{Library_Auto_Init} set to -@code{"false"}. - -For a Stand-Alone Library, only the @file{ALI} files of the Interface Units -(those that are listed in attribute @code{Library_Interface}) are copied to -the Library Directory. As a consequence, only the Interface Units may be -imported from Ada units outside of the library. If other units are imported, -the binding phase will fail. - -The attribute @code{Library_Src_Dir} may be specified for a -Stand-Alone Library. @code{Library_Src_Dir} is a simple attribute that has a -single string value. Its value must be the path (absolute or relative to the -project directory) of an existing directory. This directory cannot be the -object directory or one of the source directories, but it can be the same as -the library directory. The sources of the Interface -Units of the library that are needed by an Ada client of the library will be -copied to the designated directory, called the Interface Copy directory. -These sources include the specs of the Interface Units, but they may also -include bodies and subunits, when pragmas @code{Inline} or @code{Inline_Always} -are used, or when there is a generic unit in the spec. Before the sources -are copied to the Interface Copy directory, an attempt is made to delete all -files in the Interface Copy directory. - -Building stand-alone libraries by hand is somewhat tedious, but for those -occasions when it is necessary here are the steps that you need to perform: -@itemize @bullet -@item -Compile all library sources. - -@item -Invoke the binder with the switch @option{-n} (No Ada main program), -with all the @file{ALI} files of the interfaces, and -with the switch @option{-L} to give specific names to the @code{init} -and @code{final} procedures. For example: -@smallexample - gnatbind -n int1.ali int2.ali -Lsal1 -@end smallexample - -@item -Compile the binder generated file: -@smallexample - gcc -c b~int2.adb -@end smallexample - -@item -Link the dynamic library with all the necessary object files, -indicating to the linker the names of the @code{init} (and possibly -@code{final}) procedures for automatic initialization (and finalization). -The built library should be placed in a directory different from -the object directory. - -@item -Copy the @code{ALI} files of the interface to the library directory, -add in this copy an indication that it is an interface to a SAL -(i.e., add a word @option{SL} on the line in the @file{ALI} file that starts -with letter ``P'') and make the modified copy of the @file{ALI} file -read-only. -@end itemize - -@noindent -Using SALs is not different from using other libraries -(see @ref{Using a library}). - -@node Creating a Stand-alone Library to be used in a non-Ada context -@subsection Creating a Stand-alone Library to be used in a non-Ada context - -@noindent -It is easy to adapt the SAL build procedure discussed above for use of a SAL in -a non-Ada context. - -The only extra step required is to ensure that library interface subprograms -are compatible with the main program, by means of @code{pragma Export} -or @code{pragma Convention}. - -Here is an example of simple library interface for use with C main program: - -@smallexample @c ada -package My_Package is - - procedure Do_Something; - pragma Export (C, Do_Something, "do_something"); - - procedure Do_Something_Else; - pragma Export (C, Do_Something_Else, "do_something_else"); - -end My_Package; -@end smallexample - -@noindent -On the foreign language side, you must provide a ``foreign'' view of the -library interface; remember that it should contain elaboration routines in -addition to interface subprograms. - -The example below shows the content of @code{mylib_interface.h} (note -that there is no rule for the naming of this file, any name can be used) -@smallexample -/* the library elaboration procedure */ -extern void mylibinit (void); - -/* the library finalization procedure */ -extern void mylibfinal (void); - -/* the interface exported by the library */ -extern void do_something (void); -extern void do_something_else (void); -@end smallexample - -@noindent -Libraries built as explained above can be used from any program, provided -that the elaboration procedures (named @code{mylibinit} in the previous -example) are called before the library services are used. Any number of -libraries can be used simultaneously, as long as the elaboration -procedure of each library is called. - -Below is an example of a C program that uses the @code{mylib} library. - -@smallexample -#include "mylib_interface.h" - -int -main (void) -@{ - /* First, elaborate the library before using it */ - mylibinit (); - - /* Main program, using the library exported entities */ - do_something (); - do_something_else (); - - /* Library finalization at the end of the program */ - mylibfinal (); - return 0; -@} -@end smallexample - -@noindent -Note that invoking any library finalization procedure generated by -@code{gnatbind} shuts down the Ada run-time environment. -Consequently, the -finalization of all Ada libraries must be performed at the end of the program. -No call to these libraries or to the Ada run-time library should be made -after the finalization phase. - -@node Restrictions in Stand-alone Libraries -@subsection Restrictions in Stand-alone Libraries - -@noindent -The pragmas listed below should be used with caution inside libraries, -as they can create incompatibilities with other Ada libraries: -@itemize @bullet -@item pragma @code{Locking_Policy} -@item pragma @code{Queuing_Policy} -@item pragma @code{Task_Dispatching_Policy} -@item pragma @code{Unreserve_All_Interrupts} -@end itemize - -@noindent -When using a library that contains such pragmas, the user must make sure -that all libraries use the same pragmas with the same values. Otherwise, -@code{Program_Error} will -be raised during the elaboration of the conflicting -libraries. The usage of these pragmas and its consequences for the user -should therefore be well documented. - -Similarly, the traceback in the exception occurrence mechanism should be -enabled or disabled in a consistent manner across all libraries. -Otherwise, Program_Error will be raised during the elaboration of the -conflicting libraries. - -If the @code{Version} or @code{Body_Version} -attributes are used inside a library, then you need to -perform a @code{gnatbind} step that specifies all @file{ALI} files in all -libraries, so that version identifiers can be properly computed. -In practice these attributes are rarely used, so this is unlikely -to be a consideration. - -@node Rebuilding the GNAT Run-Time Library -@section Rebuilding the GNAT Run-Time Library -@cindex GNAT Run-Time Library, rebuilding -@cindex Building the GNAT Run-Time Library -@cindex Rebuilding the GNAT Run-Time Library -@cindex Run-Time Library, rebuilding - -@noindent -It may be useful to recompile the GNAT library in various contexts, the -most important one being the use of partition-wide configuration pragmas -such as @code{Normalize_Scalars}. A special Makefile called -@code{Makefile.adalib} is provided to that effect and can be found in -the directory containing the GNAT library. The location of this -directory depends on the way the GNAT environment has been installed and can -be determined by means of the command: - -@smallexample -$ gnatls -v -@end smallexample - -@noindent -The last entry in the object search path usually contains the -gnat library. This Makefile contains its own documentation and in -particular the set of instructions needed to rebuild a new library and -to use it. - -@node Using the GNU make Utility -@chapter Using the GNU @code{make} Utility -@findex make - -@noindent -This chapter offers some examples of makefiles that solve specific -problems. It does not explain how to write a makefile (@pxref{Top,, GNU -make, make, GNU @code{make}}), nor does it try to replace the -@command{gnatmake} utility (@pxref{The GNAT Make Program gnatmake}). - -All the examples in this section are specific to the GNU version of -make. Although @command{make} is a standard utility, and the basic language -is the same, these examples use some advanced features found only in -@code{GNU make}. - -@menu -* Using gnatmake in a Makefile:: -* Automatically Creating a List of Directories:: -* Generating the Command Line Switches:: -* Overcoming Command Line Length Limits:: -@end menu - -@node Using gnatmake in a Makefile -@section Using gnatmake in a Makefile -@findex makefile -@cindex GNU make - -@noindent -Complex project organizations can be handled in a very powerful way by -using GNU make combined with gnatmake. For instance, here is a Makefile -which allows you to build each subsystem of a big project into a separate -shared library. Such a makefile allows you to significantly reduce the link -time of very big applications while maintaining full coherence at -each step of the build process. - -The list of dependencies are handled automatically by -@command{gnatmake}. The Makefile is simply used to call gnatmake in each of -the appropriate directories. - -Note that you should also read the example on how to automatically -create the list of directories -(@pxref{Automatically Creating a List of Directories}) -which might help you in case your project has a lot of subdirectories. - -@smallexample -@iftex -@leftskip=0cm -@font@heightrm=cmr8 -@heightrm -@end iftex -## This Makefile is intended to be used with the following directory -## configuration: -## - The sources are split into a series of csc (computer software components) -## Each of these csc is put in its own directory. -## Their name are referenced by the directory names. -## They will be compiled into shared library (although this would also work -## with static libraries -## - The main program (and possibly other packages that do not belong to any -## csc is put in the top level directory (where the Makefile is). -## toplevel_dir __ first_csc (sources) __ lib (will contain the library) -## \_ second_csc (sources) __ lib (will contain the library) -## \_ @dots{} -## Although this Makefile is build for shared library, it is easy to modify -## to build partial link objects instead (modify the lines with -shared and -## gnatlink below) -## -## With this makefile, you can change any file in the system or add any new -## file, and everything will be recompiled correctly (only the relevant shared -## objects will be recompiled, and the main program will be re-linked). - -# The list of computer software component for your project. This might be -# generated automatically. -CSC_LIST=aa bb cc - -# Name of the main program (no extension) -MAIN=main - -# If we need to build objects with -fPIC, uncomment the following line -#NEED_FPIC=-fPIC - -# The following variable should give the directory containing libgnat.so -# You can get this directory through 'gnatls -v'. This is usually the last -# directory in the Object_Path. -GLIB=@dots{} - -# The directories for the libraries -# (This macro expands the list of CSC to the list of shared libraries, you -# could simply use the expanded form: -# LIB_DIR=aa/lib/libaa.so bb/lib/libbb.so cc/lib/libcc.so -LIB_DIR=$@{foreach dir,$@{CSC_LIST@},$@{dir@}/lib/lib$@{dir@}.so@} - -$@{MAIN@}: objects $@{LIB_DIR@} - gnatbind $@{MAIN@} $@{CSC_LIST:%=-aO%/lib@} -shared - gnatlink $@{MAIN@} $@{CSC_LIST:%=-l%@} - -objects:: - # recompile the sources - gnatmake -c -i $@{MAIN@}.adb $@{NEED_FPIC@} $@{CSC_LIST:%=-I%@} - -# Note: In a future version of GNAT, the following commands will be simplified -# by a new tool, gnatmlib -$@{LIB_DIR@}: - mkdir -p $@{dir $@@ @} - cd $@{dir $@@ @} && gcc -shared -o $@{notdir $@@ @} ../*.o -L$@{GLIB@} -lgnat - cd $@{dir $@@ @} && cp -f ../*.ali . - -# The dependencies for the modules -# Note that we have to force the expansion of *.o, since in some cases -# make won't be able to do it itself. -aa/lib/libaa.so: $@{wildcard aa/*.o@} -bb/lib/libbb.so: $@{wildcard bb/*.o@} -cc/lib/libcc.so: $@{wildcard cc/*.o@} - -# Make sure all of the shared libraries are in the path before starting the -# program -run:: - LD_LIBRARY_PATH=`pwd`/aa/lib:`pwd`/bb/lib:`pwd`/cc/lib ./$@{MAIN@} - -clean:: - $@{RM@} -rf $@{CSC_LIST:%=%/lib@} - $@{RM@} $@{CSC_LIST:%=%/*.ali@} - $@{RM@} $@{CSC_LIST:%=%/*.o@} - $@{RM@} *.o *.ali $@{MAIN@} -@end smallexample - -@node Automatically Creating a List of Directories -@section Automatically Creating a List of Directories - -@noindent -In most makefiles, you will have to specify a list of directories, and -store it in a variable. For small projects, it is often easier to -specify each of them by hand, since you then have full control over what -is the proper order for these directories, which ones should be -included. - -However, in larger projects, which might involve hundreds of -subdirectories, it might be more convenient to generate this list -automatically. - -The example below presents two methods. The first one, although less -general, gives you more control over the list. It involves wildcard -characters, that are automatically expanded by @command{make}. Its -shortcoming is that you need to explicitly specify some of the -organization of your project, such as for instance the directory tree -depth, whether some directories are found in a separate tree, @enddots{} - -The second method is the most general one. It requires an external -program, called @command{find}, which is standard on all Unix systems. All -the directories found under a given root directory will be added to the -list. - -@smallexample -@iftex -@leftskip=0cm -@font@heightrm=cmr8 -@heightrm -@end iftex -# The examples below are based on the following directory hierarchy: -# All the directories can contain any number of files -# ROOT_DIRECTORY -> a -> aa -> aaa -# -> ab -# -> ac -# -> b -> ba -> baa -# -> bb -# -> bc -# This Makefile creates a variable called DIRS, that can be reused any time -# you need this list (see the other examples in this section) - -# The root of your project's directory hierarchy -ROOT_DIRECTORY=. - -#### -# First method: specify explicitly the list of directories -# This allows you to specify any subset of all the directories you need. -#### - -DIRS := a/aa/ a/ab/ b/ba/ - -#### -# Second method: use wildcards -# Note that the argument(s) to wildcard below should end with a '/'. -# Since wildcards also return file names, we have to filter them out -# to avoid duplicate directory names. -# We thus use make's @code{dir} and @code{sort} functions. -# It sets DIRs to the following value (note that the directories aaa and baa -# are not given, unless you change the arguments to wildcard). -# DIRS= ./a/a/ ./b/ ./a/aa/ ./a/ab/ ./a/ac/ ./b/ba/ ./b/bb/ ./b/bc/ -#### - -DIRS := $@{sort $@{dir $@{wildcard $@{ROOT_DIRECTORY@}/*/ - $@{ROOT_DIRECTORY@}/*/*/@}@}@} - -#### -# Third method: use an external program -# This command is much faster if run on local disks, avoiding NFS slowdowns. -# This is the most complete command: it sets DIRs to the following value: -# DIRS= ./a ./a/aa ./a/aa/aaa ./a/ab ./a/ac ./b ./b/ba ./b/ba/baa ./b/bb ./b/bc -#### - -DIRS := $@{shell find $@{ROOT_DIRECTORY@} -type d -print@} - -@end smallexample - -@node Generating the Command Line Switches -@section Generating the Command Line Switches - -@noindent -Once you have created the list of directories as explained in the -previous section (@pxref{Automatically Creating a List of Directories}), -you can easily generate the command line arguments to pass to gnatmake. - -For the sake of completeness, this example assumes that the source path -is not the same as the object path, and that you have two separate lists -of directories. - -@smallexample -# see "Automatically creating a list of directories" to create -# these variables -SOURCE_DIRS= -OBJECT_DIRS= - -GNATMAKE_SWITCHES := $@{patsubst %,-aI%,$@{SOURCE_DIRS@}@} -GNATMAKE_SWITCHES += $@{patsubst %,-aO%,$@{OBJECT_DIRS@}@} - -all: - gnatmake $@{GNATMAKE_SWITCHES@} main_unit -@end smallexample - -@node Overcoming Command Line Length Limits -@section Overcoming Command Line Length Limits - -@noindent -One problem that might be encountered on big projects is that many -operating systems limit the length of the command line. It is thus hard to give -gnatmake the list of source and object directories. - -This example shows how you can set up environment variables, which will -make @command{gnatmake} behave exactly as if the directories had been -specified on the command line, but have a much higher length limit (or -even none on most systems). - -It assumes that you have created a list of directories in your Makefile, -using one of the methods presented in -@ref{Automatically Creating a List of Directories}. -For the sake of completeness, we assume that the object -path (where the ALI files are found) is different from the sources patch. - -Note a small trick in the Makefile below: for efficiency reasons, we -create two temporary variables (SOURCE_LIST and OBJECT_LIST), that are -expanded immediately by @code{make}. This way we overcome the standard -make behavior which is to expand the variables only when they are -actually used. - -On Windows, if you are using the standard Windows command shell, you must -replace colons with semicolons in the assignments to these variables. - -@smallexample -@iftex -@leftskip=0cm -@font@heightrm=cmr8 -@heightrm -@end iftex -# In this example, we create both ADA_INCLUDE_PATH and ADA_OBJECT_PATH. -# This is the same thing as putting the -I arguments on the command line. -# (the equivalent of using -aI on the command line would be to define -# only ADA_INCLUDE_PATH, the equivalent of -aO is ADA_OBJECT_PATH). -# You can of course have different values for these variables. -# -# Note also that we need to keep the previous values of these variables, since -# they might have been set before running 'make' to specify where the GNAT -# library is installed. - -# see "Automatically creating a list of directories" to create these -# variables -SOURCE_DIRS= -OBJECT_DIRS= - -empty:= -space:=$@{empty@} $@{empty@} -SOURCE_LIST := $@{subst $@{space@},:,$@{SOURCE_DIRS@}@} -OBJECT_LIST := $@{subst $@{space@},:,$@{OBJECT_DIRS@}@} -ADA_INCLUDE_PATH += $@{SOURCE_LIST@} -ADA_OBJECT_PATH += $@{OBJECT_LIST@} -export ADA_INCLUDE_PATH -export ADA_OBJECT_PATH - -all: - gnatmake main_unit -@end smallexample -@end ifclear - -@node Memory Management Issues -@chapter Memory Management Issues - -@noindent -This chapter describes some useful memory pools provided in the GNAT library -and in particular the GNAT Debug Pool facility, which can be used to detect -incorrect uses of access values (including ``dangling references''). -@ifclear vms -It also describes the @command{gnatmem} tool, which can be used to track down -``memory leaks''. -@end ifclear - -@menu -* Some Useful Memory Pools:: -* The GNAT Debug Pool Facility:: -@ifclear vms -* The gnatmem Tool:: -@end ifclear -@end menu - -@node Some Useful Memory Pools -@section Some Useful Memory Pools -@findex Memory Pool -@cindex storage, pool - -@noindent -The @code{System.Pool_Global} package offers the Unbounded_No_Reclaim_Pool -storage pool. Allocations use the standard system call @code{malloc} while -deallocations use the standard system call @code{free}. No reclamation is -performed when the pool goes out of scope. For performance reasons, the -standard default Ada allocators/deallocators do not use any explicit storage -pools but if they did, they could use this storage pool without any change in -behavior. That is why this storage pool is used when the user -manages to make the default implicit allocator explicit as in this example: -@smallexample @c ada - type T1 is access Something; - -- no Storage pool is defined for T2 - type T2 is access Something_Else; - for T2'Storage_Pool use T1'Storage_Pool; - -- the above is equivalent to - for T2'Storage_Pool use System.Pool_Global.Global_Pool_Object; -@end smallexample - -@noindent -The @code{System.Pool_Local} package offers the Unbounded_Reclaim_Pool storage -pool. The allocation strategy is similar to @code{Pool_Local}'s -except that the all -storage allocated with this pool is reclaimed when the pool object goes out of -scope. This pool provides a explicit mechanism similar to the implicit one -provided by several Ada 83 compilers for allocations performed through a local -access type and whose purpose was to reclaim memory when exiting the -scope of a given local access. As an example, the following program does not -leak memory even though it does not perform explicit deallocation: - -@smallexample @c ada -with System.Pool_Local; -procedure Pooloc1 is - procedure Internal is - type A is access Integer; - X : System.Pool_Local.Unbounded_Reclaim_Pool; - for A'Storage_Pool use X; - v : A; - begin - for I in 1 .. 50 loop - v := new Integer; - end loop; - end Internal; -begin - for I in 1 .. 100 loop - Internal; - end loop; -end Pooloc1; -@end smallexample - -@noindent -The @code{System.Pool_Size} package implements the Stack_Bounded_Pool used when -@code{Storage_Size} is specified for an access type. -The whole storage for the pool is -allocated at once, usually on the stack at the point where the access type is -elaborated. It is automatically reclaimed when exiting the scope where the -access type is defined. This package is not intended to be used directly by the -user and it is implicitly used for each such declaration: - -@smallexample @c ada - type T1 is access Something; - for T1'Storage_Size use 10_000; -@end smallexample - -@node The GNAT Debug Pool Facility -@section The GNAT Debug Pool Facility -@findex Debug Pool -@cindex storage, pool, memory corruption - -@noindent -The use of unchecked deallocation and unchecked conversion can easily -lead to incorrect memory references. The problems generated by such -references are usually difficult to tackle because the symptoms can be -very remote from the origin of the problem. In such cases, it is -very helpful to detect the problem as early as possible. This is the -purpose of the Storage Pool provided by @code{GNAT.Debug_Pools}. - -In order to use the GNAT specific debugging pool, the user must -associate a debug pool object with each of the access types that may be -related to suspected memory problems. See Ada Reference Manual 13.11. -@smallexample @c ada -type Ptr is access Some_Type; -Pool : GNAT.Debug_Pools.Debug_Pool; -for Ptr'Storage_Pool use Pool; -@end smallexample - -@noindent -@code{GNAT.Debug_Pools} is derived from a GNAT-specific kind of -pool: the @code{Checked_Pool}. Such pools, like standard Ada storage pools, -allow the user to redefine allocation and deallocation strategies. They -also provide a checkpoint for each dereference, through the use of -the primitive operation @code{Dereference} which is implicitly called at -each dereference of an access value. - -Once an access type has been associated with a debug pool, operations on -values of the type may raise four distinct exceptions, -which correspond to four potential kinds of memory corruption: -@itemize @bullet -@item -@code{GNAT.Debug_Pools.Accessing_Not_Allocated_Storage} -@item -@code{GNAT.Debug_Pools.Accessing_Deallocated_Storage} -@item -@code{GNAT.Debug_Pools.Freeing_Not_Allocated_Storage} -@item -@code{GNAT.Debug_Pools.Freeing_Deallocated_Storage } -@end itemize - -@noindent -For types associated with a Debug_Pool, dynamic allocation is performed using -the standard GNAT allocation routine. References to all allocated chunks of -memory are kept in an internal dictionary. Several deallocation strategies are -provided, whereupon the user can choose to release the memory to the system, -keep it allocated for further invalid access checks, or fill it with an easily -recognizable pattern for debug sessions. The memory pattern is the old IBM -hexadecimal convention: @code{16#DEADBEEF#}. - -See the documentation in the file g-debpoo.ads for more information on the -various strategies. - -Upon each dereference, a check is made that the access value denotes a -properly allocated memory location. Here is a complete example of use of -@code{Debug_Pools}, that includes typical instances of memory corruption: -@smallexample @c ada -@iftex -@leftskip=0cm -@end iftex -with Gnat.Io; use Gnat.Io; -with Unchecked_Deallocation; -with Unchecked_Conversion; -with GNAT.Debug_Pools; -with System.Storage_Elements; -with Ada.Exceptions; use Ada.Exceptions; -procedure Debug_Pool_Test is - - type T is access Integer; - type U is access all T; - - P : GNAT.Debug_Pools.Debug_Pool; - for T'Storage_Pool use P; - - procedure Free is new Unchecked_Deallocation (Integer, T); - function UC is new Unchecked_Conversion (U, T); - A, B : aliased T; - - procedure Info is new GNAT.Debug_Pools.Print_Info(Put_Line); +Note that the result is always all lower case (except on OpenVMS where it is +all upper case). Characters of the other case are folded as required. -begin - Info (P); - A := new Integer; - B := new Integer; - B := A; - Info (P); - Free (A); - begin - Put_Line (Integer'Image(B.all)); - exception - when E : others => Put_Line ("raised: " & Exception_Name (E)); - end; - begin - Free (B); - exception - when E : others => Put_Line ("raised: " & Exception_Name (E)); - end; - B := UC(A'Access); - begin - Put_Line (Integer'Image(B.all)); - exception - when E : others => Put_Line ("raised: " & Exception_Name (E)); - end; - begin - Free (B); - exception - when E : others => Put_Line ("raised: " & Exception_Name (E)); - end; - Info (P); -end Debug_Pool_Test; -@end smallexample +@var{length} represents the length of the krunched name. The default +when no argument is given is ^8^39^ characters. A length of zero stands for +unlimited, in other words do not chop except for system files where the +implied crunching length is always eight characters. @noindent -The debug pool mechanism provides the following precise diagnostics on the -execution of this erroneous program: -@smallexample -Debug Pool info: - Total allocated bytes : 0 - Total deallocated bytes : 0 - Current Water Mark: 0 - High Water Mark: 0 - -Debug Pool info: - Total allocated bytes : 8 - Total deallocated bytes : 0 - Current Water Mark: 8 - High Water Mark: 8 - -raised: GNAT.DEBUG_POOLS.ACCESSING_DEALLOCATED_STORAGE -raised: GNAT.DEBUG_POOLS.FREEING_DEALLOCATED_STORAGE -raised: GNAT.DEBUG_POOLS.ACCESSING_NOT_ALLOCATED_STORAGE -raised: GNAT.DEBUG_POOLS.FREEING_NOT_ALLOCATED_STORAGE -Debug Pool info: - Total allocated bytes : 8 - Total deallocated bytes : 4 - Current Water Mark: 4 - High Water Mark: 8 -@end smallexample +The output is the krunched name. The output has an extension only if the +original argument was a file name with an extension. -@ifclear vms -@node The gnatmem Tool -@section The @command{gnatmem} Tool -@findex gnatmem +@node Krunching Method +@section Krunching Method @noindent -The @code{gnatmem} utility monitors dynamic allocation and -deallocation activity in a program, and displays information about -incorrect deallocations and possible sources of memory leaks. -It is designed to work in association with a static runtime library -only and in this context provides three types of information: -@itemize @bullet -@item -General information concerning memory management, such as the total -number of allocations and deallocations, the amount of allocated -memory and the high water mark, i.e.@: the largest amount of allocated -memory in the course of program execution. +The initial file name is determined by the name of the unit that the file +contains. The name is formed by taking the full expanded name of the +unit and replacing the separating dots with hyphens and +using ^lowercase^uppercase^ +for all letters, except that a hyphen in the second character position is +replaced by a ^tilde^dollar sign^ if the first character is +^@samp{a}, @samp{i}, @samp{g}, or @samp{s}^@samp{A}, @samp{I}, @samp{G}, or @samp{S}^. +The extension is @code{.ads} for a +spec and @code{.adb} for a body. +Krunching does not affect the extension, but the file name is shortened to +the specified length by following these rules: +@itemize @bullet @item -Backtraces for all incorrect deallocations, that is to say deallocations -which do not correspond to a valid allocation. +The name is divided into segments separated by hyphens, tildes or +underscores and all hyphens, tildes, and underscores are +eliminated. If this leaves the name short enough, we are done. @item -Information on each allocation that is potentially the origin of a memory -leak. -@end itemize - -@menu -* Running gnatmem:: -* Switches for gnatmem:: -* Example of gnatmem Usage:: -@end menu - -@node Running gnatmem -@subsection Running @code{gnatmem} - -@noindent -@code{gnatmem} makes use of the output created by the special version of -allocation and deallocation routines that record call information. This -allows to obtain accurate dynamic memory usage history at a minimal cost to -the execution speed. Note however, that @code{gnatmem} is not supported on -all platforms (currently, it is supported on AIX, HP-UX, GNU/Linux, -Solaris and Windows NT/2000/XP (x86). - -@noindent -The @code{gnatmem} command has the form - -@smallexample - $ gnatmem @ovar{switches} user_program -@end smallexample - -@noindent -The program must have been linked with the instrumented version of the -allocation and deallocation routines. This is done by linking with the -@file{libgmem.a} library. For correct symbolic backtrace information, -the user program should be compiled with debugging options -(see @ref{Switches for gcc}). For example to build @file{my_program}: - -@smallexample -$ gnatmake -g my_program -largs -lgmem -@end smallexample - -@noindent -As library @file{libgmem.a} contains an alternate body for package -@code{System.Memory}, @file{s-memory.adb} should not be compiled and linked -when an executable is linked with library @file{libgmem.a}. It is then not -recommended to use @command{gnatmake} with switch @option{^-a^/ALL_FILES^}. - -@noindent -When @file{my_program} is executed, the file @file{gmem.out} is produced. -This file contains information about all allocations and deallocations -performed by the program. It is produced by the instrumented allocations and -deallocations routines and will be used by @code{gnatmem}. - -In order to produce symbolic backtrace information for allocations and -deallocations performed by the GNAT run-time library, you need to use a -version of that library that has been compiled with the @option{-g} switch -(see @ref{Rebuilding the GNAT Run-Time Library}). - -Gnatmem must be supplied with the @file{gmem.out} file and the executable to -examine. If the location of @file{gmem.out} file was not explicitly supplied by -@option{-i} switch, gnatmem will assume that this file can be found in the -current directory. For example, after you have executed @file{my_program}, -@file{gmem.out} can be analyzed by @code{gnatmem} using the command: - -@smallexample -$ gnatmem my_program -@end smallexample +If the name is too long, the longest segment is located (left-most +if there are two of equal length), and shortened by dropping +its last character. This is repeated until the name is short enough. -@noindent -This will produce the output with the following format: +As an example, consider the krunching of @*@file{our-strings-wide_fixed.adb} +to fit the name into 8 characters as required by some operating systems. -*************** debut cc @smallexample -$ gnatmem my_program - -Global information ------------------- - Total number of allocations : 45 - Total number of deallocations : 6 - Final Water Mark (non freed mem) : 11.29 Kilobytes - High Water Mark : 11.40 Kilobytes - -. -. -. -Allocation Root # 2 -------------------- - Number of non freed allocations : 11 - Final Water Mark (non freed mem) : 1.16 Kilobytes - High Water Mark : 1.27 Kilobytes - Backtrace : - my_program.adb:23 my_program.alloc -. -. -. +our-strings-wide_fixed 22 +our strings wide fixed 19 +our string wide fixed 18 +our strin wide fixed 17 +our stri wide fixed 16 +our stri wide fixe 15 +our str wide fixe 14 +our str wid fixe 13 +our str wid fix 12 +ou str wid fix 11 +ou st wid fix 10 +ou st wi fix 9 +ou st wi fi 8 +Final file name: oustwifi.adb @end smallexample -The first block of output gives general information. In this case, the -Ada construct ``@code{@b{new}}'' was executed 45 times, and only 6 calls to an -Unchecked_Deallocation routine occurred. - -@noindent -Subsequent paragraphs display information on all allocation roots. -An allocation root is a specific point in the execution of the program -that generates some dynamic allocation, such as a ``@code{@b{new}}'' -construct. This root is represented by an execution backtrace (or subprogram -call stack). By default the backtrace depth for allocations roots is 1, so -that a root corresponds exactly to a source location. The backtrace can -be made deeper, to make the root more specific. - -@node Switches for gnatmem -@subsection Switches for @code{gnatmem} - -@noindent -@code{gnatmem} recognizes the following switches: - -@table @option - -@item -q -@cindex @option{-q} (@code{gnatmem}) -Quiet. Gives the minimum output needed to identify the origin of the -memory leaks. Omits statistical information. - -@item @var{N} -@cindex @var{N} (@code{gnatmem}) -N is an integer literal (usually between 1 and 10) which controls the -depth of the backtraces defining allocation root. The default value for -N is 1. The deeper the backtrace, the more precise the localization of -the root. Note that the total number of roots can depend on this -parameter. This parameter must be specified @emph{before} the name of the -executable to be analyzed, to avoid ambiguity. - -@item -b n -@cindex @option{-b} (@code{gnatmem}) -This switch has the same effect as just depth parameter. +@item +The file names for all predefined units are always krunched to eight +characters. The krunching of these predefined units uses the following +special prefix replacements: -@item -i @var{file} -@cindex @option{-i} (@code{gnatmem}) -Do the @code{gnatmem} processing starting from @file{file}, rather than -@file{gmem.out} in the current directory. +@table @file +@item ada- +replaced by @file{^a^A^-} -@item -m n -@cindex @option{-m} (@code{gnatmem}) -This switch causes @code{gnatmem} to mask the allocation roots that have less -than n leaks. The default value is 1. Specifying the value of 0 will allow to -examine even the roots that didn't result in leaks. +@item gnat- +replaced by @file{^g^G^-} -@item -s order -@cindex @option{-s} (@code{gnatmem}) -This switch causes @code{gnatmem} to sort the allocation roots according to the -specified order of sort criteria, each identified by a single letter. The -currently supported criteria are @code{n, h, w} standing respectively for -number of unfreed allocations, high watermark, and final watermark -corresponding to a specific root. The default order is @code{nwh}. +@item interfaces- +replaced by @file{^i^I^-} +@item system- +replaced by @file{^s^S^-} @end table -@node Example of gnatmem Usage -@subsection Example of @code{gnatmem} Usage - -@noindent -The following example shows the use of @code{gnatmem} -on a simple memory-leaking program. -Suppose that we have the following Ada program: +These system files have a hyphen in the second character position. That +is why normal user files replace such a character with a +^tilde^dollar sign^, to +avoid confusion with system file names. -@smallexample @c ada -@group -@cartouche -with Unchecked_Deallocation; -procedure Test_Gm is +As an example of this special rule, consider +@*@file{ada-strings-wide_fixed.adb}, which gets krunched as follows: - type T is array (1..1000) of Integer; - type Ptr is access T; - procedure Free is new Unchecked_Deallocation (T, Ptr); - A : Ptr; +@smallexample +ada-strings-wide_fixed 22 +a- strings wide fixed 18 +a- string wide fixed 17 +a- strin wide fixed 16 +a- stri wide fixed 15 +a- stri wide fixe 14 +a- str wide fixe 13 +a- str wid fixe 12 +a- str wid fix 11 +a- st wid fix 10 +a- st wi fix 9 +a- st wi fi 8 +Final file name: a-stwifi.adb +@end smallexample +@end itemize - procedure My_Alloc is - begin - A := new T; - end My_Alloc; +Of course no file shortening algorithm can guarantee uniqueness over all +possible unit names, and if file name krunching is used then it is your +responsibility to ensure that no name clashes occur. The utility +program @code{gnatkr} is supplied for conveniently determining the +krunched name of a file. - procedure My_DeAlloc is - B : Ptr := A; - begin - Free (B); - end My_DeAlloc; +@node Examples of gnatkr Usage +@section Examples of @code{gnatkr} Usage -begin - My_Alloc; - for I in 1 .. 5 loop - for J in I .. 5 loop - My_Alloc; - end loop; - My_Dealloc; - end loop; -end; -@end cartouche -@end group +@smallexample +@iftex +@leftskip=0cm +@end iftex +@ifclear vms +$ gnatkr very_long_unit_name.ads --> velounna.ads +$ gnatkr grandparent-parent-child.ads --> grparchi.ads +$ gnatkr Grandparent.Parent.Child.ads --> grparchi.ads +$ gnatkr grandparent-parent-child --> grparchi +@end ifclear +$ gnatkr very_long_unit_name.ads/count=6 --> vlunna.ads +$ gnatkr very_long_unit_name.ads/count=0 --> very_long_unit_name.ads @end smallexample +@node Preprocessing Using gnatprep +@chapter Preprocessing Using @code{gnatprep} +@findex gnatprep + @noindent -The program needs to be compiled with debugging option and linked with -@code{gmem} library: +This chapter discusses how to use GNAT's @code{gnatprep} utility for simple +preprocessing. +Although designed for use with GNAT, @code{gnatprep} does not depend on any +special GNAT features. +For further discussion of conditional compilation in general, see +@ref{Conditional Compilation}. -@smallexample -$ gnatmake -g test_gm -largs -lgmem -@end smallexample +@menu +* Preprocessing Symbols:: +* Using gnatprep:: +* Switches for gnatprep:: +* Form of Definitions File:: +* Form of Input Text for gnatprep:: +@end menu + +@node Preprocessing Symbols +@section Preprocessing Symbols @noindent -Then we execute the program as usual: +Preprocessing symbols are defined in definition files and referred to in +sources to be preprocessed. A Preprocessing symbol is an identifier, following +normal Ada (case-insensitive) rules for its syntax, with the restriction that +all characters need to be in the ASCII set (no accented letters). -@smallexample -$ test_gm -@end smallexample +@node Using gnatprep +@section Using @code{gnatprep} @noindent -Then @code{gnatmem} is invoked simply with +To call @code{gnatprep} use + @smallexample -$ gnatmem test_gm +@c $ gnatprep @ovar{switches} @var{infile} @var{outfile} @ovar{deffile} +@c Expanding @ovar macro inline (explanation in macro def comments) +$ gnatprep @r{[}@var{switches}@r{]} @var{infile} @var{outfile} @r{[}@var{deffile}@r{]} @end smallexample @noindent -which produces the following output (result may vary on different platforms): +where +@table @var +@item switches +is an optional sequence of switches as described in the next section. -@smallexample -Global information ------------------- - Total number of allocations : 18 - Total number of deallocations : 5 - Final Water Mark (non freed mem) : 53.00 Kilobytes - High Water Mark : 56.90 Kilobytes +@item infile +is the full name of the input file, which is an Ada source +file containing preprocessor directives. -Allocation Root # 1 -------------------- - Number of non freed allocations : 11 - Final Water Mark (non freed mem) : 42.97 Kilobytes - High Water Mark : 46.88 Kilobytes - Backtrace : - test_gm.adb:11 test_gm.my_alloc +@item outfile +is the full name of the output file, which is an Ada source +in standard Ada form. When used with GNAT, this file name will +normally have an ads or adb suffix. -Allocation Root # 2 -------------------- - Number of non freed allocations : 1 - Final Water Mark (non freed mem) : 10.02 Kilobytes - High Water Mark : 10.02 Kilobytes - Backtrace : - s-secsta.adb:81 system.secondary_stack.ss_init +@item deffile +is the full name of a text file containing definitions of +preprocessing symbols to be referenced by the preprocessor. This argument is +optional, and can be replaced by the use of the @option{-D} switch. + +@end table + +@node Switches for gnatprep +@section Switches for @code{gnatprep} + +@table @option +@c !sort! + +@item ^-b^/BLANK_LINES^ +@cindex @option{^-b^/BLANK_LINES^} (@command{gnatprep}) +Causes both preprocessor lines and the lines deleted by +preprocessing to be replaced by blank lines in the output source file, +preserving line numbers in the output file. + +@item ^-c^/COMMENTS^ +@cindex @option{^-c^/COMMENTS^} (@command{gnatprep}) +Causes both preprocessor lines and the lines deleted +by preprocessing to be retained in the output source as comments marked +with the special string @code{"--! "}. This option will result in line numbers +being preserved in the output file. + +@item ^-C^/REPLACE_IN_COMMENTS^ +@cindex @option{^-C^/REPLACE_IN_COMMENTS^} (@command{gnatprep}) +Causes comments to be scanned. Normally comments are ignored by gnatprep. +If this option is specified, then comments are scanned and any $symbol +substitutions performed as in program text. This is particularly useful +when structured comments are used (e.g., when writing programs in the +SPARK dialect of Ada). Note that this switch is not available when +doing integrated preprocessing (it would be useless in this context +since comments are ignored by the compiler in any case). + +@item ^-Dsymbol=value^/ASSOCIATE="symbol=value"^ +@cindex @option{^-D^/ASSOCIATE^} (@command{gnatprep}) +Defines a new preprocessing symbol, associated with value. If no value is given +on the command line, then symbol is considered to be @code{True}. This switch +can be used in place of a definition file. + +@ifset vms +@item /REMOVE +@cindex @option{/REMOVE} (@command{gnatprep}) +This is the default setting which causes lines deleted by preprocessing +to be entirely removed from the output file. +@end ifset + +@item ^-r^/REFERENCE^ +@cindex @option{^-r^/REFERENCE^} (@command{gnatprep}) +Causes a @code{Source_Reference} pragma to be generated that +references the original input file, so that error messages will use +the file name of this original file. The use of this switch implies +that preprocessor lines are not to be removed from the file, so its +use will force @option{^-b^/BLANK_LINES^} mode if +@option{^-c^/COMMENTS^} +has not been specified explicitly. + +Note that if the file to be preprocessed contains multiple units, then +it will be necessary to @code{gnatchop} the output file from +@code{gnatprep}. If a @code{Source_Reference} pragma is present +in the preprocessed file, it will be respected by +@code{gnatchop ^-r^/REFERENCE^} +so that the final chopped files will correctly refer to the original +input source file for @code{gnatprep}. + +@item ^-s^/SYMBOLS^ +@cindex @option{^-s^/SYMBOLS^} (@command{gnatprep}) +Causes a sorted list of symbol names and values to be +listed on the standard output file. + +@item ^-u^/UNDEFINED^ +@cindex @option{^-u^/UNDEFINED^} (@command{gnatprep}) +Causes undefined symbols to be treated as having the value FALSE in the context +of a preprocessor test. In the absence of this option, an undefined symbol in +a @code{#if} or @code{#elsif} test will be treated as an error. -Allocation Root # 3 -------------------- - Number of non freed allocations : 1 - Final Water Mark (non freed mem) : 12 Bytes - High Water Mark : 12 Bytes - Backtrace : - s-secsta.adb:181 system.secondary_stack.ss_init -@end smallexample +@end table +@ifclear vms @noindent -Note that the GNAT run time contains itself a certain number of -allocations that have no corresponding deallocation, -as shown here for root #2 and root -#3. This is a normal behavior when the number of non-freed allocations -is one, it allocates dynamic data structures that the run time needs for -the complete lifetime of the program. Note also that there is only one -allocation root in the user program with a single line back trace: -test_gm.adb:11 test_gm.my_alloc, whereas a careful analysis of the -program shows that 'My_Alloc' is called at 2 different points in the -source (line 21 and line 24). If those two allocation roots need to be -distinguished, the backtrace depth parameter can be used: +Note: if neither @option{-b} nor @option{-c} is present, +then preprocessor lines and +deleted lines are completely removed from the output, unless -r is +specified, in which case -b is assumed. +@end ifclear -@smallexample -$ gnatmem 3 test_gm -@end smallexample +@node Form of Definitions File +@section Form of Definitions File @noindent -which will give the following output: +The definitions file contains lines of the form @smallexample -Global information ------------------- - Total number of allocations : 18 - Total number of deallocations : 5 - Final Water Mark (non freed mem) : 53.00 Kilobytes - High Water Mark : 56.90 Kilobytes - -Allocation Root # 1 -------------------- - Number of non freed allocations : 10 - Final Water Mark (non freed mem) : 39.06 Kilobytes - High Water Mark : 42.97 Kilobytes - Backtrace : - test_gm.adb:11 test_gm.my_alloc - test_gm.adb:24 test_gm - b_test_gm.c:52 main - -Allocation Root # 2 -------------------- - Number of non freed allocations : 1 - Final Water Mark (non freed mem) : 10.02 Kilobytes - High Water Mark : 10.02 Kilobytes - Backtrace : - s-secsta.adb:81 system.secondary_stack.ss_init - s-secsta.adb:283 - b_test_gm.c:33 adainit - -Allocation Root # 3 -------------------- - Number of non freed allocations : 1 - Final Water Mark (non freed mem) : 3.91 Kilobytes - High Water Mark : 3.91 Kilobytes - Backtrace : - test_gm.adb:11 test_gm.my_alloc - test_gm.adb:21 test_gm - b_test_gm.c:52 main - -Allocation Root # 4 -------------------- - Number of non freed allocations : 1 - Final Water Mark (non freed mem) : 12 Bytes - High Water Mark : 12 Bytes - Backtrace : - s-secsta.adb:181 system.secondary_stack.ss_init - s-secsta.adb:283 - b_test_gm.c:33 adainit +symbol := value @end smallexample @noindent -The allocation root #1 of the first example has been split in 2 roots #1 -and #3 thanks to the more precise associated backtrace. - -@end ifclear +where symbol is a preprocessing symbol, and value is one of the following: -@node Stack Related Facilities -@chapter Stack Related Facilities +@itemize @bullet +@item +Empty, corresponding to a null substitution +@item +A string literal using normal Ada syntax +@item +Any sequence of characters from the set +(letters, digits, period, underline). +@end itemize @noindent -This chapter describes some useful tools associated with stack -checking and analysis. In -particular, it deals with dynamic and static stack usage measurements. - -@menu -* Stack Overflow Checking:: -* Static Stack Usage Analysis:: -* Dynamic Stack Usage Analysis:: -@end menu +Comment lines may also appear in the definitions file, starting with +the usual @code{--}, +and comments may be added to the definitions lines. -@node Stack Overflow Checking -@section Stack Overflow Checking -@cindex Stack Overflow Checking -@cindex -fstack-check +@node Form of Input Text for gnatprep +@section Form of Input Text for @code{gnatprep} @noindent -For most operating systems, @command{gcc} does not perform stack overflow -checking by default. This means that if the main environment task or -some other task exceeds the available stack space, then unpredictable -behavior will occur. Most native systems offer some level of protection by -adding a guard page at the end of each task stack. This mechanism is usually -not enough for dealing properly with stack overflow situations because -a large local variable could ``jump'' above the guard page. -Furthermore, when the -guard page is hit, there may not be any space left on the stack for executing -the exception propagation code. Enabling stack checking avoids -such situations. +The input text may contain preprocessor conditional inclusion lines, +as well as general symbol substitution sequences. -To activate stack checking, compile all units with the gcc option -@option{-fstack-check}. For example: +The preprocessor conditional inclusion commands have the form @smallexample -gcc -c -fstack-check package1.adb +@group +@cartouche +#if @i{expression} @r{[}then@r{]} + lines +#elsif @i{expression} @r{[}then@r{]} + lines +#elsif @i{expression} @r{[}then@r{]} + lines +@dots{} +#else + lines +#end if; +@end cartouche +@end group @end smallexample @noindent -Units compiled with this option will generate extra instructions to check -that any use of the stack (for procedure calls or for declaring local -variables in declare blocks) does not exceed the available stack space. -If the space is exceeded, then a @code{Storage_Error} exception is raised. - -For declared tasks, the stack size is controlled by the size -given in an applicable @code{Storage_Size} pragma or by the value specified -at bind time with @option{-d} (@pxref{Switches for gnatbind}) or is set to -the default size as defined in the GNAT runtime otherwise. +In this example, @i{expression} is defined by the following grammar: +@smallexample +@i{expression} ::= +@i{expression} ::= = "" +@i{expression} ::= = +@i{expression} ::= 'Defined +@i{expression} ::= not @i{expression} +@i{expression} ::= @i{expression} and @i{expression} +@i{expression} ::= @i{expression} or @i{expression} +@i{expression} ::= @i{expression} and then @i{expression} +@i{expression} ::= @i{expression} or else @i{expression} +@i{expression} ::= ( @i{expression} ) +@end smallexample -For the environment task, the stack size depends on -system defaults and is unknown to the compiler. Stack checking -may still work correctly if a fixed -size stack is allocated, but this cannot be guaranteed. -@ifclear vms -To ensure that a clean exception is signalled for stack -overflow, set the environment variable -@env{GNAT_STACK_LIMIT} to indicate the maximum -stack area that can be used, as in: -@cindex GNAT_STACK_LIMIT +The following restriction exists: it is not allowed to have "and" or "or" +following "not" in the same expression without parentheses. For example, this +is not allowed: @smallexample -SET GNAT_STACK_LIMIT 1600 + not X or Y @end smallexample -@noindent -The limit is given in kilobytes, so the above declaration would -set the stack limit of the environment task to 1.6 megabytes. -Note that the only purpose of this usage is to limit the amount -of stack used by the environment task. If it is necessary to -increase the amount of stack for the environment task, then this -is an operating systems issue, and must be addressed with the -appropriate operating systems commands. -@end ifclear -@ifset vms -To have a fixed size stack in the environment task, the stack must be put -in the P0 address space and its size specified. Use these switches to -create a p0 image: +This should be one of the following: @smallexample -gnatmake my_progs -largs "-Wl,--opt=STACK=4000,/p0image" + (not X) or Y + not (X or Y) @end smallexample @noindent -The quotes are required to keep case. The number after @samp{STACK=} is the -size of the environmental task stack in pagelets (512 bytes). In this example -the stack size is about 2 megabytes. +For the first test (@i{expression} ::= ) the symbol must have +either the value true or false, that is to say the right-hand of the +symbol definition must be one of the (case-insensitive) literals +@code{True} or @code{False}. If the value is true, then the +corresponding lines are included, and if the value is false, they are +excluded. -@noindent -A consequence of the @option{/p0image} qualifier is also to makes RMS buffers -be placed in P0 space. Refer to @cite{HP OpenVMS Linker Utility Manual} for -more details about the @option{/p0image} qualifier and the @option{stack} -option. -@end ifset +The test (@i{expression} ::= @code{'Defined}) is true only if +the symbol has been defined in the definition file or by a @option{-D} +switch on the command line. Otherwise, the test is false. -@node Static Stack Usage Analysis -@section Static Stack Usage Analysis -@cindex Static Stack Usage Analysis -@cindex -fstack-usage +The equality tests are case insensitive, as are all the preprocessor lines. -@noindent -A unit compiled with @option{-fstack-usage} will generate an extra file -that specifies -the maximum amount of stack used, on a per-function basis. -The file has the same -basename as the target object file with a @file{.su} extension. -Each line of this file is made up of three fields: +If the symbol referenced is not defined in the symbol definitions file, +then the effect depends on whether or not switch @option{-u} +is specified. If so, then the symbol is treated as if it had the value +false and the test fails. If this switch is not specified, then +it is an error to reference an undefined symbol. It is also an error to +reference a symbol that is defined with a value other than @code{True} +or @code{False}. -@itemize -@item -The name of the function. -@item -A number of bytes. -@item -One or more qualifiers: @code{static}, @code{dynamic}, @code{bounded}. -@end itemize +The use of the @code{not} operator inverts the sense of this logical test. +The @code{not} operator cannot be combined with the @code{or} or @code{and} +operators, without parentheses. For example, "if not X or Y then" is not +allowed, but "if (not X) or Y then" and "if not (X or Y) then" are. -The second field corresponds to the size of the known part of the function -frame. +The @code{then} keyword is optional as shown + +The @code{#} must be the first non-blank character on a line, but +otherwise the format is free form. Spaces or tabs may appear between +the @code{#} and the keyword. The keywords and the symbols are case +insensitive as in normal Ada code. Comments may be used on a +preprocessor line, but other than that, no other tokens may appear on a +preprocessor line. Any number of @code{elsif} clauses can be present, +including none at all. The @code{else} is optional, as in Ada. -The qualifier @code{static} means that the function frame size -is purely static. -It usually means that all local variables have a static size. -In this case, the second field is a reliable measure of the function stack -utilization. +The @code{#} marking the start of a preprocessor line must be the first +non-blank character on the line, i.e., it must be preceded only by +spaces or horizontal tabs. -The qualifier @code{dynamic} means that the function frame size is not static. -It happens mainly when some local variables have a dynamic size. When this -qualifier appears alone, the second field is not a reliable measure -of the function stack analysis. When it is qualified with @code{bounded}, it -means that the second field is a reliable maximum of the function stack -utilization. +Symbol substitution outside of preprocessor lines is obtained by using +the sequence -@node Dynamic Stack Usage Analysis -@section Dynamic Stack Usage Analysis +@smallexample +$symbol +@end smallexample @noindent -It is possible to measure the maximum amount of stack used by a task, by -adding a switch to @command{gnatbind}, as: +anywhere within a source line, except in a comment or within a +string literal. The identifier +following the @code{$} must match one of the symbols defined in the symbol +definition file, and the result is to substitute the value of the +symbol in place of @code{$symbol} in the output file. + +Note that although the substitution of strings within a string literal +is not possible, it is possible to have a symbol whose defined value is +a string literal. So instead of setting XYZ to @code{hello} and writing: @smallexample -$ gnatbind -u0 file +Header : String := "$XYZ"; @end smallexample @noindent -With this option, at each task termination, its stack usage is output on -@file{stderr}. -It is not always convenient to output the stack usage when the program -is still running. Hence, it is possible to delay this output until program -termination. for a given number of tasks specified as the argument of the -@option{-u} option. For instance: +you should set XYZ to @code{"hello"} and write: @smallexample -$ gnatbind -u100 file +Header : String := $XYZ; @end smallexample @noindent -will buffer the stack usage information of the first 100 tasks to terminate and -output this info at program termination. Results are displayed in four -columns: +and then the substitution will occur as desired. + +@ifset vms +@node The GNAT Run-Time Library Builder gnatlbr +@chapter The GNAT Run-Time Library Builder @code{gnatlbr} +@findex gnatlbr +@cindex Library builder @noindent -Index | Task Name | Stack Size | Stack Usage [Value +/- Variation] +@code{gnatlbr} is a tool for rebuilding the GNAT run time with user +supplied configuration pragmas. + +@menu +* Running gnatlbr:: +* Switches for gnatlbr:: +* Examples of gnatlbr Usage:: +@end menu + +@node Running gnatlbr +@section Running @code{gnatlbr} @noindent -where: +The @code{gnatlbr} command has the form -@table @emph -@item Index -is a number associated with each task. +@smallexample +$ GNAT LIBRARY /@r{[}CREATE@r{|}SET@r{|}DELETE@r{]}=directory @r{[}/CONFIG=file@r{]} +@end smallexample -@item Task Name -is the name of the task analyzed. +@node Switches for gnatlbr +@section Switches for @code{gnatlbr} -@item Stack Size -is the maximum size for the stack. +@noindent +@code{gnatlbr} recognizes the following switches: -@item Stack Usage -is the measure done by the stack analyzer. In order to prevent overflow, the stack -is not entirely analyzed, and it's not possible to know exactly how -much has actually been used. The report thus contains the theoretical stack usage -(Value) and the possible variation (Variation) around this value. +@table @option +@c !sort! +@item /CREATE=directory +@cindex @code{/CREATE} (@code{gnatlbr}) +Create the new run-time library in the specified directory. + +@item /SET=directory +@cindex @code{/SET} (@code{gnatlbr}) +Make the library in the specified directory the current run-time library. + +@item /DELETE=directory +@cindex @code{/DELETE} (@code{gnatlbr}) +Delete the run-time library in the specified directory. + +@item /CONFIG=file +@cindex @code{/CONFIG} (@code{gnatlbr}) +With /CREATE: Use the configuration pragmas in the specified file when +building the library. + +With /SET: Use the configuration pragmas in the specified file when +compiling. @end table -@noindent -The environment task stack, e.g., the stack that contains the main unit, is -only processed when the environment variable GNAT_STACK_LIMIT is set. +@node Examples of gnatlbr Usage +@section Example of @code{gnatlbr} Usage +@smallexample +Contents of VAXFLOAT.ADC: +pragma Float_Representation (VAX_Float); -@c ********************************* -@c * GNATCHECK * -@c ********************************* -@node Verifying Properties Using gnatcheck -@chapter Verifying Properties Using @command{gnatcheck} -@findex gnatcheck -@cindex @command{gnatcheck} +$ GNAT LIBRARY /CREATE=[.VAXFLOAT] /CONFIG=VAXFLOAT.ADC -@noindent -The @command{gnatcheck} tool is an ASIS-based utility that checks properties -of Ada source files according to a given set of semantic rules. -@cindex ASIS +GNAT LIBRARY rebuilds the run-time library in directory [.VAXFLOAT] -In order to check compliance with a given rule, @command{gnatcheck} has to -semantically analyze the Ada sources. -Therefore, checks can only be performed on -legal Ada units. Moreover, when a unit depends semantically upon units located -outside the current directory, the source search path has to be provided when -calling @command{gnatcheck}, either through a specified project file or -through @command{gnatcheck} switches as described below. +@end smallexample +@end ifset -A number of rules are predefined in @command{gnatcheck} and are described -later in this chapter. -You can also add new rules, by modifying the @command{gnatcheck} code and -rebuilding the tool. In order to add a simple rule making some local checks, -a small amount of straightforward ASIS-based programming is usually needed. +@node The GNAT Library Browser gnatls +@chapter The GNAT Library Browser @code{gnatls} +@findex gnatls +@cindex Library browser -Project support for @command{gnatcheck} is provided by the GNAT +@noindent +@code{gnatls} is a tool that outputs information about compiled +units. It gives the relationship between objects, unit names and source +files. It can also be used to check the source dependencies of a unit +as well as various characteristics. + +Note: to invoke @code{gnatls} with a project file, use the @code{gnat} driver (see @ref{The GNAT Driver and Project Files}). -Invoking @command{gnatcheck} on the command line has the form: +@menu +* Running gnatls:: +* Switches for gnatls:: +* Examples of gnatls Usage:: +@end menu + +@node Running gnatls +@section Running @code{gnatls} + +@noindent +The @code{gnatls} command has the form @smallexample -$ gnatcheck @ovar{switches} @{@var{filename}@} - @r{[}^-files^/FILES^=@{@var{arg_list_filename}@}@r{]} - @r{[}-cargs @var{gcc_switches}@r{]} -rules @var{rule_options} +$ gnatls switches @var{object_or_ali_file} @end smallexample @noindent -where -@itemize @bullet -@item -@var{switches} specify the general tool options +The main argument is the list of object or @file{ali} files +(@pxref{The Ada Library Information Files}) +for which information is requested. -@item -Each @var{filename} is the name (including the extension) of a source -file to process. ``Wildcards'' are allowed, and -the file name may contain path information. +In normal mode, without additional option, @code{gnatls} produces a +four-column listing. Each line represents information for a specific +object. The first column gives the full path of the object, the second +column gives the name of the principal unit in this object, the third +column gives the status of the source and the fourth column gives the +full path of the source representing this unit. +Here is a simple example of use: -@item -Each @var{arg_list_filename} is the name (including the extension) of a text -file containing the names of the source files to process, separated by spaces -or line breaks. +@smallexample +$ gnatls *.o +^./^[]^demo1.o demo1 DIF demo1.adb +^./^[]^demo2.o demo2 OK demo2.adb +^./^[]^hello.o h1 OK hello.adb +^./^[]^instr-child.o instr.child MOK instr-child.adb +^./^[]^instr.o instr OK instr.adb +^./^[]^tef.o tef DIF tef.adb +^./^[]^text_io_example.o text_io_example OK text_io_example.adb +^./^[]^tgef.o tgef DIF tgef.adb +@end smallexample -@item -@var{gcc_switches} is a list of switches for -@command{gcc}. They will be passed on to all compiler invocations made by -@command{gnatcheck} to generate the ASIS trees. Here you can provide -@option{^-I^/INCLUDE_DIRS=^} switches to form the source search path, -and use the @option{-gnatec} switch to set the configuration file. +@noindent +The first line can be interpreted as follows: the main unit which is +contained in +object file @file{demo1.o} is demo1, whose main source is in +@file{demo1.adb}. Furthermore, the version of the source used for the +compilation of demo1 has been modified (DIF). Each source file has a status +qualifier which can be: -@item -@var{rule_options} is a list of options for controlling a set of -rules to be checked by @command{gnatcheck} (@pxref{gnatcheck Rule Options}). -@end itemize +@table @code +@item OK (unchanged) +The version of the source file used for the compilation of the +specified unit corresponds exactly to the actual source file. -@noindent -Either a @file{@var{filename}} or an @file{@var{arg_list_filename}} must be -supplied. +@item MOK (slightly modified) +The version of the source file used for the compilation of the +specified unit differs from the actual source file but not enough to +require recompilation. If you use gnatmake with the qualifier +@option{^-m (minimal recompilation)^/MINIMAL_RECOMPILATION^}, a file marked +MOK will not be recompiled. -@menu -* Format of the Report File:: -* General gnatcheck Switches:: -* gnatcheck Rule Options:: -* Adding the Results of Compiler Checks to gnatcheck Output:: -* Project-Wide Checks:: -* Rule exemption:: -* Predefined Rules:: -* Example of gnatcheck Usage:: -@end menu +@item DIF (modified) +No version of the source found on the path corresponds to the source +used to build this object. -@node Format of the Report File -@section Format of the Report File -@cindex Report file (for @code{gnatcheck}) +@item ??? (file not found) +No source file was found for this unit. + +@item HID (hidden, unchanged version not first on PATH) +The version of the source that corresponds exactly to the source used +for compilation has been found on the path but it is hidden by another +version of the same source that has been modified. -@noindent -The @command{gnatcheck} tool outputs on @file{stdout} all messages concerning -rule violations. -It also creates a text file that -contains the complete report of the last gnatcheck run. By default this file -is named named @file{^gnatcheck.out^GNATCHECK.OUT^} and it is located in the -current directory; the @option{^-o^/OUTPUT^} option can be used to change the -name and/or location of the report file. This report contains: -@itemize @bullet -@item date and time of @command{gnatcheck} run, the version of -the tool that has generated this report and the full parameters -of the @command{gnatcheck} invocation; -@item list of enabled rules; -@item total number of detected violations; -@item list of source files where rule violations have been detected; -@item list of source files where no violations have been detected. -@end itemize +@end table -@node General gnatcheck Switches -@section General @command{gnatcheck} Switches +@node Switches for gnatls +@section Switches for @code{gnatls} @noindent -The following switches control the general @command{gnatcheck} behavior +@code{gnatls} recognizes the following switches: @table @option @c !sort! -@cindex @option{^-a^/ALL^} (@command{gnatcheck}) -@item ^-a^/ALL^ -Process all units including those with read-only ALI files such as -those from the GNAT Run-Time library. +@cindex @option{--version} @command{gnatls} +Display Copyright and version, then exit disregarding all other options. -@ifclear vms -@ignore -@cindex @option{-d} (@command{gnatcheck}) -@item -d -Debug mode -@end ignore +@item --help +@cindex @option{--help} @command{gnatls} +If @option{--version} was not used, display usage, then exit disregarding +all other options. -@cindex @option{-dd} (@command{gnatcheck}) -@item -dd -Progress indicator mode (for use in GPS). -@end ifclear +@item ^-a^/ALL_UNITS^ +@cindex @option{^-a^/ALL_UNITS^} (@code{gnatls}) +Consider all units, including those of the predefined Ada library. +Especially useful with @option{^-d^/DEPENDENCIES^}. -@cindex @option{^-h^/HELP^} (@command{gnatcheck}) -@item ^-h^/HELP^ -List the predefined and user-defined rules. For more details see -@ref{Predefined Rules}. +@item ^-d^/DEPENDENCIES^ +@cindex @option{^-d^/DEPENDENCIES^} (@code{gnatls}) +List sources from which specified units depend on. -@cindex @option{^-l^/LOCS^} (@command{gnatcheck}) -@item ^-l^/LOCS^ -Use full source locations references in the report file. For a construct from -a generic instantiation a full source location is a chain from the location -of this construct in the generic unit to the place where this unit is -instantiated. +@item ^-h^/OUTPUT=OPTIONS^ +@cindex @option{^-h^/OUTPUT=OPTIONS^} (@code{gnatls}) +Output the list of options. -@cindex @option{^-log^/LOG^} (@command{gnatcheck}) -@item ^-log^/LOG^ -Duplicate all the output sent to @file{stderr} into a log file. The log file -is named @file{gnatcheck.log} and is located in the current directory. +@item ^-o^/OUTPUT=OBJECTS^ +@cindex @option{^-o^/OUTPUT=OBJECTS^} (@code{gnatls}) +Only output information about object files. -@cindex @option{^-m^/DIAGNOSTIC_LIMIT^} (@command{gnatcheck}) -@item ^-m@i{nnnn}^/DIAGNOSTIC_LIMIT=@i{nnnn}^ -Maximum number of diagnostics to be sent to @file{stdout}, where @i{nnnn} is in -the range 0@dots{}1000; -the default value is 500. Zero means that there is no limitation on -the number of diagnostic messages to be output. +@item ^-s^/OUTPUT=SOURCES^ +@cindex @option{^-s^/OUTPUT=SOURCES^} (@code{gnatls}) +Only output information about source files. -@cindex @option{^-q^/QUIET^} (@command{gnatcheck}) -@item ^-q^/QUIET^ -Quiet mode. All the diagnostics about rule violations are placed in the -@command{gnatcheck} report file only, without duplication on @file{stdout}. +@item ^-u^/OUTPUT=UNITS^ +@cindex @option{^-u^/OUTPUT=UNITS^} (@code{gnatls}) +Only output information about compilation units. -@cindex @option{^-s^/SHORT^} (@command{gnatcheck}) -@item ^-s^/SHORT^ -Short format of the report file (no version information, no list of applied -rules, no list of checked sources is included) +@item ^-files^/FILES^=@var{file} +@cindex @option{^-files^/FILES^} (@code{gnatls}) +Take as arguments the files listed in text file @var{file}. +Text file @var{file} may contain empty lines that are ignored. +Each nonempty line should contain the name of an existing file. +Several such switches may be specified simultaneously. -@cindex @option{^--include-file=@var{file}^/INCLUDE_FILE=@var{file}^} (@command{gnatcheck}) -@item ^--include-file^/INCLUDE_FILE^ -Append the content of the specified text file to the report file +@item ^-aO^/OBJECT_SEARCH=^@var{dir} +@itemx ^-aI^/SOURCE_SEARCH=^@var{dir} +@itemx ^-I^/SEARCH=^@var{dir} +@itemx ^-I-^/NOCURRENT_DIRECTORY^ +@itemx -nostdinc +@cindex @option{^-aO^/OBJECT_SEARCH^} (@code{gnatls}) +@cindex @option{^-aI^/SOURCE_SEARCH^} (@code{gnatls}) +@cindex @option{^-I^/SEARCH^} (@code{gnatls}) +@cindex @option{^-I-^/NOCURRENT_DIRECTORY^} (@code{gnatls}) +Source path manipulation. Same meaning as the equivalent @command{gnatmake} +flags (@pxref{Switches for gnatmake}). -@cindex @option{^-t^/TIME^} (@command{gnatcheck}) -@item ^-t^/TIME^ -Print out execution time. +@item --RTS=@var{rts-path} +@cindex @option{--RTS} (@code{gnatls}) +Specifies the default location of the runtime library. Same meaning as the +equivalent @command{gnatmake} flag (@pxref{Switches for gnatmake}). -@cindex @option{^-v^/VERBOSE^} (@command{gnatcheck}) -@item ^-v^/VERBOSE^ -Verbose mode; @command{gnatcheck} generates version information and then -a trace of sources being processed. +@item ^-v^/OUTPUT=VERBOSE^ +@cindex @option{^-v^/OUTPUT=VERBOSE^} (@code{gnatls}) +Verbose mode. Output the complete source, object and project paths. Do not use +the default column layout but instead use long format giving as much as +information possible on each requested units, including special +characteristics such as: -@cindex @option{^-o ^/OUTPUT^} (@command{gnatcheck}) -@item ^-o ^/OUTPUT=^@var{report_file} -Set name of report file file to @var{report_file} . +@table @code +@item Preelaborable +The unit is preelaborable in the Ada sense. + +@item No_Elab_Code +No elaboration code has been produced by the compiler for this unit. + +@item Pure +The unit is pure in the Ada sense. + +@item Elaborate_Body +The unit contains a pragma Elaborate_Body. + +@item Remote_Types +The unit contains a pragma Remote_Types. + +@item Shared_Passive +The unit contains a pragma Shared_Passive. + +@item Predefined +This unit is part of the predefined environment and cannot be modified +by the user. + +@item Remote_Call_Interface +The unit contains a pragma Remote_Call_Interface. @end table -@noindent -Note that if any of the options @option{^-s1^/COMPILER_STYLE^}, -@option{^-s2^/BY_RULES^} or -@option{^-s3^/BY_FILES_BY_RULES^} is specified, -then the @command{gnatcheck} report file will only contain sections -explicitly denoted by these options. +@end table -@node gnatcheck Rule Options -@section @command{gnatcheck} Rule Options +@node Examples of gnatls Usage +@section Example of @code{gnatls} Usage +@ifclear vms @noindent -The following options control the processing performed by -@command{gnatcheck}. +Example of using the verbose switch. Note how the source and +object paths are affected by the -I switch. -@table @option -@cindex @option{+ALL} (@command{gnatcheck}) -@item +ALL -Turn all the rule checks ON. +@smallexample +$ gnatls -v -I.. demo1.o -@cindex @option{-ALL} (@command{gnatcheck}) -@item -ALL -Turn all the rule checks OFF. +GNATLS 5.03w (20041123-34) +Copyright 1997-2004 Free Software Foundation, Inc. -@cindex @option{+R} (@command{gnatcheck}) -@item +R@var{rule_id}@r{[}:@var{param}@r{]} -Turn on the check for a specified rule with the specified parameter, if any. -@var{rule_id} must be the identifier of one of the currently implemented rules -(use @option{^-h^/HELP^} for the list of implemented rules). Rule identifiers -are not case-sensitive. The @var{param} item must -be a string representing a valid parameter(s) for the specified rule. -If it contains any space characters then this string must be enclosed in -quotation marks. +Source Search Path: + + ../ + /home/comar/local/adainclude/ -@cindex @option{-R} (@command{gnatcheck}) -@item -R@var{rule_id}@r{[}:@var{param}@r{]} -Turn off the check for a specified rule with the specified parameter, if any. +Object Search Path: + + ../ + /home/comar/local/lib/gcc-lib/x86-linux/3.4.3/adalib/ -@cindex @option{-from} (@command{gnatcheck}) -@item -from=@var{rule_option_filename} -Read the rule options from the text file @var{rule_option_filename}, referred -to as a ``coding standard file'' below. +Project Search Path: + + /home/comar/local/lib/gnat/ -@end table +./demo1.o + Unit => + Name => demo1 + Kind => subprogram body + Flags => No_Elab_Code + Source => demo1.adb modified +@end smallexample @noindent -The default behavior is that all the rule checks are disabled. +The following is an example of use of the dependency list. +Note the use of the -s switch +which gives a straight list of source files. This can be useful for +building specialized scripts. -A coding standard file is a text file that contains a set of rule options -described above. -@cindex Coding standard file (for @code{gnatcheck}) -The file may contain empty lines and Ada-style comments (comment -lines and end-of-line comments). There can be several rule options on a -single line (separated by a space). +@smallexample +$ gnatls -d demo2.o +./demo2.o demo2 OK demo2.adb + OK gen_list.ads + OK gen_list.adb + OK instr.ads + OK instr-child.ads + +$ gnatls -d -s -a demo1.o +demo1.adb +/home/comar/local/adainclude/ada.ads +/home/comar/local/adainclude/a-finali.ads +/home/comar/local/adainclude/a-filico.ads +/home/comar/local/adainclude/a-stream.ads +/home/comar/local/adainclude/a-tags.ads +gen_list.ads +gen_list.adb +/home/comar/local/adainclude/gnat.ads +/home/comar/local/adainclude/g-io.ads +instr.ads +/home/comar/local/adainclude/system.ads +/home/comar/local/adainclude/s-exctab.ads +/home/comar/local/adainclude/s-finimp.ads +/home/comar/local/adainclude/s-finroo.ads +/home/comar/local/adainclude/s-secsta.ads +/home/comar/local/adainclude/s-stalib.ads +/home/comar/local/adainclude/s-stoele.ads +/home/comar/local/adainclude/s-stratt.ads +/home/comar/local/adainclude/s-tasoli.ads +/home/comar/local/adainclude/s-unstyp.ads +/home/comar/local/adainclude/unchconv.ads +@end smallexample +@end ifclear -A coding standard file may reference other coding standard files by including -more @option{-from=@var{rule_option_filename}} -options, each such option being replaced with the content of the -corresponding coding standard file during processing. In case a -cycle is detected (that is, @file{@var{rule_file_1}} reads rule options -from @file{@var{rule_file_2}}, and @file{@var{rule_file_2}} reads -(directly or indirectly) rule options from @file{@var{rule_file_1}}), -processing fails with an error message. +@ifset vms +@smallexample +GNAT LIST /DEPENDENCIES /OUTPUT=SOURCES /ALL_UNITS DEMO1.ADB +GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]ada.ads +GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]a-finali.ads +GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]a-filico.ads +GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]a-stream.ads +GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]a-tags.ads +demo1.adb +gen_list.ads +gen_list.adb +GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]gnat.ads +GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]g-io.ads +instr.ads +GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]system.ads +GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]s-exctab.ads +GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]s-finimp.ads +GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]s-finroo.ads +GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]s-secsta.ads +GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]s-stalib.ads +GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]s-stoele.ads +GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]s-stratt.ads +GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]s-tasoli.ads +GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]s-unstyp.ads +GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]unchconv.ads +@end smallexample +@end ifset -@node Adding the Results of Compiler Checks to gnatcheck Output -@section Adding the Results of Compiler Checks to @command{gnatcheck} Output +@node Cleaning Up Using gnatclean +@chapter Cleaning Up Using @code{gnatclean} +@findex gnatclean +@cindex Cleaning tool @noindent -The @command{gnatcheck} tool can include in the generated diagnostic messages -and in -the report file the results of the checks performed by the compiler. Though -disabled by default, this effect may be obtained by using @option{+R} with -the following rule identifiers and parameters: - -@table @option -@item Restrictions -To record restrictions violations (which are performed by the compiler if the -pragma @code{Restrictions} or @code{Restriction_Warnings} are given), -use the @code{Restrictions} rule -with the same parameters as pragma -@code{Restrictions} or @code{Restriction_Warnings}. +@code{gnatclean} is a tool that allows the deletion of files produced by the +compiler, binder and linker, including ALI files, object files, tree files, +expanded source files, library files, interface copy source files, binder +generated files and executable files. -@item Style_Checks -To record compiler style checks (@pxref{Style Checking}), use the -@code{Style_Checks} rule. -This rule takes a parameter in one of the following forms: -@itemize -@item -@code{All_Checks}, -which enables the standard style checks corresponding to the @option{-gnatyy} -GNAT style check option, or +@menu +* Running gnatclean:: +* Switches for gnatclean:: +@c * Examples of gnatclean Usage:: +@end menu -@item -a string with the same -structure and semantics as the @code{string_LITERAL} parameter of the -GNAT pragma @code{Style_Checks} -(for further information about this pragma, -@pxref{Pragma Style_Checks,,, gnat_rm, GNAT Reference Manual}). -@end itemize +@node Running gnatclean +@section Running @code{gnatclean} @noindent -For example, the -@code{+RStyle_Checks:O} rule option activates -the compiler style check that corresponds to -@code{-gnatyO} style check option. +The @code{gnatclean} command has the form: -@item Warnings -To record compiler warnings (@pxref{Warning Message Control}), use the -@code{Warnings} rule with a parameter that is a valid -@i{static_string_expression} argument of the GNAT pragma @code{Warnings} -(for further information about this pragma, -@pxref{Pragma Warnings,,,gnat_rm, GNAT Reference Manual}). -Note that in case of gnatcheck -'s' parameter, that corresponds to the GNAT @option{-gnatws} option, disables -all the specific warnings, but not suppresses the warning mode, -and 'e' parameter, corresponding to @option{-gnatwe} that means -"treat warnings as errors", does not have any effect. +@smallexample +$ gnatclean switches @var{names} +@end smallexample -@end table +@noindent +@var{names} is a list of source file names. Suffixes @code{.^ads^ADS^} and +@code{^adb^ADB^} may be omitted. If a project file is specified using switch +@code{^-P^/PROJECT_FILE=^}, then @var{names} may be completely omitted. -To disable a specific restriction check, use @code{-RStyle_Checks} gnatcheck -option with the corresponding restriction name as a parameter. @code{-R} is -not available for @code{Style_Checks} and @code{Warnings} options, to disable -warnings and style checks, use the corresponding warning and style options. +@noindent +In normal mode, @code{gnatclean} delete the files produced by the compiler and, +if switch @code{^-c^/COMPILER_FILES_ONLY^} is not specified, by the binder and +the linker. In informative-only mode, specified by switch +@code{^-n^/NODELETE^}, the list of files that would have been deleted in +normal mode is listed, but no file is actually deleted. -@node Project-Wide Checks -@section Project-Wide Checks -@cindex Project-wide checks (for @command{gnatcheck}) +@node Switches for gnatclean +@section Switches for @code{gnatclean} @noindent -In order to perform checks on all units of a given project, you can use -the GNAT driver along with the @option{-P} option: -@smallexample - gnat check -Pproj -rules -from=my_rules -@end smallexample +@code{gnatclean} recognizes the following switches: -@noindent -If the project @code{proj} depends upon other projects, you can perform -checks on the project closure using the @option{-U} option: -@smallexample - gnat check -Pproj -U -rules -from=my_rules -@end smallexample +@table @option +@c !sort! +@cindex @option{--version} @command{gnatclean} +Display Copyright and version, then exit disregarding all other options. -@noindent -Finally, if not all the units are relevant to a particular main -program in the project closure, you can perform checks for the set -of units needed to create a given main program (unit closure) using -the @option{-U} option followed by the name of the main unit: -@smallexample - gnat check -Pproj -U main -rules -from=my_rules -@end smallexample +@item --help +@cindex @option{--help} @command{gnatclean} +If @option{--version} was not used, display usage, then exit disregarding +all other options. +@item ^--subdirs^/SUBDIRS^=subdir +Actual object directory of each project file is the subdirectory subdir of the +object directory specified or defauted in the project file. -@node Rule exemption -@section Rule exemption -@cindex Rule exemption (for @command{gnatcheck}) +@item ^--unchecked-shared-lib-imports^/UNCHECKED_SHARED_LIB_IMPORTS^ +By default, shared library projects are not allowed to import static library +projects. When this switch is used on the command line, this restriction is +relaxed. -@noindent -One of the most useful applications of @command{gnatcheck} is to -automate the enforcement of project-specific coding standards, -for example in safety-critical systems where particular features -must be restricted in order to simplify the certification effort. -However, it may sometimes be appropriate to violate a coding standard rule, -and in such cases the rationale for the violation should be provided -in the source program itself so that the individuals -reviewing or maintaining the program can immediately understand the intent. +@item ^-c^/COMPILER_FILES_ONLY^ +@cindex @option{^-c^/COMPILER_FILES_ONLY^} (@code{gnatclean}) +Only attempt to delete the files produced by the compiler, not those produced +by the binder or the linker. The files that are not to be deleted are library +files, interface copy files, binder generated files and executable files. -The @command{gnatcheck} tool supports this practice with the notion of -a ``rule exemption'' covering a specific source code section. Normally -rule violation messages are issued both on @file{stderr} -and in a report file. In contrast, exempted violations are not listed on -@file{stderr}; thus users invoking @command{gnatcheck} interactively -(e.g. in its GPS interface) do not need to pay attention to known and -justified violations. However, exempted violations along with their -justification are documented in a special section of the report file that -@command{gnatcheck} generates. +@item ^-D ^/DIRECTORY_OBJECTS=^@var{dir} +@cindex @option{^-D^/DIRECTORY_OBJECTS^} (@code{gnatclean}) +Indicate that ALI and object files should normally be found in directory +@var{dir}. -@menu -* Using pragma Annotate to Control Rule Exemption:: -* gnatcheck Annotations Rules:: -@end menu +@item ^-F^/FULL_PATH_IN_BRIEF_MESSAGES^ +@cindex @option{^-F^/FULL_PATH_IN_BRIEF_MESSAGES^} (@code{gnatclean}) +When using project files, if some errors or warnings are detected during +parsing and verbose mode is not in effect (no use of switch +^-v^/VERBOSE^), then error lines start with the full path name of the project +file, rather than its simple file name. -@node Using pragma Annotate to Control Rule Exemption -@subsection Using pragma @code{Annotate} to Control Rule Exemption -@cindex Using pragma Annotate to control rule exemption +@item ^-h^/HELP^ +@cindex @option{^-h^/HELP^} (@code{gnatclean}) +Output a message explaining the usage of @code{^gnatclean^gnatclean^}. -@noindent -Rule exemption is controlled by pragma @code{Annotate} when its first -argument is ``gnatcheck''. The syntax of @command{gnatcheck}'s -exemption control annotations is as follows: +@item ^-n^/NODELETE^ +@cindex @option{^-n^/NODELETE^} (@code{gnatclean}) +Informative-only mode. Do not delete any files. Output the list of the files +that would have been deleted if this switch was not specified. -@smallexample @c ada -@group -pragma Annotate (gnatcheck, @i{exemption_control}, @i{Rule_Name}, [@i{justification}]); +@item ^-P^/PROJECT_FILE=^@var{project} +@cindex @option{^-P^/PROJECT_FILE^} (@code{gnatclean}) +Use project file @var{project}. Only one such switch can be used. +When cleaning a project file, the files produced by the compilation of the +immediate sources or inherited sources of the project files are to be +deleted. This is not depending on the presence or not of executable names +on the command line. -@i{exemption_control} ::= Exempt_On | Exempt_Off +@item ^-q^/QUIET^ +@cindex @option{^-q^/QUIET^} (@code{gnatclean}) +Quiet output. If there are no errors, do not output anything, except in +verbose mode (switch ^-v^/VERBOSE^) or in informative-only mode +(switch ^-n^/NODELETE^). -@i{Rule_Name} ::= string_literal +@item ^-r^/RECURSIVE^ +@cindex @option{^-r^/RECURSIVE^} (@code{gnatclean}) +When a project file is specified (using switch ^-P^/PROJECT_FILE=^), +clean all imported and extended project files, recursively. If this switch +is not specified, only the files related to the main project file are to be +deleted. This switch has no effect if no project file is specified. -@i{justification} ::= string_literal -@end group -@end smallexample +@item ^-v^/VERBOSE^ +@cindex @option{^-v^/VERBOSE^} (@code{gnatclean}) +Verbose mode. -@noindent -When a @command{gnatcheck} annotation has more then four arguments, -@command{gnatcheck} issues a warning and ignores the additional arguments. -If the additional arguments do not follow the syntax above, -@command{gnatcheck} emits a warning and ignores the annotation. +@item ^-vP^/MESSAGES_PROJECT_FILE=^@emph{x} +@cindex @option{^-vP^/MESSAGES_PROJECT_FILE^} (@code{gnatclean}) +Indicates the verbosity of the parsing of GNAT project files. +@xref{Switches Related to Project Files}. + +@item ^-X^/EXTERNAL_REFERENCE=^@var{name=value} +@cindex @option{^-X^/EXTERNAL_REFERENCE^} (@code{gnatclean}) +Indicates that external variable @var{name} has the value @var{value}. +The Project Manager will use this value for occurrences of +@code{external(name)} when parsing the project file. +@xref{Switches Related to Project Files}. + +@item ^-aO^/OBJECT_SEARCH=^@var{dir} +@cindex @option{^-aO^/OBJECT_SEARCH^} (@code{gnatclean}) +When searching for ALI and object files, look in directory +@var{dir}. -The @i{@code{Rule_Name}} argument should be the name of some existing -@command{gnatcheck} rule. -Otherwise a warning message is generated and the pragma is -ignored. If @code{Rule_Name} denotes a rule that is not activated by the given -@command{gnatcheck} call, the pragma is ignored and no warning is issued. +@item ^-I^/SEARCH=^@var{dir} +@cindex @option{^-I^/SEARCH^} (@code{gnatclean}) +Equivalent to @option{^-aO^/OBJECT_SEARCH=^@var{dir}}. -A source code section where an exemption is active for a given rule is -delimited by an @code{exempt_on} and @code{exempt_off} annotation pair: +@item ^-I-^/NOCURRENT_DIRECTORY^ +@cindex @option{^-I-^/NOCURRENT_DIRECTORY^} (@code{gnatclean}) +@cindex Source files, suppressing search +Do not look for ALI or object files in the directory +where @code{gnatclean} was invoked. -@smallexample @c ada -pragma Annotate (gnatcheck, Exempt_On, Rule_Name, "justification"); --- source code section -pragma Annotate (gnatcheck, Exempt_Off, Rule_Name); -@end smallexample +@end table +@c @node Examples of gnatclean Usage +@c @section Examples of @code{gnatclean} Usage -@node gnatcheck Annotations Rules -@subsection @command{gnatcheck} Annotations Rules -@cindex @command{gnatcheck} annotations rules +@ifclear vms +@node GNAT and Libraries +@chapter GNAT and Libraries +@cindex Library, building, installing, using -@itemize @bullet +@noindent +This chapter describes how to build and use libraries with GNAT, and also shows +how to recompile the GNAT run-time library. You should be familiar with the +Project Manager facility (@pxref{GNAT Project Manager}) before reading this +chapter. -@item -An ``Exempt_Off'' annotation can only appear after a corresponding -``Exempt_On'' annotation. +@menu +* Introduction to Libraries in GNAT:: +* General Ada Libraries:: +* Stand-alone Ada Libraries:: +* Rebuilding the GNAT Run-Time Library:: +@end menu -@item -Exempted source code sections are only based on the source location of the -annotations. Any source construct between the two -annotations is part of the exempted source code section. +@node Introduction to Libraries in GNAT +@section Introduction to Libraries in GNAT -@item -Exempted source code sections for different rules are independent. They can -be nested or intersect with one another without limitation. -Creating nested or intersecting source code sections for the same rule is -not allowed. +@noindent +A library is, conceptually, a collection of objects which does not have its +own main thread of execution, but rather provides certain services to the +applications that use it. A library can be either statically linked with the +application, in which case its code is directly included in the application, +or, on platforms that support it, be dynamically linked, in which case +its code is shared by all applications making use of this library. -@item -Malformed exempted source code sections are reported by a warning, and -the corresponding rule exemptions are ignored. +GNAT supports both types of libraries. +In the static case, the compiled code can be provided in different ways. The +simplest approach is to provide directly the set of objects resulting from +compilation of the library source files. Alternatively, you can group the +objects into an archive using whatever commands are provided by the operating +system. For the latter case, the objects are grouped into a shared library. +In the GNAT environment, a library has three types of components: +@itemize @bullet @item -When an exempted source code section does not contain at least one violation -of the exempted rule, a warning is emitted on @file{stderr}. - +Source files. @item -If an ``Exempt_On'' annotation pragma does not have a matching -``Exempt_Off'' annotation pragma in the same compilation unit, then the -exemption for the given rule is ignored and a warning is issued. +@file{ALI} files. +@xref{The Ada Library Information Files}. +@item +Object files, an archive or a shared library. @end itemize - -@node Predefined Rules -@section Predefined Rules -@cindex Predefined rules (for @command{gnatcheck}) - -@ignore -@c (Jan 2007) Since the global rules are still under development and are not -@c documented, there is no point in explaining the difference between -@c global and local rules @noindent -A rule in @command{gnatcheck} is either local or global. -A @emph{local rule} is a rule that applies to a well-defined section -of a program and that can be checked by analyzing only this section. -A @emph{global rule} requires analysis of some global properties of the -whole program (mostly related to the program call graph). -As of @value{NOW}, the implementation of global rules should be -considered to be at a preliminary stage. You can use the -@option{+GLOBAL} option to enable all the global rules, and the -@option{-GLOBAL} rule option to disable all the global rules. - -All the global rules in the list below are -so indicated by marking them ``GLOBAL''. -This +GLOBAL and -GLOBAL options are not -included in the list of gnatcheck options above, because at the moment they -are considered as a temporary debug options. - -@command{gnatcheck} performs rule checks for generic -instances only for global rules. This limitation may be relaxed in a later -release. -@end ignore +A GNAT library may expose all its source files, which is useful for +documentation purposes. Alternatively, it may expose only the units needed by +an external user to make use of the library. That is to say, the specs +reflecting the library services along with all the units needed to compile +those specs, which can include generic bodies or any body implementing an +inlined routine. In the case of @emph{stand-alone libraries} those exposed +units are called @emph{interface units} (@pxref{Stand-alone Ada Libraries}). -@noindent -The following subsections document the rules implemented in -@command{gnatcheck}. -The subsection title is the same as the rule identifier, which may be -used as a parameter of the @option{+R} or @option{-R} options. +All compilation units comprising an application, including those in a library, +need to be elaborated in an order partially defined by Ada's semantics. GNAT +computes the elaboration order from the @file{ALI} files and this is why they +constitute a mandatory part of GNAT libraries. +@emph{Stand-alone libraries} are the exception to this rule because a specific +library elaboration routine is produced independently of the application(s) +using the library. +@node General Ada Libraries +@section General Ada Libraries @menu -* Abstract_Type_Declarations:: -* Anonymous_Arrays:: -* Anonymous_Subtypes:: -* Blocks:: -* Boolean_Relational_Operators:: -@ignore -* Ceiling_Violations:: -@end ignore -* Complex_Inlined_Subprograms:: -* Controlled_Type_Declarations:: -* Declarations_In_Blocks:: -* Deep_Inheritance_Hierarchies:: -* Deeply_Nested_Generics:: -* Deeply_Nested_Inlining:: -@ignore -* Deeply_Nested_Local_Inlining:: -@end ignore -* Default_Parameters:: -* Direct_Calls_To_Primitives:: -* Discriminated_Records:: -* Enumeration_Ranges_In_CASE_Statements:: -* Exceptions_As_Control_Flow:: -* Exits_From_Conditional_Loops:: -* EXIT_Statements_With_No_Loop_Name:: -* Expanded_Loop_Exit_Names:: -* Explicit_Full_Discrete_Ranges:: -* Float_Equality_Checks:: -* Forbidden_Attributes:: -* Forbidden_Pragmas:: -* Function_Style_Procedures:: -* Generics_In_Subprograms:: -* GOTO_Statements:: -* Implicit_IN_Mode_Parameters:: -* Implicit_SMALL_For_Fixed_Point_Types:: -* Improperly_Located_Instantiations:: -* Improper_Returns:: -* Library_Level_Subprograms:: -* Local_Packages:: -@ignore -* Improperly_Called_Protected_Entries:: -@end ignore -* Metrics:: -* Misnamed_Controlling_Parameters:: -* Misnamed_Identifiers:: -* Multiple_Entries_In_Protected_Definitions:: -* Name_Clashes:: -* Non_Qualified_Aggregates:: -* Non_Short_Circuit_Operators:: -* Non_SPARK_Attributes:: -* Non_Tagged_Derived_Types:: -* Non_Visible_Exceptions:: -* Numeric_Literals:: -* OTHERS_In_Aggregates:: -* OTHERS_In_CASE_Statements:: -* OTHERS_In_Exception_Handlers:: -* Outer_Loop_Exits:: -* Overloaded_Operators:: -* Overly_Nested_Control_Structures:: -* Parameters_Out_Of_Order:: -* Positional_Actuals_For_Defaulted_Generic_Parameters:: -* Positional_Actuals_For_Defaulted_Parameters:: -* Positional_Components:: -* Positional_Generic_Parameters:: -* Positional_Parameters:: -* Predefined_Numeric_Types:: -* Raising_External_Exceptions:: -* Raising_Predefined_Exceptions:: -* Separate_Numeric_Error_Handlers:: -@ignore -* Recursion:: -* Side_Effect_Functions:: -@end ignore -* Slices:: -* Too_Many_Parents:: -* Unassigned_OUT_Parameters:: -* Uncommented_BEGIN_In_Package_Bodies:: -* Unconditional_Exits:: -* Unconstrained_Array_Returns:: -* Universal_Ranges:: -* Unnamed_Blocks_And_Loops:: -@ignore -* Unused_Subprograms:: -@end ignore -* USE_PACKAGE_Clauses:: -* Visible_Components:: -* Volatile_Objects_Without_Address_Clauses:: +* Building a library:: +* Installing a library:: +* Using a library:: @end menu - -@node Abstract_Type_Declarations -@subsection @code{Abstract_Type_Declarations} -@cindex @code{Abstract_Type_Declarations} rule (for @command{gnatcheck}) +@node Building a library +@subsection Building a library @noindent -Flag all declarations of abstract types. For an abstract private -type, both the private and full type declarations are flagged. +The easiest way to build a library is to use the Project Manager, +which supports a special type of project called a @emph{Library Project} +(@pxref{Library Projects}). -This rule has no parameters. +A project is considered a library project, when two project-level attributes +are defined in it: @code{Library_Name} and @code{Library_Dir}. In order to +control different aspects of library configuration, additional optional +project-level attributes can be specified: +@table @code +@item Library_Kind +This attribute controls whether the library is to be static or dynamic +@item Library_Version +This attribute specifies the library version; this value is used +during dynamic linking of shared libraries to determine if the currently +installed versions of the binaries are compatible. -@node Anonymous_Arrays -@subsection @code{Anonymous_Arrays} -@cindex @code{Anonymous_Arrays} rule (for @command{gnatcheck}) +@item Library_Options +@item Library_GCC +These attributes specify additional low-level options to be used during +library generation, and redefine the actual application used to generate +library. +@end table @noindent -Flag all anonymous array type definitions (by Ada semantics these can only -occur in object declarations). - -This rule has no parameters. +The GNAT Project Manager takes full care of the library maintenance task, +including recompilation of the source files for which objects do not exist +or are not up to date, assembly of the library archive, and installation of +the library (i.e., copying associated source, object and @file{ALI} files +to the specified location). -@node Anonymous_Subtypes -@subsection @code{Anonymous_Subtypes} -@cindex @code{Anonymous_Subtypes} rule (for @command{gnatcheck}) +Here is a simple library project file: +@smallexample @c ada +project My_Lib is + for Source_Dirs use ("src1", "src2"); + for Object_Dir use "obj"; + for Library_Name use "mylib"; + for Library_Dir use "lib"; + for Library_Kind use "dynamic"; +end My_lib; +@end smallexample @noindent -Flag all uses of anonymous subtypes (except cases when subtype indication -is a part of a record component definition, and this subtype indication -depends on a discriminant). A use of an anonymous subtype is -any instance of a subtype indication with a constraint, other than one -that occurs immediately within a subtype declaration. Any use of a range -other than as a constraint used immediately within a subtype declaration -is considered as an anonymous subtype. - -An effect of this rule is that @code{for} loops such as the following are -flagged (since @code{1..N} is formally a ``range''): +and the compilation command to build and install the library: @smallexample @c ada -for I in 1 .. N loop - @dots{} -end loop; + $ gnatmake -Pmy_lib @end smallexample @noindent -Declaring an explicit subtype solves the problem: +It is not entirely trivial to perform manually all the steps required to +produce a library. We recommend that you use the GNAT Project Manager +for this task. In special cases where this is not desired, the necessary +steps are discussed below. + +There are various possibilities for compiling the units that make up the +library: for example with a Makefile (@pxref{Using the GNU make Utility}) or +with a conventional script. For simple libraries, it is also possible to create +a dummy main program which depends upon all the packages that comprise the +interface of the library. This dummy main program can then be given to +@command{gnatmake}, which will ensure that all necessary objects are built. +After this task is accomplished, you should follow the standard procedure +of the underlying operating system to produce the static or shared library. + +Here is an example of such a dummy program: @smallexample @c ada -subtype S is Integer range 1..N; -@dots{} -for I in S loop - @dots{} -end loop; +@group +with My_Lib.Service1; +with My_Lib.Service2; +with My_Lib.Service3; +procedure My_Lib_Dummy is +begin + null; +end; +@end group @end smallexample @noindent -This rule has no parameters. +Here are the generic commands that will build an archive or a shared library. -@node Blocks -@subsection @code{Blocks} -@cindex @code{Blocks} rule (for @command{gnatcheck}) +@smallexample +# compiling the library +$ gnatmake -c my_lib_dummy.adb -@noindent -Flag each block statement. +# we don't need the dummy object itself +$ rm my_lib_dummy.o my_lib_dummy.ali + +# create an archive with the remaining objects +$ ar rc libmy_lib.a *.o +# some systems may require "ranlib" to be run as well + +# or create a shared library +$ gcc -shared -o libmy_lib.so *.o +# some systems may require the code to have been compiled with -fPIC -This rule has no parameters. +# remove the object files that are now in the library +$ rm *.o -@node Boolean_Relational_Operators -@subsection @code{Boolean_Relational_Operators} -@cindex @code{Boolean_Relational_Operators} rule (for @command{gnatcheck}) +# Make the ALI files read-only so that gnatmake will not try to +# regenerate the objects that are in the library +$ chmod -w *.ali +@end smallexample @noindent -Flag each call to a predefined relational operator (``<'', ``>'', ``<='', -``>='', ``='' and ``/='') for the predefined Boolean type. -(This rule is useful in enforcing the SPARK language restrictions.) +Please note that the library must have a name of the form @file{lib@var{xxx}.a} +or @file{lib@var{xxx}.so} (or @file{lib@var{xxx}.dll} on Windows) in order to +be accessed by the directive @option{-l@var{xxx}} at link time. -Calls to predefined relational operators of any type derived from -@code{Standard.Boolean} are not detected. Calls to user-defined functions -with these designators, and uses of operators that are renamings -of the predefined relational operators for @code{Standard.Boolean}, -are likewise not detected. +@node Installing a library +@subsection Installing a library +@cindex @code{ADA_PROJECT_PATH} +@cindex @code{GPR_PROJECT_PATH} -This rule has no parameters. +@noindent +If you use project files, library installation is part of the library build +process (@pxref{Installing a library with project files}). -@ignore -@node Ceiling_Violations -@subsection @code{Ceiling5_Violations} (under construction, GLOBAL) -@cindex @code{Ceiling_Violations} rule (for @command{gnatcheck}) +When project files are not an option, it is also possible, but not recommended, +to install the library so that the sources needed to use the library are on the +Ada source path and the ALI files & libraries be on the Ada Object path (see +@ref{Search Paths and the Run-Time Library (RTL)}. Alternatively, the system +administrator can place general-purpose libraries in the default compiler +paths, by specifying the libraries' location in the configuration files +@file{ada_source_path} and @file{ada_object_path}. These configuration files +must be located in the GNAT installation tree at the same place as the gcc spec +file. The location of the gcc spec file can be determined as follows: +@smallexample +$ gcc -v +@end smallexample @noindent -Flag invocations of a protected operation by a task whose priority exceeds -the protected object's ceiling. +The configuration files mentioned above have a simple format: each line +must contain one unique directory name. +Those names are added to the corresponding path +in their order of appearance in the file. The names can be either absolute +or relative; in the latter case, they are relative to where theses files +are located. -As of @value{NOW}, this rule has the following limitations: +The files @file{ada_source_path} and @file{ada_object_path} might not be +present in a +GNAT installation, in which case, GNAT will look for its run-time library in +the directories @file{adainclude} (for the sources) and @file{adalib} (for the +objects and @file{ALI} files). When the files exist, the compiler does not +look in @file{adainclude} and @file{adalib}, and thus the +@file{ada_source_path} file +must contain the location for the GNAT run-time sources (which can simply +be @file{adainclude}). In the same way, the @file{ada_object_path} file must +contain the location for the GNAT run-time objects (which can simply +be @file{adalib}). -@itemize @bullet +You can also specify a new default path to the run-time library at compilation +time with the switch @option{--RTS=rts-path}. You can thus choose / change +the run-time library you want your program to be compiled with. This switch is +recognized by @command{gcc}, @command{gnatmake}, @command{gnatbind}, +@command{gnatls}, @command{gnatfind} and @command{gnatxref}. -@item - We consider only pragmas Priority and Interrupt_Priority as means to define - a task/protected operation priority. We do not consider the effect of using - Ada.Dynamic_Priorities.Set_Priority procedure; +It is possible to install a library before or after the standard GNAT +library, by reordering the lines in the configuration files. In general, a +library must be installed before the GNAT library if it redefines +any part of it. -@item - We consider only base task priorities, and no priority inheritance. That is, - we do not make a difference between calls issued during task activation and - execution of the sequence of statements from task body; +@node Using a library +@subsection Using a library -@item - Any situation when the priority of protected operation caller is set by a - dynamic expression (that is, the corresponding Priority or - Interrupt_Priority pragma has a non-static expression as an argument) we - treat as a priority inconsistency (and, therefore, detect this situation). -@end itemize +@noindent Once again, the project facility greatly simplifies the use of +libraries. In this context, using a library is just a matter of adding a +@code{with} clause in the user project. For instance, to make use of the +library @code{My_Lib} shown in examples in earlier sections, you can +write: -@noindent -At the moment the notion of the main subprogram is not implemented in -gnatcheck, so any pragma Priority in a library level subprogram body (in case -if this subprogram can be a main subprogram of a partition) changes the -priority of an environment task. So if we have more then one such pragma in -the set of processed sources, the pragma that is processed last, defines the -priority of an environment task. +@smallexample @c projectfile +with "my_lib"; +project My_Proj is + @dots{} +end My_Proj; +@end smallexample -This rule has no parameters. -@end ignore +Even if you have a third-party, non-Ada library, you can still use GNAT's +Project Manager facility to provide a wrapper for it. For example, the +following project, when @code{with}ed by your main project, will link with the +third-party library @file{liba.a}: -@node Controlled_Type_Declarations -@subsection @code{Controlled_Type_Declarations} -@cindex @code{Controlled_Type_Declarations} rule (for @command{gnatcheck}) +@smallexample @c projectfile +@group +project Liba is + for Externally_Built use "true"; + for Source_Files use (); + for Library_Dir use "lib"; + for Library_Name use "a"; + for Library_Kind use "static"; +end Liba; +@end group +@end smallexample +This is an alternative to the use of @code{pragma Linker_Options}. It is +especially interesting in the context of systems with several interdependent +static libraries where finding a proper linker order is not easy and best be +left to the tools having visibility over project dependence information. @noindent -Flag all declarations of controlled types. A declaration of a private type -is flagged if its full declaration declares a controlled type. A declaration -of a derived type is flagged if its ancestor type is controlled. Subtype -declarations are not checked. A declaration of a type that itself is not a -descendant of a type declared in @code{Ada.Finalization} but has a controlled -component is not checked. - -This rule has no parameters. +In order to use an Ada library manually, you need to make sure that this +library is on both your source and object path +(see @ref{Search Paths and the Run-Time Library (RTL)} +and @ref{Search Paths for gnatbind}). Furthermore, when the objects are grouped +in an archive or a shared library, you need to specify the desired +library at link time. +For example, you can use the library @file{mylib} installed in +@file{/dir/my_lib_src} and @file{/dir/my_lib_obj} with the following commands: -@node Complex_Inlined_Subprograms -@subsection @code{Complex_Inlined_Subprograms} -@cindex @code{Complex_Inlined_Subprograms} rule (for @command{gnatcheck}) +@smallexample +$ gnatmake -aI/dir/my_lib_src -aO/dir/my_lib_obj my_appl \ + -largs -lmy_lib +@end smallexample @noindent -Flags a subprogram (or generic subprogram) if -pragma Inline is applied to the subprogram and at least one of the following -conditions is met: - +This can be expressed more simply: +@smallexample +$ gnatmake my_appl +@end smallexample +@noindent +when the following conditions are met: @itemize @bullet @item -it contains at least one complex declaration such as a subprogram body, -package, task, protected declaration, or a generic instantiation -(except instantiation of @code{Ada.Unchecked_Conversion}); - +@file{/dir/my_lib_src} has been added by the user to the environment +variable @env{ADA_INCLUDE_PATH}, or by the administrator to the file +@file{ada_source_path} @item -it contains at least one complex statement such as a loop, a case -or a if statement, or a short circuit control form; - +@file{/dir/my_lib_obj} has been added by the user to the environment +variable @env{ADA_OBJECTS_PATH}, or by the administrator to the file +@file{ada_object_path} @item -the number of statements exceeds -a value specified by the @option{N} rule parameter; -@end itemize - -@noindent -This rule has the following (mandatory) parameter for the @option{+R} option: - -@table @emph -@item N -Positive integer specifying the maximum allowed total number of statements -in the subprogram body. -@end table - - -@node Declarations_In_Blocks -@subsection @code{Declarations_In_Blocks} -@cindex @code{Declarations_In_Blocks} rule (for @command{gnatcheck}) +a pragma @code{Linker_Options} has been added to one of the sources. +For example: -@noindent -Flag all block statements containing local declarations. A @code{declare} -block with an empty @i{declarative_part} or with a @i{declarative part} -containing only pragmas and/or @code{use} clauses is not flagged. +@smallexample @c ada +pragma Linker_Options ("-lmy_lib"); +@end smallexample +@end itemize -This rule has no parameters. +@node Stand-alone Ada Libraries +@section Stand-alone Ada Libraries +@cindex Stand-alone library, building, using +@menu +* Introduction to Stand-alone Libraries:: +* Building a Stand-alone Library:: +* Creating a Stand-alone Library to be used in a non-Ada context:: +* Restrictions in Stand-alone Libraries:: +@end menu -@node Deep_Inheritance_Hierarchies -@subsection @code{Deep_Inheritance_Hierarchies} -@cindex @code{Deep_Inheritance_Hierarchies} rule (for @command{gnatcheck}) +@node Introduction to Stand-alone Libraries +@subsection Introduction to Stand-alone Libraries @noindent -Flags a tagged derived type declaration or an interface type declaration if -its depth (in its inheritance -hierarchy) exceeds the value specified by the @option{N} rule parameter. +A Stand-alone Library (abbreviated ``SAL'') is a library that contains the +necessary code to +elaborate the Ada units that are included in the library. In contrast with +an ordinary library, which consists of all sources, objects and @file{ALI} +files of the +library, a SAL may specify a restricted subset of compilation units +to serve as a library interface. In this case, the fully +self-sufficient set of files will normally consist of an objects +archive, the sources of interface units' specs, and the @file{ALI} +files of interface units. +If an interface spec contains a generic unit or an inlined subprogram, +the body's +source must also be provided; if the units that must be provided in the source +form depend on other units, the source and @file{ALI} files of those must +also be provided. -The inheritance depth of a tagged type or interface type is defined as 0 for -a type with no parent and no progenitor, and otherwise as 1 + max of the -depths of the immediate parent and immediate progenitors. +The main purpose of a SAL is to minimize the recompilation overhead of client +applications when a new version of the library is installed. Specifically, +if the interface sources have not changed, client applications do not need to +be recompiled. If, furthermore, a SAL is provided in the shared form and its +version, controlled by @code{Library_Version} attribute, is not changed, +then the clients do not need to be relinked. -This rule does not flag private extension -declarations. In the case of a private extension, the corresponding full -declaration is checked. +SALs also allow the library providers to minimize the amount of library source +text exposed to the clients. Such ``information hiding'' might be useful or +necessary for various reasons. -This rule has the following (mandatory) parameter for the @option{+R} option: +Stand-alone libraries are also well suited to be used in an executable whose +main routine is not written in Ada. -@table @emph -@item N -Integer not less than -1 specifying the maximal allowed depth of any inheritance -hierarchy. If the rule parameter is set to -1, the rule flags all the declarations -of tagged and interface types. -@end table +@node Building a Stand-alone Library +@subsection Building a Stand-alone Library +@noindent +GNAT's Project facility provides a simple way of building and installing +stand-alone libraries; see @ref{Stand-alone Library Projects}. +To be a Stand-alone Library Project, in addition to the two attributes +that make a project a Library Project (@code{Library_Name} and +@code{Library_Dir}; see @ref{Library Projects}), the attribute +@code{Library_Interface} must be defined. For example: -@node Deeply_Nested_Generics -@subsection @code{Deeply_Nested_Generics} -@cindex @code{Deeply_Nested_Generics} rule (for @command{gnatcheck}) +@smallexample @c projectfile +@group + for Library_Dir use "lib_dir"; + for Library_Name use "dummy"; + for Library_Interface use ("int1", "int1.child"); +@end group +@end smallexample @noindent -Flags a generic declaration nested in another generic declaration if -the nesting level of the inner generic exceeds -a value specified by the @option{N} rule parameter. -The nesting level is the number of generic declaratons that enclose the given -(generic) declaration. Formal packages are not flagged by this rule. +Attribute @code{Library_Interface} has a non-empty string list value, +each string in the list designating a unit contained in an immediate source +of the project file. -This rule has the following (mandatory) parameters for the @option{+R} option: +When a Stand-alone Library is built, first the binder is invoked to build +a package whose name depends on the library name +(@file{^b~dummy.ads/b^B$DUMMY.ADS/B^} in the example above). +This binder-generated package includes initialization and +finalization procedures whose +names depend on the library name (@code{dummyinit} and @code{dummyfinal} +in the example +above). The object corresponding to this package is included in the library. -@table @emph -@item N -Positive integer specifying the maximal allowed nesting level -for a generic declaration. -@end table +You must ensure timely (e.g., prior to any use of interfaces in the SAL) +calling of these procedures if a static SAL is built, or if a shared SAL +is built +with the project-level attribute @code{Library_Auto_Init} set to +@code{"false"}. -@node Deeply_Nested_Inlining -@subsection @code{Deeply_Nested_Inlining} -@cindex @code{Deeply_Nested_Inlining} rule (for @command{gnatcheck}) +For a Stand-Alone Library, only the @file{ALI} files of the Interface Units +(those that are listed in attribute @code{Library_Interface}) are copied to +the Library Directory. As a consequence, only the Interface Units may be +imported from Ada units outside of the library. If other units are imported, +the binding phase will fail. -@noindent -Flags a subprogram (or generic subprogram) if -pragma Inline has been applied to the subprogram but the subprogram -calls to another inlined subprogram that results in nested inlining -with nesting depth exceeding the value specified by the -@option{N} rule parameter. +The attribute @code{Library_Src_Dir} may be specified for a +Stand-Alone Library. @code{Library_Src_Dir} is a simple attribute that has a +single string value. Its value must be the path (absolute or relative to the +project directory) of an existing directory. This directory cannot be the +object directory or one of the source directories, but it can be the same as +the library directory. The sources of the Interface +Units of the library that are needed by an Ada client of the library will be +copied to the designated directory, called the Interface Copy directory. +These sources include the specs of the Interface Units, but they may also +include bodies and subunits, when pragmas @code{Inline} or @code{Inline_Always} +are used, or when there is a generic unit in the spec. Before the sources +are copied to the Interface Copy directory, an attempt is made to delete all +files in the Interface Copy directory. -This rule requires the global analysis of all the compilation units that -are @command{gnatcheck} arguments; such analysis may affect the tool's -performance. +Building stand-alone libraries by hand is somewhat tedious, but for those +occasions when it is necessary here are the steps that you need to perform: +@itemize @bullet +@item +Compile all library sources. -This rule has the following (mandatory) parameter for the @option{+R} option: +@item +Invoke the binder with the switch @option{-n} (No Ada main program), +with all the @file{ALI} files of the interfaces, and +with the switch @option{-L} to give specific names to the @code{init} +and @code{final} procedures. For example: +@smallexample + gnatbind -n int1.ali int2.ali -Lsal1 +@end smallexample -@table @emph -@item N -Positive integer specifying the maximal allowed level of nested inlining. -@end table +@item +Compile the binder generated file: +@smallexample + gcc -c b~int2.adb +@end smallexample +@item +Link the dynamic library with all the necessary object files, +indicating to the linker the names of the @code{init} (and possibly +@code{final}) procedures for automatic initialization (and finalization). +The built library should be placed in a directory different from +the object directory. -@ignore -@node Deeply_Nested_Local_Inlining -@subsection @code{Deeply_Nested_Local_Inlining} -@cindex @code{Deeply_Nested_Local_Inlining} rule (for @command{gnatcheck}) +@item +Copy the @code{ALI} files of the interface to the library directory, +add in this copy an indication that it is an interface to a SAL +(i.e., add a word @option{SL} on the line in the @file{ALI} file that starts +with letter ``P'') and make the modified copy of the @file{ALI} file +read-only. +@end itemize @noindent -Flags a subprogram body if a pragma @code{Inline} is applied to the -corresponding subprogram (or generic subprogram) and the body contains a call -to another inlined subprogram that results in nested inlining with nesting -depth more then a value specified by the @option{N} rule parameter. -This rule is similar to @code{Deeply_Nested_Inlining} rule, but it -assumes that calls to subprograms in -with'ed units are not inlided, so all the analysis of the depth of inlining is -limited by the compilation unit where the subprogram body is located and the -units it depends semantically upon. Such analysis may be usefull for the case -when neiter @option{-gnatn} nor @option{-gnatN} option is used when building -the executable. - -This rule has the following (mandatory) parameters for the @option{+R} option: - -@table @emph -@item N -Positive integer specifying the maximal allowed level of nested inlining. -@end table - -@end ignore +Using SALs is not different from using other libraries +(see @ref{Using a library}). -@node Default_Parameters -@subsection @code{Default_Parameters} -@cindex @code{Default_Parameters} rule (for @command{gnatcheck}) +@node Creating a Stand-alone Library to be used in a non-Ada context +@subsection Creating a Stand-alone Library to be used in a non-Ada context @noindent -Flag all default expressions for subprogram parameters. Parameter -declarations of formal and generic subprograms are also checked. - -This rule has no parameters. +It is easy to adapt the SAL build procedure discussed above for use of a SAL in +a non-Ada context. +The only extra step required is to ensure that library interface subprograms +are compatible with the main program, by means of @code{pragma Export} +or @code{pragma Convention}. -@node Direct_Calls_To_Primitives -@subsection @code{Direct_Calls_To_Primitives} -@cindex @code{Direct_Calls_To_Primitives} rule (for @command{gnatcheck}) +Here is an example of simple library interface for use with C main program: -@noindent -Flags any non-dispatching call to a dispatching primitive operation, except -for the common idiom where a primitive subprogram for a tagged type -directly calls the same primitive subprogram of the type's immediate ancestor. +@smallexample @c ada +package My_Package is -This rule has no parameters. + procedure Do_Something; + pragma Export (C, Do_Something, "do_something"); + procedure Do_Something_Else; + pragma Export (C, Do_Something_Else, "do_something_else"); -@node Discriminated_Records -@subsection @code{Discriminated_Records} -@cindex @code{Discriminated_Records} rule (for @command{gnatcheck}) +end My_Package; +@end smallexample @noindent -Flag all declarations of record types with discriminants. Only the -declarations of record and record extension types are checked. Incomplete, -formal, private, derived and private extension type declarations are not -checked. Task and protected type declarations also are not checked. +On the foreign language side, you must provide a ``foreign'' view of the +library interface; remember that it should contain elaboration routines in +addition to interface subprograms. -This rule has no parameters. +The example below shows the content of @code{mylib_interface.h} (note +that there is no rule for the naming of this file, any name can be used) +@smallexample +/* the library elaboration procedure */ +extern void mylibinit (void); +/* the library finalization procedure */ +extern void mylibfinal (void); -@node Enumeration_Ranges_In_CASE_Statements -@subsection @code{Enumeration_Ranges_In_CASE_Statements} -@cindex @code{Enumeration_Ranges_In_CASE_Statements} (for @command{gnatcheck}) +/* the interface exported by the library */ +extern void do_something (void); +extern void do_something_else (void); +@end smallexample @noindent -Flag each use of a range of enumeration literals as a choice in a -@code{case} statement. -All forms for specifying a range (explicit ranges -such as @code{A .. B}, subtype marks and @code{'Range} attributes) are flagged. -An enumeration range is -flagged even if contains exactly one enumeration value or no values at all. A -type derived from an enumeration type is considered as an enumeration type. - -This rule helps prevent maintenance problems arising from adding an -enumeration value to a type and having it implicitly handled by an existing -@code{case} statement with an enumeration range that includes the new literal. - -This rule has no parameters. +Libraries built as explained above can be used from any program, provided +that the elaboration procedures (named @code{mylibinit} in the previous +example) are called before the library services are used. Any number of +libraries can be used simultaneously, as long as the elaboration +procedure of each library is called. +Below is an example of a C program that uses the @code{mylib} library. -@node Exceptions_As_Control_Flow -@subsection @code{Exceptions_As_Control_Flow} -@cindex @code{Exceptions_As_Control_Flow} (for @command{gnatcheck}) +@smallexample +#include "mylib_interface.h" -@noindent -Flag each place where an exception is explicitly raised and handled in the -same subprogram body. A @code{raise} statement in an exception handler, -package body, task body or entry body is not flagged. +int +main (void) +@{ + /* First, elaborate the library before using it */ + mylibinit (); -The rule has no parameters. + /* Main program, using the library exported entities */ + do_something (); + do_something_else (); -@node Exits_From_Conditional_Loops -@subsection @code{Exits_From_Conditional_Loops} -@cindex @code{Exits_From_Conditional_Loops} (for @command{gnatcheck}) + /* Library finalization at the end of the program */ + mylibfinal (); + return 0; +@} +@end smallexample @noindent -Flag any exit statement if it transfers the control out of a @code{for} loop -or a @code{while} loop. This includes cases when the @code{exit} statement -applies to a @code{FOR} or @code{while} loop, and cases when it is enclosed -in some @code{for} or @code{while} loop, but transfers the control from some -outer (inconditional) @code{loop} statement. - -The rule has no parameters. +Note that invoking any library finalization procedure generated by +@code{gnatbind} shuts down the Ada run-time environment. +Consequently, the +finalization of all Ada libraries must be performed at the end of the program. +No call to these libraries or to the Ada run-time library should be made +after the finalization phase. +@node Restrictions in Stand-alone Libraries +@subsection Restrictions in Stand-alone Libraries -@node EXIT_Statements_With_No_Loop_Name -@subsection @code{EXIT_Statements_With_No_Loop_Name} -@cindex @code{EXIT_Statements_With_No_Loop_Name} (for @command{gnatcheck}) +@noindent +The pragmas listed below should be used with caution inside libraries, +as they can create incompatibilities with other Ada libraries: +@itemize @bullet +@item pragma @code{Locking_Policy} +@item pragma @code{Queuing_Policy} +@item pragma @code{Task_Dispatching_Policy} +@item pragma @code{Unreserve_All_Interrupts} +@end itemize @noindent -Flag each @code{exit} statement that does not specify the name of the loop -being exited. +When using a library that contains such pragmas, the user must make sure +that all libraries use the same pragmas with the same values. Otherwise, +@code{Program_Error} will +be raised during the elaboration of the conflicting +libraries. The usage of these pragmas and its consequences for the user +should therefore be well documented. -The rule has no parameters. +Similarly, the traceback in the exception occurrence mechanism should be +enabled or disabled in a consistent manner across all libraries. +Otherwise, Program_Error will be raised during the elaboration of the +conflicting libraries. +If the @code{Version} or @code{Body_Version} +attributes are used inside a library, then you need to +perform a @code{gnatbind} step that specifies all @file{ALI} files in all +libraries, so that version identifiers can be properly computed. +In practice these attributes are rarely used, so this is unlikely +to be a consideration. -@node Expanded_Loop_Exit_Names -@subsection @code{Expanded_Loop_Exit_Names} -@cindex @code{Expanded_Loop_Exit_Names} rule (for @command{gnatcheck}) +@node Rebuilding the GNAT Run-Time Library +@section Rebuilding the GNAT Run-Time Library +@cindex GNAT Run-Time Library, rebuilding +@cindex Building the GNAT Run-Time Library +@cindex Rebuilding the GNAT Run-Time Library +@cindex Run-Time Library, rebuilding @noindent -Flag all expanded loop names in @code{exit} statements. - -This rule has no parameters. +It may be useful to recompile the GNAT library in various contexts, the +most important one being the use of partition-wide configuration pragmas +such as @code{Normalize_Scalars}. A special Makefile called +@code{Makefile.adalib} is provided to that effect and can be found in +the directory containing the GNAT library. The location of this +directory depends on the way the GNAT environment has been installed and can +be determined by means of the command: -@node Explicit_Full_Discrete_Ranges -@subsection @code{Explicit_Full_Discrete_Ranges} -@cindex @code{Explicit_Full_Discrete_Ranges} rule (for @command{gnatcheck}) +@smallexample +$ gnatls -v +@end smallexample @noindent -Flag each discrete range that has the form @code{A'First .. A'Last}. - -This rule has no parameters. +The last entry in the object search path usually contains the +gnat library. This Makefile contains its own documentation and in +particular the set of instructions needed to rebuild a new library and +to use it. -@node Float_Equality_Checks -@subsection @code{Float_Equality_Checks} -@cindex @code{Float_Equality_Checks} rule (for @command{gnatcheck}) +@node Using the GNU make Utility +@chapter Using the GNU @code{make} Utility +@findex make @noindent -Flag all calls to the predefined equality operations for floating-point types. -Both ``@code{=}'' and ``@code{/=}'' operations are checked. -User-defined equality operations are not flagged, nor are ``@code{=}'' -and ``@code{/=}'' operations for fixed-point types. +This chapter offers some examples of makefiles that solve specific +problems. It does not explain how to write a makefile (@pxref{Top,, GNU +make, make, GNU @code{make}}), nor does it try to replace the +@command{gnatmake} utility (@pxref{The GNAT Make Program gnatmake}). -This rule has no parameters. +All the examples in this section are specific to the GNU version of +make. Although @command{make} is a standard utility, and the basic language +is the same, these examples use some advanced features found only in +@code{GNU make}. +@menu +* Using gnatmake in a Makefile:: +* Automatically Creating a List of Directories:: +* Generating the Command Line Switches:: +* Overcoming Command Line Length Limits:: +@end menu -@node Forbidden_Attributes -@subsection @code{Forbidden_Attributes} -@cindex @code{Forbidden_Attributes} rule (for @command{gnatcheck}) +@node Using gnatmake in a Makefile +@section Using gnatmake in a Makefile +@findex makefile +@cindex GNU make @noindent -Flag each use of the specified attributes. The attributes to be detected are -named in the rule's parameters. - -This rule has the following parameters: - -@itemize @bullet -@item For the @option{+R} option +Complex project organizations can be handled in a very powerful way by +using GNU make combined with gnatmake. For instance, here is a Makefile +which allows you to build each subsystem of a big project into a separate +shared library. Such a makefile allows you to significantly reduce the link +time of very big applications while maintaining full coherence at +each step of the build process. -@table @asis -@item @emph{Attribute_Designator} -Adds the specified attribute to the set of attributes to be detected and sets -the detection checks for all the specified attributes ON. -If @emph{Attribute_Designator} -does not denote any attribute defined in the Ada standard -or in -@ref{Implementation Defined Attributes,,, gnat_rm, GNAT Reference -Manual}, it is treated as the name of unknown attribute. +The list of dependencies are handled automatically by +@command{gnatmake}. The Makefile is simply used to call gnatmake in each of +the appropriate directories. -@item @code{GNAT} -All the GNAT-specific attributes are detected; this sets -the detection checks for all the specified attributes ON. +Note that you should also read the example on how to automatically +create the list of directories +(@pxref{Automatically Creating a List of Directories}) +which might help you in case your project has a lot of subdirectories. -@item @code{ALL} -All attributes are detected; this sets the rule ON. -@end table +@smallexample +@iftex +@leftskip=0cm +@font@heightrm=cmr8 +@heightrm +@end iftex +## This Makefile is intended to be used with the following directory +## configuration: +## - The sources are split into a series of csc (computer software components) +## Each of these csc is put in its own directory. +## Their name are referenced by the directory names. +## They will be compiled into shared library (although this would also work +## with static libraries +## - The main program (and possibly other packages that do not belong to any +## csc is put in the top level directory (where the Makefile is). +## toplevel_dir __ first_csc (sources) __ lib (will contain the library) +## \_ second_csc (sources) __ lib (will contain the library) +## \_ @dots{} +## Although this Makefile is build for shared library, it is easy to modify +## to build partial link objects instead (modify the lines with -shared and +## gnatlink below) +## +## With this makefile, you can change any file in the system or add any new +## file, and everything will be recompiled correctly (only the relevant shared +## objects will be recompiled, and the main program will be re-linked). -@item For the @option{-R} option -@table @asis -@item @emph{Attribute_Designator} -Removes the specified attribute from the set of attributes to be -detected without affecting detection checks for -other attributes. If @emph{Attribute_Designator} does not correspond to any -attribute defined in the Ada standard or in -@ref{Implementation Defined Attributes,,, gnat_rm, GNAT Reference Manual}, -this option is treated as turning OFF detection of all unknown attributes. - -@item GNAT -Turn OFF detection of all GNAT-specific attributes - -@item ALL -Clear the list of the attributes to be detected and -turn the rule OFF. -@end table -@end itemize +# The list of computer software component for your project. This might be +# generated automatically. +CSC_LIST=aa bb cc -@noindent -Parameters are not case sensitive. If @emph{Attribute_Designator} does not -have the syntax of an Ada identifier and therefore can not be considered as a -(part of an) attribute designator, a diagnostic message is generated and the -corresponding parameter is ignored. (If an attribute allows a static -expression to be a part of the attribute designator, this expression is -ignored by this rule.) +# Name of the main program (no extension) +MAIN=main -When more then one parameter is given in the same rule option, the parameters -must be separated by commas. +# If we need to build objects with -fPIC, uncomment the following line +#NEED_FPIC=-fPIC -If more then one option for this rule is specified for the gnatcheck call, a -new option overrides the previous one(s). +# The following variable should give the directory containing libgnat.so +# You can get this directory through 'gnatls -v'. This is usually the last +# directory in the Object_Path. +GLIB=@dots{} -The @option{+R} option with no parameters turns the rule ON, with the set of -attributes to be detected defined by the previous rule options. -(By default this set is empty, so if the only option specified for the rule is -@option{+RForbidden_Attributes} (with -no parameter), then the rule is enabled, but it does not detect anything). -The @option{-R} option with no parameter turns the rule OFF, but it does not -affect the set of attributes to be detected. +# The directories for the libraries +# (This macro expands the list of CSC to the list of shared libraries, you +# could simply use the expanded form: +# LIB_DIR=aa/lib/libaa.so bb/lib/libbb.so cc/lib/libcc.so +LIB_DIR=$@{foreach dir,$@{CSC_LIST@},$@{dir@}/lib/lib$@{dir@}.so@} +$@{MAIN@}: objects $@{LIB_DIR@} + gnatbind $@{MAIN@} $@{CSC_LIST:%=-aO%/lib@} -shared + gnatlink $@{MAIN@} $@{CSC_LIST:%=-l%@} -@node Forbidden_Pragmas -@subsection @code{Forbidden_Pragmas} -@cindex @code{Forbidden_Pragmas} rule (for @command{gnatcheck}) +objects:: + # recompile the sources + gnatmake -c -i $@{MAIN@}.adb $@{NEED_FPIC@} $@{CSC_LIST:%=-I%@} -@noindent -Flag each use of the specified pragmas. The pragmas to be detected -are named in the rule's parameters. +# Note: In a future version of GNAT, the following commands will be simplified +# by a new tool, gnatmlib +$@{LIB_DIR@}: + mkdir -p $@{dir $@@ @} + cd $@{dir $@@ @} && gcc -shared -o $@{notdir $@@ @} ../*.o -L$@{GLIB@} -lgnat + cd $@{dir $@@ @} && cp -f ../*.ali . -This rule has the following parameters: +# The dependencies for the modules +# Note that we have to force the expansion of *.o, since in some cases +# make won't be able to do it itself. +aa/lib/libaa.so: $@{wildcard aa/*.o@} +bb/lib/libbb.so: $@{wildcard bb/*.o@} +cc/lib/libcc.so: $@{wildcard cc/*.o@} -@itemize @bullet -@item For the @option{+R} option +# Make sure all of the shared libraries are in the path before starting the +# program +run:: + LD_LIBRARY_PATH=`pwd`/aa/lib:`pwd`/bb/lib:`pwd`/cc/lib ./$@{MAIN@} -@table @asis -@item @emph{Pragma_Name} -Adds the specified pragma to the set of pragmas to be -checked and sets the checks for all the specified pragmas -ON. @emph{Pragma_Name} is treated as a name of a pragma. If it -does not correspond to any pragma name defined in the Ada -standard or to the name of a GNAT-specific pragma defined -in @ref{Implementation Defined Pragmas,,, gnat_rm, GNAT Reference -Manual}, it is treated as the name of unknown pragma. - -@item @code{GNAT} -All the GNAT-specific pragmas are detected; this sets -the checks for all the specified pragmas ON. - -@item @code{ALL} -All pragmas are detected; this sets the rule ON. -@end table +clean:: + $@{RM@} -rf $@{CSC_LIST:%=%/lib@} + $@{RM@} $@{CSC_LIST:%=%/*.ali@} + $@{RM@} $@{CSC_LIST:%=%/*.o@} + $@{RM@} *.o *.ali $@{MAIN@} +@end smallexample -@item For the @option{-R} option -@table @asis -@item @emph{Pragma_Name} -Removes the specified pragma from the set of pragmas to be -checked without affecting checks for -other pragmas. @emph{Pragma_Name} is treated as a name -of a pragma. If it does not correspond to any pragma -defined in the Ada standard or to any name defined in -@ref{Implementation Defined Pragmas,,, gnat_rm, GNAT Reference Manual}, -this option is treated as turning OFF detection of all unknown pragmas. - -@item GNAT -Turn OFF detection of all GNAT-specific pragmas - -@item ALL -Clear the list of the pragmas to be detected and -turn the rule OFF. -@end table -@end itemize +@node Automatically Creating a List of Directories +@section Automatically Creating a List of Directories @noindent -Parameters are not case sensitive. If @emph{Pragma_Name} does not have -the syntax of an Ada identifier and therefore can not be considered -as a pragma name, a diagnostic message is generated and the corresponding -parameter is ignored. +In most makefiles, you will have to specify a list of directories, and +store it in a variable. For small projects, it is often easier to +specify each of them by hand, since you then have full control over what +is the proper order for these directories, which ones should be +included. -When more then one parameter is given in the same rule option, the parameters -must be separated by a comma. +However, in larger projects, which might involve hundreds of +subdirectories, it might be more convenient to generate this list +automatically. -If more then one option for this rule is specified for the @command{gnatcheck} -call, a new option overrides the previous one(s). +The example below presents two methods. The first one, although less +general, gives you more control over the list. It involves wildcard +characters, that are automatically expanded by @command{make}. Its +shortcoming is that you need to explicitly specify some of the +organization of your project, such as for instance the directory tree +depth, whether some directories are found in a separate tree, @enddots{} -The @option{+R} option with no parameters turns the rule ON with the set of -pragmas to be detected defined by the previous rule options. -(By default this set is empty, so if the only option specified for the rule is -@option{+RForbidden_Pragmas} (with -no parameter), then the rule is enabled, but it does not detect anything). -The @option{-R} option with no parameter turns the rule OFF, but it does not -affect the set of pragmas to be detected. +The second method is the most general one. It requires an external +program, called @command{find}, which is standard on all Unix systems. All +the directories found under a given root directory will be added to the +list. +@smallexample +@iftex +@leftskip=0cm +@font@heightrm=cmr8 +@heightrm +@end iftex +# The examples below are based on the following directory hierarchy: +# All the directories can contain any number of files +# ROOT_DIRECTORY -> a -> aa -> aaa +# -> ab +# -> ac +# -> b -> ba -> baa +# -> bb +# -> bc +# This Makefile creates a variable called DIRS, that can be reused any time +# you need this list (see the other examples in this section) +# The root of your project's directory hierarchy +ROOT_DIRECTORY=. +#### +# First method: specify explicitly the list of directories +# This allows you to specify any subset of all the directories you need. +#### -@node Function_Style_Procedures -@subsection @code{Function_Style_Procedures} -@cindex @code{Function_Style_Procedures} rule (for @command{gnatcheck}) +DIRS := a/aa/ a/ab/ b/ba/ -@noindent -Flag each procedure that can be rewritten as a function. A procedure can be -converted into a function if it has exactly one parameter of mode @code{out} -and no parameters of mode @code{in out}. Procedure declarations, -formal procedure declarations, and generic procedure declarations are always -checked. Procedure -bodies and body stubs are flagged only if they do not have corresponding -separate declarations. Procedure renamings and procedure instantiations are -not flagged. +#### +# Second method: use wildcards +# Note that the argument(s) to wildcard below should end with a '/'. +# Since wildcards also return file names, we have to filter them out +# to avoid duplicate directory names. +# We thus use make's @code{dir} and @code{sort} functions. +# It sets DIRs to the following value (note that the directories aaa and baa +# are not given, unless you change the arguments to wildcard). +# DIRS= ./a/a/ ./b/ ./a/aa/ ./a/ab/ ./a/ac/ ./b/ba/ ./b/bb/ ./b/bc/ +#### -If a procedure can be rewritten as a function, but its @code{out} parameter is -of a limited type, it is not flagged. +DIRS := $@{sort $@{dir $@{wildcard $@{ROOT_DIRECTORY@}/*/ + $@{ROOT_DIRECTORY@}/*/*/@}@}@} -Protected procedures are not flagged. Null procedures also are not flagged. +#### +# Third method: use an external program +# This command is much faster if run on local disks, avoiding NFS slowdowns. +# This is the most complete command: it sets DIRs to the following value: +# DIRS= ./a ./a/aa ./a/aa/aaa ./a/ab ./a/ac ./b ./b/ba ./b/ba/baa ./b/bb ./b/bc +#### -This rule has no parameters. +DIRS := $@{shell find $@{ROOT_DIRECTORY@} -type d -print@} +@end smallexample -@node Generics_In_Subprograms -@subsection @code{Generics_In_Subprograms} -@cindex @code{Generics_In_Subprograms} rule (for @command{gnatcheck}) +@node Generating the Command Line Switches +@section Generating the Command Line Switches @noindent -Flag each declaration of a generic unit in a subprogram. Generic -declarations in the bodies of generic subprograms are also flagged. -A generic unit nested in another generic unit is not flagged. -If a generic unit is -declared in a local package that is declared in a subprogram body, the -generic unit is flagged. - -This rule has no parameters. - +Once you have created the list of directories as explained in the +previous section (@pxref{Automatically Creating a List of Directories}), +you can easily generate the command line arguments to pass to gnatmake. -@node GOTO_Statements -@subsection @code{GOTO_Statements} -@cindex @code{GOTO_Statements} rule (for @command{gnatcheck}) +For the sake of completeness, this example assumes that the source path +is not the same as the object path, and that you have two separate lists +of directories. -@noindent -Flag each occurrence of a @code{goto} statement. +@smallexample +# see "Automatically creating a list of directories" to create +# these variables +SOURCE_DIRS= +OBJECT_DIRS= -This rule has no parameters. +GNATMAKE_SWITCHES := $@{patsubst %,-aI%,$@{SOURCE_DIRS@}@} +GNATMAKE_SWITCHES += $@{patsubst %,-aO%,$@{OBJECT_DIRS@}@} +all: + gnatmake $@{GNATMAKE_SWITCHES@} main_unit +@end smallexample -@node Implicit_IN_Mode_Parameters -@subsection @code{Implicit_IN_Mode_Parameters} -@cindex @code{Implicit_IN_Mode_Parameters} rule (for @command{gnatcheck}) +@node Overcoming Command Line Length Limits +@section Overcoming Command Line Length Limits @noindent -Flag each occurrence of a formal parameter with an implicit @code{in} mode. -Note that @code{access} parameters, although they technically behave -like @code{in} parameters, are not flagged. - -This rule has no parameters. +One problem that might be encountered on big projects is that many +operating systems limit the length of the command line. It is thus hard to give +gnatmake the list of source and object directories. +This example shows how you can set up environment variables, which will +make @command{gnatmake} behave exactly as if the directories had been +specified on the command line, but have a much higher length limit (or +even none on most systems). -@node Implicit_SMALL_For_Fixed_Point_Types -@subsection @code{Implicit_SMALL_For_Fixed_Point_Types} -@cindex @code{Implicit_SMALL_For_Fixed_Point_Types} rule (for @command{gnatcheck}) +It assumes that you have created a list of directories in your Makefile, +using one of the methods presented in +@ref{Automatically Creating a List of Directories}. +For the sake of completeness, we assume that the object +path (where the ALI files are found) is different from the sources patch. -@noindent -Flag each fixed point type declaration that lacks an explicit -representation clause to define its @code{'Small} value. -Since @code{'Small} can be defined only for ordinary fixed point types, -decimal fixed point type declarations are not checked. +Note a small trick in the Makefile below: for efficiency reasons, we +create two temporary variables (SOURCE_LIST and OBJECT_LIST), that are +expanded immediately by @code{make}. This way we overcome the standard +make behavior which is to expand the variables only when they are +actually used. -This rule has no parameters. +On Windows, if you are using the standard Windows command shell, you must +replace colons with semicolons in the assignments to these variables. +@smallexample +@iftex +@leftskip=0cm +@font@heightrm=cmr8 +@heightrm +@end iftex +# In this example, we create both ADA_INCLUDE_PATH and ADA_OBJECT_PATH. +# This is the same thing as putting the -I arguments on the command line. +# (the equivalent of using -aI on the command line would be to define +# only ADA_INCLUDE_PATH, the equivalent of -aO is ADA_OBJECT_PATH). +# You can of course have different values for these variables. +# +# Note also that we need to keep the previous values of these variables, since +# they might have been set before running 'make' to specify where the GNAT +# library is installed. -@node Improperly_Located_Instantiations -@subsection @code{Improperly_Located_Instantiations} -@cindex @code{Improperly_Located_Instantiations} rule (for @command{gnatcheck}) +# see "Automatically creating a list of directories" to create these +# variables +SOURCE_DIRS= +OBJECT_DIRS= -@noindent -Flag all generic instantiations in library-level package specs -(including library generic packages) and in all subprogram bodies. +empty:= +space:=$@{empty@} $@{empty@} +SOURCE_LIST := $@{subst $@{space@},:,$@{SOURCE_DIRS@}@} +OBJECT_LIST := $@{subst $@{space@},:,$@{OBJECT_DIRS@}@} +ADA_INCLUDE_PATH += $@{SOURCE_LIST@} +ADA_OBJECT_PATH += $@{OBJECT_LIST@} +export ADA_INCLUDE_PATH +export ADA_OBJECT_PATH -Instantiations in task and entry bodies are not flagged. Instantiations in the -bodies of protected subprograms are flagged. +all: + gnatmake main_unit +@end smallexample +@end ifclear -This rule has no parameters. +@node Memory Management Issues +@chapter Memory Management Issues +@noindent +This chapter describes some useful memory pools provided in the GNAT library +and in particular the GNAT Debug Pool facility, which can be used to detect +incorrect uses of access values (including ``dangling references''). +@ifclear vms +It also describes the @command{gnatmem} tool, which can be used to track down +``memory leaks''. +@end ifclear +@menu +* Some Useful Memory Pools:: +* The GNAT Debug Pool Facility:: +@ifclear vms +* The gnatmem Tool:: +@end ifclear +@end menu -@node Improper_Returns -@subsection @code{Improper_Returns} -@cindex @code{Improper_Returns} rule (for @command{gnatcheck}) +@node Some Useful Memory Pools +@section Some Useful Memory Pools +@findex Memory Pool +@cindex storage, pool @noindent -Flag each explicit @code{return} statement in procedures, and -multiple @code{return} statements in functions. -Diagnostic messages are generated for all @code{return} statements -in a procedure (thus each procedure must be written so that it -returns implicitly at the end of its statement part), -and for all @code{return} statements in a function after the first one. -This rule supports the stylistic convention that each subprogram -should have no more than one point of normal return. - -This rule has no parameters. +The @code{System.Pool_Global} package offers the Unbounded_No_Reclaim_Pool +storage pool. Allocations use the standard system call @code{malloc} while +deallocations use the standard system call @code{free}. No reclamation is +performed when the pool goes out of scope. For performance reasons, the +standard default Ada allocators/deallocators do not use any explicit storage +pools but if they did, they could use this storage pool without any change in +behavior. That is why this storage pool is used when the user +manages to make the default implicit allocator explicit as in this example: +@smallexample @c ada + type T1 is access Something; + -- no Storage pool is defined for T2 + type T2 is access Something_Else; + for T2'Storage_Pool use T1'Storage_Pool; + -- the above is equivalent to + for T2'Storage_Pool use System.Pool_Global.Global_Pool_Object; +@end smallexample +@noindent +The @code{System.Pool_Local} package offers the Unbounded_Reclaim_Pool storage +pool. The allocation strategy is similar to @code{Pool_Local}'s +except that the all +storage allocated with this pool is reclaimed when the pool object goes out of +scope. This pool provides a explicit mechanism similar to the implicit one +provided by several Ada 83 compilers for allocations performed through a local +access type and whose purpose was to reclaim memory when exiting the +scope of a given local access. As an example, the following program does not +leak memory even though it does not perform explicit deallocation: -@node Library_Level_Subprograms -@subsection @code{Library_Level_Subprograms} -@cindex @code{Library_Level_Subprograms} rule (for @command{gnatcheck}) +@smallexample @c ada +with System.Pool_Local; +procedure Pooloc1 is + procedure Internal is + type A is access Integer; + X : System.Pool_Local.Unbounded_Reclaim_Pool; + for A'Storage_Pool use X; + v : A; + begin + for I in 1 .. 50 loop + v := new Integer; + end loop; + end Internal; +begin + for I in 1 .. 100 loop + Internal; + end loop; +end Pooloc1; +@end smallexample @noindent -Flag all library-level subprograms (including generic subprogram instantiations). - -This rule has no parameters. +The @code{System.Pool_Size} package implements the Stack_Bounded_Pool used when +@code{Storage_Size} is specified for an access type. +The whole storage for the pool is +allocated at once, usually on the stack at the point where the access type is +elaborated. It is automatically reclaimed when exiting the scope where the +access type is defined. This package is not intended to be used directly by the +user and it is implicitly used for each such declaration: +@smallexample @c ada + type T1 is access Something; + for T1'Storage_Size use 10_000; +@end smallexample -@node Local_Packages -@subsection @code{Local_Packages} -@cindex @code{Local_Packages} rule (for @command{gnatcheck}) +@node The GNAT Debug Pool Facility +@section The GNAT Debug Pool Facility +@findex Debug Pool +@cindex storage, pool, memory corruption @noindent -Flag all local packages declared in package and generic package -specs. -Local packages in bodies are not flagged. - -This rule has no parameters. +The use of unchecked deallocation and unchecked conversion can easily +lead to incorrect memory references. The problems generated by such +references are usually difficult to tackle because the symptoms can be +very remote from the origin of the problem. In such cases, it is +very helpful to detect the problem as early as possible. This is the +purpose of the Storage Pool provided by @code{GNAT.Debug_Pools}. -@ignore -@node Improperly_Called_Protected_Entries -@subsection @code{Improperly_Called_Protected_Entries} (under construction, GLOBAL) -@cindex @code{Improperly_Called_Protected_Entries} rule (for @command{gnatcheck}) +In order to use the GNAT specific debugging pool, the user must +associate a debug pool object with each of the access types that may be +related to suspected memory problems. See Ada Reference Manual 13.11. +@smallexample @c ada +type Ptr is access Some_Type; +Pool : GNAT.Debug_Pools.Debug_Pool; +for Ptr'Storage_Pool use Pool; +@end smallexample @noindent -Flag each protected entry that can be called from more than one task. - -This rule has no parameters. -@end ignore +@code{GNAT.Debug_Pools} is derived from a GNAT-specific kind of +pool: the @code{Checked_Pool}. Such pools, like standard Ada storage pools, +allow the user to redefine allocation and deallocation strategies. They +also provide a checkpoint for each dereference, through the use of +the primitive operation @code{Dereference} which is implicitly called at +each dereference of an access value. -@node Metrics -@subsection @code{Metrics} -@cindex @code{Metrics} rule (for @command{gnatcheck}) - -@noindent -There is a set of checks based on computing a metric value and comparing the -result with the specified upper (or lower, depending on a specific metric) -value specified for a given metric. A construct is flagged if a given metric -is applicable (can be computed) for it and the computed value is greater -then (lover then) the specified upper (lower) bound. - -The name of any metric-based rule consists of the prefix @code{Metrics_} -followed by the name of the corresponding metric (see the table below). -For @option{+R} option, each metric-based rule has a numeric parameter -specifying the bound (integer or real, depending on a metric), @option{-R} -option for metric rules does not have a parameter. - -The following table shows the metric names for that the corresponding -metrics-based checks are supported by gnatcheck, including the -constraint that must be satisfied by the bound that is specified for the check -and what bound - upper (U) or lower (L) - should be specified. - -@multitable {@code{Cyclomatic_Complexity}}{Cyclomatic complexity}{Positive integer} -@ifnothtml -@headitem Check Name @tab Description @tab Bounds Value -@end ifnothtml -@ifhtml -@item @b{Check Name} @tab @b{Description} @tab @b{Bounds Value} -@end ifhtml -@c Above conditional code is workaround to bug in texi2html (Feb 2008) -@item @code{Essential_Complexity} @tab Essential complexity @tab Positive integer (U) -@item @code{Cyclomatic_Complexity} @tab Cyclomatic complexity @tab Positive integer (U) -@item @code{LSLOC} @tab Logical Source Lines of Code @tab Positive integer (U) -@end multitable +Once an access type has been associated with a debug pool, operations on +values of the type may raise four distinct exceptions, +which correspond to four potential kinds of memory corruption: +@itemize @bullet +@item +@code{GNAT.Debug_Pools.Accessing_Not_Allocated_Storage} +@item +@code{GNAT.Debug_Pools.Accessing_Deallocated_Storage} +@item +@code{GNAT.Debug_Pools.Freeing_Not_Allocated_Storage} +@item +@code{GNAT.Debug_Pools.Freeing_Deallocated_Storage } +@end itemize @noindent -The meaning and the computed values for all these metrics are exactly -the same as for the corresponding metrics in @command{gnatmetric}. +For types associated with a Debug_Pool, dynamic allocation is performed using +the standard GNAT allocation routine. References to all allocated chunks of +memory are kept in an internal dictionary. Several deallocation strategies are +provided, whereupon the user can choose to release the memory to the system, +keep it allocated for further invalid access checks, or fill it with an easily +recognizable pattern for debug sessions. The memory pattern is the old IBM +hexadecimal convention: @code{16#DEADBEEF#}. -@emph{Example:} the rule -@smallexample -+RMetrics_Cyclomatic_Complexity : 7 -@end smallexample -@noindent -means that all bodies with cyclomatic complexity exceeding 7 will be flagged. +See the documentation in the file g-debpoo.ads for more information on the +various strategies. -To turn OFF the check for cyclomatic complexity metric, use the following option: -@smallexample --RMetrics_Cyclomatic_Complexity -@end smallexample +Upon each dereference, a check is made that the access value denotes a +properly allocated memory location. Here is a complete example of use of +@code{Debug_Pools}, that includes typical instances of memory corruption: +@smallexample @c ada +@iftex +@leftskip=0cm +@end iftex +with Gnat.Io; use Gnat.Io; +with Unchecked_Deallocation; +with Unchecked_Conversion; +with GNAT.Debug_Pools; +with System.Storage_Elements; +with Ada.Exceptions; use Ada.Exceptions; +procedure Debug_Pool_Test is + + type T is access Integer; + type U is access all T; + P : GNAT.Debug_Pools.Debug_Pool; + for T'Storage_Pool use P; -@node Misnamed_Controlling_Parameters -@subsection @code{Misnamed_Controlling_Parameters} -@cindex @code{Misnamed_Controlling_Parameters} rule (for @command{gnatcheck}) + procedure Free is new Unchecked_Deallocation (Integer, T); + function UC is new Unchecked_Conversion (U, T); + A, B : aliased T; -@noindent -Flags a declaration of a dispatching operation, if the first parameter is -not a controlling one and its name is not @code{This} (the check for -parameter name is not case-sensitive). Declarations of dispatching functions -with controlling result and no controlling parameter are never flagged. + procedure Info is new GNAT.Debug_Pools.Print_Info(Put_Line); -A subprogram body declaration, subprogram renaming declaration or subprogram -body stub is flagged only if it is not a completion of a prior subprogram -declaration. +begin + Info (P); + A := new Integer; + B := new Integer; + B := A; + Info (P); + Free (A); + begin + Put_Line (Integer'Image(B.all)); + exception + when E : others => Put_Line ("raised: " & Exception_Name (E)); + end; + begin + Free (B); + exception + when E : others => Put_Line ("raised: " & Exception_Name (E)); + end; + B := UC(A'Access); + begin + Put_Line (Integer'Image(B.all)); + exception + when E : others => Put_Line ("raised: " & Exception_Name (E)); + end; + begin + Free (B); + exception + when E : others => Put_Line ("raised: " & Exception_Name (E)); + end; + Info (P); +end Debug_Pool_Test; +@end smallexample -This rule has no parameters. +@noindent +The debug pool mechanism provides the following precise diagnostics on the +execution of this erroneous program: +@smallexample +Debug Pool info: + Total allocated bytes : 0 + Total deallocated bytes : 0 + Current Water Mark: 0 + High Water Mark: 0 +Debug Pool info: + Total allocated bytes : 8 + Total deallocated bytes : 0 + Current Water Mark: 8 + High Water Mark: 8 +raised: GNAT.DEBUG_POOLS.ACCESSING_DEALLOCATED_STORAGE +raised: GNAT.DEBUG_POOLS.FREEING_DEALLOCATED_STORAGE +raised: GNAT.DEBUG_POOLS.ACCESSING_NOT_ALLOCATED_STORAGE +raised: GNAT.DEBUG_POOLS.FREEING_NOT_ALLOCATED_STORAGE +Debug Pool info: + Total allocated bytes : 8 + Total deallocated bytes : 4 + Current Water Mark: 4 + High Water Mark: 8 +@end smallexample -@node Misnamed_Identifiers -@subsection @code{Misnamed_Identifiers} -@cindex @code{Misnamed_Identifiers} rule (for @command{gnatcheck}) +@ifclear vms +@node The gnatmem Tool +@section The @command{gnatmem} Tool +@findex gnatmem @noindent -Flag the declaration of each identifier that does not have a suffix -corresponding to the kind of entity being declared. -The following declarations are checked: - +The @code{gnatmem} utility monitors dynamic allocation and +deallocation activity in a program, and displays information about +incorrect deallocations and possible sources of memory leaks. +It is designed to work in association with a static runtime library +only and in this context provides three types of information: @itemize @bullet @item -type declarations - -@item -subtype declarations +General information concerning memory management, such as the total +number of allocations and deallocations, the amount of allocated +memory and the high water mark, i.e.@: the largest amount of allocated +memory in the course of program execution. @item -constant declarations (but not number declarations) +Backtraces for all incorrect deallocations, that is to say deallocations +which do not correspond to a valid allocation. @item -package renaming declarations (but not generic package renaming -declarations) +Information on each allocation that is potentially the origin of a memory +leak. @end itemize -@noindent -This rule may have parameters. When used without parameters, the rule enforces -the following checks: +@menu +* Running gnatmem:: +* Switches for gnatmem:: +* Example of gnatmem Usage:: +@end menu -@itemize @bullet -@item -type-defining names end with @code{_T}, unless the type is an access type, -in which case the suffix must be @code{_A} -@item -constant names end with @code{_C} -@item -names defining package renamings end with @code{_R} -@end itemize +@node Running gnatmem +@subsection Running @code{gnatmem} @noindent -Defining identifiers from incomplete type declarations are never flagged. - -For a private type declaration (including private extensions), the defining -identifier from the private type declaration is checked against the type -suffix (even if the corresponding full declaration is an access type -declaration), and the defining identifier from the corresponding full type -declaration is not checked. +@code{gnatmem} makes use of the output created by the special version of +allocation and deallocation routines that record call information. This +allows to obtain accurate dynamic memory usage history at a minimal cost to +the execution speed. Note however, that @code{gnatmem} is not supported on +all platforms (currently, it is supported on AIX, HP-UX, GNU/Linux, +Solaris and Windows NT/2000/XP (x86). @noindent -For a deferred constant, the defining name in the corresponding full constant -declaration is not checked. - -Defining names of formal types are not checked. - -The rule may have the following parameters: - -@itemize @bullet -@item -For the @option{+R} option: -@table @code -@item Default -Sets the default listed above for all the names to be checked. - -@item Type_Suffix=@emph{string} -Specifies the suffix for a type name. - -@item Access_Suffix=@emph{string} -Specifies the suffix for an access type name. If -this parameter is set, it overrides for access -types the suffix set by the @code{Type_Suffix} parameter. -For access types, @emph{string} may have the following format: -@emph{suffix1(suffix2)}. That means that an access type name -should have the @emph{suffix1} suffix except for the case when -the designated type is also an access type, in this case the -type name should have the @emph{suffix1 & suffix2} suffix. - -@item Class_Access_Suffix=@emph{string} -Specifies the suffix for the name of an access type that points to some class-wide -type. If this parameter is set, it overrides for such access -types the suffix set by the @code{Type_Suffix} or @code{Access_Suffix} -parameter. - -@item Class_Subtype_Suffix=@emph{string} -Specifies the suffix for the name of a subtype that denotes a class-wide type. - -@item Constant_Suffix=@emph{string} -Specifies the suffix for a constant name. - -@item Renaming_Suffix=@emph{string} -Specifies the suffix for a package renaming name. -@end table +The @code{gnatmem} command has the form -@item -For the @option{-R} option: -@table @code -@item All_Suffixes -Remove all the suffixes specified for the -identifier suffix checks, whether by default or -as specified by other rule parameters. All the -checks for this rule are disabled as a result. - -@item Type_Suffix -Removes the suffix specified for types. This -disables checks for types but does not disable -any other checks for this rule (including the -check for access type names if @code{Access_Suffix} is -set). - -@item Access_Suffix -Removes the suffix specified for access types. -This disables checks for access type names but -does not disable any other checks for this rule. -If @code{Type_Suffix} is set, access type names are -checked as ordinary type names. - -@item Class_Access_Suffix -Removes the suffix specified for access types pointing to class-wide -type. This disables specific checks for names of access types pointing to -class-wide types but does not disable any other checks for this rule. -If @code{Type_Suffix} is set, access type names are -checked as ordinary type names. If @code{Access_Suffix} is set, these -access types are checked as any other access type name. - -@item Class_Subtype_Suffix=@emph{string} -Removes the suffix specified for subtype names. -This disables checks for subtype names but -does not disable any other checks for this rule. - -@item Constant_Suffix -Removes the suffix specified for constants. This -disables checks for constant names but does not -disable any other checks for this rule. - -@item Renaming_Suffix -Removes the suffix specified for package -renamings. This disables checks for package -renamings but does not disable any other checks -for this rule. -@end table -@end itemize +@smallexample +@c $ gnatmem @ovar{switches} user_program +@c Expanding @ovar macro inline (explanation in macro def comments) + $ gnatmem @r{[}@var{switches}@r{]} @var{user_program} +@end smallexample @noindent -If more than one parameter is used, parameters must be separated by commas. - -If more than one option is specified for the @command{gnatcheck} invocation, -a new option overrides the previous one(s). - -The @option{+RMisnamed_Identifiers} option (with no parameter) enables -checks for all the -name suffixes specified by previous options used for this rule. - -The @option{-RMisnamed_Identifiers} option (with no parameter) disables -all the checks but keeps -all the suffixes specified by previous options used for this rule. - -The @emph{string} value must be a valid suffix for an Ada identifier (after -trimming all the leading and trailing space characters, if any). -Parameters are not case sensitive, except the @emph{string} part. - -If any error is detected in a rule parameter, the parameter is ignored. -In such a case the options that are set for the rule are not -specified. - - +The program must have been linked with the instrumented version of the +allocation and deallocation routines. This is done by linking with the +@file{libgmem.a} library. For correct symbolic backtrace information, +the user program should be compiled with debugging options +(see @ref{Switches for gcc}). For example to build @file{my_program}: -@node Multiple_Entries_In_Protected_Definitions -@subsection @code{Multiple_Entries_In_Protected_Definitions} -@cindex @code{Multiple_Entries_In_Protected_Definitions} rule (for @command{gnatcheck}) +@smallexample +$ gnatmake -g my_program -largs -lgmem +@end smallexample @noindent -Flag each protected definition (i.e., each protected object/type declaration) -that defines more than one entry. -Diagnostic messages are generated for all the entry declarations -except the first one. An entry family is counted as one entry. Entries from -the private part of the protected definition are also checked. - -This rule has no parameters. - -@node Name_Clashes -@subsection @code{Name_Clashes} -@cindex @code{Name_Clashes} rule (for @command{gnatcheck}) +As library @file{libgmem.a} contains an alternate body for package +@code{System.Memory}, @file{s-memory.adb} should not be compiled and linked +when an executable is linked with library @file{libgmem.a}. It is then not +recommended to use @command{gnatmake} with switch @option{^-a^/ALL_FILES^}. @noindent -Check that certain names are not used as defining identifiers. To activate -this rule, you need to supply a reference to the dictionary file(s) as a rule -parameter(s) (more then one dictionary file can be specified). If no -dictionary file is set, this rule will not cause anything to be flagged. -Only defining occurrences, not references, are checked. -The check is not case-sensitive. - -This rule is enabled by default, but without setting any corresponding -dictionary file(s); thus the default effect is to do no checks. +When @file{my_program} is executed, the file @file{gmem.out} is produced. +This file contains information about all allocations and deallocations +performed by the program. It is produced by the instrumented allocations and +deallocations routines and will be used by @code{gnatmem}. -A dictionary file is a plain text file. The maximum line length for this file -is 1024 characters. If the line is longer then this limit, extra characters -are ignored. +In order to produce symbolic backtrace information for allocations and +deallocations performed by the GNAT run-time library, you need to use a +version of that library that has been compiled with the @option{-g} switch +(see @ref{Rebuilding the GNAT Run-Time Library}). -Each line can be either an empty line, a comment line, or a line containing -a list of identifiers separated by space or HT characters. -A comment is an Ada-style comment (from @code{--} to end-of-line). -Identifiers must follow the Ada syntax for identifiers. -A line containing one or more identifiers may end with a comment. +Gnatmem must be supplied with the @file{gmem.out} file and the executable to +examine. If the location of @file{gmem.out} file was not explicitly supplied by +@option{-i} switch, gnatmem will assume that this file can be found in the +current directory. For example, after you have executed @file{my_program}, +@file{gmem.out} can be analyzed by @code{gnatmem} using the command: -@node Non_Qualified_Aggregates -@subsection @code{Non_Qualified_Aggregates} -@cindex @code{Non_Qualified_Aggregates} rule (for @command{gnatcheck}) +@smallexample +$ gnatmem my_program +@end smallexample @noindent -Flag each non-qualified aggregate. -A non-qualified aggregate is an -aggregate that is not the expression of a qualified expression. A -string literal is not considered an aggregate, but an array -aggregate of a string type is considered as a normal aggregate. -Aggregates of anonymous array types are not flagged. - -This rule has no parameters. - +This will produce the output with the following format: -@node Non_Short_Circuit_Operators -@subsection @code{Non_Short_Circuit_Operators} -@cindex @code{Non_Short_Circuit_Operators} rule (for @command{gnatcheck}) +*************** debut cc +@smallexample +$ gnatmem my_program -@noindent -Flag all calls to predefined @code{and} and @code{or} operators for -any boolean type. Calls to -user-defined @code{and} and @code{or} and to operators defined by renaming -declarations are not flagged. Calls to predefined @code{and} and @code{or} -operators for modular types or boolean array types are not flagged. +Global information +------------------ + Total number of allocations : 45 + Total number of deallocations : 6 + Final Water Mark (non freed mem) : 11.29 Kilobytes + High Water Mark : 11.40 Kilobytes -This rule has no parameters. +. +. +. +Allocation Root # 2 +------------------- + Number of non freed allocations : 11 + Final Water Mark (non freed mem) : 1.16 Kilobytes + High Water Mark : 1.27 Kilobytes + Backtrace : + my_program.adb:23 my_program.alloc +. +. +. +@end smallexample +The first block of output gives general information. In this case, the +Ada construct ``@code{@b{new}}'' was executed 45 times, and only 6 calls to an +Unchecked_Deallocation routine occurred. +@noindent +Subsequent paragraphs display information on all allocation roots. +An allocation root is a specific point in the execution of the program +that generates some dynamic allocation, such as a ``@code{@b{new}}'' +construct. This root is represented by an execution backtrace (or subprogram +call stack). By default the backtrace depth for allocations roots is 1, so +that a root corresponds exactly to a source location. The backtrace can +be made deeper, to make the root more specific. -@node Non_SPARK_Attributes -@subsection @code{Non_SPARK_Attributes} -@cindex @code{Non_SPARK_Attributes} rule (for @command{gnatcheck}) +@node Switches for gnatmem +@subsection Switches for @code{gnatmem} @noindent -The SPARK language defines the following subset of Ada 95 attribute -designators as those that can be used in SPARK programs. The use of -any other attribute is flagged. +@code{gnatmem} recognizes the following switches: -@itemize @bullet -@item @code{'Adjacent} -@item @code{'Aft} -@item @code{'Base} -@item @code{'Ceiling} -@item @code{'Component_Size} -@item @code{'Compose} -@item @code{'Copy_Sign} -@item @code{'Delta} -@item @code{'Denorm} -@item @code{'Digits} -@item @code{'Exponent} -@item @code{'First} -@item @code{'Floor} -@item @code{'Fore} -@item @code{'Fraction} -@item @code{'Last} -@item @code{'Leading_Part} -@item @code{'Length} -@item @code{'Machine} -@item @code{'Machine_Emax} -@item @code{'Machine_Emin} -@item @code{'Machine_Mantissa} -@item @code{'Machine_Overflows} -@item @code{'Machine_Radix} -@item @code{'Machine_Rounds} -@item @code{'Max} -@item @code{'Min} -@item @code{'Model} -@item @code{'Model_Emin} -@item @code{'Model_Epsilon} -@item @code{'Model_Mantissa} -@item @code{'Model_Small} -@item @code{'Modulus} -@item @code{'Pos} -@item @code{'Pred} -@item @code{'Range} -@item @code{'Remainder} -@item @code{'Rounding} -@item @code{'Safe_First} -@item @code{'Safe_Last} -@item @code{'Scaling} -@item @code{'Signed_Zeros} -@item @code{'Size} -@item @code{'Small} -@item @code{'Succ} -@item @code{'Truncation} -@item @code{'Unbiased_Rounding} -@item @code{'Val} -@item @code{'Valid} -@end itemize +@table @option -@noindent -This rule has no parameters. +@item -q +@cindex @option{-q} (@code{gnatmem}) +Quiet. Gives the minimum output needed to identify the origin of the +memory leaks. Omits statistical information. +@item @var{N} +@cindex @var{N} (@code{gnatmem}) +N is an integer literal (usually between 1 and 10) which controls the +depth of the backtraces defining allocation root. The default value for +N is 1. The deeper the backtrace, the more precise the localization of +the root. Note that the total number of roots can depend on this +parameter. This parameter must be specified @emph{before} the name of the +executable to be analyzed, to avoid ambiguity. -@node Non_Tagged_Derived_Types -@subsection @code{Non_Tagged_Derived_Types} -@cindex @code{Non_Tagged_Derived_Types} rule (for @command{gnatcheck}) +@item -b n +@cindex @option{-b} (@code{gnatmem}) +This switch has the same effect as just depth parameter. -@noindent -Flag all derived type declarations that do not have a record extension part. +@item -i @var{file} +@cindex @option{-i} (@code{gnatmem}) +Do the @code{gnatmem} processing starting from @file{file}, rather than +@file{gmem.out} in the current directory. -This rule has no parameters. +@item -m n +@cindex @option{-m} (@code{gnatmem}) +This switch causes @code{gnatmem} to mask the allocation roots that have less +than n leaks. The default value is 1. Specifying the value of 0 will allow to +examine even the roots that didn't result in leaks. +@item -s order +@cindex @option{-s} (@code{gnatmem}) +This switch causes @code{gnatmem} to sort the allocation roots according to the +specified order of sort criteria, each identified by a single letter. The +currently supported criteria are @code{n, h, w} standing respectively for +number of unfreed allocations, high watermark, and final watermark +corresponding to a specific root. The default order is @code{nwh}. +@end table -@node Non_Visible_Exceptions -@subsection @code{Non_Visible_Exceptions} -@cindex @code{Non_Visible_Exceptions} rule (for @command{gnatcheck}) +@node Example of gnatmem Usage +@subsection Example of @code{gnatmem} Usage @noindent -Flag constructs leading to the possibility of propagating an exception -out of the scope in which the exception is declared. -Two cases are detected: - -@itemize @bullet -@item -An exception declaration in a subprogram body, task body or block -statement is flagged if the body or statement does not contain a handler for -that exception or a handler with an @code{others} choice. +The following example shows the use of @code{gnatmem} +on a simple memory-leaking program. +Suppose that we have the following Ada program: -@item -A @code{raise} statement in an exception handler of a subprogram body, -task body or block statement is flagged if it (re)raises a locally -declared exception. This may occur under the following circumstances: -@itemize @minus -@item -it explicitly raises a locally declared exception, or -@item -it does not specify an exception name (i.e., it is simply @code{raise;}) -and the enclosing handler contains a locally declared exception in its -exception choices. -@end itemize -@end itemize +@smallexample @c ada +@group +@cartouche +with Unchecked_Deallocation; +procedure Test_Gm is -@noindent -Renamings of local exceptions are not flagged. + type T is array (1..1000) of Integer; + type Ptr is access T; + procedure Free is new Unchecked_Deallocation (T, Ptr); + A : Ptr; -This rule has no parameters. + procedure My_Alloc is + begin + A := new T; + end My_Alloc; + procedure My_DeAlloc is + B : Ptr := A; + begin + Free (B); + end My_DeAlloc; -@node Numeric_Literals -@subsection @code{Numeric_Literals} -@cindex @code{Numeric_Literals} rule (for @command{gnatcheck}) +begin + My_Alloc; + for I in 1 .. 5 loop + for J in I .. 5 loop + My_Alloc; + end loop; + My_Dealloc; + end loop; +end; +@end cartouche +@end group +@end smallexample @noindent -Flag each use of a numeric literal in an index expression, and in any -circumstance except for the following: - -@itemize @bullet -@item -a literal occurring in the initialization expression for a constant -declaration or a named number declaration, or +The program needs to be compiled with debugging option and linked with +@code{gmem} library: -@item -an integer literal that is less than or equal to a value -specified by the @option{N} rule parameter. -@end itemize +@smallexample +$ gnatmake -g test_gm -largs -lgmem +@end smallexample @noindent -This rule may have the following parameters for the @option{+R} option: +Then we execute the program as usual: -@table @asis -@item @emph{N} -@emph{N} is an integer literal used as the maximal value that is not flagged -(i.e., integer literals not exceeding this value are allowed) +@smallexample +$ test_gm +@end smallexample -@item @code{ALL} -All integer literals are flagged -@end table +@noindent +Then @code{gnatmem} is invoked simply with +@smallexample +$ gnatmem test_gm +@end smallexample @noindent -If no parameters are set, the maximum unflagged value is 1. +which produces the following output (result may vary on different platforms): -The last specified check limit (or the fact that there is no limit at -all) is used when multiple @option{+R} options appear. +@smallexample +Global information +------------------ + Total number of allocations : 18 + Total number of deallocations : 5 + Final Water Mark (non freed mem) : 53.00 Kilobytes + High Water Mark : 56.90 Kilobytes -The @option{-R} option for this rule has no parameters. -It disables the rule but retains the last specified maximum unflagged value. -If the @option{+R} option subsequently appears, this value is used as the -threshold for the check. +Allocation Root # 1 +------------------- + Number of non freed allocations : 11 + Final Water Mark (non freed mem) : 42.97 Kilobytes + High Water Mark : 46.88 Kilobytes + Backtrace : + test_gm.adb:11 test_gm.my_alloc +Allocation Root # 2 +------------------- + Number of non freed allocations : 1 + Final Water Mark (non freed mem) : 10.02 Kilobytes + High Water Mark : 10.02 Kilobytes + Backtrace : + s-secsta.adb:81 system.secondary_stack.ss_init -@node OTHERS_In_Aggregates -@subsection @code{OTHERS_In_Aggregates} -@cindex @code{OTHERS_In_Aggregates} rule (for @command{gnatcheck}) +Allocation Root # 3 +------------------- + Number of non freed allocations : 1 + Final Water Mark (non freed mem) : 12 Bytes + High Water Mark : 12 Bytes + Backtrace : + s-secsta.adb:181 system.secondary_stack.ss_init +@end smallexample @noindent -Flag each use of an @code{others} choice in extension aggregates. -In record and array aggregates, an @code{others} choice is flagged unless -it is used to refer to all components, or to all but one component. - -If, in case of a named array aggregate, there are two associations, one -with an @code{others} choice and another with a discrete range, the -@code{others} choice is flagged even if the discrete range specifies -exactly one component; for example, @code{(1..1 => 0, others => 1)}. - -This rule has no parameters. +Note that the GNAT run time contains itself a certain number of +allocations that have no corresponding deallocation, +as shown here for root #2 and root +#3. This is a normal behavior when the number of non-freed allocations +is one, it allocates dynamic data structures that the run time needs for +the complete lifetime of the program. Note also that there is only one +allocation root in the user program with a single line back trace: +test_gm.adb:11 test_gm.my_alloc, whereas a careful analysis of the +program shows that 'My_Alloc' is called at 2 different points in the +source (line 21 and line 24). If those two allocation roots need to be +distinguished, the backtrace depth parameter can be used: -@node OTHERS_In_CASE_Statements -@subsection @code{OTHERS_In_CASE_Statements} -@cindex @code{OTHERS_In_CASE_Statements} rule (for @command{gnatcheck}) +@smallexample +$ gnatmem 3 test_gm +@end smallexample @noindent -Flag any use of an @code{others} choice in a @code{case} statement. - -This rule has no parameters. +which will give the following output: -@node OTHERS_In_Exception_Handlers -@subsection @code{OTHERS_In_Exception_Handlers} -@cindex @code{OTHERS_In_Exception_Handlers} rule (for @command{gnatcheck}) +@smallexample +Global information +------------------ + Total number of allocations : 18 + Total number of deallocations : 5 + Final Water Mark (non freed mem) : 53.00 Kilobytes + High Water Mark : 56.90 Kilobytes -@noindent -Flag any use of an @code{others} choice in an exception handler. +Allocation Root # 1 +------------------- + Number of non freed allocations : 10 + Final Water Mark (non freed mem) : 39.06 Kilobytes + High Water Mark : 42.97 Kilobytes + Backtrace : + test_gm.adb:11 test_gm.my_alloc + test_gm.adb:24 test_gm + b_test_gm.c:52 main -This rule has no parameters. +Allocation Root # 2 +------------------- + Number of non freed allocations : 1 + Final Water Mark (non freed mem) : 10.02 Kilobytes + High Water Mark : 10.02 Kilobytes + Backtrace : + s-secsta.adb:81 system.secondary_stack.ss_init + s-secsta.adb:283 + b_test_gm.c:33 adainit +Allocation Root # 3 +------------------- + Number of non freed allocations : 1 + Final Water Mark (non freed mem) : 3.91 Kilobytes + High Water Mark : 3.91 Kilobytes + Backtrace : + test_gm.adb:11 test_gm.my_alloc + test_gm.adb:21 test_gm + b_test_gm.c:52 main -@node Outer_Loop_Exits -@subsection @code{Outer_Loop_Exits} -@cindex @code{Outer_Loop_Exits} rule (for @command{gnatcheck}) +Allocation Root # 4 +------------------- + Number of non freed allocations : 1 + Final Water Mark (non freed mem) : 12 Bytes + High Water Mark : 12 Bytes + Backtrace : + s-secsta.adb:181 system.secondary_stack.ss_init + s-secsta.adb:283 + b_test_gm.c:33 adainit +@end smallexample @noindent -Flag each @code{exit} statement containing a loop name that is not the name -of the immediately enclosing @code{loop} statement. - -This rule has no parameters. +The allocation root #1 of the first example has been split in 2 roots #1 +and #3 thanks to the more precise associated backtrace. +@end ifclear -@node Overloaded_Operators -@subsection @code{Overloaded_Operators} -@cindex @code{Overloaded_Operators} rule (for @command{gnatcheck}) +@node Stack Related Facilities +@chapter Stack Related Facilities @noindent -Flag each function declaration that overloads an operator symbol. -A function body is checked only if the body does not have a -separate spec. Formal functions are also checked. For a -renaming declaration, only renaming-as-declaration is checked - -This rule has no parameters. +This chapter describes some useful tools associated with stack +checking and analysis. In +particular, it deals with dynamic and static stack usage measurements. +@menu +* Stack Overflow Checking:: +* Static Stack Usage Analysis:: +* Dynamic Stack Usage Analysis:: +@end menu -@node Overly_Nested_Control_Structures -@subsection @code{Overly_Nested_Control_Structures} -@cindex @code{Overly_Nested_Control_Structures} rule (for @command{gnatcheck}) +@node Stack Overflow Checking +@section Stack Overflow Checking +@cindex Stack Overflow Checking +@cindex -fstack-check @noindent -Flag each control structure whose nesting level exceeds the value provided -in the rule parameter. +For most operating systems, @command{gcc} does not perform stack overflow +checking by default. This means that if the main environment task or +some other task exceeds the available stack space, then unpredictable +behavior will occur. Most native systems offer some level of protection by +adding a guard page at the end of each task stack. This mechanism is usually +not enough for dealing properly with stack overflow situations because +a large local variable could ``jump'' above the guard page. +Furthermore, when the +guard page is hit, there may not be any space left on the stack for executing +the exception propagation code. Enabling stack checking avoids +such situations. -The control structures checked are the following: +To activate stack checking, compile all units with the gcc option +@option{-fstack-check}. For example: -@itemize @bullet -@item @code{if} statement -@item @code{case} statement -@item @code{loop} statement -@item Selective accept statement -@item Timed entry call statement -@item Conditional entry call -@item Asynchronous select statement -@end itemize +@smallexample +gcc -c -fstack-check package1.adb +@end smallexample @noindent -The rule has the following parameter for the @option{+R} option: +Units compiled with this option will generate extra instructions to check +that any use of the stack (for procedure calls or for declaring local +variables in declare blocks) does not exceed the available stack space. +If the space is exceeded, then a @code{Storage_Error} exception is raised. -@table @emph -@item N -Positive integer specifying the maximal control structure nesting -level that is not flagged -@end table +For declared tasks, the stack size is controlled by the size +given in an applicable @code{Storage_Size} pragma or by the value specified +at bind time with @option{-d} (@pxref{Switches for gnatbind}) or is set to +the default size as defined in the GNAT runtime otherwise. -@noindent -If the parameter for the @option{+R} option is not specified or -if it is not a positive integer, @option{+R} option is ignored. +For the environment task, the stack size depends on +system defaults and is unknown to the compiler. Stack checking +may still work correctly if a fixed +size stack is allocated, but this cannot be guaranteed. +@ifclear vms +To ensure that a clean exception is signalled for stack +overflow, set the environment variable +@env{GNAT_STACK_LIMIT} to indicate the maximum +stack area that can be used, as in: +@cindex GNAT_STACK_LIMIT -If more then one option is specified for the gnatcheck call, the later option and -new parameter override the previous one(s). +@smallexample +SET GNAT_STACK_LIMIT 1600 +@end smallexample +@noindent +The limit is given in kilobytes, so the above declaration would +set the stack limit of the environment task to 1.6 megabytes. +Note that the only purpose of this usage is to limit the amount +of stack used by the environment task. If it is necessary to +increase the amount of stack for the environment task, then this +is an operating systems issue, and must be addressed with the +appropriate operating systems commands. +@end ifclear +@ifset vms +To have a fixed size stack in the environment task, the stack must be put +in the P0 address space and its size specified. Use these switches to +create a p0 image: -@node Parameters_Out_Of_Order -@subsection @code{Parameters_Out_Of_Order} -@cindex @code{Parameters_Out_Of_Order} rule (for @command{gnatcheck}) +@smallexample +gnatmake my_progs -largs "-Wl,--opt=STACK=4000,/p0image" +@end smallexample @noindent -Flag each subprogram and entry declaration whose formal parameters are not -ordered according to the following scheme: - -@itemize @bullet +The quotes are required to keep case. The number after @samp{STACK=} is the +size of the environmental task stack in pagelets (512 bytes). In this example +the stack size is about 2 megabytes. -@item @code{in} and @code{access} parameters first, -then @code{in out} parameters, -and then @code{out} parameters; +@noindent +A consequence of the @option{/p0image} qualifier is also to makes RMS buffers +be placed in P0 space. Refer to @cite{HP OpenVMS Linker Utility Manual} for +more details about the @option{/p0image} qualifier and the @option{stack} +option. +@end ifset -@item for @code{in} mode, parameters with default initialization expressions -occur last -@end itemize +@node Static Stack Usage Analysis +@section Static Stack Usage Analysis +@cindex Static Stack Usage Analysis +@cindex -fstack-usage @noindent -Only the first violation of the described order is flagged. - -The following constructs are checked: +A unit compiled with @option{-fstack-usage} will generate an extra file +that specifies +the maximum amount of stack used, on a per-function basis. +The file has the same +basename as the target object file with a @file{.su} extension. +Each line of this file is made up of three fields: -@itemize @bullet -@item subprogram declarations (including null procedures); -@item generic subprogram declarations; -@item formal subprogram declarations; -@item entry declarations; -@item subprogram bodies and subprogram body stubs that do not -have separate specifications +@itemize +@item +The name of the function. +@item +A number of bytes. +@item +One or more qualifiers: @code{static}, @code{dynamic}, @code{bounded}. @end itemize -@noindent -Subprogram renamings are not checked. +The second field corresponds to the size of the known part of the function +frame. -This rule has no parameters. +The qualifier @code{static} means that the function frame size +is purely static. +It usually means that all local variables have a static size. +In this case, the second field is a reliable measure of the function stack +utilization. +The qualifier @code{dynamic} means that the function frame size is not static. +It happens mainly when some local variables have a dynamic size. When this +qualifier appears alone, the second field is not a reliable measure +of the function stack analysis. When it is qualified with @code{bounded}, it +means that the second field is a reliable maximum of the function stack +utilization. -@node Positional_Actuals_For_Defaulted_Generic_Parameters -@subsection @code{Positional_Actuals_For_Defaulted_Generic_Parameters} -@cindex @code{Positional_Actuals_For_Defaulted_Generic_Parameters} rule (for @command{gnatcheck}) +@node Dynamic Stack Usage Analysis +@section Dynamic Stack Usage Analysis @noindent -Flag each generic actual parameter corresponding to a generic formal -parameter with a default initialization, if positional notation is used. - -This rule has no parameters. +It is possible to measure the maximum amount of stack used by a task, by +adding a switch to @command{gnatbind}, as: -@node Positional_Actuals_For_Defaulted_Parameters -@subsection @code{Positional_Actuals_For_Defaulted_Parameters} -@cindex @code{Positional_Actuals_For_Defaulted_Parameters} rule (for @command{gnatcheck}) +@smallexample +$ gnatbind -u0 file +@end smallexample @noindent -Flag each actual parameter to a subprogram or entry call where the -corresponding formal parameter has a default expression, if positional -notation is used. - -This rule has no parameters. +With this option, at each task termination, its stack usage is output on +@file{stderr}. +It is not always convenient to output the stack usage when the program +is still running. Hence, it is possible to delay this output until program +termination. for a given number of tasks specified as the argument of the +@option{-u} option. For instance: -@node Positional_Components -@subsection @code{Positional_Components} -@cindex @code{Positional_Components} rule (for @command{gnatcheck}) +@smallexample +$ gnatbind -u100 file +@end smallexample @noindent -Flag each array, record and extension aggregate that includes positional -notation. - -This rule has no parameters. - - -@node Positional_Generic_Parameters -@subsection @code{Positional_Generic_Parameters} -@cindex @code{Positional_Generic_Parameters} rule (for @command{gnatcheck}) +will buffer the stack usage information of the first 100 tasks to terminate and +output this info at program termination. Results are displayed in four +columns: @noindent -Flag each positional actual generic parameter except for the case when -the generic unit being iinstantiated has exactly one generic formal -parameter. - -This rule has no parameters. - - -@node Positional_Parameters -@subsection @code{Positional_Parameters} -@cindex @code{Positional_Parameters} rule (for @command{gnatcheck}) +Index | Task Name | Stack Size | Stack Usage [Value +/- Variation] @noindent -Flag each positional parameter notation in a subprogram or entry call, -except for the following: - -@itemize @bullet -@item -Parameters of calls to of prefix or infix operators are not flagged -@item -If the called subprogram or entry has only one formal parameter, -the parameter of the call is not flagged; -@item -If a subprogram call uses the @emph{Object.Operation} notation, then -@itemize @minus -@item -the first parameter (that is, @emph{Object}) is not flagged; -@item -if the called subprogram has only two parameters, the second parameter -of the call is not flagged; -@end itemize -@end itemize +where: -@noindent -This rule has no parameters. +@table @emph +@item Index +is a number associated with each task. +@item Task Name +is the name of the task analyzed. +@item Stack Size +is the maximum size for the stack. +@item Stack Usage +is the measure done by the stack analyzer. In order to prevent overflow, the stack +is not entirely analyzed, and it's not possible to know exactly how +much has actually been used. The report thus contains the theoretical stack usage +(Value) and the possible variation (Variation) around this value. -@node Predefined_Numeric_Types -@subsection @code{Predefined_Numeric_Types} -@cindex @code{Predefined_Numeric_Types} rule (for @command{gnatcheck}) +@end table @noindent -Flag each explicit use of the name of any numeric type or subtype defined -in package @code{Standard}. +The environment task stack, e.g., the stack that contains the main unit, is +only processed when the environment variable GNAT_STACK_LIMIT is set. -The rationale for this rule is to detect when the -program may depend on platform-specific characteristics of the implementation -of the predefined numeric types. Note that this rule is over-pessimistic; -for example, a program that uses @code{String} indexing -likely needs a variable of type @code{Integer}. -Another example is the flagging of predefined numeric types with explicit -constraints: -@smallexample @c ada - subtype My_Integer is Integer range Left .. Right; - Vy_Var : My_Integer; -@end smallexample +@c ********************************* +@c * GNATCHECK * +@c ********************************* +@node Verifying Properties Using gnatcheck +@chapter Verifying Properties Using @command{gnatcheck} +@findex gnatcheck +@cindex @command{gnatcheck} @noindent -This rule detects only numeric types and subtypes defined in -@code{Standard}. The use of numeric types and subtypes defined in other -predefined packages (such as @code{System.Any_Priority} or -@code{Ada.Text_IO.Count}) is not flagged +The @command{gnatcheck} tool is an ASIS-based utility that checks properties +of Ada source files according to a given set of semantic rules. +@cindex ASIS + +In order to check compliance with a given rule, @command{gnatcheck} has to +semantically analyze the Ada sources. +Therefore, checks can only be performed on +legal Ada units. Moreover, when a unit depends semantically upon units located +outside the current directory, the source search path has to be provided when +calling @command{gnatcheck}, either through a specified project file or +through @command{gnatcheck} switches as described below. -This rule has no parameters. +A number of rules are predefined in @command{gnatcheck} and are described +later in this chapter. +You can also add new rules, by modifying the @command{gnatcheck} code and +rebuilding the tool. In order to add a simple rule making some local checks, +a small amount of straightforward ASIS-based programming is usually needed. +Project support for @command{gnatcheck} is provided by the GNAT +driver (see @ref{The GNAT Driver and Project Files}). +Invoking @command{gnatcheck} on the command line has the form: -@node Raising_External_Exceptions -@subsection @code{Raising_External_Exceptions} -@cindex @code{Raising_External_Exceptions} rule (for @command{gnatcheck}) +@smallexample +@c $ gnatcheck @ovar{switches} @{@var{filename}@} +@c @r{[}^-files^/FILES^=@{@var{arg_list_filename}@}@r{]} +@c @r{[}-cargs @var{gcc_switches}@r{]} -rules @var{rule_options} +@c Expanding @ovar macro inline (explanation in macro def comments) +$ gnatcheck @r{[}@var{switches}@r{]} @{@var{filename}@} + @r{[}^-files^/FILES^=@{@var{arg_list_filename}@}@r{]} + @r{[}-cargs @var{gcc_switches}@r{]} -rules @var{rule_options} +@end smallexample @noindent -Flag any @code{raise} statement, in a program unit declared in a library -package or in a generic library package, for an exception that is -neither a predefined exception nor an exception that is also declared (or -renamed) in the visible part of the package. +where +@itemize @bullet +@item +@var{switches} specify the general tool options -This rule has no parameters. +@item +Each @var{filename} is the name (including the extension) of a source +file to process. ``Wildcards'' are allowed, and +the file name may contain path information. +@item +Each @var{arg_list_filename} is the name (including the extension) of a text +file containing the names of the source files to process, separated by spaces +or line breaks. +@item +@var{gcc_switches} is a list of switches for +@command{gcc}. They will be passed on to all compiler invocations made by +@command{gnatcheck} to generate the ASIS trees. Here you can provide +@option{^-I^/INCLUDE_DIRS=^} switches to form the source search path, +and use the @option{-gnatec} switch to set the configuration file. -@node Raising_Predefined_Exceptions -@subsection @code{Raising_Predefined_Exceptions} -@cindex @code{Raising_Predefined_Exceptions} rule (for @command{gnatcheck}) +@item +@var{rule_options} is a list of options for controlling a set of +rules to be checked by @command{gnatcheck} (@pxref{gnatcheck Rule Options}). +@end itemize @noindent -Flag each @code{raise} statement that raises a predefined exception -(i.e., one of the exceptions @code{Constraint_Error}, @code{Numeric_Error}, -@code{Program_Error}, @code{Storage_Error}, or @code{Tasking_Error}). +Either a @file{@var{filename}} or an @file{@var{arg_list_filename}} must be +supplied. -This rule has no parameters. +@menu +* Format of the Report File:: +* General gnatcheck Switches:: +* gnatcheck Rule Options:: +* Adding the Results of Compiler Checks to gnatcheck Output:: +* Project-Wide Checks:: +* Rule exemption:: +* Predefined Rules:: +* Example of gnatcheck Usage:: +@end menu -@node Separate_Numeric_Error_Handlers -@subsection @code{Separate_Numeric_Error_Handlers} -@cindex @code{Separate_Numeric_Error_Handlers} rule (for @command{gnatcheck}) +@node Format of the Report File +@section Format of the Report File +@cindex Report file (for @code{gnatcheck}) @noindent -Flags each exception handler that contains a choice for -the predefined @code{Constraint_Error} exception, but does not contain -the choice for the predefined @code{Numeric_Error} exception, or -that contains the choice for @code{Numeric_Error}, but does not contain the -choice for @code{Constraint_Error}. - -This rule has no parameters. +The @command{gnatcheck} tool outputs on @file{stdout} all messages concerning +rule violations. +It also creates a text file that +contains the complete report of the last gnatcheck run. By default this file +is named named @file{^gnatcheck.out^GNATCHECK.OUT^} and it is located in the +current directory; the @option{^-o^/OUTPUT^} option can be used to change the +name and/or location of the report file. This report contains: +@itemize @bullet +@item date and time of @command{gnatcheck} run, the version of +the tool that has generated this report and the full parameters +of the @command{gnatcheck} invocation; +@item list of enabled rules; +@item total number of detected violations; +@item list of source files where rule violations have been detected; +@item list of source files where no violations have been detected. +@end itemize -@ignore -@node Recursion -@subsection @code{Recursion} (under construction, GLOBAL) -@cindex @code{Recursion} rule (for @command{gnatcheck}) +@node General gnatcheck Switches +@section General @command{gnatcheck} Switches @noindent -Flag recursive subprograms (cycles in the call graph). Declarations, and not -calls, of recursive subprograms are detected. +The following switches control the general @command{gnatcheck} behavior -This rule has no parameters. -@end ignore +@table @option +@c !sort! +@cindex @option{^-a^/ALL^} (@command{gnatcheck}) +@item ^-a^/ALL^ +Process all units including those with read-only ALI files such as +those from the GNAT Run-Time library. +@ifclear vms @ignore -@node Side_Effect_Functions -@subsection @code{Side_Effect_Functions} (under construction, GLOBAL) -@cindex @code{Side_Effect_Functions} rule (for @command{gnatcheck}) - -@noindent -Flag functions with side effects. - -We define a side effect as changing any data object that is not local for the -body of this function. +@cindex @option{-d} (@command{gnatcheck}) +@item -d +Debug mode +@end ignore -At the moment, we do NOT consider a side effect any input-output operations -(changing a state or a content of any file). +@cindex @option{-dd} (@command{gnatcheck}) +@item -dd +Progress indicator mode (for use in GPS). +@end ifclear -We do not consider protected functions for this rule (???) +@cindex @option{^-h^/HELP^} (@command{gnatcheck}) +@item ^-h^/HELP^ +List the predefined and user-defined rules. For more details see +@ref{Predefined Rules}. -There are the following sources of side effect: +@cindex @option{^-l^/LOCS^} (@command{gnatcheck}) +@item ^-l^/LOCS^ +Use full source locations references in the report file. For a construct from +a generic instantiation a full source location is a chain from the location +of this construct in the generic unit to the place where this unit is +instantiated. -@enumerate -@item Explicit (or direct) side-effect: +@cindex @option{^-log^/LOG^} (@command{gnatcheck}) +@item ^-log^/LOG^ +Duplicate all the output sent to @file{stderr} into a log file. The log file +is named @file{gnatcheck.log} and is located in the current directory. -@itemize @bullet -@item -direct assignment to a non-local variable; +@cindex @option{^-m^/DIAGNOSTIC_LIMIT^} (@command{gnatcheck}) +@item ^-m@i{nnnn}^/DIAGNOSTIC_LIMIT=@i{nnnn}^ +Maximum number of diagnostics to be sent to @file{stdout}, where @i{nnnn} is in +the range 0@dots{}1000; +the default value is 500. Zero means that there is no limitation on +the number of diagnostic messages to be output. -@item -direct call to an entity that is known to change some data object that is - not local for the body of this function (Note, that if F1 calls F2 and F2 - does have a side effect, this does not automatically mean that F1 also - have a side effect, because it may be the case that F2 is declared in - F1's body and it changes some data object that is global for F2, but - local for F1); -@end itemize +@cindex @option{^-q^/QUIET^} (@command{gnatcheck}) +@item ^-q^/QUIET^ +Quiet mode. All the diagnostics about rule violations are placed in the +@command{gnatcheck} report file only, without duplication on @file{stdout}. -@item Indirect side-effect: -@itemize @bullet -@item -Subprogram calls implicitly issued by: -@itemize @bullet -@item -computing initialization expressions from type declarations as a part - of object elaboration or allocator evaluation; -@item -computing implicit parameters of subprogram or entry calls or generic - instantiations; -@end itemize +@cindex @option{^-s^/SHORT^} (@command{gnatcheck}) +@item ^-s^/SHORT^ +Short format of the report file (no version information, no list of applied +rules, no list of checked sources is included) -@item -activation of a task that change some non-local data object (directly or - indirectly); +@cindex @option{^--include-file=@var{file}^/INCLUDE_FILE=@var{file}^} (@command{gnatcheck}) +@item ^--include-file^/INCLUDE_FILE^ +Append the content of the specified text file to the report file -@item -elaboration code of a package that is a result of a package instantiation; +@cindex @option{^-t^/TIME^} (@command{gnatcheck}) +@item ^-t^/TIME^ +Print out execution time. -@item -controlled objects; -@end itemize +@cindex @option{^-v^/VERBOSE^} (@command{gnatcheck}) +@item ^-v^/VERBOSE^ +Verbose mode; @command{gnatcheck} generates version information and then +a trace of sources being processed. -@item Situations when we can suspect a side-effect, but the full static check -is either impossible or too hard: -@itemize @bullet -@item -assignment to access variables or to the objects pointed by access - variables; +@cindex @option{^-o ^/OUTPUT^} (@command{gnatcheck}) +@item ^-o ^/OUTPUT=^@var{report_file} +Set name of report file file to @var{report_file} . -@item -call to a subprogram pointed by access-to-subprogram value +@end table -@item -dispatching calls; -@end itemize -@end enumerate +@node gnatcheck Rule Options +@section @command{gnatcheck} Rule Options @noindent -This rule has no parameters. -@end ignore +The following options control the processing performed by +@command{gnatcheck}. + +@table @option +@cindex @option{+ALL} (@command{gnatcheck}) +@item +ALL +Turn all the rule checks ON. -@node Slices -@subsection @code{Slices} -@cindex @code{Slices} rule (for @command{gnatcheck}) +@cindex @option{-ALL} (@command{gnatcheck}) +@item -ALL +Turn all the rule checks OFF. -@noindent -Flag all uses of array slicing +@cindex @option{+R} (@command{gnatcheck}) +@item +R@var{rule_id}@r{[}:@var{param}@r{]} +Turn on the check for a specified rule with the specified parameter, if any. +@var{rule_id} must be the identifier of one of the currently implemented rules +(use @option{^-h^/HELP^} for the list of implemented rules). Rule identifiers +are not case-sensitive. The @var{param} item must +be a string representing a valid parameter(s) for the specified rule. +If it contains any space characters then this string must be enclosed in +quotation marks. -This rule has no parameters. +@cindex @option{-R} (@command{gnatcheck}) +@item -R@var{rule_id}@r{[}:@var{param}@r{]} +Turn off the check for a specified rule with the specified parameter, if any. +@cindex @option{-from} (@command{gnatcheck}) +@item -from=@var{rule_option_filename} +Read the rule options from the text file @var{rule_option_filename}, referred +to as a ``coding standard file'' below. -@node Too_Many_Parents -@subsection @code{Too_Many_Parents} -@cindex @code{Too_Many_Parents} rule (for @command{gnatcheck}) +@end table @noindent -Flags any type declaration, single task declaration or single protected -declaration that has more then @option{N} parents, @option{N} is a parameter -of the rule. -A parent here is either a (sub)type denoted by the subtype mark from the -parent_subtype_indication (in case of a derived type declaration), or -any of the progenitors from the interface list, if any. +The default behavior is that all the rule checks are disabled. -This rule has the following (mandatory) parameters for the @option{+R} option: +A coding standard file is a text file that contains a set of rule options +described above. +@cindex Coding standard file (for @code{gnatcheck}) +The file may contain empty lines and Ada-style comments (comment +lines and end-of-line comments). There can be several rule options on a +single line (separated by a space). -@table @emph -@item N -Positive integer specifying the maximal allowed number of parents. -@end table +A coding standard file may reference other coding standard files by including +more @option{-from=@var{rule_option_filename}} +options, each such option being replaced with the content of the +corresponding coding standard file during processing. In case a +cycle is detected (that is, @file{@var{rule_file_1}} reads rule options +from @file{@var{rule_file_2}}, and @file{@var{rule_file_2}} reads +(directly or indirectly) rule options from @file{@var{rule_file_1}}), +processing fails with an error message. -@node Unassigned_OUT_Parameters -@subsection @code{Unassigned_OUT_Parameters} -@cindex @code{Unassigned_OUT_Parameters} rule (for @command{gnatcheck}) +@node Adding the Results of Compiler Checks to gnatcheck Output +@section Adding the Results of Compiler Checks to @command{gnatcheck} Output @noindent -Flags procedures' @code{out} parameters that are not assigned, and -identifies the contexts in which the assignments are missing. - -An @code{out} parameter is flagged in the statements in the procedure -body's handled sequence of statements (before the procedure body's -@code{exception} part, if any) if this sequence of statements contains -no assignments to the parameter. - -An @code{out} parameter is flagged in an exception handler in the exception -part of the procedure body's handled sequence of statements if the handler -contains no assignment to the parameter. - -Bodies of generic procedures are also considered. +The @command{gnatcheck} tool can include in the generated diagnostic messages +and in +the report file the results of the checks performed by the compiler. Though +disabled by default, this effect may be obtained by using @option{+R} with +the following rule identifiers and parameters: -The following are treated as assignments to an @code{out} parameter: +@table @option +@item Restrictions +To record restrictions violations (which are performed by the compiler if the +pragma @code{Restrictions} or @code{Restriction_Warnings} are given), +use the @code{Restrictions} rule +with the same parameters as pragma +@code{Restrictions} or @code{Restriction_Warnings}. -@itemize @bullet +@item Style_Checks +To record compiler style checks (@pxref{Style Checking}), use the +@code{Style_Checks} rule. +This rule takes a parameter in one of the following forms: +@itemize @item -an assignment statement, with the parameter or some component as the target; +@code{All_Checks}, +which enables the standard style checks corresponding to the @option{-gnatyy} +GNAT style check option, or @item -passing the parameter (or one of its components) as an @code{out} or -@code{in out} parameter. +a string with the same +structure and semantics as the @code{string_LITERAL} parameter of the +GNAT pragma @code{Style_Checks} +(for further information about this pragma, +@pxref{Pragma Style_Checks,,, gnat_rm, GNAT Reference Manual}). @end itemize @noindent -This rule does not have any parameters. - - - -@node Uncommented_BEGIN_In_Package_Bodies -@subsection @code{Uncommented_BEGIN_In_Package_Bodies} -@cindex @code{Uncommented_BEGIN_In_Package_Bodies} rule (for @command{gnatcheck}) +For example, the +@code{+RStyle_Checks:O} rule option activates +the compiler style check that corresponds to +@code{-gnatyO} style check option. -@noindent -Flags each package body with declarations and a statement part that does not -include a trailing comment on the line containing the @code{begin} keyword; -this trailing comment needs to specify the package name and nothing else. -The @code{begin} is not flagged if the package body does not -contain any declarations. +@item Warnings +To record compiler warnings (@pxref{Warning Message Control}), use the +@code{Warnings} rule with a parameter that is a valid +@i{static_string_expression} argument of the GNAT pragma @code{Warnings} +(for further information about this pragma, +@pxref{Pragma Warnings,,,gnat_rm, GNAT Reference Manual}). +Note that in case of gnatcheck +'s' parameter, that corresponds to the GNAT @option{-gnatws} option, disables +all the specific warnings, but not suppresses the warning mode, +and 'e' parameter, corresponding to @option{-gnatwe} that means +"treat warnings as errors", does not have any effect. -If the @code{begin} keyword is placed on the -same line as the last declaration or the first statement, it is flagged -independently of whether the line contains a trailing comment. The -diagnostic message is attached to the line containing the first statement. +@end table -This rule has no parameters. +To disable a specific restriction check, use @code{-RStyle_Checks} gnatcheck +option with the corresponding restriction name as a parameter. @code{-R} is +not available for @code{Style_Checks} and @code{Warnings} options, to disable +warnings and style checks, use the corresponding warning and style options. -@node Unconditional_Exits -@subsection @code{Unconditional_Exits} -@cindex @code{Unconditional_Exits} rule (for @command{gnatcheck}) +@node Project-Wide Checks +@section Project-Wide Checks +@cindex Project-wide checks (for @command{gnatcheck}) @noindent -Flag unconditional @code{exit} statements. - -This rule has no parameters. - -@node Unconstrained_Array_Returns -@subsection @code{Unconstrained_Array_Returns} -@cindex @code{Unconstrained_Array_Returns} rule (for @command{gnatcheck}) +In order to perform checks on all units of a given project, you can use +the GNAT driver along with the @option{-P} option: +@smallexample + gnat check -Pproj -rules -from=my_rules +@end smallexample @noindent -Flag each function returning an unconstrained array. Function declarations, -function bodies (and body stubs) having no separate specifications, -and generic function instantiations are checked. -Function calls and function renamings are -not checked. +If the project @code{proj} depends upon other projects, you can perform +checks on the project closure using the @option{-U} option: +@smallexample + gnat check -Pproj -U -rules -from=my_rules +@end smallexample -Generic function declarations, and function declarations in generic -packages are not checked, instead this rule checks the results of -generic instantiations (that is, expanded specification and expanded -body corresponding to an instantiation). +@noindent +Finally, if not all the units are relevant to a particular main +program in the project closure, you can perform checks for the set +of units needed to create a given main program (unit closure) using +the @option{-U} option followed by the name of the main unit: +@smallexample + gnat check -Pproj -U main -rules -from=my_rules +@end smallexample -This rule has no parameters. -@node Universal_Ranges -@subsection @code{Universal_Ranges} -@cindex @code{Universal_Ranges} rule (for @command{gnatcheck}) +@node Rule exemption +@section Rule exemption +@cindex Rule exemption (for @command{gnatcheck}) @noindent -Flag discrete ranges that are a part of an index constraint, constrained -array definition, or @code{for}-loop parameter specification, and whose bounds -are both of type @i{universal_integer}. Ranges that have at least one -bound of a specific type (such as @code{1 .. N}, where @code{N} is a variable -or an expression of non-universal type) are not flagged. +One of the most useful applications of @command{gnatcheck} is to +automate the enforcement of project-specific coding standards, +for example in safety-critical systems where particular features +must be restricted in order to simplify the certification effort. +However, it may sometimes be appropriate to violate a coding standard rule, +and in such cases the rationale for the violation should be provided +in the source program itself so that the individuals +reviewing or maintaining the program can immediately understand the intent. -This rule has no parameters. +The @command{gnatcheck} tool supports this practice with the notion of +a ``rule exemption'' covering a specific source code section. Normally +rule violation messages are issued both on @file{stderr} +and in a report file. In contrast, exempted violations are not listed on +@file{stderr}; thus users invoking @command{gnatcheck} interactively +(e.g. in its GPS interface) do not need to pay attention to known and +justified violations. However, exempted violations along with their +justification are documented in a special section of the report file that +@command{gnatcheck} generates. +@menu +* Using pragma Annotate to Control Rule Exemption:: +* gnatcheck Annotations Rules:: +@end menu -@node Unnamed_Blocks_And_Loops -@subsection @code{Unnamed_Blocks_And_Loops} -@cindex @code{Unnamed_Blocks_And_Loops} rule (for @command{gnatcheck}) +@node Using pragma Annotate to Control Rule Exemption +@subsection Using pragma @code{Annotate} to Control Rule Exemption +@cindex Using pragma Annotate to control rule exemption @noindent -Flag each unnamed block statement and loop statement. +Rule exemption is controlled by pragma @code{Annotate} when its first +argument is ``gnatcheck''. The syntax of @command{gnatcheck}'s +exemption control annotations is as follows: -The rule has no parameters. +@smallexample @c ada +@group +pragma Annotate (gnatcheck, @i{exemption_control}, @i{Rule_Name}, [@i{justification}]); +@i{exemption_control} ::= Exempt_On | Exempt_Off +@i{Rule_Name} ::= string_literal -@ignore -@node Unused_Subprograms -@subsection @code{Unused_Subprograms} (under construction, GLOBAL) -@cindex @code{Unused_Subprograms} rule (for @command{gnatcheck}) +@i{justification} ::= string_literal +@end group +@end smallexample @noindent -Flag all unused subprograms. +When a @command{gnatcheck} annotation has more then four arguments, +@command{gnatcheck} issues a warning and ignores the additional arguments. +If the additional arguments do not follow the syntax above, +@command{gnatcheck} emits a warning and ignores the annotation. -This rule has no parameters. -@end ignore +The @i{@code{Rule_Name}} argument should be the name of some existing +@command{gnatcheck} rule. +Otherwise a warning message is generated and the pragma is +ignored. If @code{Rule_Name} denotes a rule that is not activated by the given +@command{gnatcheck} call, the pragma is ignored and no warning is issued. +A source code section where an exemption is active for a given rule is +delimited by an @code{exempt_on} and @code{exempt_off} annotation pair: +@smallexample @c ada +pragma Annotate (gnatcheck, Exempt_On, Rule_Name, "justification"); +-- source code section +pragma Annotate (gnatcheck, Exempt_Off, Rule_Name); +@end smallexample -@node USE_PACKAGE_Clauses -@subsection @code{USE_PACKAGE_Clauses} -@cindex @code{USE_PACKAGE_Clauses} rule (for @command{gnatcheck}) +@node gnatcheck Annotations Rules +@subsection @command{gnatcheck} Annotations Rules +@cindex @command{gnatcheck} annotations rules -@noindent -Flag all @code{use} clauses for packages; @code{use type} clauses are -not flagged. +@itemize @bullet -This rule has no parameters. +@item +An ``Exempt_Off'' annotation can only appear after a corresponding +``Exempt_On'' annotation. +@item +Exempted source code sections are only based on the source location of the +annotations. Any source construct between the two +annotations is part of the exempted source code section. -@node Visible_Components -@subsection @code{Visible_Components} -@cindex @code{Visible_Components} rule (for @command{gnatcheck}) +@item +Exempted source code sections for different rules are independent. They can +be nested or intersect with one another without limitation. +Creating nested or intersecting source code sections for the same rule is +not allowed. -@noindent -Flags all the type declarations located in the visible part of a library -package or a library generic package that can declare a visible component. A -type is considered as declaring a visible component if it contains a record -definition by its own or as a part of a record extension. Type declaration is -flagged even if it contains a record definition that defines no components. +@item +Malformed exempted source code sections are reported by a warning, and +the corresponding rule exemptions are ignored. -Declarations located in private parts of local (generic) packages are not -flagged. Declarations in private packages are not flagged. +@item +When an exempted source code section does not contain at least one violation +of the exempted rule, a warning is emitted on @file{stderr}. -This rule has no parameters. +@item +If an ``Exempt_On'' annotation pragma does not have a matching +``Exempt_Off'' annotation pragma in the same compilation unit, then the +exemption for the given rule is ignored and a warning is issued. +@end itemize -@node Volatile_Objects_Without_Address_Clauses -@subsection @code{Volatile_Objects_Without_Address_Clauses} -@cindex @code{Volatile_Objects_Without_Address_Clauses} rule (for @command{gnatcheck}) +@node Predefined Rules +@section Predefined Rules +@cindex Predefined rules (for @command{gnatcheck}) +@ignore +@c (Jan 2007) Since the global rules are still under development and are not +@c documented, there is no point in explaining the difference between +@c global and local rules @noindent -Flag each volatile object that does not have an address clause. +A rule in @command{gnatcheck} is either local or global. +A @emph{local rule} is a rule that applies to a well-defined section +of a program and that can be checked by analyzing only this section. +A @emph{global rule} requires analysis of some global properties of the +whole program (mostly related to the program call graph). +As of @value{NOW}, the implementation of global rules should be +considered to be at a preliminary stage. You can use the +@option{+GLOBAL} option to enable all the global rules, and the +@option{-GLOBAL} rule option to disable all the global rules. -The following check is made: if the pragma @code{Volatile} is applied to a -data object or to its type, then an address clause must -be supplied for this object. +All the global rules in the list below are +so indicated by marking them ``GLOBAL''. +This +GLOBAL and -GLOBAL options are not +included in the list of gnatcheck options above, because at the moment they +are considered as a temporary debug options. -This rule does not check the components of data objects, -array components that are volatile as a result of the pragma -@code{Volatile_Components}, or objects that are volatile because -they are atomic as a result of pragmas @code{Atomic} or -@code{Atomic_Components}. +@command{gnatcheck} performs rule checks for generic +instances only for global rules. This limitation may be relaxed in a later +release. +@end ignore -Only variable declarations, and not constant declarations, are checked. +@noindent +The predefined rules implemented in @command{gnatcheck} +are described in a companion document, +@cite{GNATcheck Reference Manual -- Predefined Rules}. +The rule identifier is +used as a parameter of @command{gnatcheck}'s @option{+R} or @option{-R} +switches. -This rule has no parameters. @node Example of gnatcheck Usage @section Example of @command{gnatcheck} Usage @@ -23157,7 +17849,9 @@ option @option{^--no-exception^/NO_EXCEPTION^} (see below). @command{gnatstub} has the command-line interface of the form @smallexample -$ gnatstub @ovar{switches} @var{filename} @ovar{directory} +@c $ gnatstub @ovar{switches} @var{filename} @ovar{directory} +@c Expanding @ovar macro inline (explanation in macro def comments) +$ gnatstub @r{[}@var{switches}@r{]} @var{filename} @r{[}@var{directory}@r{]} @r{[}-cargs @var{gcc_switches}@r{]} @end smallexample @noindent @@ -23185,6 +17879,12 @@ indicates the directory in which the body stub is to be placed (the default is the current directory) +@item @samp{@var{gcc_switches}} is a list of switches for +@command{gcc}. They will be passed on to all compiler invocations made by +@command{gnatelim} to generate the ASIS trees. Here you can provide +@option{^-I^/INCLUDE_DIRS=^} switches to form the source search path, +use the @option{-gnatec} switch to set the configuration file etc. + @item switches is an optional sequence of switches as described in the next section @end table @@ -23689,7 +18389,9 @@ be able to click on any identifier and go to its declaration. The command line is as follow: @smallexample -$ perl gnathtml.pl @ovar{^switches^options^} @var{ada-files} +@c $ perl gnathtml.pl @ovar{^switches^options^} @var{ada-files} +@c Expanding @ovar macro inline (explanation in macro def comments) +$ perl gnathtml.pl @r{[}@var{^switches^options^}@r{]} @var{ada-files} @end smallexample @noindent @@ -23795,7 +18497,9 @@ is. The syntax of this line is: Alternatively, you may run the script using the following command line: @smallexample -$ perl gnathtml.pl @ovar{switches} @var{files} +@c $ perl gnathtml.pl @ovar{switches} @var{files} +@c Expanding @ovar macro inline (explanation in macro def comments) +$ perl gnathtml.pl @r{[}@var{switches}@r{]} @var{files} @end smallexample @ifset vms @@ -24155,6 +18859,7 @@ the incorrect user program. * Ada Exceptions:: * Ada Tasks:: * Debugging Generic Units:: +* Remote Debugging using gdbserver:: * GNAT Abnormal Termination or Failure to Terminate:: * Naming Conventions for GNAT Source Files:: * Getting Internal Debugging Information:: @@ -24300,11 +19005,10 @@ and execution encounters the breakpoint, then the program stops and @code{GDB} signals that the breakpoint was encountered by printing the line of code before which the program is halted. -@item breakpoint exception @var{name} -A special form of the breakpoint command which breakpoints whenever -exception @var{name} is raised. -If @var{name} is omitted, -then a breakpoint will occur when any exception is raised. +@item catch exception @var{name} +This command causes the program execution to stop whenever exception +@var{name} is raised. If @var{name} is omitted, then the execution is +suspended when any exception is raised. @item print @var{expression} This will print the value of the given expression. Most simple @@ -24466,25 +19170,25 @@ The value returned is always that from the first return statement that was stepped through. @node Ada Exceptions -@section Breaking on Ada Exceptions +@section Stopping when Ada Exceptions are Raised @cindex Exceptions @noindent -You can set breakpoints that trip when your program raises -selected exceptions. +You can set catchpoints that stop the program execution when your program +raises selected exceptions. @table @code -@item break exception -Set a breakpoint that trips whenever (any task in the) program raises -any exception. +@item catch exception +Set a catchpoint that stops execution whenever (any task in the) program +raises any exception. -@item break exception @var{name} -Set a breakpoint that trips whenever (any task in the) program raises -the exception @var{name}. +@item catch exception @var{name} +Set a catchpoint that stops execution whenever (any task in the) program +raises the exception @var{name}. -@item break exception unhandled -Set a breakpoint that trips whenever (any task in the) program raises an -exception for which there is no handler. +@item catch exception unhandled +Set a catchpoint that stops executino whenever (any task in the) program +raises an exception for which there is no handler. @item info exceptions @itemx info exceptions @var{regexp} @@ -24613,6 +19317,56 @@ When the breakpoint occurs, you can step through the code of the instance in the normal manner and examine the values of local variables, as for other units. +@node Remote Debugging using gdbserver +@section Remote Debugging using gdbserver +@cindex Remote Debugging using gdbserver + +@noindent +On platforms where gdbserver is supported, it is possible to use this tool +to debug your application remotely. This can be useful in situations +where the program needs to be run on a target host that is different +from the host used for development, particularly when the target has +a limited amount of resources (either CPU and/or memory). + +To do so, start your program using gdbserver on the target machine. +gdbserver then automatically suspends the execution of your program +at its entry point, waiting for a debugger to connect to it. The +following commands starts an application and tells gdbserver to +wait for a connection with the debugger on localhost port 4444. + +@smallexample +$ gdbserver localhost:4444 program +Process program created; pid = 5685 +Listening on port 4444 +@end smallexample + +Once gdbserver has started listening, we can tell the debugger to establish +a connection with this gdbserver, and then start the same debugging session +as if the program was being debugged on the same host, directly under +the control of GDB. + +@smallexample +$ gdb program +(gdb) target remote targethost:4444 +Remote debugging using targethost:4444 +0x00007f29936d0af0 in ?? () from /lib64/ld-linux-x86-64.so. +(gdb) b foo.adb:3 +Breakpoint 1 at 0x401f0c: file foo.adb, line 3. +(gdb) continue +Continuing. + +Breakpoint 1, foo () at foo.adb:4 +4 end foo; +@end smallexample + +It is also possible to use gdbserver to attach to an already running +program, in which case the execution of that program is simply suspended +until the connection between the debugger and gdbserver is established. + +For more information on how to use gdbserver, @ref{Top, Server, Using +the gdbserver Program, gdb, Debugging with GDB}. GNAT Pro provides support +for gdbserver on x86-linux, x86-windows and x86_64-linux. + @node GNAT Abnormal Termination or Failure to Terminate @section GNAT Abnormal Termination or Failure to Terminate @cindex GNAT Abnormal Termination or Failure to Terminate @@ -25964,7 +20718,9 @@ Unlike HP Ada, the GNAT ``@code{EXPORT_}@i{subprogram}'' pragmas require a separate subprogram specification which must appear before the subprogram body. -GNAT also supplies a number of implementation-defined pragmas as follows: +GNAT also supplies a number of implementation-defined pragmas including the +following: + @itemize @bullet @item @code{ABORT_DEFER} @@ -25974,6 +20730,12 @@ GNAT also supplies a number of implementation-defined pragmas as follows: @item @code{ADA_05} +@item @code{Ada_2005} + +@item @code{Ada_12} + +@item @code{Ada_2012} + @item @code{ANNOTATE} @item @code{ASSERT} @@ -26020,7 +20782,7 @@ GNAT also supplies a number of implementation-defined pragmas as follows: @end itemize @noindent -For full details on these GNAT implementation-defined pragmas, +For full details on these and other GNAT implementation-defined pragmas, see @ref{Implementation Defined Pragmas,,, gnat_rm, GNAT Reference Manual}. @@ -26919,6 +21681,7 @@ information about several specific platforms. * AIX-Specific Considerations:: * Irix-Specific Considerations:: * RTX-Specific Considerations:: +* HP-UX-Specific Considerations:: @end menu @node Summary of Run-Time Configurations @@ -27278,10 +22041,47 @@ Windows executables that run in Ring 3 to utilize memory protection @item Real-time subsystem (RTSS) executables that run in Ring 0, where performance can be optimized with RTSS applications taking precedent -over all Windows applications (@emph{rts-rtx-rtss}). +over all Windows applications (@emph{rts-rtx-rtss}). This mode requires +the Microsoft linker to handle RTSS libraries. + +@end itemize + +@node HP-UX-Specific Considerations +@section HP-UX-Specific Considerations +@cindex HP-UX Scheduling + +@noindent +On HP-UX, appropriate privileges are required to change the scheduling +parameters of a task. The calling process must have appropriate +privileges or be a member of a group having @code{PRIV_RTSCHED} access to +successfully change the scheduling parameters. + +By default, GNAT uses the @code{SCHED_HPUX} policy. To have access to the +priority range 0-31 either the @code{FIFO_Within_Priorities} or the +@code{Round_Robin_Within_Priorities} scheduling policies need to be set. +To specify the @code{FIFO_Within_Priorities} scheduling policy you can use +one of the following: + +@itemize @bullet +@item +@code{pragma Time_Slice (0.0)} +@cindex pragma Time_Slice +@item +the corresponding binder option @option{-T0} +@cindex @option{-T0} option +@item +@code{pragma Task_Dispatching_Policy (FIFO_Within_Priorities)} +@cindex pragma Task_Dispatching_Policy @end itemize +@noindent +To specify the @code{Round_Robin_Within_Priorities}, scheduling policy +you should use @code{pragma Time_Slice} with a +value greater than @code{0.0}, or use the corresponding @option{-T} +binder option, or set the @code{pragma Task_Dispatching_Policy +(Round_Robin_Within_Priorities)}. + @c ******************************* @node Example of Binder Output File @appendix Example of Binder Output File @@ -33270,7 +28070,9 @@ static import library for the DLL and the actual DLL. The form of the @smallexample @cartouche -$ gnatdll @ovar{switches} @var{list-of-files} @r{[}-largs @var{opts}@r{]} +@c $ gnatdll @ovar{switches} @var{list-of-files} @r{[}-largs @var{opts}@r{]} +@c Expanding @ovar macro inline (explanation in macro def comments) +$ gnatdll @r{[}@var{switches}@r{]} @var{list-of-files} @r{[}-largs @var{opts}@r{]} @end cartouche @end smallexample @@ -33286,7 +28088,9 @@ missing, only the static import library is generated. You may specify any of the following switches to @code{gnatdll}: @table @code -@item -a@ovar{address} +@c @item -a@ovar{address} +@c Expanding @ovar macro inline (explanation in macro def comments) +@item -a@r{[}@var{address}@r{]} @cindex @option{-a} (@code{gnatdll}) Build a non-relocatable DLL at @var{address}. If @var{address} is not specified the default address @var{0x11000000} will be used. By default, @@ -33489,7 +28293,9 @@ common @code{dlltool} switches. The form of the @code{dlltool} command is @smallexample -$ dlltool @ovar{switches} +@c $ dlltool @ovar{switches} +@c Expanding @ovar macro inline (explanation in macro def comments) +$ dlltool @r{[}@var{switches}@r{]} @end smallexample @noindent diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb index fb3dc3d74ba..cb234d262e6 100644 --- a/gcc/ada/gnatbind.adb +++ b/gcc/ada/gnatbind.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -45,6 +45,7 @@ with Rident; use Rident; with Snames; with Switch; use Switch; with Switch.B; use Switch.B; +with Table; with Targparm; use Targparm; with Types; use Types; @@ -81,6 +82,16 @@ procedure Gnatbind is Mapping_File : String_Ptr := null; + package Closure_Sources is new Table.Table + (Table_Component_Type => File_Name_Type, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Gnatbind.Closure_Sources"); + -- Table to record the sources in the closure, to avoid duplications. Used + -- only with switch -R. + function Gnatbind_Supports_Auto_Init return Boolean; -- Indicates if automatic initialization of elaboration procedure -- through the constructor mechanism is possible on the platform. @@ -671,11 +682,12 @@ begin begin Id := Scan_ALI - (F => Main_Lib_File, - T => Text, - Ignore_ED => False, - Err => False, - Ignore_Errors => Debug_Flag_I); + (F => Main_Lib_File, + T => Text, + Ignore_ED => False, + Err => False, + Ignore_Errors => Debug_Flag_I, + Directly_Scanned => True); end; Free (Text); @@ -726,10 +738,10 @@ begin Free (Text); end if; - -- Acquire all information in ALI files that have been read in + -- Load ALIs for all dependent units for Index in ALIs.First .. ALIs.Last loop - Read_ALI (Index); + Read_Withed_ALIs (Index); end loop; -- Quit if some file needs compiling @@ -738,6 +750,28 @@ begin raise Unrecoverable_Error; end if; + -- Output list of ALI files in closure + + if Output_ALI_List then + if ALI_List_Filename /= null then + Set_List_File (ALI_List_Filename.all); + end if; + + for Index in ALIs.First .. ALIs.Last loop + declare + Full_Afile : constant File_Name_Type := + Find_File (ALIs.Table (Index).Afile, Library); + begin + Write_Name (Full_Afile); + Write_Eol; + end; + end loop; + + if ALI_List_Filename /= null then + Close_List_File; + end if; + end if; + -- Build source file table from the ALI files we have read in Set_Source_Table; @@ -814,55 +848,90 @@ begin -- sources) if -R was used. if List_Closure then - if not Zero_Formatting then - Write_Eol; - Write_Str ("REFERENCED SOURCES"); - Write_Eol; - end if; + List_Closure_Display : declare + Source : File_Name_Type; - for J in reverse Elab_Order.First .. Elab_Order.Last loop + function Put_In_Sources (S : File_Name_Type) return Boolean; + -- Check if S is already in table Sources and put in Sources + -- if it is not. Return False if the source is already in + -- Sources, and True if it is added. - -- Do not include the sources of the runtime + -------------------- + -- Put_In_Sources -- + -------------------- - if not Is_Internal_File_Name - (Units.Table (Elab_Order.Table (J)).Sfile) - then - if not Zero_Formatting then - Write_Str (" "); - end if; + function Put_In_Sources (S : File_Name_Type) + return Boolean + is + begin + for J in 1 .. Closure_Sources.Last loop + if Closure_Sources.Table (J) = S then + return False; + end if; + end loop; + + Closure_Sources.Append (S); + return True; + end Put_In_Sources; + + -- Start of processing for List_Closure_Display + + begin + Closure_Sources.Init; - Write_Str - (Get_Name_String - (Units.Table (Elab_Order.Table (J)).Sfile)); + if not Zero_Formatting then + Write_Eol; + Write_Str ("REFERENCED SOURCES"); Write_Eol; end if; - end loop; - -- Subunits do not appear in the elaboration table because they - -- are subsumed by their parent units, but we need to list them - -- for other tools. For now they are listed after other files, - -- rather than right after their parent, since there is no easy - -- link between the elaboration table and the ALIs table ??? - -- Note also that subunits may appear repeatedly in the list, - -- if the parent unit appears in the context of several units - -- in the closure. - - for J in Sdep.First .. Sdep.Last loop - if Sdep.Table (J).Subunit_Name /= No_Name - and then not Is_Internal_File_Name (Sdep.Table (J).Sfile) - then - if not Zero_Formatting then - Write_Str (" "); + for J in reverse Elab_Order.First .. Elab_Order.Last loop + Source := Units.Table (Elab_Order.Table (J)).Sfile; + + -- Do not include the sources of the runtime and do not + -- include the same source several times. + + if Put_In_Sources (Source) + and then not Is_Internal_File_Name (Source) + then + if not Zero_Formatting then + Write_Str (" "); + end if; + + Write_Str (Get_Name_String (Source)); + Write_Eol; end if; + end loop; + + -- Subunits do not appear in the elaboration table because + -- they are subsumed by their parent units, but we need to + -- list them for other tools. For now they are listed after + -- other files, rather than right after their parent, since + -- there is no easy link between the elaboration table and + -- the ALIs table ??? As subunits may appear repeatedly in + -- the list, if the parent unit appears in the context of + -- several units in the closure, duplicates are suppressed. + + for J in Sdep.First .. Sdep.Last loop + Source := Sdep.Table (J).Sfile; + + if Sdep.Table (J).Subunit_Name /= No_Name + and then Put_In_Sources (Source) + and then not Is_Internal_File_Name (Source) + then + if not Zero_Formatting then + Write_Str (" "); + end if; + + Write_Str (Get_Name_String (Source)); + Write_Eol; + end if; + end loop; - Write_Str (Get_Name_String (Sdep.Table (J).Sfile)); + if not Zero_Formatting then Write_Eol; end if; - end loop; - - if not Zero_Formatting then - Write_Eol; - end if; + end List_Closure_Display; end if; end if; end if; diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index 6ab6821a63d..0f3810144e4 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -122,6 +122,7 @@ procedure GNATCmd is Naming_String : constant SA := new String'("naming"); Binder_String : constant SA := new String'("binder"); + Builder_String : constant SA := new String'("builder"); Compiler_String : constant SA := new String'("compiler"); Check_String : constant SA := new String'("check"); Synchronize_String : constant SA := new String'("synchronize"); @@ -139,7 +140,8 @@ procedure GNATCmd is new String_List'((Naming_String, Binder_String)); Packages_To_Check_By_Check : constant String_List_Access := - new String_List'((Naming_String, Check_String, Compiler_String)); + new String_List' + ((Naming_String, Builder_String, Check_String, Compiler_String)); Packages_To_Check_By_Sync : constant String_List_Access := new String_List'((Naming_String, Synchronize_String, Compiler_String)); @@ -209,9 +211,9 @@ procedure GNATCmd is procedure Check_Files; -- For GNAT LIST, GNAT PRETTY, GNAT METRIC, and GNAT STACK, check if a - -- project file is specified, without any file arguments. If it is the - -- case, invoke the GNAT tool with the proper list of files, derived from - -- the sources of the project. + -- project file is specified, without any file arguments and without a + -- switch -files=. If it is the case, invoke the GNAT tool with the proper + -- list of files, derived from the sources of the project. function Check_Project (Project : Project_Id; @@ -232,6 +234,11 @@ procedure GNATCmd is -- STUB), gnatpp (GNAT PRETTY), gnatelim (GNAT ELIM), and gnatmetric (GNAT -- METRIC). + function Mapping_File return Path_Name_Type; + -- Create and return the path name of a mapping file. Used for gnatstub + -- (GNAT STUB), gnatpp (GNAT PRETTY), gnatelim (GNAT ELIM), and gnatmetric + -- (GNAT METRIC). + procedure Delete_Temp_Config_Files; -- Delete all temporary config files. The caller is responsible for -- ensuring that Keep_Temporary_Files is False. @@ -314,20 +321,25 @@ procedure GNATCmd is Success : Boolean; begin - -- Check if there is at least one argument that is not a switch + -- Check if there is at least one argument that is not a switch or if + -- there is a -files= switch. for Index in 1 .. Last_Switches.Last loop - if Last_Switches.Table (Index) (1) /= '-' then + if Last_Switches.Table (Index).all'Length > 7 + and then Last_Switches.Table (Index) (1 .. 7) = "-files=" + then + Add_Sources := False; + exit; + + elsif Last_Switches.Table (Index) (1) /= '-' then if Index = 1 or else (The_Command = Check - and then - Last_Switches.Table (Index - 1).all /= "-o") + and then Last_Switches.Table (Index - 1).all /= "-o") or else (The_Command = Pretty - and then - Last_Switches.Table (Index - 1).all /= "-o" and then - Last_Switches.Table (Index - 1).all /= "-of") + and then Last_Switches.Table (Index - 1).all /= "-o" + and then Last_Switches.Table (Index - 1).all /= "-of") or else (The_Command = Metric and then @@ -346,13 +358,13 @@ procedure GNATCmd is end if; end loop; - -- If all arguments were switches, add the path names of all the sources - -- of the main project. + -- If all arguments are switches and there is no switch -files=, add + -- the path names of all the sources of the main project. if Add_Sources then - -- For gnatcheck, gnatpp and gnatmetric , create a temporary file and - -- put the list of sources in it. + -- For gnatcheck, gnatpp, and gnatmetric, create a temporary file + -- and put the list of sources in it. if The_Command = Check or else The_Command = Pretty or else @@ -443,8 +455,8 @@ procedure GNATCmd is then -- There is a body, check if it is for this project - if All_Projects or else - Unit.File_Names (Impl).Project = Project + if All_Projects + or else Unit.File_Names (Impl).Project = Project then Subunit := False; @@ -882,6 +894,21 @@ procedure GNATCmd is return 0; end Index; + ------------------ + -- Mapping_File -- + ------------------ + + function Mapping_File return Path_Name_Type is + Result : Path_Name_Type; + begin + Prj.Env.Create_Mapping_File + (Project => Project, + Language => Name_Ada, + In_Tree => Project_Tree, + Name => Result); + return Result; + end Mapping_File; + ------------------ -- Process_Link -- ------------------ @@ -1056,8 +1083,7 @@ procedure GNATCmd is -- Append ".ali" if file name does not end with it if Switch'Length <= 4 - or else Switch (Switch'Last - 3 .. Switch'Last) - /= ".ali" + or else Switch (Switch'Last - 3 .. Switch'Last) /= ".ali" then Last := ALI_File'Last; end if; @@ -1070,8 +1096,8 @@ procedure GNATCmd is else for K in Switch'Range loop - if Switch (K) = '/' or else - Switch (K) = Directory_Separator + if Switch (K) = '/' + or else Switch (K) = Directory_Separator then Test_Existence := True; exit; @@ -1245,7 +1271,10 @@ procedure GNATCmd is New_Line; for C in Command_List'Range loop - if not Command_List (C).VMS_Only then + + -- No usage for VMS only command or for Sync + + if not Command_List (C).VMS_Only and then C /= Sync then if Targparm.AAMP_On_Target then Put ("gnaampcmd "); else @@ -1279,7 +1308,7 @@ procedure GNATCmd is end loop; New_Line; - Put_Line ("Commands find, list, metric, pretty, stack, stub and xref " & + Put_Line ("All commands except chop, krunch and preprocess " & "accept project file switches -vPx, -Pprj and -Xnam=val"); New_Line; end Non_VMS_Usage; @@ -1611,11 +1640,12 @@ begin -- --subdirs=... Specify Subdirs - if Argv'Length > Makeutl.Subdirs_Option'Length and then - Argv - (Argv'First .. - Argv'First + Makeutl.Subdirs_Option'Length - 1) = - Makeutl.Subdirs_Option + if Argv'Length > Makeutl.Subdirs_Option'Length + and then + Argv + (Argv'First .. + Argv'First + Makeutl.Subdirs_Option'Length - 1) = + Makeutl.Subdirs_Option then Subdirs := new String' @@ -1724,8 +1754,9 @@ begin ('=', Argv (Argv'First + 2 .. Argv'Last)); begin - if Equal_Pos >= Argv'First + 3 and then - Equal_Pos /= Argv'Last then + if Equal_Pos >= Argv'First + 3 + and then Equal_Pos /= Argv'Last + then Add (Project_Node_Tree, External_Name => Argv (Argv'First + 2 .. Equal_Pos - 1), @@ -1927,7 +1958,7 @@ begin end if; end; - if The_Command = Bind + if The_Command = Bind or else The_Command = Link or else The_Command = Elim then @@ -1942,7 +1973,7 @@ begin -- For gnatcheck, gnatstub, gnatmetric, gnatpp and gnatelim, create -- a configuration pragmas file, if necessary. - if The_Command = Pretty + if The_Command = Pretty or else The_Command = Metric or else The_Command = Stub or else The_Command = Elim @@ -2080,7 +2111,7 @@ begin while K <= First_Switches.Last and then (The_Command /= Check - or else First_Switches.Table (K).all /= "-rules") + or else First_Switches.Table (K).all /= "-rules") loop Add_To_Carg_Switches (First_Switches.Table (K)); K := K + 1; @@ -2120,8 +2151,7 @@ begin while K <= Last_Switches.Last and then (The_Command /= Check - or else - Last_Switches.Table (K).all /= "-rules") + or else Last_Switches.Table (K).all /= "-rules") loop Add_To_Carg_Switches (Last_Switches.Table (K)); K := K + 1; @@ -2149,6 +2179,7 @@ begin declare CP_File : constant Path_Name_Type := Configuration_Pragmas_File; + M_File : constant Path_Name_Type := Mapping_File; begin if CP_File /= No_Path then @@ -2162,6 +2193,95 @@ begin (new String'("-gnatec=" & Get_Name_String (CP_File))); end if; end if; + + if M_File /= No_Path then + Add_To_Carg_Switches + (new String'("-gnatem=" & Get_Name_String (M_File))); + end if; + + -- For gnatcheck, also indicate a global configuration pragmas + -- file and, if -U is not used, a local one. + + if The_Command = Check then + declare + Pkg : constant Prj.Package_Id := + Prj.Util.Value_Of + (Name => Name_Builder, + In_Packages => Project.Decl.Packages, + In_Tree => Project_Tree); + + Variable : Variable_Value := + Prj.Util.Value_Of + (Name => No_Name, + Attribute_Or_Array_Name => + Name_Global_Configuration_Pragmas, + In_Package => Pkg, + In_Tree => Project_Tree); + + begin + if (Variable = Nil_Variable_Value + or else Length_Of_Name (Variable.Value) = 0) + and then Pkg /= No_Package + then + Variable := + Prj.Util.Value_Of + (Name => Name_Ada, + Attribute_Or_Array_Name => + Name_Global_Config_File, + In_Package => Pkg, + In_Tree => Project_Tree); + end if; + + if Variable /= Nil_Variable_Value + and then Length_Of_Name (Variable.Value) /= 0 + then + Add_To_Carg_Switches + (new String' + ("-gnatec=" & Get_Name_String (Variable.Value))); + end if; + end; + + if not All_Projects then + declare + Pkg : constant Prj.Package_Id := + Prj.Util.Value_Of + (Name => Name_Compiler, + In_Packages => Project.Decl.Packages, + In_Tree => Project_Tree); + + Variable : Variable_Value := + Prj.Util.Value_Of + (Name => No_Name, + Attribute_Or_Array_Name => + Name_Local_Configuration_Pragmas, + In_Package => Pkg, + In_Tree => Project_Tree); + + begin + if (Variable = Nil_Variable_Value + or else Length_Of_Name (Variable.Value) = 0) + and then Pkg /= No_Package + then + Variable := + Prj.Util.Value_Of + (Name => Name_Ada, + Attribute_Or_Array_Name => + Name_Local_Config_File, + In_Package => Pkg, + In_Tree => Project_Tree); + end if; + + if Variable /= Nil_Variable_Value + and then Length_Of_Name (Variable.Value) /= 0 + then + Add_To_Carg_Switches + (new String' + ("-gnatec=" & + Get_Name_String (Variable.Value))); + end if; + end; + end if; + end if; end; end if; diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb index 4469c91ec5d..675d9a364e4 100644 --- a/gcc/ada/gnatlink.adb +++ b/gcc/ada/gnatlink.adb @@ -1447,8 +1447,6 @@ procedure Gnatlink is Write_Eol; Write_Line (" mainprog.ali the ALI file of the main program"); Write_Eol; - Write_Line (" -A Binder generated source file is in Ada (default)"); - Write_Line (" -C Binder generated source file is in C"); Write_Line (" -f force object file list to be generated"); Write_Line (" -g Compile binder source file with debug information"); Write_Line (" -n Do not compile the binder source file"); @@ -1648,15 +1646,6 @@ begin Linker_Options.Increment_Last; Linker_Options.Table (Linker_Options.Last) := new String'("-mrtp"); - - -- Pass -fsjlj to the linker if --RTS=sjlj was passed - - elsif Arg'Length > 9 - and then Arg (Arg'First + 6 .. Arg'First + 9) = "sjlj" - then - Linker_Options.Increment_Last; - Linker_Options.Table (Linker_Options.Last) := - new String'("-fsjlj"); end if; end if; end; diff --git a/gcc/ada/gnatname.adb b/gcc/ada/gnatname.adb index 4c935bebbc7..00ebebe413e 100644 --- a/gcc/ada/gnatname.adb +++ b/gcc/ada/gnatname.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -306,7 +306,20 @@ procedure Gnatname is -- Add and initialize another component to Arguments table - Arguments.Increment_Last; + declare + New_Arguments : Argument_Data; + pragma Warnings (Off, New_Arguments); + -- Declaring this defaulted initialized object ensures + -- that the new allocated component of table Arguments + -- is correctly initialized. + + -- This is VERY ugly, Table should never be used with + -- data requiring default initialization. We should + -- find a way to avoid violating this rule ??? + + begin + Arguments.Append (New_Arguments); + end; Patterns.Init (Arguments.Table (Arguments.Last).Directories); diff --git a/gcc/ada/gnatsym.adb b/gcc/ada/gnatsym.adb index dec5257f45c..5a88994a4c4 100644 --- a/gcc/ada/gnatsym.adb +++ b/gcc/ada/gnatsym.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -41,19 +41,19 @@ -- - (optional) the name of the reference symbol file -- - the names of one or more object files where the symbols are found -with Ada.Exceptions; use Ada.Exceptions; -with Ada.Text_IO; use Ada.Text_IO; - -with GNAT.Command_Line; use GNAT.Command_Line; -with GNAT.OS_Lib; use GNAT.OS_Lib; - with Gnatvsn; use Gnatvsn; with Osint; use Osint; with Output; use Output; - with Symbols; use Symbols; with Table; +with Ada.Exceptions; use Ada.Exceptions; +with Ada.Text_IO; use Ada.Text_IO; + +with GNAT.Command_Line; use GNAT.Command_Line; +with GNAT.Directory_Operations; use GNAT.Directory_Operations; +with GNAT.OS_Lib; use GNAT.OS_Lib; + procedure Gnatsym is Empty_String : aliased String := ""; @@ -82,8 +82,13 @@ procedure Gnatsym is Version_String : String_Access := Empty; -- The version of the library (used on VMS) + type Object_File_Data is record + Path : String_Access; + Name : String_Access; + end record; + package Object_Files is new Table.Table - (Table_Component_Type => String_Access, + (Table_Component_Type => Object_File_Data, Table_Index_Type => Natural, Table_Low_Bound => 0, Table_Initial => 10, @@ -164,7 +169,8 @@ procedure Gnatsym is end case; end loop; - -- Get the file names + -- Get the object file names and put them in the table in alphabetical + -- order of base names. loop declare @@ -175,7 +181,26 @@ procedure Gnatsym is exit when S'Length = 0; Object_Files.Increment_Last; - Object_Files.Table (Object_Files.Last) := S; + + declare + Base : constant String := Base_Name (S.all); + Last : constant Positive := Object_Files.Last; + J : Positive; + + begin + J := 1; + while J < Last loop + if Object_Files.Table (J).Name.all > Base then + Object_Files.Table (J + 1 .. Last) := + Object_Files.Table (J .. Last - 1); + exit; + end if; + + J := J + 1; + end loop; + + Object_Files.Table (J) := (S, new String'(Base)); + end; end; end loop; exception @@ -304,14 +329,16 @@ begin if Verbose then Write_Str ("Processing object file """); - Write_Str (Object_Files.Table (Object_File).all); + Write_Str (Object_Files.Table (Object_File).Path.all); Write_Line (""""); end if; - Processing.Process (Object_Files.Table (Object_File).all, Success); + Processing.Process + (Object_Files.Table (Object_File).Path.all, + Success); end loop; - -- Finalize the object file + -- Finalize the symbol file if Success then if Verbose then diff --git a/gcc/ada/gnatvsn.ads b/gcc/ada/gnatvsn.ads index 0a62a693839..684a3bb4d79 100644 --- a/gcc/ada/gnatvsn.ads +++ b/gcc/ada/gnatvsn.ads @@ -77,7 +77,7 @@ package Gnatvsn is -- value should never be decreased in the future, but it would be -- OK to increase it if absolutely necessary. - Library_Version : constant String := "4.5"; + Library_Version : constant String := "4.6"; -- Library version. This value must be updated whenever any change to the -- compiler affects the library formats in such a way as to obsolete -- previously compiled library modules. diff --git a/gcc/ada/gnatxref.adb b/gcc/ada/gnatxref.adb index 2cccc0f1f51..c20ef175564 100644 --- a/gcc/ada/gnatxref.adb +++ b/gcc/ada/gnatxref.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -52,6 +52,9 @@ procedure Gnatxref is RTS_Specified : String_Access := null; -- Used to detect multiple use of --RTS= switch + EXT_Specified : String_Access := null; + -- Used to detect multiple use of --ext= switch + procedure Parse_Cmd_Line; -- Parse every switch on the command line @@ -79,7 +82,7 @@ procedure Gnatxref is loop case GNAT.Command_Line.Getopt - ("a aI: aO: d f g h I: nostdinc nostdlib p: u v -RTS=") + ("a aI: aO: d f g h I: nostdinc nostdlib p: u v -RTS= -ext=") is when ASCII.NUL => exit; @@ -140,43 +143,70 @@ procedure Gnatxref is -- Check that it is the first time we see this switch - if RTS_Specified = null then - RTS_Specified := new String'(GNAT.Command_Line.Parameter); + if Full_Switch = "-RTS" then + if RTS_Specified = null then + RTS_Specified := new String'(GNAT.Command_Line.Parameter); - elsif RTS_Specified.all /= GNAT.Command_Line.Parameter then - Osint.Fail ("--RTS cannot be specified multiple times"); - end if; + elsif RTS_Specified.all /= GNAT.Command_Line.Parameter then + Osint.Fail ("--RTS cannot be specified multiple times"); + end if; - Opt.No_Stdinc := True; - Opt.RTS_Switch := True; + Opt.No_Stdinc := True; + Opt.RTS_Switch := True; - declare - Src_Path_Name : constant String_Ptr := - Get_RTS_Search_Dir - (GNAT.Command_Line.Parameter, Include); + declare + Src_Path_Name : constant String_Ptr := + Get_RTS_Search_Dir + (GNAT.Command_Line.Parameter, + Include); - Lib_Path_Name : constant String_Ptr := - Get_RTS_Search_Dir - (GNAT.Command_Line.Parameter, Objects); + Lib_Path_Name : constant String_Ptr := + Get_RTS_Search_Dir + (GNAT.Command_Line.Parameter, + Objects); - begin - if Src_Path_Name /= null and then Lib_Path_Name /= null then - Add_Search_Dirs (Src_Path_Name, Include); - Add_Search_Dirs (Lib_Path_Name, Objects); + begin + if Src_Path_Name /= null + and then Lib_Path_Name /= null + then + Add_Search_Dirs (Src_Path_Name, Include); + Add_Search_Dirs (Lib_Path_Name, Objects); + + elsif Src_Path_Name = null + and then Lib_Path_Name = null + then + Osint.Fail ("RTS path not valid: missing " & + "adainclude and adalib directories"); + + elsif Src_Path_Name = null then + Osint.Fail ("RTS path not valid: missing " & + "adainclude directory"); - elsif Src_Path_Name = null and then Lib_Path_Name = null then - Osint.Fail ("RTS path not valid: missing " & - "adainclude and adalib directories"); + elsif Lib_Path_Name = null then + Osint.Fail ("RTS path not valid: missing " & + "adalib directory"); + end if; + end; - elsif Src_Path_Name = null then - Osint.Fail ("RTS path not valid: missing " & - "adainclude directory"); + elsif GNAT.Command_Line.Full_Switch = "-ext" then - elsif Lib_Path_Name = null then - Osint.Fail ("RTS path not valid: missing " & - "adalib directory"); + -- Check that it is the first time we see this switch + + if EXT_Specified = null then + EXT_Specified := new String'(GNAT.Command_Line.Parameter); + + elsif EXT_Specified.all /= GNAT.Command_Line.Parameter then + Osint.Fail ("--ext cannot be specified multiple times"); end if; - end; + + if EXT_Specified'Length + = Osint.ALI_Default_Suffix'Length + then + Osint.ALI_Suffix := EXT_Specified.all'Access; + else + Osint.Fail ("--ext argument must have 3 characters"); + end if; + end if; when others => Write_Usage; @@ -239,6 +269,7 @@ procedure Gnatxref is & " directory"); Put_Line (" -nostdlib Don't look for library files in the system" & " default directory"); + Put_Line (" --ext=xxx Specify alternate ali file extension"); Put_Line (" --RTS=dir specify the default source and object search" & " path"); Put_Line (" -p file Use file as the default project file"); diff --git a/gcc/ada/gsocket.h b/gcc/ada/gsocket.h index a8e6faa2467..7763b1801de 100644 --- a/gcc/ada/gsocket.h +++ b/gcc/ada/gsocket.h @@ -194,34 +194,37 @@ #include #endif -/* - * Handling of gethostbyname, gethostbyaddr, getservbyname and getservbyport - * ========================================================================= - * - * The default implementation of GNAT.Sockets.Thin requires that these - * operations be either thread safe, or that a reentrant version getXXXbyYYY_r - * be provided. In both cases, socket.c provides a __gnat_safe_getXXXbyYYY - * function with the same signature as getXXXbyYYY_r. If the operating - * system version of getXXXbyYYY is thread safe, the provided auxiliary - * buffer argument is unused and ignored. - * - * Target specific versions of GNAT.Sockets.Thin for platforms that can't - * fulfill these requirements must provide their own protection mechanism - * in Safe_GetXXXbyYYY, and if they require GNAT.Sockets to provide a buffer - * to this effect, then we need to set Need_Netdb_Buffer here (case of - * VxWorks and VMS). - */ - -#if defined (_AIX) || defined (__FreeBSD__) || defined (__hpux__) || defined (__osf__) || defined (_WIN32) || defined (__APPLE__) +#if defined (_AIX) || defined (__FreeBSD__) || defined (__hpux__) || \ + defined (__osf__) || defined (_WIN32) || defined (__APPLE__) # define HAVE_THREAD_SAFE_GETxxxBYyyy 1 -#elif defined (sgi) || defined (linux) || defined (__GLIBC__) || (defined (sun) && defined (__SVR4) && !defined (__vxworks)) || defined(__rtems__) + +#elif defined (sgi) || defined (linux) || defined (__GLIBC__) || \ + (defined (sun) && defined (__SVR4) && !defined (__vxworks)) || \ + defined(__rtems__) # define HAVE_GETxxxBYyyy_R 1 #endif -#if defined (HAVE_GETxxxBYyyy_R) || !defined (HAVE_THREAD_SAFE_GETxxxBYyyy) +/* + * Properties of the unerlying NetDB library: + * Need_Netdb_Buffer __gnat_getXXXbyYYY expects a caller-supplied buffer + * Need_Netdb_Lock __gnat_getXXXbyYYY expects the caller to ensure + * mutual exclusion + * + * See "Handling of gethostbyname, gethostbyaddr, getservbyname and + * getservbyport" in socket.c for details. + */ + +#if defined (HAVE_GETxxxBYyyy_R) # define Need_Netdb_Buffer 1 +# define Need_Netdb_Lock 0 + #else # define Need_Netdb_Buffer 0 +# if !defined (HAVE_THREAD_SAFE_GETxxxBYyyy) +# define Need_Netdb_Lock 1 +# else +# define Need_Netdb_Lock 0 +# endif #endif #if defined (__FreeBSD__) || defined (__vxworks) || defined(__rtems__) diff --git a/gcc/ada/i-cstrea.ads b/gcc/ada/i-cstrea.ads index 73258e76437..5c997bd75be 100644 --- a/gcc/ada/i-cstrea.ads +++ b/gcc/ada/i-cstrea.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1995-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -76,9 +76,9 @@ package Interfaces.C_Streams is -- Standard C functions -- -------------------------- - -- The functions selected below are ones that are available in DOS, - -- OS/2, UNIX and Xenix (but not necessarily in ANSI C). These are - -- very thin interfaces which copy exactly the C headers. For more + -- The functions selected below are ones that are available in + -- UNIX (but not necessarily in ANSI C). These are very thin + -- interfaces which copy exactly the C headers. For more -- documentation on these functions, see the Microsoft C "Run-Time -- Library Reference" (Microsoft Press, 1990, ISBN 1-55615-225-6), -- which includes useful information on system compatibility. diff --git a/gcc/ada/i-forbla-darwin.adb b/gcc/ada/i-forbla-darwin.adb index 2a2134ecba4..825a8840414 100644 --- a/gcc/ada/i-forbla-darwin.adb +++ b/gcc/ada/i-forbla-darwin.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2006-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2006-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -32,5 +32,7 @@ -- Version for Mac OS X package body Interfaces.Fortran.BLAS is + pragma Linker_Options ("-lgnala"); + pragma Linker_Options ("-lm"); pragma Linker_Options ("-Wl,-framework,vecLib"); end Interfaces.Fortran.BLAS; diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index 0f3ad5793ec..cbd489064ca 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2000-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -173,6 +173,14 @@ package body Impunit is "a-wichun", -- Ada.Wide_Characters.Unicode "a-widcha", -- Ada.Wide_Characters + -- Note: strictly the next two should be Ada 2012 units, but it seems + -- harmless (and useful) to make then available in Ada 95 mode, since + -- they only deal with Wide_Character, not Wide_Wide_Character. + + "a-stuten", -- Ada.Strings.UTF_Encoding + "a-suenco", -- Ada.Strings.UTF_Encoding.Conversions + "a-suewen", -- Ada.Strings.UTF_Encoding.Wide_Encoding + --------------------------- -- GNAT Special IO Units -- --------------------------- @@ -250,6 +258,8 @@ package body Impunit is "g-io ", -- GNAT.IO "g-io_aux", -- GNAT.IO_Aux "g-locfil", -- GNAT.Lock_Files + "g-mbdira", -- GNAT.MBBS_Discrete_Random + "g-mbflra", -- GNAT.MBBS_Float_Random "g-md5 ", -- GNAT.MD5 "g-memdum", -- GNAT.Memory_Dump "g-moreex", -- GNAT.Most_Recent_Exception @@ -457,6 +467,11 @@ package body Impunit is "a-szuzti", -- Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO "a-zchuni", -- Ada.Wide_Wide_Characters.Unicode + -- Note: strictly the following should be Ada 2012 units, but it seems + -- harmless (and useful) to make then available in Ada 2005 mode. + + "a-suezen", -- Ada.Strings.UTF_Encoding.Wide_Wide_Encoding + --------------------------- -- GNAT Special IO Units -- --------------------------- @@ -494,6 +509,8 @@ package body Impunit is -- Array of alternative unit names Scasuti : aliased String := "GNAT.Case_Util"; + Scrc32 : aliased String := "GNAT.CRC32"; + Shtable : aliased String := "GNAT.HTable"; Sos_lib : aliased String := "GNAT.OS_Lib"; Sregexp : aliased String := "GNAT.Regexp"; Sregpat : aliased String := "GNAT.Regpat"; @@ -504,8 +521,10 @@ package body Impunit is -- Array giving mapping - Map_Array : constant array (1 .. 8) of Aunit_Record := ( + Map_Array : constant array (1 .. 10) of Aunit_Record := ( ("casuti", Scasuti'Access), + ("crc32 ", Scrc32 'Access), + ("htable", Shtable'Access), ("os_lib", Sos_lib'Access), ("regexp", Sregexp'Access), ("regpat", Sregpat'Access), @@ -609,12 +628,17 @@ package body Impunit is Get_Name_String (Fname); - if Name_Len = 12 + if Name_Len in 11 .. 12 and then Name_Buffer (1 .. 2) = "s-" - and then Name_Buffer (9 .. 12) = ".ads" + and then Name_Buffer (Name_Len - 3 .. Name_Len) = ".ads" then for J in Map_Array'Range loop - if Name_Buffer (3 .. 8) = Map_Array (J).Fname then + if (Name_Len = 12 and then + Name_Buffer (3 .. 8) = Map_Array (J).Fname) + or else + (Name_Len = 11 and then + Name_Buffer (3 .. 7) = Map_Array (J).Fname (1 .. 5)) + then Error_Msg_Strlen := Map_Array (J).Aname'Length; Error_Msg_String (1 .. Error_Msg_Strlen) := Map_Array (J).Aname.all; diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 28498c428a5..f011668899c 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 1992-2009, Free Software Foundation, Inc. * + * Copyright (C) 1992-2010, Free Software Foundation, Inc. * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * @@ -214,12 +214,10 @@ nanosleep (struct timestruc_t *Rqtp, struct timestruc_t *Rmtp) #endif /* _AIXVERSION_430 */ -static void __gnat_error_handler (int sig, siginfo_t * si, void * uc); - static void __gnat_error_handler (int sig, - siginfo_t * si ATTRIBUTE_UNUSED, - void * uc ATTRIBUTE_UNUSED) + siginfo_t *si ATTRIBUTE_UNUSED, + void *ucontext ATTRIBUTE_UNUSED) { struct Exception_Data *exception; const char *msg; @@ -287,7 +285,6 @@ __gnat_install_handler (void) #include #include -static void __gnat_error_handler (int, siginfo_t *, struct sigcontext *); extern char *__gnat_get_code_loc (struct sigcontext *); extern void __gnat_set_code_loc (struct sigcontext *, char *); extern size_t __gnat_machine_state_length (void); @@ -310,7 +307,7 @@ __gnat_adjust_context_for_raise (int signo, void *ucontext) } static void -__gnat_error_handler (int sig, siginfo_t *sip, struct sigcontext *context) +__gnat_error_handler (int sig, siginfo_t *si, void *ucontext) { struct Exception_Data *exception; static int recurse = 0; @@ -318,10 +315,10 @@ __gnat_error_handler (int sig, siginfo_t *sip, struct sigcontext *context) /* Adjusting is required for every fault context, so adjust for this one now, before we possibly trigger a recursive fault below. */ - __gnat_adjust_context_for_raise (sig, context); + __gnat_adjust_context_for_raise (sig, ucontext); /* If this was an explicit signal from a "kill", just resignal it. */ - if (SI_FROMUSER (sip)) + if (SI_FROMUSER (si)) { signal (sig, SIG_DFL); kill (getpid(), sig); @@ -338,8 +335,9 @@ __gnat_error_handler (int sig, siginfo_t *sip, struct sigcontext *context) ??? Using a static variable here isn't task-safe, but it's much too hard to do anything else and we're just determining which exception to raise. */ - if (sip->si_code == SEGV_ACCERR - || (((long) sip->si_addr) & 3) != 0 + if (si->si_code == SEGV_ACCERR + || (long) si->si_addr == 0 + || (((long) si->si_addr) & 3) != 0 || recurse) { exception = &constraint_error; @@ -353,9 +351,9 @@ __gnat_error_handler (int sig, siginfo_t *sip, struct sigcontext *context) the actual address, just to be on the same page. */ recurse++; ((volatile char *) - ((long) sip->si_addr & - getpagesize ()))[getpagesize ()]; - msg = "stack overflow (or erroneous memory access)"; + ((long) si->si_addr & - getpagesize ()))[getpagesize ()]; exception = &storage_error; + msg = "stack overflow (or erroneous memory access)"; } break; @@ -438,13 +436,9 @@ __gnat_machine_state_length (void) #include static void -__gnat_error_handler (int sig, siginfo_t *siginfo, void *ucontext); - -static void -__gnat_error_handler - (int sig, - siginfo_t *siginfo ATTRIBUTE_UNUSED, - void *ucontext ATTRIBUTE_UNUSED) +__gnat_error_handler (int sig, + siginfo_t *si ATTRIBUTE_UNUSED, + void *ucontext ATTRIBUTE_UNUSED) { struct Exception_Data *exception; const char *msg; @@ -570,8 +564,6 @@ void fake_linux_sigemptyset (sigset_t *set) { #endif -static void __gnat_error_handler (int, siginfo_t *siginfo, void *ucontext); - #if defined (i386) || defined (__x86_64__) || defined (__ia64__) #define HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE @@ -581,11 +573,7 @@ __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext) { mcontext_t *mcontext = &((ucontext_t *) ucontext)->uc_mcontext; - /* On the i386 and x86-64 architectures, we specifically detect calls to - the null address and entirely fold the not-yet-fully-established frame - to prevent it from stopping the unwinding. - - On the i386 and x86-64 architectures, stack checking is performed by + /* On the i386 and x86-64 architectures, stack checking is performed by means of probes with moving stack pointer, that is to say the probed address is always the value of the stack pointer. Upon hitting the guard page, the stack pointer therefore points to an inaccessible @@ -605,25 +593,13 @@ __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext) #if defined (i386) unsigned long *pc = (unsigned long *)mcontext->gregs[REG_EIP]; - /* The call insn pushes the return address onto the stack. Pop it. */ - if (pc == NULL) - { - mcontext->gregs[REG_EIP] = *(unsigned long *)mcontext->gregs[REG_ESP]; - mcontext->gregs[REG_ESP] += 4; - } /* The pattern is "orl $0x0,(%esp)" for a probe in 32-bit mode. */ - else if (signo == SIGSEGV && *pc == 0x00240c83) + if (signo == SIGSEGV && pc && *pc == 0x00240c83) mcontext->gregs[REG_ESP] += 4096 + 4 * sizeof (unsigned long); #elif defined (__x86_64__) unsigned long *pc = (unsigned long *)mcontext->gregs[REG_RIP]; - /* The call insn pushes the return address onto the stack. Pop it. */ - if (pc == NULL) - { - mcontext->gregs[REG_RIP] = *(unsigned long *)mcontext->gregs[REG_RSP]; - mcontext->gregs[REG_RSP] += 8; - } /* The pattern is "orq $0x0,(%rsp)" for a probe in 64-bit mode. */ - else if (signo == SIGSEGV && (*pc & 0xffffffffff) == 0x00240c8348) + if (signo == SIGSEGV && pc && (*pc & 0xffffffffff) == 0x00240c8348) mcontext->gregs[REG_RSP] += 4096 + 4 * sizeof (unsigned long); #elif defined (__ia64__) /* ??? The IA-64 unwinder doesn't compensate for signals. */ @@ -634,12 +610,9 @@ __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext) #endif static void -__gnat_error_handler (int sig, - siginfo_t *siginfo ATTRIBUTE_UNUSED, - void *ucontext) +__gnat_error_handler (int sig, siginfo_t *si ATTRIBUTE_UNUSED, void *ucontext) { struct Exception_Data *exception; - static int recurse = 0; const char *msg; /* Adjusting is required for every fault context, so adjust for this one @@ -649,42 +622,24 @@ __gnat_error_handler (int sig, switch (sig) { case SIGSEGV: - /* If the problem was permissions, this is a constraint error. - Likewise if the failing address isn't maximally aligned or if - we've recursed. - - ??? Using a static variable here isn't task-safe, but it's - much too hard to do anything else and we're just determining - which exception to raise. */ - if (recurse) - { - exception = &constraint_error; - msg = "SIGSEGV"; - } - else - { - /* Here we would like a discrimination test to see whether the - page before the faulting address is accessible. Unfortunately - Linux seems to have no way of giving us the faulting address. + /* Here we would like a discrimination test to see whether the page + before the faulting address is accessible. Unfortunately, Linux + seems to have no way of giving us the faulting address. - In versions of a-init.c before 1.95, we had a test of the page - before the stack pointer using: + In old versions of init.c, we had a test of the page before the + stack pointer: - recurse++; - ((volatile char *) - ((long) info->esp_at_signal & - getpagesize ()))[getpagesize ()]; + ((volatile char *) + ((long) si->esp_at_signal & - getpagesize ()))[getpagesize ()]; - but that's wrong, since it tests the stack pointer location, and - the current stack probe code does not move the stack pointer - until all probes succeed. + but that's wrong since it tests the stack pointer location and the + stack probing code may not move it until all probes succeed. - For now we simply do not attempt any discrimination at all. Note - that this is quite acceptable, since a "real" SIGSEGV can only - occur as the result of an erroneous program. */ - - msg = "stack overflow (or erroneous memory access)"; - exception = &storage_error; - } + For now we simply do not attempt any discrimination at all. Note + that this is quite acceptable, since a "real" SIGSEGV can only + occur as the result of an erroneous program. */ + exception = &storage_error; + msg = "stack overflow (or erroneous memory access)"; break; case SIGBUS: @@ -702,11 +657,10 @@ __gnat_error_handler (int sig, msg = "unhandled signal"; } - recurse = 0; Raise_From_Signal_Handler (exception, msg); } -#if defined (i386) || defined (__x86_64__) +#if defined (i386) || defined (__x86_64__) || defined (__powerpc__) /* This must be in keeping with System.OS_Interface.Alternate_Stack_Size. */ char __gnat_alternate_stack[16 * 1024]; /* 2 * SIGSTKSZ */ #endif @@ -747,7 +701,7 @@ __gnat_install_handler (void) handled properly, avoiding a SEGV generation from stack usage by the handler itself. */ -#if defined (i386) || defined (__x86_64__) +#if defined (i386) || defined (__x86_64__) || defined (__powerpc__) stack_t stack; stack.ss_sp = __gnat_alternate_stack; stack.ss_size = sizeof (__gnat_alternate_stack); @@ -768,7 +722,7 @@ __gnat_install_handler (void) sigaction (SIGILL, &act, NULL); if (__gnat_get_interrupt_state (SIGBUS) != 's') sigaction (SIGBUS, &act, NULL); -#if defined (i386) || defined (__x86_64__) +#if defined (i386) || defined (__x86_64__) || defined (__powerpc__) act.sa_flags |= SA_ONSTACK; #endif if (__gnat_get_interrupt_state (SIGSEGV) != 's') @@ -800,8 +754,6 @@ extern int (*Check_Abort_Status) (void); extern struct Exception_Data _abort_signal; -static void __gnat_error_handler (int, int, sigcontext_t *); - /* We are not setting the SA_SIGINFO bit in the sigaction flags when connecting that handler, with the effects described in the sigaction man page: @@ -1007,58 +959,13 @@ __gnat_install_handler(void) #define RETURN_ADDR_OFFSET 0 #endif -/* Likewise regarding how the "instruction pointer" register slot can - be identified in signal machine contexts. We have either "REG_PC" - or "PC" at hand, depending on the target CPU and Solaris version. */ -#if !defined (REG_PC) -#define REG_PC PC -#endif - -static void __gnat_error_handler (int, siginfo_t *, void *); - -#define HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE - -void -__gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext) -{ - mcontext_t *mcontext = &((ucontext_t *) ucontext)->uc_mcontext; - unsigned long *pc = (unsigned long *)mcontext->gregs[REG_PC]; - - /* We specifically detect calls to the null address and entirely fold - the not-yet-fully-established frame to prevent it from stopping the - unwinding. */ - if (pc == NULL) -#if defined (__sparc) - /* The call insn moves the return address into %o7. Move it back. */ - mcontext->gregs[REG_PC] = mcontext->gregs[REG_O7]; -#elif defined (i386) - { - /* The call insn pushes the return address onto the stack. Pop it. */ - mcontext->gregs[REG_PC] = *(unsigned long *)mcontext->gregs[UESP]; - mcontext->gregs[UESP] += 4; - } -#elif defined (__x86_64__) - { - /* The call insn pushes the return address onto the stack. Pop it. */ - mcontext->gregs[REG_PC] = *(unsigned long *)mcontext->gregs[REG_RSP]; - mcontext->gregs[REG_RSP] += 8; - } -#else -#error architecture not supported on Solaris -#endif -} - static void -__gnat_error_handler (int sig, siginfo_t *sip, void *ucontext) +__gnat_error_handler (int sig, siginfo_t *si, void *ucontext ATTRIBUTE_UNUSED) { struct Exception_Data *exception; static int recurse = 0; const char *msg; - /* Adjusting is required for every fault context, so adjust for this one - now, before we possibly trigger a recursive fault below. */ - __gnat_adjust_context_for_raise (sig, ucontext); - switch (sig) { case SIGSEGV: @@ -1069,9 +976,9 @@ __gnat_error_handler (int sig, siginfo_t *sip, void *ucontext) ??? Using a static variable here isn't task-safe, but it's much too hard to do anything else and we're just determining which exception to raise. */ - if (sip->si_code == SEGV_ACCERR - || (long) sip->si_addr == 0 - || (((long) sip->si_addr) & 3) != 0 + if (si->si_code == SEGV_ACCERR + || (long) si->si_addr == 0 + || (((long) si->si_addr) & 3) != 0 || recurse) { exception = &constraint_error; @@ -1085,7 +992,7 @@ __gnat_error_handler (int sig, siginfo_t *sip, void *ucontext) the actual address, just to be on the same page. */ recurse++; ((volatile char *) - ((long) sip->si_addr & - getpagesize ()))[getpagesize ()]; + ((long) si->si_addr & - getpagesize ()))[getpagesize ()]; exception = &storage_error; msg = "stack overflow (or erroneous memory access)"; } @@ -1661,15 +1568,18 @@ __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext) #endif -/* Feature logical name and global variable address pair */ +/* Feature logical name and global variable address pair. + If we ever add another feature logical to this list, the + feature struct will need to be enhanced to take into account + possible values for *gl_addr. */ struct feature {char *name; int* gl_addr;}; /* Default values for GNAT features set by environment. */ -int __gl_no_malloc_64 = 0; +int __gl_heap_size = 64; /* Array feature logical names and global variable addresses */ static struct feature features[] = { - {"GNAT$NO_MALLOC_64", &__gl_no_malloc_64}, + {"GNAT$NO_MALLOC_64", &__gl_heap_size}, {0, 0} }; @@ -1700,10 +1610,14 @@ void __gnat_set_features () else strcpy (buff, ""); - if (strcmp (buff, "ENABLE") == 0) - *features [i].gl_addr = 1; - else if (strcmp (buff, "DISABLE") == 0) - *features [i].gl_addr = 0; + if ((strcmp (buff, "ENABLE") == 0) || + (strcmp (buff, "TRUE") == 0) || + (strcmp (buff, "1") == 0)) + *features [i].gl_addr = 32; + else if ((strcmp (buff, "DISABLE") == 0) || + (strcmp (buff, "FALSE") == 0) || + (strcmp (buff, "0") == 0)) + *features [i].gl_addr = 64; } __gnat_features_set = 1; @@ -1719,11 +1633,10 @@ void __gnat_set_features () #include #include -static void __gnat_error_handler (int, siginfo_t *, ucontext_t *); - static void -__gnat_error_handler (int sig, siginfo_t *info __attribute__ ((unused)), - ucontext_t *ucontext) +__gnat_error_handler (int sig, + siginfo_t *si ATTRIBUTE_UNUSED, + void *ucontext ATTRIBUTE_UNUSED) { struct Exception_Data *exception; const char *msg; @@ -1939,8 +1852,9 @@ __gnat_map_signal (int sig) propagation after the required low level adjustments. */ void -__gnat_error_handler (int sig, void * si ATTRIBUTE_UNUSED, - struct sigcontext * sc) +__gnat_error_handler (int sig, + void *si ATTRIBUTE_UNUSED, + struct sigcontext *sc ATTRIBUTE_UNUSED) { sigset_t mask; @@ -2176,8 +2090,6 @@ __gnat_install_handler(void) /* This must be in keeping with System.OS_Interface.Alternate_Stack_Size. */ char __gnat_alternate_stack[32 * 1024]; /* 1 * MINSIGSTKSZ */ -static void __gnat_error_handler (int sig, siginfo_t * si, void * uc); - /* Defined in xnu unix_signal.c. Tell the kernel to re-use alt stack when delivering a signal. */ #define UC_RESET_ALT_STACK 0x80000000 @@ -2208,7 +2120,7 @@ __gnat_is_stack_guard (mach_vm_address_t addr) } static void -__gnat_error_handler (int sig, siginfo_t * si, void * uc ATTRIBUTE_UNUSED) +__gnat_error_handler (int sig, siginfo_t *si, void *ucontext ATTRIBUTE_UNUSED) { struct Exception_Data *exception; const char *msg; @@ -2306,10 +2218,10 @@ __gnat_install_handler (void) /*********************/ /* This routine is called as each process thread is created, for possible - initialization of the FP processor. This version is used under INTERIX, - WIN32 and could be used under OS/2. */ + initialization of the FP processor. This version is used under INTERIX + and WIN32. */ -#if defined (_WIN32) || defined (__INTERIX) || defined (__EMX__) \ +#if defined (_WIN32) || defined (__INTERIX) \ || defined (__Lynx__) || defined(__NetBSD__) || defined(__FreeBSD__) \ || defined (__OpenBSD__) diff --git a/gcc/ada/initialize.c b/gcc/ada/initialize.c index fbbdf605275..32ea0e5c7f3 100644 --- a/gcc/ada/initialize.c +++ b/gcc/ada/initialize.c @@ -307,13 +307,10 @@ __gnat_initialize (void *eh) or the other, except for the mixed Ada/C++ case in which the first scheme would fail for the same reason as in the linked-with-kernel situation. - Selecting the crt set with the ctors/dtors capabilities (first scheme - above) is triggered by adding "-dynamic" to the gcc *link* command line - options. Selecting the other set is achieved by using "-static" instead. - - This is a first approach, tightly synchronized with a number of GCC - configuration and crtstuff changes. We need to ensure that those changes - are there to activate this circuitry. */ + The crt set selection is controlled by command line options via GCC's + STARTFILE_SPEC in rs6000/vxworks.h. This is tightly synchronized with a + number of other GCC configuration and crtstuff changes, and we need to + ensure that those changes are there to activate this circuitry. */ #if (__GNUC__ >= 3) && (defined (_ARCH_PPC) || defined (__ppc)) { diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index eeeb9da9106..1379a9e82dd 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -34,7 +34,6 @@ with Fname.UF; use Fname.UF; with Lib; use Lib; with Namet; use Namet; with Nlists; use Nlists; -with Opt; use Opt; with Sem_Aux; use Sem_Aux; with Sem_Ch8; use Sem_Ch8; with Sem_Ch10; use Sem_Ch10; diff --git a/gcc/ada/inline.ads b/gcc/ada/inline.ads index fec948d6941..04cb3234400 100644 --- a/gcc/ada/inline.ads +++ b/gcc/ada/inline.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -36,6 +36,7 @@ -- Frontend, and thus are not mutually recursive. with Alloc; +with Opt; use Opt; with Sem; use Sem; with Table; with Types; use Types; @@ -84,6 +85,10 @@ package Inline is -- This means we have to capture this information from the current scope -- at the point of instantiation. + Version : Ada_Version_Type; + -- The body must be compiled with the same language version as the + -- spec. The version may be set by a configuration pragma in a separate + -- file or in the current file, and may differ from body to body. end record; package Pending_Instantiations is new Table.Table ( diff --git a/gcc/ada/itypes.ads b/gcc/ada/itypes.ads index 0d70c1d382d..ffd3a1d496e 100644 --- a/gcc/ada/itypes.ads +++ b/gcc/ada/itypes.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -127,7 +127,7 @@ package Itypes is -- If the implicit type does not need an external name, then the -- Related_Id parameter is omitted (and hence Empty). In this case -- Suffix and Suffix_Index are ignored and the implicit type name is - -- created by a call to New_Internal_Name ('T'). + -- created by a call to Make_Temporary. -- -- Note that in all cases, the name starts with "T". This is used -- to identify implicit types in the error message handling circuits. diff --git a/gcc/ada/layout.adb b/gcc/ada/layout.adb index 69772d69290..be2bd802317 100644 --- a/gcc/ada/layout.adb +++ b/gcc/ada/layout.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -2560,10 +2560,10 @@ package body Layout is begin -- For some reasons, access types can cause trouble, So let's - -- just do this for discrete types ??? + -- just do this for scalar types ??? if Present (CT) - and then Is_Discrete_Type (CT) + and then Is_Scalar_Type (CT) and then Known_Static_Esize (CT) then declare @@ -2736,8 +2736,7 @@ package body Layout is begin if Spec < Min then Error_Msg_Uint_1 := Min; - Error_Msg_NE - ("size for & too small, minimum allowed is ^", SC, E); + Error_Msg_NE ("size for & too small, minimum allowed is ^", SC, E); Init_Esize (E); Init_RM_Size (E); end if; @@ -3119,11 +3118,7 @@ package body Layout is Make_Func : Boolean := False) return Dynamic_SO_Ref is Loc : constant Source_Ptr := Sloc (Ins_Type); - - K : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('K')); - + K : constant Entity_Id := Make_Temporary (Loc, 'K'); Decl : Node_Id; Vtype_Primary_View : Entity_Id; diff --git a/gcc/ada/lib-util.adb b/gcc/ada/lib-util.adb index 77b0efc5b55..9047690d663 100644 --- a/gcc/ada/lib-util.adb +++ b/gcc/ada/lib-util.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -25,6 +25,7 @@ with Hostparm; with Osint.C; use Osint.C; +with Stringt; use Stringt; package body Lib.Util is @@ -39,8 +40,13 @@ package body Lib.Util is Info_Buffer_Col : Natural := 1; -- Column number of next character to be written. - -- Can be different from Info_Buffer_Len + 1 - -- because of tab characters written by Write_Info_Tab. + -- Can be different from Info_Buffer_Len + 1 because of tab characters + -- written by Write_Info_Tab. + + procedure Write_Info_Hex_Byte (J : Natural); + -- Place two hex digits representing the value J (which is in the range + -- 0-255) in Info_Buffer, incrementing Info_Buffer_Len by 2. The digits + -- are output using lower case letters. --------------------- -- Write_Info_Char -- @@ -58,20 +64,6 @@ package body Lib.Util is -------------------------- procedure Write_Info_Char_Code (Code : Char_Code) is - - procedure Write_Info_Hex_Byte (J : Natural); - -- Write single hex digit - - procedure Write_Info_Hex_Byte (J : Natural) is - Hexd : constant String := "0123456789abcdef"; - - begin - Write_Info_Char (Hexd (J / 16 + 1)); - Write_Info_Char (Hexd (J mod 16 + 1)); - end Write_Info_Hex_Byte; - - -- Start of processing for Write_Info_Char_Code - begin -- 00 .. 7F @@ -127,12 +119,40 @@ package body Lib.Util is end if; end Write_Info_EOL; + ------------------------- + -- Write_Info_Hex_Byte -- + ------------------------- + + procedure Write_Info_Hex_Byte (J : Natural) is + Hexd : constant array (0 .. 15) of Character := "0123456789abcdef"; + begin + Write_Info_Char (Hexd (J / 16)); + Write_Info_Char (Hexd (J mod 16)); + end Write_Info_Hex_Byte; + ------------------------- -- Write_Info_Initiate -- ------------------------- procedure Write_Info_Initiate (Key : Character) renames Write_Info_Char; + -------------------- + -- Write_Info_Int -- + -------------------- + + procedure Write_Info_Int (N : Int) is + begin + if N >= 0 then + Write_Info_Nat (N); + + -- Negative numbers, use Write_Info_Uint to avoid problems with largest + -- negative number. + + else + Write_Info_Uint (UI_From_Int (N)); + end if; + end Write_Info_Int; + --------------------- -- Write_Info_Name -- --------------------- @@ -169,6 +189,38 @@ package body Lib.Util is Write_Info_Char (Character'Val (N mod 10 + Character'Pos ('0'))); end Write_Info_Nat; + --------------------- + -- Write_Info_Slit -- + --------------------- + + procedure Write_Info_Slit (S : String_Id) is + C : Character; + + begin + Write_Info_Str (""""); + + for J in 1 .. String_Length (S) loop + C := Get_Character (Get_String_Char (S, J)); + + if C in Character'Val (16#20#) .. Character'Val (16#7E#) + and then C /= '{' + then + Write_Info_Char (C); + + if C = '"' then + Write_Info_Char (C); + end if; + + else + Write_Info_Char ('{'); + Write_Info_Hex_Byte (Character'Pos (C)); + Write_Info_Char ('}'); + end if; + end loop; + + Write_Info_Char ('"'); + end Write_Info_Slit; + -------------------- -- Write_Info_Str -- -------------------- @@ -225,7 +277,16 @@ package body Lib.Util is Info_Buffer_Len := 0; Info_Buffer_Col := 1; - end Write_Info_Terminate; + --------------------- + -- Write_Info_Uint -- + --------------------- + + procedure Write_Info_Uint (N : Uint) is + begin + UI_Image (N, Decimal); + Write_Info_Str (UI_Image_Buffer (1 .. UI_Image_Length)); + end Write_Info_Uint; + end Lib.Util; diff --git a/gcc/ada/lib-util.ads b/gcc/ada/lib-util.ads index a8326ac2a50..b34bd277a09 100644 --- a/gcc/ada/lib-util.ads +++ b/gcc/ada/lib-util.ads @@ -23,6 +23,8 @@ -- -- ------------------------------------------------------------------------------ +with Uintp; use Uintp; + package Lib.Util is -- This package implements a buffered write of library information @@ -52,6 +54,10 @@ package Lib.Util is procedure Write_Info_Nat (N : Nat); -- Adds image of N to Info_Buffer with no leading or trailing blanks + procedure Write_Info_Int (N : Int); + -- Adds image of N to Info_Buffer with no leading or trailing blanks. A + -- minus sign is prepended for negative values. + procedure Write_Info_Name (Name : Name_Id); procedure Write_Info_Name (Name : File_Name_Type); procedure Write_Info_Name (Name : Unit_Name_Type); @@ -59,6 +65,9 @@ package Lib.Util is -- name is written literally from the names table entry without modifying -- the case, using simply Get_Name_String. + procedure Write_Info_Slit (S : String_Id); + -- Write string literal value in format required for L/N lines in ali file + procedure Write_Info_Str (Val : String); -- Adds characters of Val to Info_Buffer surrounded by quotes @@ -70,4 +79,8 @@ package Lib.Util is procedure Write_Info_Terminate; -- Terminate current info line and output lines built in Info_Buffer + procedure Write_Info_Uint (N : Uint); + -- Adds decimal image of N to Info_Buffer with no leading or trailing + -- blanks. A minus sign is prepended for negative values. + end Lib.Util; diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index 94d4b455526..24cce9251a3 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -592,42 +592,90 @@ package body Lib.Writ is for J in 1 .. Linker_Option_Lines.Last loop declare - S : constant Linker_Option_Entry := - Linker_Option_Lines.Table (J); - C : Character; - + S : Linker_Option_Entry renames Linker_Option_Lines.Table (J); begin if S.Unit = Unit_Num then Write_Info_Initiate ('L'); - Write_Info_Str (" """); + Write_Info_Char (' '); + Write_Info_Slit (S.Option); + Write_Info_EOL; + end if; + end; + end loop; + + -- Output notes + + for J in 1 .. Notes.Last loop + declare + N : constant Node_Id := Notes.Table (J).Pragma_Node; + L : constant Source_Ptr := Sloc (N); + U : constant Unit_Number_Type := Notes.Table (J).Unit; + C : Character; - for J in 1 .. String_Length (S.Option) loop - C := Get_Character (Get_String_Char (S.Option, J)); + begin + if U = Unit_Num then + Write_Info_Initiate ('N'); + Write_Info_Char (' '); + + case Chars (Pragma_Identifier (N)) is + when Name_Annotate => + C := 'A'; + when Name_Comment => + C := 'C'; + when Name_Ident => + C := 'I'; + when Name_Title => + C := 'T'; + when Name_Subtitle => + C := 'S'; + when others => + raise Program_Error; + end case; + + Write_Info_Char (C); + Write_Info_Int (Int (Get_Logical_Line_Number (L))); + Write_Info_Char (':'); + Write_Info_Int (Int (Get_Column_Number (L))); - if C in Character'Val (16#20#) .. Character'Val (16#7E#) - and then C /= '{' - then - Write_Info_Char (C); + declare + A : Node_Id; - if C = '"' then - Write_Info_Char (C); + begin + A := First (Pragma_Argument_Associations (N)); + while Present (A) loop + Write_Info_Char (' '); + + if Chars (A) /= No_Name then + Write_Info_Name (Chars (A)); + Write_Info_Char (':'); end if; - else declare - Hex : constant array (0 .. 15) of Character := - "0123456789ABCDEF"; + Expr : constant Node_Id := Expression (A); begin - Write_Info_Char ('{'); - Write_Info_Char (Hex (Character'Pos (C) / 16)); - Write_Info_Char (Hex (Character'Pos (C) mod 16)); - Write_Info_Char ('}'); + if Nkind (Expr) = N_Identifier then + Write_Info_Name (Chars (Expr)); + + elsif Nkind (Expr) = N_Integer_Literal + and then Is_Static_Expression (Expr) + then + Write_Info_Uint (Intval (Expr)); + + elsif Nkind (Expr) = N_String_Literal + and then Is_Static_Expression (Expr) + then + Write_Info_Slit (Strval (Expr)); + + else + Write_Info_Str (""); + end if; end; - end if; - end loop; - Write_Info_Char ('"'); + Next (A); + end loop; + end; + Write_Info_EOL; end if; end; diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads index 593442c4d4f..54514325229 100644 --- a/gcc/ada/lib-writ.ads +++ b/gcc/ada/lib-writ.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -571,13 +571,47 @@ package Lib.Writ is -- source file, so that this order is preserved by the binder in -- constructing the set of linker arguments. + -- -------------- + -- -- N Notes -- + -- -------------- + + -- The final section of unit-specific lines contains notes which record + -- annotations inserted in source code for processing by external tools + -- using pragmas. For each occurrence of any of these pragmas, a line is + -- generated with the following syntax: + + -- N x [:] ... + + -- x is one of: + -- A pragma Annotate + -- C pragma Comment + -- I pragma Ident + -- T pragma Title + -- S pragma Subtitle + + -- is the source location of the pragma in line:col format + + -- Successive entries record the pragma_argument_associations. + + -- If a pragma argument identifier is present, the entry is prefixed + -- with the pragma argument identifier followed by a colon. + + -- represents the pragma argument, and has the following + -- conventions: + + -- - identifiers are output verbatim + -- - static string expressions are output as literals encoded as + -- for L lines + -- - static integer expressions are output as decimal literals + -- - any other expression is replaced by the placeholder "" + --------------------- -- Reference Lines -- --------------------- -- The reference lines contain information about references from any of the - -- units in the compilation (including, body version and version - -- attributes, linker options pragmas and source dependencies. + -- units in the compilation (including body version and version attributes, + -- linker options pragmas and source dependencies). -- ------------------------------------ -- -- E External Version References -- @@ -654,40 +688,6 @@ package Lib.Writ is -- The cross-reference data follows the dependency lines. See the spec of -- Lib.Xref for details on the format of this data. - -- -------------- - -- -- N Notes -- - -- -------------- - - -- The note lines record annotations inserted in source code for processing - -- by external tools using pragmas. For each occurrence of any of these - -- pragmas, a line is generated with the following syntax: - - -- N x [:] ... - - -- x is one of: - -- A pragma Annotate - -- C pragma Comment - -- I pragma Ident - -- T pragma Title - -- S pragma Subtitle - - -- is the source file containing the pragma by its dependency index - -- (first D line has index 1) - -- is the source location of the pragma - - -- Successive entries record the pragma_argument_associations. - - -- For a named association, the entry is prefixed with the pragma argument - -- identifier followed by a colon. - - -- represents the pragma argument, and has the following conventions: - - -- - identifiers are output verbatim - -- - static string expressions are output as literals encoded as for - -- L lines - -- - static integer expressions are output as decimal literals - -- - any other expression is replaced by the placeholder "" - --------------------------------- -- Source Coverage Obligations -- --------------------------------- @@ -696,14 +696,13 @@ package Lib.Writ is -- reference data. See the spec of Par_SCO for full details of the format. ---------------------- - -- Global_Variables -- + -- Global Variables -- ---------------------- - -- The table structure defined here stores one entry for each - -- Interrupt_State pragma encountered either in the main source or - -- in an ancillary with'ed source. Since interrupt state values - -- have to be consistent across all units in a partition, we may - -- as well detect inconsistencies at compile time when we can. + -- The table defined here stores one entry for each Interrupt_State pragma + -- encountered either in the main source or in an ancillary with'ed source. + -- Since interrupt state values have to be consistent across all units in a + -- partition, we detect inconsistencies at compile time when we can. type Interrupt_State_Entry is record Interrupt_Number : Pos; diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index 516fc55261f..5283023a856 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -214,7 +214,6 @@ package body Lib.Xref is Base_T : Entity_Id; Prim : Elmt_Id; Prim_List : Elist_Id; - Ent : Entity_Id; begin -- Handle subtypes of synchronized types @@ -262,12 +261,8 @@ package body Lib.Xref is -- reference purposes (it is the original for which we want the xref -- and for which the comes_from_source test must be performed). - Ent := Node (Prim); - while Present (Alias (Ent)) loop - Ent := Alias (Ent); - end loop; - - Generate_Reference (Typ, Ent, 'p', Set_Ref => False); + Generate_Reference + (Typ, Ultimate_Alias (Node (Prim)), 'p', Set_Ref => False); Next_Elmt (Prim); end loop; end Generate_Prim_Op_References; @@ -666,7 +661,7 @@ package body Lib.Xref is -- Check for pragma Unreferenced given and reference is within -- this source unit (occasion for possible warning to be issued). - if Has_Pragma_Unreferenced (E) + if Has_Unreferenced (E) and then In_Same_Extended_Unit (E, N) then -- A reference as a named parameter in a call does not count @@ -699,7 +694,7 @@ package body Lib.Xref is BE := First_Entity (Current_Scope); while Present (BE) loop if Chars (BE) = Chars (E) then - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("?pragma Unreferenced given for&!", N, BE); exit; end if; @@ -711,7 +706,8 @@ package body Lib.Xref is -- Here we issue the warning, since this is a real reference else - Error_Msg_NE ("?pragma Unreferenced given for&!", N, E); + Error_Msg_NE -- CODEFIX + ("?pragma Unreferenced given for&!", N, E); end if; end if; @@ -1703,10 +1699,7 @@ package body Lib.Xref is -- through several levels of derivation, so find the -- ultimate (source) ancestor. - Op := Alias (Old_E); - while Present (Alias (Op)) loop - Op := Alias (Op); - end loop; + Op := Ultimate_Alias (Old_E); -- Normal case of no alias present diff --git a/gcc/ada/lib-xref.ads b/gcc/ada/lib-xref.ads index 2e9c8d26439..86303d1627d 100644 --- a/gcc/ada/lib-xref.ads +++ b/gcc/ada/lib-xref.ads @@ -68,9 +68,10 @@ package Lib.Xref is -- col is the column number of the referenced entity -- level is a single character that separates the col and - -- entity fields. It is an asterisk for a top level library + -- entity fields. It is an asterisk (*) for a top level library -- entity that is publicly visible, as well for an entity declared - -- in the visible part of a generic package, and space otherwise. + -- in the visible part of a generic package, the plus sign (+) for + -- a C/C++ static entity, and space otherwise. -- entity is the name of the referenced entity, with casing in -- the canonical casing for the source file where it is defined. @@ -541,7 +542,7 @@ package Lib.Xref is -- d decimal fixed-point object decimal fixed-point type -- e non-Boolean enumeration object non_Boolean enumeration type -- f floating-point object floating-point type - -- g (unused) (unused) + -- g C/C++ macro C/C++ fun-like macro -- h Interface (Ada 2005) Abstract type -- i signed integer object signed integer type -- j (unused) (unused) @@ -551,7 +552,7 @@ package Lib.Xref is -- n enumeration literal named number -- o ordinary fixed-point object ordinary fixed-point type -- p access object access type - -- q label on block (unused) + -- q label on block C/C++ include file -- r record object record type -- s string object string type -- t task object task type diff --git a/gcc/ada/lib.adb b/gcc/ada/lib.adb index 63dd62025fe..940527fc64d 100644 --- a/gcc/ada/lib.adb +++ b/gcc/ada/lib.adb @@ -858,6 +858,7 @@ package body Lib is procedure Initialize is begin Linker_Option_Lines.Init; + Notes.Init; Load_Stack.Init; Units.Init; Compilation_Switches.Init; @@ -984,11 +985,18 @@ package body Lib is procedure Store_Linker_Option_String (S : String_Id) is begin - Linker_Option_Lines.Increment_Last; - Linker_Option_Lines.Table (Linker_Option_Lines.Last) := - (Option => S, Unit => Current_Sem_Unit); + Linker_Option_Lines.Append ((Option => S, Unit => Current_Sem_Unit)); end Store_Linker_Option_String; + ---------------- + -- Store_Note -- + ---------------- + + procedure Store_Note (N : Node_Id) is + begin + Notes.Append ((Pragma_Node => N, Unit => Current_Sem_Unit)); + end Store_Note; + ------------------------------- -- Synchronize_Serial_Number -- ------------------------------- diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads index 9c36d91ff35..4a956b5118f 100644 --- a/gcc/ada/lib.ads +++ b/gcc/ada/lib.ads @@ -574,6 +574,10 @@ package Lib is -- This procedure is called to register the string from a pragma -- Linker_Option. The argument is the Id of the string to register. + procedure Store_Note (N : Node_Id); + -- This procedure is called to register a pragma N for which a notes + -- entry is required. + procedure Initialize; -- Initialize internal tables @@ -733,6 +737,21 @@ private Table_Increment => Alloc.Linker_Option_Lines_Increment, Table_Name => "Linker_Option_Lines"); + -- The following table stores references to pragmas that generate Notes + + type Notes_Entry is record + Pragma_Node : Node_Id; + Unit : Unit_Number_Type; + end record; + + package Notes is new Table.Table ( + Table_Component_Type => Notes_Entry, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => Alloc.Notes_Initial, + Table_Increment => Alloc.Notes_Increment, + Table_Name => "Notes"); + -- The following table records the compilation switches used to compile -- the main unit. The table includes only switches. It excludes -o -- switches as well as artifacts of the gcc/gnat1 interface such as diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index 0e3c85765d5..d1cafbf32d3 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -202,6 +202,14 @@ package body Make is Unique_Compile_All_Projects : Boolean := False; -- Set to True if -U is used + Must_Compile : Boolean := False; + -- True if gnatmake is invoked with -f -u and one or several mains on the + -- command line. + + Main_On_Command_Line : Boolean := False; + -- True if gnatmake is invoked with one or several mains on the command + -- line. + RTS_Specified : String_Access := null; -- Used to detect multiple --RTS= switches @@ -1387,7 +1395,7 @@ package body Make is if Project_Of_Current_Object_Directory /= Project then Project_Of_Current_Object_Directory := Project; - Object_Directory := Project.Object_Directory.Name; + Object_Directory := Project.Object_Directory.Display_Name; -- Set the working directory to the object directory of the actual -- project. @@ -1785,6 +1793,13 @@ package body Make is Modified_Source := Time_Stamp_Mismatch (ALI, Read_Only); + -- To avoid using too much memory when switch -m is used, free the + -- memory allocated for the source file when computing the checksum. + + if Minimal_Recompilation then + Sinput.P.Clear_Source_File_Table; + end if; + if Modified_Source /= No_File then ALI := No_ALI_Id; @@ -2236,12 +2251,14 @@ package body Make is if Arguments_Project = No_Project then Add_Arguments (The_Saved_Gcc_Switches.all); - elsif not Arguments_Project.Externally_Built then + elsif not Arguments_Project.Externally_Built + or else Must_Compile + then -- We get the project directory for the relative path -- switches and arguments. - Arguments_Project := Ultimate_Extending_Project_Of - (Arguments_Project); + Arguments_Project := + Ultimate_Extending_Project_Of (Arguments_Project); -- If building a dynamic or relocatable library, compile with -- PIC option, if it exists. @@ -2251,7 +2268,6 @@ package body Make is then declare PIC : constant String := MLib.Tgt.PIC_Option; - begin if PIC /= "" then Add_Arguments ((1 => new String'(PIC))); @@ -2432,7 +2448,7 @@ package body Make is -- Info on the mapping file Need_To_Check_Standard_Library : Boolean := - Check_Readonly_Files + (Check_Readonly_Files or Must_Compile) and not Unique_Compile; procedure Add_Process @@ -2719,11 +2735,14 @@ package body Make is -- check for an eventual library project, and use the full path. if Arguments_Project /= No_Project then - if not Arguments_Project.Externally_Built then + if not Arguments_Project.Externally_Built + or else Must_Compile + then Prj.Env.Set_Ada_Paths (Arguments_Project, Project_Tree, - Including_Libraries => True); + Including_Libraries => True, + Include_Path => Use_Include_Path_File); if not Unique_Compile and then MLib.Tgt.Support_For_Libraries /= Prj.None @@ -2734,7 +2753,7 @@ package body Make is begin if Prj.Library - and then not Prj.Externally_Built + and then (not Prj.Externally_Built or else Must_Compile) and then not Prj.Need_To_Build_Lib then -- Add to the Q all sources of the project that have @@ -2886,7 +2905,7 @@ package body Make is begin if Is_Predefined_File_Name (Fname, False) then - if Check_Readonly_Files then + if Check_Readonly_Files or else Must_Compile then Comp_Args (Comp_Args'First + 2 .. Comp_Last + 1) := Comp_Args (Comp_Args'First + 1 .. Comp_Last); Comp_Last := Comp_Last + 1; @@ -3084,7 +3103,7 @@ package body Make is if Is_Marked (Sfile, Source_Index) then Debug_Msg ("Skipping marked file:", Sfile); - elsif not Check_Readonly_Files + elsif not (Check_Readonly_Files or Must_Compile) and then Is_Internal_File_Name (Sfile, False) then Debug_Msg ("Skipping internal file:", Sfile); @@ -3265,14 +3284,14 @@ package body Make is end if; In_Lib_Dir := Full_Lib_File /= No_File - and then In_Ada_Lib_Dir (Full_Lib_File); + and then In_Ada_Lib_Dir (Full_Lib_File); -- Since the following requires a system call, we precompute it -- when needed. if not In_Lib_Dir then if Full_Lib_File /= No_File - and then not Check_Readonly_Files + and then not (Check_Readonly_Files or else Must_Compile) then Get_Name_String (Full_Lib_File); Name_Buffer (Name_Len + 1) := ASCII.NUL; @@ -3314,7 +3333,7 @@ package body Make is -- Source and library files can be located but are internal -- files. - elsif not Check_Readonly_Files + elsif not (Check_Readonly_Files or else Must_Compile) and then Full_Lib_File /= No_File and then Is_Internal_File_Name (Source_File, False) then @@ -3342,6 +3361,7 @@ package body Make is if Arguments_Project = No_Project or else not Arguments_Project.Externally_Built + or else Must_Compile then -- Don't waste any time if we have to recompile anyway @@ -4731,13 +4751,6 @@ package body Make is Display_Version ("GNATMAKE", "1995"); end if; - if Main_Project /= No_Project - and then Main_Project.Externally_Built - then - Make_Failed - ("nothing to do for a main project that is externally built"); - end if; - if Osint.Number_Of_Files = 0 then if Main_Project /= No_Project and then Main_Project.Library @@ -5174,6 +5187,25 @@ package body Make is end; end if; + -- The combination of -f -u and one or several mains on the command line + -- implies -a. + + if Force_Compilations + and then Unique_Compile + and then not Unique_Compile_All_Projects + and then Main_On_Command_Line + then + Must_Compile := True; + end if; + + if Main_Project /= No_Project + and then not Must_Compile + and then Main_Project.Externally_Built + then + Make_Failed + ("nothing to do for a main project that is externally built"); + end if; + -- Get the target parameters, which are only needed for a couple of -- cases in gnatmake. Protect against an exception, such as the case of -- system.ads missing from the library, and fail gracefully. @@ -6026,7 +6058,8 @@ package body Make is -- and all the object directories in ADA_OBJECTS_PATH, -- except those of library projects. - Prj.Env.Set_Ada_Paths (Main_Project, Project_Tree, False); + Prj.Env.Set_Ada_Paths + (Main_Project, Project_Tree, Use_Include_Path_File); -- If switch -C was specified, create a binder mapping file @@ -6043,7 +6076,7 @@ package body Make is exception when others => - -- Delete the temporary mapping file, if one was created. + -- Delete the temporary mapping file if one was created if Mapping_Path /= No_Path then Delete_Temporary_File (Project_Tree, Mapping_Path); @@ -6054,7 +6087,7 @@ package body Make is raise; end; - -- If -dn was not specified, delete the temporary mapping file, + -- If -dn was not specified, delete the temporary mapping file -- if one was created. if Mapping_Path /= No_Path then @@ -6253,7 +6286,11 @@ package body Make is -- Put the object directories in ADA_OBJECTS_PATH - Prj.Env.Set_Ada_Paths (Main_Project, Project_Tree, False); + Prj.Env.Set_Ada_Paths + (Main_Project, + Project_Tree, + Including_Libraries => False, + Include_Path => False); -- Check for attributes Linker'Linker_Options in projects -- other than the main project @@ -8174,13 +8211,11 @@ package body Make is elsif Argv (2 .. Argv'Last) = "nostdlib" then - -- Don't pass -nostdlib to gnatlink, it will disable - -- linking with all standard library files. + -- Pass -nstdlib to gnatbind and gnatlink No_Stdlib := True; - - Add_Switch (Argv, Compiler, And_Save => And_Save); Add_Switch (Argv, Binder, And_Save => And_Save); + Add_Switch (Argv, Linker, And_Save => And_Save); elsif Argv (2 .. Argv'Last) = "nostdinc" then @@ -8206,6 +8241,10 @@ package body Make is -- If not a switch it must be a file name else + if And_Save then + Main_On_Command_Line := True; + end if; + Add_File (Argv); Mains.Add_Main (Argv); end if; diff --git a/gcc/ada/makeusg.adb b/gcc/ada/makeusg.adb index ca22dceec9c..7f8ddb6163d 100644 --- a/gcc/ada/makeusg.adb +++ b/gcc/ada/makeusg.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -23,8 +23,9 @@ -- -- ------------------------------------------------------------------------------ -with Osint; use Osint; -with Output; use Output; +with Makeutl; +with Osint; use Osint; +with Output; use Output; with Usage; procedure Makeusg is @@ -311,6 +312,14 @@ begin Write_Str (" --subdirs=dir real obj/lib/exec dirs are subdirs"); Write_Eol; + + -- Line for --unchecked-shared-lib-imports + + Write_Str (" "); + Write_Str (Makeutl.Unchecked_Shared_Lib_Imports); + Write_Eol; + Write_Str (" Allow shared libraries to import static libraries"); + Write_Eol; Write_Eol; -- General Compiler, Binder, Linker switches diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb index ab00b506578..e07bebbad6b 100644 --- a/gcc/ada/makeutl.adb +++ b/gcc/ada/makeutl.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -26,6 +26,7 @@ with ALI; use ALI; with Debug; with Fname; +with Hostparm; with Osint; use Osint; with Output; use Output; with Opt; use Opt; @@ -38,8 +39,8 @@ with Ada.Command_Line; use Ada.Command_Line; with GNAT.Directory_Operations; use GNAT.Directory_Operations; -with System.Case_Util; use System.Case_Util; -with System.HTable; +with GNAT.Case_Util; use GNAT.Case_Util; +with GNAT.HTable; package body Makeutl is @@ -58,7 +59,7 @@ package body Makeutl is function Hash (Key : Mark_Key) return Mark_Num; - package Marks is new System.HTable.Simple_HTable + package Marks is new GNAT.HTable.Simple_HTable (Header_Num => Mark_Num, Element => Boolean, No_Element => False, @@ -378,6 +379,12 @@ package body Makeutl is -- Beginning of Executable_Prefix_Path begin + -- For VMS, the path returned is always /gnu/ + + if Hostparm.OpenVMS then + return "/gnu/"; + end if; + -- First determine if a path prefix was placed in front of the -- executable name. diff --git a/gcc/ada/makeutl.ads b/gcc/ada/makeutl.ads index a7614f399c4..fd286a8ebcc 100644 --- a/gcc/ada/makeutl.ads +++ b/gcc/ada/makeutl.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -47,6 +47,11 @@ package Makeutl is -- Switch used to indicate that the real directories (object, exec, -- library, ...) are subdirectories of those in the project file. + Unchecked_Shared_Lib_Imports : constant String := + "--unchecked-shared-lib-imports"; + -- Command line switch to allow shared library projects to import projects + -- that are not shared library projects. + procedure Add (Option : String_Access; To : in out String_List_Access; diff --git a/gcc/ada/mlib-prj.adb b/gcc/ada/mlib-prj.adb index f15b7c06d27..97a4c16180f 100644 --- a/gcc/ada/mlib-prj.adb +++ b/gcc/ada/mlib-prj.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2009, AdaCore -- +-- Copyright (C) 2001-2010, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -2285,6 +2285,11 @@ package body MLib.Prj is for Index in 1 .. Argument_Number loop Write_Char (' '); Write_Str (Arguments (Index).all); + + if not Opt.Verbose_Mode and then Index > 4 then + Write_Str (" ..."); + exit; + end if; end loop; Write_Eol; diff --git a/gcc/ada/mlib-utl.adb b/gcc/ada/mlib-utl.adb index 78378a673b9..67e03097ed6 100644 --- a/gcc/ada/mlib-utl.adb +++ b/gcc/ada/mlib-utl.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2008, AdaCore -- +-- Copyright (C) 2002-2010, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -460,11 +460,25 @@ package body MLib.Utl is end loop; if not Opt.Quiet_Output then - Write_Str (Driver.all); + if Opt.Verbose_Mode then + Write_Str (Driver.all); + + elsif Driver_Name /= No_Name then + Write_Str (Get_Name_String (Driver_Name)); + + else + Write_Str (Gcc_Name.all); + end if; for J in 1 .. A loop - Write_Char (' '); - Write_Str (Arguments (J).all); + if Opt.Verbose_Mode or else J < 4 then + Write_Char (' '); + Write_Str (Arguments (J).all); + + else + Write_Str (" ..."); + exit; + end if; end loop; -- Do not display all the object files if not in verbose mode, only @@ -480,10 +494,19 @@ package body MLib.Utl is elsif Position = Second then Write_Str (" ..."); Position := Last; + exit; end if; end loop; for J in Options_2'Range loop + if not Opt.Verbose_Mode then + if Position = Second then + Write_Str (" ..."); + end if; + + exit; + end if; + Write_Char (' '); Write_Str (Options_2 (J).all); end loop; diff --git a/gcc/ada/nlists.adb b/gcc/ada/nlists.adb index 09bd85a8439..fe4d27c24c4 100644 --- a/gcc/ada/nlists.adb +++ b/gcc/ada/nlists.adb @@ -1055,6 +1055,77 @@ package body Nlists is Set_List_Link (Node, To); end Prepend; + ------------------ + -- Prepend_List -- + ------------------ + + procedure Prepend_List (List : List_Id; To : List_Id) is + + procedure Prepend_List_Debug; + pragma Inline (Prepend_List_Debug); + -- Output debug information if Debug_Flag_N set + + ------------------------ + -- Prepend_List_Debug -- + ------------------------ + + procedure Prepend_List_Debug is + begin + if Debug_Flag_N then + Write_Str ("Prepend list "); + Write_Int (Int (List)); + Write_Str (" to list "); + Write_Int (Int (To)); + Write_Eol; + end if; + end Prepend_List_Debug; + + -- Start of processing for Prepend_List + + begin + if Is_Empty_List (List) then + return; + + else + declare + F : constant Node_Id := First (To); + L : constant Node_Id := Last (List); + N : Node_Id; + + begin + pragma Debug (Prepend_List_Debug); + + N := L; + loop + Set_List_Link (N, To); + N := Prev (N); + exit when No (N); + end loop; + + if No (F) then + Set_Last (To, L); + else + Set_Next (L, F); + end if; + + Set_Prev (F, L); + Set_First (To, First (List)); + + Set_First (List, Empty); + Set_Last (List, Empty); + end; + end if; + end Prepend_List; + + --------------------- + -- Prepend_List_To -- + --------------------- + + procedure Prepend_List_To (To : List_Id; List : List_Id) is + begin + Prepend_List (List, To); + end Prepend_List_To; + ---------------- -- Prepend_To -- ---------------- diff --git a/gcc/ada/nlists.ads b/gcc/ada/nlists.ads index 3753936df10..cecf3a21db4 100644 --- a/gcc/ada/nlists.ads +++ b/gcc/ada/nlists.ads @@ -259,6 +259,14 @@ package Nlists is pragma Inline (Prepend_To); -- Like Prepend, but arguments are the other way round + procedure Prepend_List (List : List_Id; To : List_Id); + -- Prepends node list List to the start of node list To. On return, + -- List is reset to be empty. + + procedure Prepend_List_To (To : List_Id; List : List_Id); + pragma Inline (Prepend_List_To); + -- Like Prepend_List, but arguments are the other way round + procedure Remove (Node : Node_Id); -- Removes Node, which must be a node that is a member of a node list, -- from this node list. The contents of Node are not otherwise affected. diff --git a/gcc/ada/opt.adb b/gcc/ada/opt.adb index a1528962b01..65c5726b901 100644 --- a/gcc/ada/opt.adb +++ b/gcc/ada/opt.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 9013d7d3dcd..54cec4932d6 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -41,8 +41,11 @@ with Hostparm; use Hostparm; with Types; use Types; +pragma Warnings (Off); +-- This package is used also by gnatcoll with System.Strings; use System.Strings; with System.WCh_Con; use System.WCh_Con; +pragma Warnings (On); package Opt is @@ -61,17 +64,15 @@ package Opt is -- GNATBIND, GNATLINK -- Set True if binder file to be generated in Ada rather than C - type Ada_Version_Type is (Ada_83, Ada_95, Ada_05); - pragma Warnings (Off, Ada_Version_Type); + type Ada_Version_Type is (Ada_83, Ada_95, Ada_05, Ada_12); -- Versions of Ada for Ada_Version below. Note that these are ordered, -- so that tests like Ada_Version >= Ada_95 are legitimate and useful. - -- The Warnings_Off pragma stops warnings for Ada_Version >= Ada_05, - -- which we want to allow, so that things work OK when Ada_15 is added! - -- This warning is now removed, so this pragma can be removed some time??? - Ada_Version_Default : Ada_Version_Type := Ada_05; + Ada_Version_Default : constant Ada_Version_Type := Ada_05; + pragma Warnings (Off, Ada_Version_Default); -- GNAT - -- Default Ada version if no switch given + -- Default Ada version if no switch given. The Warnings off is to kill + -- constant condition warnings. Ada_Version : Ada_Version_Type := Ada_Version_Default; -- GNAT @@ -88,7 +89,7 @@ package Opt is -- the rare cases (notably for pragmas Preelaborate_05 and Pure_05) -- where in the run-time we want the explicit version set. - Ada_Version_Runtime : Ada_Version_Type := Ada_05; + Ada_Version_Runtime : Ada_Version_Type := Ada_12; -- GNAT -- Ada version used to compile the runtime. Used to set Ada_Version (but -- not Ada_Version_Explicit) when compiling predefined or internal units. @@ -172,6 +173,15 @@ package Opt is -- also set true if certain Unchecked_Conversion instantiations require -- checking based on annotated values. + Back_End_Handles_Limited_Types : Boolean; + -- This flag is set true if the back end can properly handle limited or + -- other by reference types, and avoid copies. If this flag is False, then + -- the front end does special expansion for conditional expressions to make + -- sure that no copy occurs. If the flag is True, then the expansion for + -- conditional expressions relies on the back end properly handling things. + -- Currently the default is False for all cases (set in gnat1drv). The + -- default can be modified using -gnatd.L (sets the flag True). + Bind_Alternate_Main_Name : Boolean := False; -- GNATBIND -- True if main should be called Alternate_Main_Name.all. @@ -183,8 +193,8 @@ package Opt is Bind_For_Library : Boolean := False; -- GNATBIND - -- Set to True if the binder needs to generate a file designed for - -- building a library. May be set to True by Gnatbind.Scan_Bind_Arg. + -- Set to True if the binder needs to generate a file designed for building + -- a library. May be set to True by Gnatbind.Scan_Bind_Arg. Bind_Only : Boolean := False; -- GNATMAKE, GPRMAKE, GPRBUILD @@ -224,7 +234,10 @@ package Opt is -- GNAT -- This points to the list of N_Pragma nodes for Check_Policy pragmas -- that are linked through the Next_Pragma fields, with the list being - -- terminated by Empty. The order is most recently processed first. + -- terminated by Empty. The order is most recently processed first. Note + -- that Push_Scope and Pop_Scope in Sem_Ch8 save and restore the value + -- of this variable, implementing the required scope control for pragmas + -- appearing a declarative part. Check_Readonly_Files : Boolean := False; -- GNATMAKE @@ -450,8 +463,8 @@ package Opt is Front_End_Setjmp_Longjmp_Exceptions; -- GNAT -- Set to the appropriate value depending on the default as given in - -- system.ads (ZCX_By_Default, GCC_ZCX_Support). - -- The C convention is there to make this variable accessible to gigi. + -- system.ads (ZCX_By_Default, GCC_ZCX_Support). The C convention is there + -- to make this variable accessible to gigi. Exception_Tracebacks : Boolean := False; -- GNATBIND @@ -570,6 +583,11 @@ package Opt is -- GNAT -- True if compiling in GNAT system mode (-gnatg switch) + Heap_Size : Nat := 0; + -- GNATBIND + -- Heap size for memory allocations. Valid values are 32 and 64. Only + -- available on VMS. + HLO_Active : Boolean := False; -- GNAT -- True if High Level Optimizer is activated (-gnatH switch) @@ -939,9 +957,17 @@ package Opt is -- GNATBIND -- True if output of list of linker options is requested (-K switch set) - Output_Object_List : Boolean := False; + Output_ALI_List : Boolean := False; + ALI_List_Filename : String_Ptr; + -- GNATBIND + -- True if output of list of ALIs is requested (-A switch set). List is + -- output under the given filename, or standard output if not specified. + + Output_Object_List : Boolean := False; + Object_List_Filename : String_Ptr; -- GNATBIND - -- True if output of list of objects is requested (-O switch set) + -- True if output of list of objects is requested (-O switch set). List is + -- output under the given filename, or standard output if not specified. Overflow_Checks_Unsuppressed : Boolean := False; -- GNAT @@ -1226,11 +1252,23 @@ package Opt is -- set True, and upper half characters in the source indicate the start of -- a wide character sequence. Set by -gnatW or -W switches. + Use_Include_Path_File : Boolean := False; + -- GNATMAKE, GPRBUILD + -- When True, create a source search path file, even when a mapping file + -- is used. + Usage_Requested : Boolean := False; -- GNAT, GNATBIND, GNATMAKE -- Set to True if -h (-gnath for the compiler) switch encountered -- requesting usage information + Use_Expression_With_Actions : Boolean; + -- The N_Expression_With_Actions node has been introduced relatively + -- recently, and not all back ends are prepared to handle it yet. So + -- we use this flag to suppress its use during a transitional period. + -- Currently the default is False for all cases (set in gnat1drv). + -- The default can be modified using -gnatd.X/-gnatd.Y. + Use_Pragma_Linker_Constructor : Boolean := False; -- GNATBIND -- True if pragma Linker_Constructor applies to adainit diff --git a/gcc/ada/osint-b.adb b/gcc/ada/osint-b.adb index b66cebf2ac2..39b7a99be84 100644 --- a/gcc/ada/osint-b.adb +++ b/gcc/ada/osint-b.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -24,10 +24,13 @@ ------------------------------------------------------------------------------ with Opt; use Opt; +with Output; use Output; with Targparm; use Targparm; package body Osint.B is + Current_List_File : File_Descriptor := Invalid_FD; + ------------------------- -- Close_Binder_Output -- ------------------------- @@ -45,6 +48,19 @@ package body Osint.B is end Close_Binder_Output; + --------------------- + -- Close_List_File -- + --------------------- + + procedure Close_List_File is + begin + if Current_List_File /= Invalid_FD then + Close (Current_List_File); + Current_List_File := Invalid_FD; + Set_Standard_Output; + end if; + end Close_List_File; + -------------------------- -- Create_Binder_Output -- -------------------------- @@ -65,8 +81,8 @@ package body Osint.B is begin if Output_File_Name /= "" then - Name_Buffer (Output_File_Name'Range) := Output_File_Name; - Name_Buffer (Output_File_Name'Last + 1) := ASCII.NUL; + Name_Buffer (1 .. Output_File_Name'Length) := Output_File_Name; + Name_Buffer (Output_File_Name'Length + 1) := ASCII.NUL; if Typ = 's' then Name_Buffer (Output_File_Name'Last) := 's'; @@ -176,6 +192,22 @@ package body Osint.B is Current_File_Name_Index := To; end Set_Current_File_Name_Index; + ------------------- + -- Set_List_File -- + ------------------- + + procedure Set_List_File (Filename : String) is + begin + pragma Assert (Current_List_File = Invalid_FD); + Current_List_File := Create_File (Filename, Text); + + if Current_List_File = Invalid_FD then + Fail ("cannot create list file: " & Filename); + else + Set_Output (Current_List_File); + end if; + end Set_List_File; + ----------------------- -- Write_Binder_Info -- ----------------------- diff --git a/gcc/ada/osint-b.ads b/gcc/ada/osint-b.ads index a6b601fd296..d24ec91ee21 100644 --- a/gcc/ada/osint-b.ads +++ b/gcc/ada/osint-b.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -44,9 +44,9 @@ package Osint.B is -- Binder Output -- ------------------- - -- These routines are used by the binder to generate the C source file - -- containing the binder output. The format of this file is described - -- in the package Bindfmt. + -- These routines are used by the binder to generate the C or Ada source + -- files containing the binder output. The format of these files is + -- described in package Bindgen. procedure Create_Binder_Output (Output_File_Name : String; @@ -81,4 +81,16 @@ package Osint.B is procedure Set_Current_File_Name_Index (To : Int); -- Set value of Current_File_Name_Index (in private part of Osint) to To + ---------------------------------- + -- Other binder-generated files -- + ---------------------------------- + + procedure Set_List_File (Filename : String); + -- Create Filename as a text output file and set it as the current output + -- (see Output.Set_Output). + + procedure Close_List_File; + -- If a specific output file was created by Set_List_File, close it and + -- reset the current output file to standard output. + end Osint.B; diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb index 6265ede68d1..75995e3fca4 100644 --- a/gcc/ada/osint.adb +++ b/gcc/ada/osint.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -23,23 +23,26 @@ -- -- ------------------------------------------------------------------------------ +with Alloc; +with Debug; +with Fmap; use Fmap; +with Gnatvsn; use Gnatvsn; +with Hostparm; +with Opt; use Opt; +with Output; use Output; +with Sdefault; use Sdefault; +with Table; +with Targparm; use Targparm; + with Unchecked_Conversion; +pragma Warnings (Off); +-- This package is used also by gnatcoll with System.Case_Util; use System.Case_Util; +pragma Warnings (On); with GNAT.HTable; -with Alloc; -with Debug; -with Fmap; use Fmap; -with Gnatvsn; use Gnatvsn; -with Hostparm; -with Opt; use Opt; -with Output; use Output; -with Sdefault; use Sdefault; -with Table; -with Targparm; use Targparm; - package body Osint is Running_Program : Program_Type := Unspecified; @@ -538,7 +541,11 @@ package body Osint is end loop; end if; - if not Opt.No_Stdlib and not Opt.RTS_Switch then + -- Even when -nostdlib is used, we still want to have visibility on + -- the run-time object directory, as it is used by gnatbind to find + -- the run-time ALI files in "real" ZFP set up. + + if not Opt.RTS_Switch then Search_Path := Read_Default_Search_Dirs (String_Access (Update_Path (Search_Dir_Prefix)), diff --git a/gcc/ada/osint.ads b/gcc/ada/osint.ads index ae827ba286b..a1d9d05d4c4 100644 --- a/gcc/ada/osint.ads +++ b/gcc/ada/osint.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,19 +29,23 @@ with Namet; use Namet; with Types; use Types; -with System.Storage_Elements; -with System.OS_Lib; use System.OS_Lib; with System; use System; +pragma Warnings (Off); +-- This package is used also by gnatcoll +with System.OS_Lib; use System.OS_Lib; +pragma Warnings (On); + +with System.Storage_Elements; + pragma Elaborate_All (System.OS_Lib); -- For the call to function Get_Target_Object_Suffix in the private part package Osint is Multi_Unit_Index_Character : Character := '~'; - -- The character before the index of the unit in a multi-unit source, in - -- ALI and object file names. This is not a constant, because it is changed - -- to '$' on VMS. + -- The character before the index of the unit in a multi-unit source in ALI + -- and object file names. Changed to '$' on VMS. Ada_Include_Path : constant String := "ADA_INCLUDE_PATH"; Ada_Objects_Path : constant String := "ADA_OBJECTS_PATH"; @@ -80,7 +84,7 @@ package Osint is Get_File_Names_Case_Sensitive /= 0; -- Set to indicate whether the operating system convention is for file -- names to be case sensitive (e.g., in Unix, set True), or non case - -- sensitive (e.g., in OS/2, set False). + -- sensitive (e.g., in Windows, set False). procedure Canonical_Case_File_Name (S : in out String); -- Given a file name, converts it to canonical case form. For systems diff --git a/gcc/ada/output.adb b/gcc/ada/output.adb index 141c12fb294..8210d3f258f 100644 --- a/gcc/ada/output.adb +++ b/gcc/ada/output.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,8 +29,6 @@ -- -- ------------------------------------------------------------------------------ -with System.OS_Lib; use System.OS_Lib; - package body Output is Current_FD : File_Descriptor := Standout; @@ -228,17 +226,26 @@ package body Output is Special_Output_Proc := P; end Set_Special_Output; - ------------------------ - -- Set_Standard_Error -- - ------------------------ + ---------------- + -- Set_Output -- + ---------------- - procedure Set_Standard_Error is + procedure Set_Output (FD : File_Descriptor) is begin if Special_Output_Proc = null then Flush_Buffer; end if; - Current_FD := Standerr; + Current_FD := FD; + end Set_Output; + + ------------------------ + -- Set_Standard_Error -- + ------------------------ + + procedure Set_Standard_Error is + begin + Set_Output (Standerr); end Set_Standard_Error; ------------------------- @@ -247,11 +254,7 @@ package body Output is procedure Set_Standard_Output is begin - if Special_Output_Proc = null then - Flush_Buffer; - end if; - - Current_FD := Standout; + Set_Output (Standout); end Set_Standard_Output; ------- diff --git a/gcc/ada/output.ads b/gcc/ada/output.ads index 7f13dc24b15..ddc395448d3 100644 --- a/gcc/ada/output.ads +++ b/gcc/ada/output.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,42 +29,46 @@ -- -- ------------------------------------------------------------------------------ --- This package contains low level output routines used by the compiler --- for writing error messages and informational output. It is also used --- by the debug source file output routines (see Sprintf.Print_Eol). +-- This package contains low level output routines used by the compiler for +-- writing error messages and informational output. It is also used by the +-- debug source file output routines (see Sprint.Print_Debug_Line). with Hostparm; use Hostparm; with Types; use Types; +pragma Warnings (Off); +-- This package is used also by gnatcoll +with System.OS_Lib; use System.OS_Lib; +pragma Warnings (On); + package Output is pragma Elaborate_Body; type Output_Proc is access procedure (S : String); - -- This type is used for the Set_Special_Output procedure. If this - -- procedure is called, then instead of lines being written to - -- standard error or standard output, a call is made to the given - -- procedure for each line, passing the line with an end of line - -- character (which is a single ASCII.LF character, even in systems - -- which normally use CR/LF or some other sequence for line end). + -- This type is used for the Set_Special_Output procedure. If Output_Proc + -- is called, then instead of lines being written to standard error or + -- standard output, a call is made to the given procedure for each line, + -- passing the line with an end of line character (which is a single + -- ASCII.LF character, even in systems which normally use CR/LF or some + -- other sequence for line end). ----------------- -- Subprograms -- ----------------- procedure Set_Special_Output (P : Output_Proc); - -- Sets subsequent output to call procedure P. If P is null, then - -- the call cancels the effect of a previous call, reverting the - -- output to standard error or standard output depending on the - -- mode at the time of previous call. Any exception generated by - -- by calls to P is simply propagated to the caller of the routine - -- causing the write operation. + -- Sets subsequent output to call procedure P. If P is null, then the call + -- cancels the effect of a previous call, reverting the output to standard + -- error or standard output depending on the mode at the time of previous + -- call. Any exception generated by by calls to P is simply propagated to + -- the caller of the routine causing the write operation. procedure Cancel_Special_Output; - -- Cancels the effect of a call to Set_Special_Output, if any. - -- The output is then directed to standard error or standard output - -- depending on the last call to Set_Standard_Error or Set_Standard_Output. - -- It is never an error to call Cancel_Special_Output. It has the same - -- effect as calling Set_Special_Output (null). + -- Cancels the effect of a call to Set_Special_Output, if any. The output + -- is then directed to standard error or standard output depending on the + -- last call to Set_Standard_Error or Set_Standard_Output. It is never an + -- error to call Cancel_Special_Output. It has the same effect as calling + -- Set_Special_Output (null). procedure Ignore_Output (S : String); -- Does nothing. To disable output, pass Ignore_Output'Access to @@ -79,11 +83,17 @@ package Output is procedure Set_Standard_Output; -- Sets subsequent output to appear on the standard output file (whatever - -- that might mean for the host operating system, if anything) when - -- no special output is in effect. When a special output is in effect, - -- the output will appear on standard output only after special output - -- has been cancelled. Output to standard output is the default mode - -- before any call to either of the Set procedures. + -- that might mean for the host operating system, if anything) when no + -- special output is in effect. When a special output is in effect, the + -- output will appear on standard output only after special output has been + -- cancelled. Output to standard output is the default mode before any call + -- to either of the Set procedures. + + procedure Set_Output (FD : File_Descriptor); + -- Sets subsequent output to appear on the given file descriptor when no + -- special output is in effect. When a special output is in effect, the + -- output will appear on the given file descriptor only after special + -- output has been cancelled. procedure Indent; -- Increases the current indentation level. Whenever a line is written @@ -101,36 +111,36 @@ package Output is -- If last character in buffer matches C, erase it, otherwise no effect procedure Write_Eol; - -- Write an end of line (whatever is required by the system in use, - -- e.g. CR/LF for DOS, or LF for Unix) to the standard output file. - -- This routine also empties the line buffer, actually writing it - -- to the file. Note that Write_Eol is the only routine that causes - -- any actual output to be written. Trailing spaces are removed. + -- Write an end of line (whatever is required by the system in use, e.g. + -- CR/LF for DOS, or LF for Unix) to the standard output file. This routine + -- also empties the line buffer, actually writing it to the file. Note that + -- Write_Eol is the only routine that causes any actual output to be + -- written. Trailing spaces are removed. procedure Write_Eol_Keep_Blanks; -- Similar as Write_Eol, except that trailing spaces are not removed procedure Write_Int (Val : Int); - -- Write an integer value with no leading blanks or zeroes. Negative - -- values are preceded by a minus sign). + -- Write an integer value with no leading blanks or zeroes. Negative values + -- are preceded by a minus sign). procedure Write_Spaces (N : Nat); -- Write N spaces procedure Write_Str (S : String); -- Write a string of characters to the standard output file. Note that - -- end of line is normally handled separately using WRITE_EOL, but it - -- is allowed for the string to contain LF (but not CR) characters, - -- which are properly interpreted as end of line characters. The string - -- may also contain horizontal tab characters. + -- end of line is normally handled separately using WRITE_EOL, but it is + -- allowable for the string to contain LF (but not CR) characters, which + -- are properly interpreted as end of line characters. The string may also + -- contain horizontal tab characters. procedure Write_Line (S : String); -- Equivalent to Write_Str (S) followed by Write_Eol; function Column return Pos; pragma Inline (Column); - -- Returns the number of the column about to be written (e.g. a value - -- of 1 means the current line is empty). + -- Returns the number of the column about to be written (e.g. a value of 1 + -- means the current line is empty). ------------------------- -- Buffer Save/Restore -- diff --git a/gcc/ada/par-ch10.adb b/gcc/ada/par-ch10.adb index 23cb1cd444c..e321affbfb9 100644 --- a/gcc/ada/par-ch10.adb +++ b/gcc/ada/par-ch10.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -344,7 +344,8 @@ package body Ch10 is Get_Expected_Unit_Type (File_Name (Current_Source_File)) = Expect_Body then - Error_Msg_BC ("keyword BODY expected here [see file name]"); + Error_Msg_BC -- CODEFIX + ("keyword BODY expected here [see file name]"); Restore_Scan_State (Scan_State); Set_Unit (Comp_Unit_Node, P_Package (Pf_Pbod)); else @@ -395,7 +396,8 @@ package body Ch10 is -- Otherwise we saved the semicolon position, so complain else - Error_Msg (""";"" should be IS", SIS_Semicolon_Sloc); + Error_Msg -- CODEFIX + (""";"" should be IS", SIS_Semicolon_Sloc); end if; Body_Node := Unit (Comp_Unit_Node); @@ -836,7 +838,8 @@ package body Ch10 is end if; if Token /= Tok_With then - Error_Msg_SC ("unexpected LIMITED ignored"); + Error_Msg_SC -- CODEFIX + ("unexpected LIMITED ignored"); end if; if Ada_Version < Ada_05 then @@ -876,8 +879,7 @@ package body Ch10 is -- WITH TYPE is an obsolete GNAT specific extension - Error_Msg_SP - ("`WITH TYPE` is an obsolete 'G'N'A'T extension"); + Error_Msg_SP ("`WITH TYPE` is an obsolete 'G'N'A'T extension"); Error_Msg_SP ("\use Ada 2005 `LIMITED WITH` clause instead"); Scan; -- past TYPE @@ -1028,7 +1030,11 @@ package body Ch10 is Ignore (Tok_Semicolon); - if Token = Tok_Function or else Token = Tok_Procedure then + if Token = Tok_Function + or else Token = Tok_Not + or else Token = Tok_Overriding + or else Token = Tok_Procedure + then Body_Node := P_Subprogram (Pf_Pbod); elsif Token = Tok_Package then diff --git a/gcc/ada/par-ch11.adb b/gcc/ada/par-ch11.adb index 14129bc6230..62887237aa8 100644 --- a/gcc/ada/par-ch11.adb +++ b/gcc/ada/par-ch11.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -119,7 +119,8 @@ package body Ch11 is Set_Choice_Parameter (Handler_Node, Choice_Param_Node); elsif Token = Tok_Others then - Error_Msg_AP ("missing "":"""); + Error_Msg_AP -- CODEFIX + ("missing "":"""); Change_Identifier_To_Defining_Identifier (Choice_Param_Node); Set_Choice_Parameter (Handler_Node, Choice_Param_Node); diff --git a/gcc/ada/par-ch12.adb b/gcc/ada/par-ch12.adb index 046ac43e775..642c05a331b 100644 --- a/gcc/ada/par-ch12.adb +++ b/gcc/ada/par-ch12.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -346,7 +346,7 @@ package body Ch12 is Scan; -- past OTHERS if Token /= Tok_Arrow then - Error_Msg_BC ("expect arrow after others"); + Error_Msg_BC ("expect arrow after others"); else Scan; -- past arrow end if; @@ -912,7 +912,8 @@ package body Ch12 is Scan; if Token = Tok_Private then - Error_Msg_SC ("TAGGED should be WITH"); + Error_Msg_SC -- CODEFIX + ("TAGGED should be WITH"); Set_Private_Present (Def_Node, True); T_Private; else diff --git a/gcc/ada/par-ch2.adb b/gcc/ada/par-ch2.adb index e96c3794f99..def8ef5c521 100644 --- a/gcc/ada/par-ch2.adb +++ b/gcc/ada/par-ch2.adb @@ -503,7 +503,9 @@ package body Ch2 is if Identifier_Seen and not Id_Present then Error_Msg_SC - ("|pragma argument identifier required here (RM 2.8(4))"); + ("|pragma argument identifier required here"); + Error_Msg_SC + ("\since previous argument had identifier (RM 2.8(4))"); end if; if Id_Present then diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index 1b2683379e3..d1bc039b969 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -111,7 +111,6 @@ package body Ch3 is -- current token, and if this is the first such message issued, saves -- the message id in Missing_Begin_Msg, for possible later replacement. - --------------------------------- -- Check_Restricted_Expression -- --------------------------------- @@ -126,9 +125,7 @@ package body Ch3 is and then Paren_Count (N) = 0 then Error_Msg_N - ("|this expression must be parenthesized!", N); - Error_Msg_N - ("\|since extensions (and set notation) are allowed", N); + ("|this expression must be parenthesized in Ada 2012 mode!", N); end if; end Check_Restricted_Expression; @@ -385,7 +382,8 @@ package body Ch3 is Scan; -- past = used in place of IS elsif Token = Tok_Renames then - Error_Msg_SC ("RENAMES should be IS"); + Error_Msg_SC -- CODEFIX + ("RENAMES should be IS"); Scan; -- past RENAMES used in place of IS else @@ -972,7 +970,8 @@ package body Ch3 is TF_Is; if Token = Tok_New then - Error_Msg_SC ("NEW ignored (only allowed in type declaration)"); + Error_Msg_SC -- CODEFIX + ("NEW ignored (only allowed in type declaration)"); Scan; -- past NEW end if; @@ -1358,8 +1357,9 @@ package body Ch3 is procedure No_List is begin if Num_Idents > 1 then - Error_Msg ("identifier list not allowed for RENAMES", - Sloc (Idents (2))); + Error_Msg + ("identifier list not allowed for RENAMES", + Sloc (Idents (2))); end if; List_OK := False; @@ -1379,7 +1379,8 @@ package body Ch3 is Check_Misspelling_Of (Tok_Renames); if Token = Tok_Renames then - Error_Msg_SP ("|extra "":"" ignored"); + Error_Msg_SP -- CODEFIX + ("|extra "":"" ignored"); Scan; -- past RENAMES return True; else @@ -1750,9 +1751,10 @@ package body Ch3 is -- illegal if Token_Is_Renames then - Error_Msg_N ("constraint not allowed in object renaming " - & "declaration", - Constraint (Object_Definition (Decl_Node))); + Error_Msg_N + ("constraint not allowed in object renaming " + & "declaration", + Constraint (Object_Definition (Decl_Node))); raise Error_Resync; end if; end if; @@ -1981,8 +1983,7 @@ package body Ch3 is T_With; -- past WITH or give error message if Token = Tok_Limited then - Error_Msg_SC - ("LIMITED keyword not allowed in private extension"); + Error_Msg_SC ("LIMITED keyword not allowed in private extension"); Scan; -- ignore LIMITED end if; @@ -2107,7 +2108,6 @@ package body Ch3 is Range_Node : Node_Id; Save_Loc : Source_Ptr; - -- Start of processing for P_Range_Or_Subtype_Mark begin @@ -2170,6 +2170,11 @@ package body Ch3 is return Expr_Node; end if; + -- Simple expression case + + elsif Expr_Form = EF_Simple and then Allow_Simple_Expression then + return Expr_Node; + -- Here we have some kind of error situation. Check for junk parens -- then return what we have, caller will deal with other errors. @@ -3434,8 +3439,7 @@ package body Ch3 is Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present); if Token = Tok_Array then - Error_Msg_SC - ("anonymous arrays not allowed as components"); + Error_Msg_SC ("anonymous arrays not allowed as components"); raise Error_Resync; end if; @@ -3514,7 +3518,8 @@ package body Ch3 is Error_Msg ("discriminant name expected", Sloc (Case_Node)); elsif Paren_Count (Case_Node) /= 0 then - Error_Msg ("|discriminant name may not be parenthesized", + Error_Msg + ("|discriminant name may not be parenthesized", Sloc (Case_Node)); Set_Paren_Count (Case_Node, 0); end if; @@ -3657,10 +3662,10 @@ package body Ch3 is -- Expression else - -- If extensions are permitted then the expression must be a - -- simple expression. The resaon for this restriction (i.e. - -- going back to the Ada 83 rule) is to avoid ambiguities - -- when set membership operations are allowed, consider the + -- In Ada 2012 mode, the expression must be a simple + -- expression. The resaon for this restriction (i.e. going + -- back to the Ada 83 rule) is to avoid ambiguities when set + -- membership operations are allowed, consider the -- following: -- when A in 1 .. 10 | 12 => @@ -3673,12 +3678,12 @@ package body Ch3 is -- when (A in 1 .. 10 | 12) => -- when (A in 1 .. 10) | 12 => - -- To solve this, if extensins are enabled, we disallow + -- To solve this, in Ada 2012 mode, we disallow -- the use of membership operations in expressions in -- choices. Technically in the grammar, the expression -- must match the grammar for restricted expression. - if Extensions_Allowed then + if Ada_Version >= Ada_12 then Check_Restricted_Expression (Expr_Node); -- In Ada 83 mode, the syntax required a simple expression @@ -3698,7 +3703,8 @@ package body Ch3 is end if; if Token = Tok_Comma then - Error_Msg_SC (""","" should be ""'|"""); + Error_Msg_SC -- CODEFIX + (""","" should be ""'|"""); else exit when Token /= Tok_Vertical_Bar; end if; @@ -3745,8 +3751,9 @@ package body Ch3 is end if; if Abstract_Present then - Error_Msg_SP ("ABSTRACT not allowed in interface type definition " & - "(RM 3.9.4(2/2))"); + Error_Msg_SP + ("ABSTRACT not allowed in interface type definition " & + "(RM 3.9.4(2/2))"); end if; Scan; -- past INTERFACE @@ -4284,7 +4291,8 @@ package body Ch3 is -- Otherwise we saved the semicolon position, so complain else - Error_Msg ("|"";"" should be IS", SIS_Semicolon_Sloc); + Error_Msg -- CODEFIX + ("|"";"" should be IS", SIS_Semicolon_Sloc); end if; -- The next job is to fix up any declarations that occurred @@ -4519,14 +4527,12 @@ package body Ch3 is Kind = N_Task_Body or else Kind = N_Protected_Body then - Error_Msg - ("proper body not allowed in package spec", Sloc (Decl)); + Error_Msg ("proper body not allowed in package spec", Sloc (Decl)); -- Test for body stub scanned, not acceptable as basic decl item elsif Kind in N_Body_Stub then - Error_Msg - ("body stub not allowed in package spec", Sloc (Decl)); + Error_Msg ("body stub not allowed in package spec", Sloc (Decl)); elsif Kind = N_Assignment_Statement then Error_Msg diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 2bb9d25fcc1..d90b413d952 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -63,6 +63,7 @@ package body Ch4 is function P_Aggregate_Or_Paren_Expr return Node_Id; function P_Allocator return Node_Id; + function P_Case_Expression_Alternative return Node_Id; function P_Record_Or_Array_Component_Association return Node_Id; function P_Factor return Node_Id; function P_Primary return Node_Id; @@ -436,7 +437,7 @@ package body Ch4 is elsif Token = Tok_Access then Attr_Name := Name_Access; - elsif Token = Tok_Mod and then Ada_Version = Ada_05 then + elsif Token = Tok_Mod and then Ada_Version >= Ada_95 then Attr_Name := Name_Mod; elsif Apostrophe_Should_Be_Semicolon then @@ -565,8 +566,7 @@ package body Ch4 is elsif Token = Tok_Range then if Expr_Form /= EF_Simple_Name then - Error_Msg_SC -- CODEFIX??? - ("subtype mark must precede RANGE"); + Error_Msg_SC ("subtype mark must precede RANGE"); raise Error_Resync; end if; @@ -1164,6 +1164,13 @@ package body Ch4 is T_Right_Paren; return Expr_Node; + -- Case expression case + + elsif Token = Tok_Case then + Expr_Node := P_Case_Expression; + T_Right_Paren; + return Expr_Node; + -- Note: the mechanism used here of rescanning the initial expression -- is distinctly unpleasant, but it saves a lot of fiddling in scanning -- out the discrete choice list. @@ -1332,7 +1339,7 @@ package body Ch4 is or else Token = Tok_Semicolon then if Present (Assoc_List) then - Error_Msg_BC + Error_Msg_BC -- CODEFIX ("""='>"" expected (positional association cannot follow " & "named association)"); end if; @@ -1570,12 +1577,14 @@ package body Ch4 is end P_Expression; -- This function is identical to the normal P_Expression, except that it - -- also permits the appearence of a conditional expression without the - -- usual surrounding parentheses. + -- also permits the appearence of a case of conditional expression without + -- the usual surrounding parentheses. function P_Expression_If_OK return Node_Id is begin - if Token = Tok_If then + if Token = Tok_Case then + return P_Case_Expression; + elsif Token = Tok_If then return P_Conditional_Expression; else return P_Expression; @@ -1672,11 +1681,13 @@ package body Ch4 is end if; end P_Expression_Or_Range_Attribute; - -- Version that allows a non-parenthesized conditional expression + -- Version that allows a non-parenthesized case or conditional expression function P_Expression_Or_Range_Attribute_If_OK return Node_Id is begin - if Token = Tok_If then + if Token = Tok_Case then + return P_Case_Expression; + elsif Token = Tok_If then return P_Conditional_Expression; else return P_Expression_Or_Range_Attribute; @@ -2339,9 +2350,9 @@ package body Ch4 is return Error; -- If this looks like a conditional expression, then treat it - -- that way with an error messasge. + -- that way with an error message. - elsif Extensions_Allowed then + elsif Ada_Version >= Ada_12 then Error_Msg_SC ("conditional expression must be parenthesized"); return P_Conditional_Expression; @@ -2352,6 +2363,31 @@ package body Ch4 is return P_Identifier; end if; + -- Deal with CASE (possible unparenthesized case expression) + + when Tok_Case => + + -- If this looks like a real case, defined as a CASE appearing + -- the start of a new line, then we consider we have a missing + -- operand. + + if Token_Is_At_Start_Of_Line then + Error_Msg_AP ("missing operand"); + return Error; + + -- If this looks like a case expression, then treat it that way + -- with an error message. + + elsif Ada_Version >= Ada_12 then + Error_Msg_SC ("case expression must be parenthesized"); + return P_Case_Expression; + + -- Otherwise treat as misused identifier + + else + return P_Identifier; + end if; + -- Anything else is illegal as the first token of a primary, but -- we test for a reserved identifier so that it is treated nicely @@ -2360,7 +2396,8 @@ package body Ch4 is return P_Identifier; elsif Prev_Token = Tok_Comma then - Error_Msg_SP ("|extra "","" ignored"); + Error_Msg_SP -- CODEFIX + ("|extra "","" ignored"); raise Error_Resync; else @@ -2458,7 +2495,8 @@ package body Ch4 is begin if Token = Tok_Box then - Error_Msg_SC ("|""'<'>"" should be ""/="""); + Error_Msg_SC -- CODEFIX + ("|""'<'>"" should be ""/="""); end if; Op_Kind := Relop_Node (Token); @@ -2620,6 +2658,94 @@ package body Ch4 is return Alloc_Node; end P_Allocator; + ----------------------- + -- P_Case_Expression -- + ----------------------- + + function P_Case_Expression return Node_Id is + Loc : constant Source_Ptr := Token_Ptr; + Case_Node : Node_Id; + Save_State : Saved_Scan_State; + + begin + if Ada_Version < Ada_12 then + Error_Msg_SC ("|case expression is an Ada 2012 feature"); + Error_Msg_SC ("\|use -gnat12 switch to compile this unit"); + end if; + + Scan; -- past CASE + Case_Node := + Make_Case_Expression (Loc, + Expression => P_Expression_No_Right_Paren, + Alternatives => New_List); + T_Is; + + -- We now have scanned out CASE expression IS, scan alternatives + + loop + T_When; + Append_To (Alternatives (Case_Node), P_Case_Expression_Alternative); + + -- Missing comma if WHEN (more alternatives present) + + if Token = Tok_When then + T_Comma; + + -- If comma/WHEN, skip comma and we have another alternative + + elsif Token = Tok_Comma then + Save_Scan_State (Save_State); + Scan; -- past comma + + if Token /= Tok_When then + Restore_Scan_State (Save_State); + exit; + end if; + + -- If no comma or WHEN, definitely done + + else + exit; + end if; + end loop; + + -- If we have an END CASE, diagnose as not needed + + if Token = Tok_End then + Error_Msg_SC ("`END CASE` not allowed at end of case expression"); + Scan; -- past END + + if Token = Tok_Case then + Scan; -- past CASE; + end if; + end if; + + -- Return the Case_Expression node + + return Case_Node; + end P_Case_Expression; + + ----------------------------------- + -- P_Case_Expression_Alternative -- + ----------------------------------- + + -- CASE_STATEMENT_ALTERNATIVE ::= + -- when DISCRETE_CHOICE_LIST => + -- EXPRESSION + + -- The caller has checked that and scanned past the initial WHEN token + -- Error recovery: can raise Error_Resync + + function P_Case_Expression_Alternative return Node_Id is + Case_Alt_Node : Node_Id; + begin + Case_Alt_Node := New_Node (N_Case_Expression_Alternative, Token_Ptr); + Set_Discrete_Choices (Case_Alt_Node, P_Discrete_Choice_List); + TF_Arrow; + Set_Expression (Case_Alt_Node, P_Expression); + return Case_Alt_Node; + end P_Case_Expression_Alternative; + ------------------------------ -- P_Conditional_Expression -- ------------------------------ @@ -2633,9 +2759,9 @@ package body Ch4 is begin Inside_Conditional_Expression := Inside_Conditional_Expression + 1; - if Token = Tok_If and then not Extensions_Allowed then - Error_Msg_SC ("|conditional expression is an Ada extension"); - Error_Msg_SC ("\|use -gnatX switch to compile this unit"); + if Token = Tok_If and then Ada_Version < Ada_12 then + Error_Msg_SC ("|conditional expression is an Ada 2012 feature"); + Error_Msg_SC ("\|use -gnat12 switch to compile this unit"); end if; Scan; -- past IF or ELSIF @@ -2652,7 +2778,8 @@ package body Ch4 is Scan; -- past semicolon if Token = Tok_Else or else Token = Tok_Elsif then - Error_Msg_SP ("|extra "";"" ignored"); + Error_Msg_SP -- CODEFIX + ("|extra "";"" ignored"); else Restore_Scan_State (State); @@ -2709,15 +2836,15 @@ package body Ch4 is procedure P_Membership_Test (N : Node_Id) is Alt : constant Node_Id := P_Range_Or_Subtype_Mark - (Allow_Simple_Expression => Extensions_Allowed); + (Allow_Simple_Expression => (Ada_Version >= Ada_12)); begin -- Set case if Token = Tok_Vertical_Bar then - if not Extensions_Allowed then - Error_Msg_SC ("set notation is a language extension"); - Error_Msg_SC ("\|use -gnatX switch to compile this unit"); + if Ada_Version < Ada_12 then + Error_Msg_SC ("set notation is an Ada 2012 feature"); + Error_Msg_SC ("\|use -gnat12 switch to compile this unit"); end if; Set_Alternatives (N, New_List (Alt)); diff --git a/gcc/ada/par-ch5.adb b/gcc/ada/par-ch5.adb index f782f51e024..ec1bcebb8fe 100644 --- a/gcc/ada/par-ch5.adb +++ b/gcc/ada/par-ch5.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -193,7 +193,8 @@ package body Ch5 is procedure Test_Statement_Required is begin if Statement_Required then - Error_Msg_BC ("statement expected"); + Error_Msg_BC -- CODEFIX + ("statement expected"); end if; end Test_Statement_Required; @@ -607,7 +608,8 @@ package body Ch5 is or else Nkind (Name_Node) = N_Selected_Component) then - Error_Msg_SC ("""/"" should be ""."""); + Error_Msg_SC -- CODEFIX + ("""/"" should be ""."""); Statement_Required := False; raise Error_Resync; @@ -857,7 +859,8 @@ package body Ch5 is Junk_Declaration; else - Error_Msg_BC ("statement expected"); + Error_Msg_BC -- CODEFIX + ("statement expected"); raise Error_Resync; end if; end case; @@ -1172,7 +1175,8 @@ package body Ch5 is -- of WHEN expression => if Token = Tok_Arrow then - Error_Msg_SC ("THEN expected"); + Error_Msg_SC -- CODEFIX + ("THEN expected"); Scan; -- past the arrow Pop_Scope_Stack; -- remove unneeded entry raise Error_Resync; @@ -1208,7 +1212,8 @@ package body Ch5 is Scan; -- past ELSE if Else_Should_Be_Elsif then - Error_Msg_SP ("ELSE should be ELSIF"); + Error_Msg_SP -- CODEFIX + ("ELSE should be ELSIF"); Add_Elsif_Part; else @@ -1258,7 +1263,8 @@ package body Ch5 is if Token = Tok_Colon_Equal then while Token = Tok_Colon_Equal loop - Error_Msg_SC (""":="" should be ""="""); + Error_Msg_SC -- CODEFIX + (""":="" should be ""="""); Scan; -- past junk := Discard_Junk_Node (P_Expression_No_Right_Paren); end loop; @@ -2196,7 +2202,8 @@ package body Ch5 is -- What we are interested in is whether it was a case of a bad IS. if Scope.Table (Scope.Last + 1).Etyp = E_Bad_Is then - Error_Msg ("|IS should be "";""", Scope.Table (Scope.Last + 1).S_Is); + Error_Msg -- CODEFIX + ("|IS should be "";""", Scope.Table (Scope.Last + 1).S_Is); Set_Bad_Is_Detected (Parent, True); end if; @@ -2225,7 +2232,8 @@ package body Ch5 is TF_Then; while Token = Tok_Then loop - Error_Msg_SC ("redundant THEN"); + Error_Msg_SC -- CODEFIX + ("redundant THEN"); TF_Then; end loop; diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index ea5df6dfb3b..fc9a3741366 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -64,7 +64,8 @@ package body Ch6 is if Token = Tok_Return then Restore_Scan_State (Scan_State); - Error_Msg_SC ("|extra "";"" ignored"); + Error_Msg_SC -- CODEFIX + ("|extra "";"" ignored"); Scan; -- rescan past junk semicolon else Restore_Scan_State (Scan_State); @@ -195,7 +196,8 @@ package body Ch6 is Not_Overriding := True; else - Error_Msg_SC ("OVERRIDING expected!"); + Error_Msg_SC -- CODEFIX + ("OVERRIDING expected!"); end if; -- Ada 2005: scan leading OVERRIDING indicator @@ -215,14 +217,17 @@ package body Ch6 is -- already been given, so no need to give another message here. -- An overriding indicator is allowed for subprogram declarations, - -- bodies, renamings, stubs, and instantiations. The test against - -- Pf_Decl_Pbod is added to account for the case of subprograms - -- declared in a protected type, where only subprogram declarations - -- and bodies can occur. + -- bodies (including subunits), renamings, stubs, and + -- instantiations. The test against Pf_Decl_Pbod is added to account + -- for the case of subprograms declared in a protected type, where + -- only subprogram declarations and bodies can occur. The Pf_Pbod + -- case is for subunits. if Pf_Flags /= Pf_Decl_Gins_Pbod_Rnam_Stub and then Pf_Flags /= Pf_Decl_Pbod + and then + Pf_Flags /= Pf_Pbod then Error_Msg_SC ("overriding indicator not allowed here!"); @@ -345,7 +350,8 @@ package body Ch6 is if Token = Tok_Return then if not Func then - Error_Msg ("PROCEDURE should be FUNCTION", Fproc_Sloc); + Error_Msg -- CODEFIX + ("PROCEDURE should be FUNCTION", Fproc_Sloc); Func := True; end if; @@ -418,7 +424,8 @@ package body Ch6 is Scan; -- past semicolon if Token = Tok_Is then - Error_Msg_SP ("extra "";"" ignored"); + Error_Msg_SP -- CODEFIX + ("extra "";"" ignored"); else Restore_Scan_State (Scan_State); end if; @@ -437,7 +444,8 @@ package body Ch6 is -- semicolon, and go process the body. if Token = Tok_Is then - Error_Msg_SP ("|extra "";"" ignored"); + Error_Msg_SP -- CODEFIX + ("|extra "";"" ignored"); T_Is; -- scan past IS goto Subprogram_Body; @@ -449,7 +457,8 @@ package body Ch6 is elsif Token = Tok_Begin and then Start_Column >= Scope.Table (Scope.Last).Ecol then - Error_Msg_SP ("|"";"" should be IS!"); + Error_Msg_SP -- CODEFIX + ("|"";"" should be IS!"); goto Subprogram_Body; else @@ -489,7 +498,8 @@ package body Ch6 is -- Deal nicely with (now obsolete) use of <> in place of abstract if Token = Tok_Box then - Error_Msg_SC ("ABSTRACT expected"); + Error_Msg_SC -- CODEFIX + ("ABSTRACT expected"); Token := Tok_Abstract; end if; @@ -553,7 +563,8 @@ package body Ch6 is -- semicolon which should really be an IS else - Error_Msg_AP ("|missing "";"""); + Error_Msg_AP -- CODEFIX + ("|missing "";"""); SIS_Missing_Semicolon_Message := Get_Msg_Id; goto Subprogram_Declaration; end if; @@ -1216,7 +1227,8 @@ package body Ch6 is -- that semicolon should have been a right parenthesis and exit if Token = Tok_Is or else Token = Tok_Return then - Error_Msg_SP ("|"";"" should be "")"""); + Error_Msg_SP -- CODEFIX + ("|"";"" should be "")"""); exit Specification_Loop; end if; @@ -1224,7 +1236,8 @@ package body Ch6 is -- assume we had a missing right parenthesis and terminate list if Token in Token_Class_Declk then - Error_Msg_AP ("missing "")"""); + Error_Msg_AP -- CODEFIX + ("missing "")"""); Restore_Scan_State (Scan_State); exit Specification_Loop; end if; @@ -1287,7 +1300,8 @@ package body Ch6 is Set_In_Present (Node, True); if Style.Mode_In_Check and then Token /= Tok_Out then - Error_Msg_SP ("(style) IN should be omitted"); + Error_Msg_SP -- CODEFIX + ("(style) IN should be omitted"); end if; if Token = Tok_Access then @@ -1302,8 +1316,7 @@ package body Ch6 is end if; if Token = Tok_In then - Error_Msg_SC -- CODEFIX ??? - ("IN must precede OUT in parameter mode"); + Error_Msg_SC ("IN must precede OUT in parameter mode"); Scan; -- past IN Set_In_Present (Node, True); end if; diff --git a/gcc/ada/par-ch7.adb b/gcc/ada/par-ch7.adb index 3b24c8792b8..d4d168de7bc 100644 --- a/gcc/ada/par-ch7.adb +++ b/gcc/ada/par-ch7.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -69,10 +69,10 @@ package body Ch7 is -- Pf_Flags.Rnam Set if renaming declaration OK -- Pf_Flags.Stub Set if body stub OK - -- If an inappropriate form is encountered, it is scanned out but an - -- error message indicating that it is appearing in an inappropriate - -- context is issued. The only possible settings for Pf_Flags are those - -- defined as constants in package Par. + -- If an inappropriate form is encountered, it is scanned out but an error + -- message indicating that it is appearing in an inappropriate context is + -- issued. The only possible settings for Pf_Flags are those defined as + -- constants in package Par. -- Note: in all contexts where a package specification is required, there -- is a terminating semicolon. This semicolon is scanned out in the case @@ -101,7 +101,8 @@ package body Ch7 is Scan; -- past PACKAGE if Token = Tok_Type then - Error_Msg_SC ("TYPE not allowed here"); + Error_Msg_SC -- CODEFIX + ("TYPE not allowed here"); Scan; -- past TYPE end if; diff --git a/gcc/ada/par-ch9.adb b/gcc/ada/par-ch9.adb index 1271d478a73..23b27c7774e 100644 --- a/gcc/ada/par-ch9.adb +++ b/gcc/ada/par-ch9.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -154,7 +154,8 @@ package body Ch9 is Scan; -- past semicolon if Token = Tok_Entry then - Error_Msg_SP ("|"";"" should be IS"); + Error_Msg_SP -- CODEFIX + ("|"";"" should be IS"); Set_Task_Definition (Task_Node, P_Task_Definition); else Pop_Scope_Stack; -- Remove unused entry @@ -181,13 +182,14 @@ package body Ch9 is end loop; if Token /= Tok_With then - Error_Msg_SC ("WITH expected"); + Error_Msg_SC -- CODEFIX + ("WITH expected"); end if; Scan; -- past WITH if Token = Tok_Private then - Error_Msg_SP + Error_Msg_SP -- CODEFIX ("PRIVATE not allowed in task type declaration"); end if; end if; @@ -454,7 +456,8 @@ package body Ch9 is if Token /= Tok_Is then Restore_Scan_State (Scan_State); - Error_Msg_SC ("missing IS"); + Error_Msg_SC -- CODEFIX + ("missing IS"); Set_Protected_Definition (Protected_Node, Make_Protected_Definition (Token_Ptr, Visible_Declarations => Empty_List, @@ -466,7 +469,8 @@ package body Ch9 is return Protected_Node; end if; - Error_Msg_SP ("|extra ""("" ignored"); + Error_Msg_SP -- CODEFIX + ("|extra ""("" ignored"); end if; T_Is; @@ -492,7 +496,8 @@ package body Ch9 is end loop; if Token /= Tok_With then - Error_Msg_SC ("WITH expected"); + Error_Msg_SC -- CODEFIX + ("WITH expected"); end if; Scan; -- past WITH @@ -625,7 +630,8 @@ package body Ch9 is Scan; -- past OVERRIDING Not_Overriding := True; else - Error_Msg_SC ("OVERRIDING expected!"); + Error_Msg_SC -- CODEFIX + ("OVERRIDING expected!"); end if; else @@ -758,8 +764,7 @@ package body Ch9 is Scan; -- past PRIVATE elsif Token = Tok_Identifier then - Error_Msg_SC - ("all components must be declared in spec!"); + Error_Msg_SC ("all components must be declared in spec!"); Resync_Past_Semicolon; elsif Token in Token_Class_Declk then @@ -809,7 +814,8 @@ package body Ch9 is Scan; -- part OVERRIDING Not_Overriding := True; else - Error_Msg_SC ("OVERRIDING expected!"); + Error_Msg_SC -- CODEFIX + ("OVERRIDING expected!"); end if; elsif Token = Tok_Overriding then @@ -823,7 +829,8 @@ package body Ch9 is Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); elsif Token /= Tok_Entry then - Error_Msg_SC ("ENTRY expected!"); + Error_Msg_SC -- CODEFIX + ("ENTRY expected!"); end if; end if; @@ -1115,7 +1122,8 @@ package body Ch9 is Bnode := P_Expression_No_Right_Paren; if Token = Tok_Colon_Equal then - Error_Msg_SC ("|"":="" should be ""="""); + Error_Msg_SC -- CODEFIX + ("|"":="" should be ""="""); Scan; Bnode := P_Expression_No_Right_Paren; end if; diff --git a/gcc/ada/par-endh.adb b/gcc/ada/par-endh.adb index 94e753976aa..5b16bce00b9 100644 --- a/gcc/ada/par-endh.adb +++ b/gcc/ada/par-endh.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/par-labl.adb b/gcc/ada/par-labl.adb index 9874c4fcef9..6609a07576e 100644 --- a/gcc/ada/par-labl.adb +++ b/gcc/ada/par-labl.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -375,13 +375,21 @@ procedure Labl is and then Matches (Node (N), Node (S1)) then if not Found then - if Parent (Node (N)) = Parent (Node (S1)) then + + -- If the label and the goto are both in the same statement + -- list, then we've found a loop. Note that labels and goto + -- statements are always part of some list, so + -- List_Containing always makes sense. + + if List_Containing (Node (N)) = + List_Containing (Node (S1)) + then Source := S1; Found := True; - else - -- The goto is within some nested structure + -- The goto is within some nested structure + else No_Header (N); return; end if; diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 9b5b0ab76a3..a421592ad84 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -150,8 +150,7 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is Error_Msg_Name_2 := Name_On; Error_Msg_Name_3 := Name_Off; - Error_Msg - ("argument for pragma% must be% or%", Sloc (Argx)); + Error_Msg ("argument for pragma% must be% or%", Sloc (Argx)); raise Error_Resync; end if; end Check_Arg_Is_On_Or_Off; @@ -307,7 +306,7 @@ begin -- Ada_05/Ada_2005 -- --------------------- - -- This pragma must be processed at parse time, since we want to set + -- These pragmas must be processed at parse time, since we want to set -- the Ada version properly at parse time to recognize the appropriate -- Ada version syntax. However, it is only the zero argument form that -- must be processed at parse time. @@ -318,6 +317,18 @@ begin Ada_Version_Explicit := Ada_05; end if; + --------------------- + -- Ada_12/Ada_2012 -- + --------------------- + + -- These pragmas must be processed at parse time, since we want to set + -- the Ada version properly at parse time to recognize the appropriate + -- Ada version syntax. + + when Pragma_Ada_12 | Pragma_Ada_2012 => + Ada_Version := Ada_12; + Ada_Version_Explicit := Ada_12; + ----------- -- Debug -- ----------- @@ -375,8 +386,10 @@ begin if Chars (Expression (Arg1)) = Name_On then Extensions_Allowed := True; + Ada_Version := Ada_12; else Extensions_Allowed := False; + Ada_Version := Ada_Version_Explicit; end if; ---------------- @@ -943,7 +956,11 @@ begin OK := False; elsif Chars (A) = Name_All_Checks then - Stylesw.Set_Default_Style_Check_Options; + if GNAT_Mode then + Stylesw.Set_GNAT_Style_Check_Options; + else + Stylesw.Set_Default_Style_Check_Options; + end if; elsif Chars (A) = Name_On then Style_Check := True; diff --git a/gcc/ada/par-tchk.adb b/gcc/ada/par-tchk.adb index 9329b41cd14..c92b20fbfe2 100644 --- a/gcc/ada/par-tchk.adb +++ b/gcc/ada/par-tchk.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -83,15 +83,18 @@ package body Tchk is -- A little recovery helper, accept then in place of => elsif Token = Tok_Then then - Error_Msg_BC ("|THEN should be ""='>"""); + Error_Msg_BC -- CODEFIX + ("|THEN should be ""='>"""); Scan; -- past THEN used in place of => elsif Token = Tok_Colon_Equal then - Error_Msg_SC ("|"":="" should be ""='>"""); + Error_Msg_SC -- CODEFIX + ("|"":="" should be ""='>"""); Scan; -- past := used in place of => else - Error_Msg_AP ("missing ""='>"""); + Error_Msg_AP -- CODEFIX + ("missing ""='>"""); end if; end T_Arrow; @@ -122,7 +125,8 @@ package body Tchk is if Token = Tok_Box then Scan; else - Error_Msg_AP ("missing ""'<'>"""); + Error_Msg_AP -- CODEFIX + ("missing ""'<'>"""); end if; end T_Box; @@ -135,7 +139,8 @@ package body Tchk is if Token = Tok_Colon then Scan; else - Error_Msg_AP ("missing "":"""); + Error_Msg_AP -- CODEFIX + ("missing "":"""); end if; end T_Colon; @@ -149,19 +154,23 @@ package body Tchk is Scan; elsif Token = Tok_Equal then - Error_Msg_SC ("|""="" should be "":="""); + Error_Msg_SC -- CODEFIX + ("|""="" should be "":="""); Scan; elsif Token = Tok_Colon then - Error_Msg_SC ("|"":"" should be "":="""); + Error_Msg_SC -- CODEFIX + ("|"":"" should be "":="""); Scan; elsif Token = Tok_Is then - Error_Msg_SC ("|IS should be "":="""); + Error_Msg_SC -- CODEFIX + ("|IS should be "":="""); Scan; else - Error_Msg_AP ("missing "":="""); + Error_Msg_AP -- CODEFIX + ("missing "":="""); end if; end T_Colon_Equal; @@ -182,7 +191,8 @@ package body Tchk is if Token = Tok_Comma then Scan; else - Error_Msg_AP ("missing "","""); + Error_Msg_AP -- CODEFIX + ("missing "","""); end if; end if; @@ -200,7 +210,8 @@ package body Tchk is if Token = Tok_Dot_Dot then Scan; else - Error_Msg_AP ("missing "".."""); + Error_Msg_AP -- CODEFIX + ("missing "".."""); end if; end T_Dot_Dot; @@ -222,7 +233,8 @@ package body Tchk is if Token = Tok_Greater_Greater then Scan; else - Error_Msg_AP ("missing ""'>'>"""); + Error_Msg_AP -- CODEFIX + ("missing ""'>'>"""); end if; end T_Greater_Greater; @@ -271,15 +283,18 @@ package body Tchk is -- Allow OF, => or = to substitute for IS with complaint elsif Token = Tok_Arrow then - Error_Msg_SC ("|""=>"" should be IS"); + Error_Msg_SC -- CODEFIX + ("|""=>"" should be IS"); Scan; -- past => elsif Token = Tok_Of then - Error_Msg_SC ("|OF should be IS"); + Error_Msg_SC -- CODEFIX + ("|OF should be IS"); Scan; -- past OF elsif Token = Tok_Equal then - Error_Msg_SC ("|""="" should be IS"); + Error_Msg_SC -- CODEFIX + ("|""="" should be IS"); Scan; -- past = else @@ -289,7 +304,8 @@ package body Tchk is -- Ignore extra IS keywords while Token = Tok_Is loop - Error_Msg_SC ("|extra IS ignored"); + Error_Msg_SC -- CODEFIX + ("|extra IS ignored"); Scan; end loop; end T_Is; @@ -303,7 +319,8 @@ package body Tchk is if Token = Tok_Left_Paren then Scan; else - Error_Msg_AP ("missing ""("""); + Error_Msg_AP -- CODEFIX + ("missing ""("""); end if; end T_Left_Paren; @@ -314,7 +331,8 @@ package body Tchk is procedure T_Loop is begin if Token = Tok_Do then - Error_Msg_SC ("LOOP expected"); + Error_Msg_SC -- CODEFIX + ("LOOP expected"); Scan; else Check_Token (Tok_Loop, AP); @@ -393,7 +411,8 @@ package body Tchk is if Token = Tok_Right_Paren then Scan; else - Error_Msg_AP ("|missing "")"""); + Error_Msg_AP -- CODEFIX + ("|missing "")"""); end if; end T_Right_Paren; @@ -408,24 +427,28 @@ package body Tchk is Scan; if Token = Tok_Semicolon then - Error_Msg_SC ("|extra "";"" ignored"); + Error_Msg_SC -- CODEFIX + ("|extra "";"" ignored"); Scan; end if; return; elsif Token = Tok_Colon then - Error_Msg_SC ("|"":"" should be "";"""); + Error_Msg_SC -- CODEFIX + ("|"":"" should be "";"""); Scan; return; elsif Token = Tok_Comma then - Error_Msg_SC ("|"","" should be "";"""); + Error_Msg_SC -- CODEFIX + ("|"","" should be "";"""); Scan; return; elsif Token = Tok_Dot then - Error_Msg_SC ("|""."" should be "";"""); + Error_Msg_SC -- CODEFIX + ("|""."" should be "";"""); Scan; return; @@ -464,7 +487,8 @@ package body Tchk is -- If none of those tests return, we really have a missing semicolon - Error_Msg_AP ("|missing "";"""); + Error_Msg_AP -- CODEFIX + ("|missing "";"""); return; end T_Semicolon; @@ -646,7 +670,8 @@ package body Tchk is Scan; -- skip RETURN and we are done else - Error_Msg_SC ("missing RETURN"); + Error_Msg_SC -- CODEFIX + ("missing RETURN"); Save_Scan_State (Scan_State); -- at start of junk tokens loop @@ -814,7 +839,8 @@ package body Tchk is if Token = Tok_Left_Paren then Scan; else - Error_Msg_AP ("missing ""(""!"); + Error_Msg_AP -- CODEFIX + ("missing ""(""!"); end if; end U_Left_Paren; @@ -827,7 +853,8 @@ package body Tchk is if Token = Tok_Right_Paren then Scan; else - Error_Msg_AP ("|missing "")""!"); + Error_Msg_AP -- CODEFIX + ("|missing "")""!"); end if; end U_Right_Paren; @@ -846,7 +873,8 @@ package body Tchk is Scan; if Token = T then - Error_Msg_SP ("|extra "";"" ignored"); + Error_Msg_SP -- CODEFIX + ("|extra "";"" ignored"); Scan; else Error_Msg_SP (M); @@ -856,7 +884,8 @@ package body Tchk is Scan; if Token = T then - Error_Msg_SP ("|extra "","" ignored"); + Error_Msg_SP -- CODEFIX + ("|extra "","" ignored"); Scan; else diff --git a/gcc/ada/par-util.adb b/gcc/ada/par-util.adb index 3672ca8145e..6a0e8efc6cb 100644 --- a/gcc/ada/par-util.adb +++ b/gcc/ada/par-util.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -72,7 +72,8 @@ package body Util is and then Name_Len = 7 and then Name_Buffer (1 .. 7) = "program" then - Error_Msg_SC ("PROCEDURE expected"); + Error_Msg_SC -- CODEFIX + ("PROCEDURE expected"); Token := T; return True; @@ -86,8 +87,7 @@ package body Util is M2 (P2 + J - 1) := Fold_Upper (S (J)); end loop; - Error_Msg_SC -- CODEFIX??? - (M2 (1 .. P2 - 1 + S'Last)); + Error_Msg_SC (M2 (1 .. P2 - 1 + S'Last)); Token := T; return True; end if; @@ -334,7 +334,8 @@ package body Util is <> Restore_Scan_State (Scan_State); - Error_Msg_SC ("|"";"" should be "","""); + Error_Msg_SC -- CODEFIX + ("|"";"" should be "","""); Scan; -- past the semicolon return True; @@ -384,26 +385,30 @@ package body Util is begin while Token = T loop if T = Tok_Comma then - Error_Msg_SC ("|extra "","" ignored"); + Error_Msg_SC -- CODEFIX + ("|extra "","" ignored"); elsif T = Tok_Left_Paren then - Error_Msg_SC ("|extra ""("" ignored"); + Error_Msg_SC -- CODEFIX + ("|extra ""("" ignored"); elsif T = Tok_Right_Paren then - Error_Msg_SC ("|extra "")"" ignored"); + Error_Msg_SC -- CODEFIX + ("|extra "")"" ignored"); elsif T = Tok_Semicolon then - Error_Msg_SC ("|extra "";"" ignored"); + Error_Msg_SC -- CODEFIX + ("|extra "";"" ignored"); elsif T = Tok_Colon then - Error_Msg_SC ("|extra "":"" ignored"); + Error_Msg_SC -- CODEFIX + ("|extra "":"" ignored"); else declare Tname : constant String := Token_Type'Image (Token); begin - Error_Msg_SC - ("|extra " & Tname (5 .. Tname'Last) & "ignored"); + Error_Msg_SC ("|extra " & Tname (5 .. Tname'Last) & "ignored"); end; end if; @@ -567,8 +572,7 @@ package body Util is end; Error_Msg_Node_1 := Prev; - Error_Msg_SC - ("unexpected identifier, possibly & was meant here"); + Error_Msg_SC ("unexpected identifier, possibly & was meant here"); Scan; end Merge_Identifier; diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 78ffd604ebd..bf3dc1e6b51 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -676,8 +676,13 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is function P_Simple_Expression return Node_Id; function P_Simple_Expression_Or_Range_Attribute return Node_Id; + function P_Case_Expression return Node_Id; + -- Scans out a case expression. Called with Token pointing to the CASE + -- keyword, and returns pointing to the terminating right parent, + -- semicolon, or comma, but does not consume this terminating token. + function P_Conditional_Expression return Node_Id; - -- Scans out a conditional expression. Called with token pointing to + -- Scans out a conditional expression. Called with Token pointing to -- the IF keyword, and returns pointing to the terminating right paren, -- semicolon or comma, but does not consume this terminating token. @@ -1182,12 +1187,12 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -------------- procedure Labl; - -- This procedure creates implicit label declarations for all label that - -- are declared in the current unit. Note that this could conceptually - -- be done at the point where the labels are declared, but it is tricky - -- to do it then, since the tree is not hooked up at the point where the - -- label is declared (e.g. a sequence of statements is not yet attached - -- to its containing scope at the point a label in the sequence is found) + -- This procedure creates implicit label declarations for all labels that + -- are declared in the current unit. Note that this could conceptually be + -- done at the point where the labels are declared, but it is tricky to do + -- it then, since the tree is not hooked up at the point where the label is + -- declared (e.g. a sequence of statements is not yet attached to its + -- containing scope at the point a label in the sequence is found). -------------- -- Par.Load -- diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb index 82ab9d651a0..7dbaf93af89 100644 --- a/gcc/ada/par_sco.adb +++ b/gcc/ada/par_sco.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -63,13 +63,14 @@ package body Par_SCO is Table_Increment => 200, Table_Name => "SCO_Unit_Number_Entry"); - -------------------------- - -- Condition Hash Table -- - -------------------------- + --------------------------------- + -- Condition/Pragma Hash Table -- + --------------------------------- -- We need to be able to get to conditions quickly for handling the calls - -- to Set_SCO_Condition efficiently. For this purpose we identify the - -- conditions in the table by their starting sloc, and use the following + -- to Set_SCO_Condition efficiently, and similarly to get to pragmas to + -- handle calls to Set_SCO_Pragma_Enabled. For this purpose we identify the + -- conditions and pragmas in the table by their starting sloc, and use this -- hash table to map from these starting sloc values to SCO_Table indexes. type Header_Num is new Integer range 0 .. 996; @@ -81,7 +82,7 @@ package body Par_SCO is function Equal (F1, F2 : Source_Ptr) return Boolean; -- Function to test two keys for equality - package Condition_Hash_Table is new Simple_HTable + package Condition_Pragma_Hash_Table is new Simple_HTable (Header_Num, Int, 0, Source_Ptr, Hash, Equal); -- The actual hash table @@ -104,8 +105,9 @@ package body Par_SCO is -- If N is Empty, has no effect. Otherwise scans the tree for the node N, -- to output any decisions it contains. T is one of IEPWX (for context of -- expresion: if/exit when/pragma/while/expression). If T is other than X, - -- then a decision is always present (at the very least a simple decision - -- is present at the top level). + -- the node N is the conditional expression involved, and a decision is + -- always present (at the very least a simple decision is present at the + -- top level). procedure Process_Decisions (L : List_Id; T : Character); -- Calls above procedure for each element of the list L @@ -119,11 +121,13 @@ package body Par_SCO is -- Append an entry to SCO_Table with fields set as per arguments procedure Traverse_Declarations_Or_Statements (L : List_Id); + procedure Traverse_Generic_Instantiation (N : Node_Id); procedure Traverse_Generic_Package_Declaration (N : Node_Id); procedure Traverse_Handled_Statement_Sequence (N : Node_Id); procedure Traverse_Package_Body (N : Node_Id); procedure Traverse_Package_Declaration (N : Node_Id); procedure Traverse_Subprogram_Body (N : Node_Id); + procedure Traverse_Subprogram_Declaration (N : Node_Id); -- Traverse the corresponding construct, generating SCO table entries procedure Write_SCOs_To_ALI_File is new Put_SCOs; @@ -299,8 +303,7 @@ package body Par_SCO is function Is_Logical_Operator (N : Node_Id) return Boolean is begin - return Nkind_In (N, N_Op_Xor, - N_Op_Not, + return Nkind_In (N, N_Op_Not, N_And_Then, N_Or_Else); end Is_Logical_Operator; @@ -327,6 +330,17 @@ package body Par_SCO is procedure Process_Decisions (N : Node_Id; T : Character) is + Mark : Nat; + -- This is used to mark the location of a decision sequence in the SCO + -- table. We use it for backing out a simple decision in an expression + -- context that contains only NOT operators. + + X_Not_Decision : Boolean; + -- This flag keeps track of whether a decision sequence in the SCO table + -- contains only NOT operators, and is for an expression context (T=X). + -- The flag will be set False if T is other than X, or if an operator + -- other than NOT is in the sequence. + function Process_Node (N : Node_Id) return Traverse_Result; -- Processes one node in the traversal, looking for logical operators, -- and if one is found, outputs the appropriate table entries. @@ -340,13 +354,15 @@ package body Par_SCO is -- Process_Decision_Operand, because we can't get decisions mixed up in -- the global table. Call has no effect if N is Empty. - procedure Output_Element (N : Node_Id; T : Character); + procedure Output_Element (N : Node_Id); -- Node N is an operand of a logical operator that is not itself a -- logical operator, or it is a simple decision. This routine outputs - -- the table entry for the element, with C1 set to T (' ' for one of - -- the elements of a complex decision, or 'I'/'W'/'E' for a simple - -- decision (from an IF, WHILE, or EXIT WHEN). Last is set to False, - -- and an entry is made in the condition hash table. + -- the table entry for the element, with C1 set to ' '. Last is set + -- False, and an entry is made in the condition hash table. + + procedure Output_Header (T : Character); + -- Outputs a decision header node. T is I/W/E/P for IF/WHILE/EXIT WHEN/ + -- PRAGMA, and 'X' for the expression case. procedure Process_Decision_Operand (N : Node_Id); -- This is called on node N, the top level node of a decision, or on one @@ -376,16 +392,19 @@ package body Par_SCO is else L := Left_Opnd (N); - if Nkind (N) = N_Op_Xor then - C := '^'; - elsif Nkind_In (N, N_Op_Or, N_Or_Else) then + if Nkind_In (N, N_Op_Or, N_Or_Else) then C := '|'; else C := '&'; end if; end if; - Set_Table_Entry (C, ' ', No_Location, No_Location, False); + Set_Table_Entry + (C1 => C, + C2 => ' ', + From => Sloc (N), + To => No_Location, + Last => False); Output_Decision_Operand (L); Output_Decision_Operand (Right_Opnd (N)); @@ -393,7 +412,7 @@ package body Par_SCO is -- Not a logical operator else - Output_Element (N, ' '); + Output_Element (N); end if; end Output_Decision_Operand; @@ -401,15 +420,83 @@ package body Par_SCO is -- Output_Element -- -------------------- - procedure Output_Element (N : Node_Id; T : Character) is + procedure Output_Element (N : Node_Id) is FSloc : Source_Ptr; LSloc : Source_Ptr; begin Sloc_Range (N, FSloc, LSloc); - Set_Table_Entry (T, 'c', FSloc, LSloc, False); - Condition_Hash_Table.Set (FSloc, SCO_Table.Last); + Set_Table_Entry + (C1 => ' ', + C2 => 'c', + From => FSloc, + To => LSloc, + Last => False); + Condition_Pragma_Hash_Table.Set (FSloc, SCO_Table.Last); end Output_Element; + ------------------- + -- Output_Header -- + ------------------- + + procedure Output_Header (T : Character) is + begin + case T is + when 'I' | 'E' | 'W' => + + -- For IF, EXIT, WHILE, the token SLOC can be found from + -- the SLOC of the parent of the expression. + + Set_Table_Entry + (C1 => T, + C2 => ' ', + From => Sloc (Parent (N)), + To => No_Location, + Last => False); + + when 'P' => + + -- For PRAGMA, we must get the location from the pragma node. + -- Argument N is the pragma argument, and we have to go up two + -- levels (through the pragma argument association) to get to + -- the pragma node itself. + + declare + Loc : constant Source_Ptr := Sloc (Parent (Parent (N))); + + begin + Set_Table_Entry + (C1 => 'P', + C2 => 'd', + From => Loc, + To => No_Location, + Last => False); + + -- For pragmas we also must make an entry in the hash table + -- for later access by Set_SCO_Pragma_Enabled. We set the + -- pragma as disabled above, the call will change C2 to 'e' + -- to enable the pragma header entry. + + Condition_Pragma_Hash_Table.Set (Loc, SCO_Table.Last); + end; + + when 'X' => + + -- For an expression, no Sloc + + Set_Table_Entry + (C1 => 'X', + C2 => ' ', + From => No_Location, + To => No_Location, + Last => False); + + -- No other possibilities + + when others => + raise Program_Error; + end case; + end Output_Header; + ------------------------------ -- Process_Decision_Operand -- ------------------------------ @@ -419,6 +506,7 @@ package body Par_SCO is if Is_Logical_Operator (N) then if Nkind (N) /= N_Op_Not then Process_Decision_Operand (Left_Opnd (N)); + X_Not_Decision := False; end if; Process_Decision_Operand (Right_Opnd (N)); @@ -439,9 +527,9 @@ package body Par_SCO is -- Logical operators, output table entries and then process -- operands recursively to deal with nested conditions. - when N_And_Then | - N_Or_Else | - N_Op_Not => + when N_And_Then | + N_Or_Else | + N_Op_Not => declare T : Character; @@ -458,15 +546,26 @@ package body Par_SCO is -- Output header for sequence - Set_Table_Entry (T, ' ', No_Location, No_Location, False); + X_Not_Decision := T = 'X' and then Nkind (N) = N_Op_Not; + Mark := SCO_Table.Last; + Output_Header (T); -- Output the decision Output_Decision_Operand (N); - -- Change Last in last table entry to True to mark end + -- If the decision was in an expression context (T = 'X') + -- and contained only NOT operators, then we don't output + -- it, so delete it. + + if X_Not_Decision then + SCO_Table.Set_Last (Mark); - SCO_Table.Table (SCO_Table.Last).Last := True; + -- Otherwise, set Last in last table entry to mark end + + else + SCO_Table.Table (SCO_Table.Last).Last := True; + end if; -- Process any embedded decisions @@ -474,9 +573,14 @@ package body Par_SCO is return Skip; end; + -- Case expression + + when N_Case_Expression => + return OK; -- ??? + -- Conditional expression, processed like an if statement - when N_Conditional_Expression => + when N_Conditional_Expression => declare Cond : constant Node_Id := First (Expressions (N)); Thnx : constant Node_Id := Next (Cond); @@ -508,11 +612,12 @@ package body Par_SCO is -- See if we have simple decision at outer level and if so then -- generate the decision entry for this simple decision. A simple -- decision is a boolean expression (which is not a logical operator - -- or short circuit form) appearing as the operand of an IF, WHILE - -- or EXIT WHEN construct. + -- or short circuit form) appearing as the operand of an IF, WHILE, + -- EXIT WHEN, or special PRAGMA construct. if T /= 'X' and then not Is_Logical_Operator (N) then - Output_Element (N, T); + Output_Header (T); + Output_Element (N); -- Change Last in last table entry to True to mark end of -- sequence, which is this case is only one element long. @@ -671,6 +776,9 @@ package body Par_SCO is if Nkind (Lu) = N_Subprogram_Body then Traverse_Subprogram_Body (Lu); + elsif Nkind (Lu) = N_Subprogram_Declaration then + Traverse_Subprogram_Declaration (Lu); + elsif Nkind (Lu) = N_Package_Declaration then Traverse_Package_Declaration (Lu); @@ -680,12 +788,14 @@ package body Par_SCO is elsif Nkind (Lu) = N_Generic_Package_Declaration then Traverse_Generic_Package_Declaration (Lu); - -- For anything else, the only issue is default expressions for - -- parameters, where we have to worry about possible embedded decisions - -- but nothing else. + elsif Nkind (Lu) in N_Generic_Instantiation then + Traverse_Generic_Instantiation (Lu); + + -- All other cases of compilation units (e.g. renamings), generate + -- no SCO information. else - Process_Decisions (Lu, 'X'); + null; end if; -- Make entry for new unit in unit tables, we will fill in the file @@ -704,14 +814,48 @@ package body Par_SCO is -- Set_SCO_Condition -- ----------------------- - procedure Set_SCO_Condition (First_Loc : Source_Ptr; Typ : Character) is - Index : constant Nat := Condition_Hash_Table.Get (First_Loc); + procedure Set_SCO_Condition (Cond : Node_Id; Val : Boolean) is + Orig : constant Node_Id := Original_Node (Cond); + Index : Nat; + Start : Source_Ptr; + Dummy : Source_Ptr; + + Constant_Condition_Code : constant array (Boolean) of Character := + (False => 'f', True => 't'); begin + Sloc_Range (Orig, Start, Dummy); + Index := Condition_Pragma_Hash_Table.Get (Start); + + -- The test here for zero is to deal with possible previous errors + if Index /= 0 then - SCO_Table.Table (Index).C2 := Typ; + pragma Assert (SCO_Table.Table (Index).C1 = ' '); + SCO_Table.Table (Index).C2 := Constant_Condition_Code (Val); end if; end Set_SCO_Condition; + ---------------------------- + -- Set_SCO_Pragma_Enabled -- + ---------------------------- + + procedure Set_SCO_Pragma_Enabled (Loc : Source_Ptr) is + Index : Nat; + + begin + -- Note: the reason we use the Sloc value as the key is that in the + -- generic case, the call to this procedure is made on a copy of the + -- original node, so we can't use the Node_Id value. + + Index := Condition_Pragma_Hash_Table.Get (Loc); + + -- The test here for zero is to deal with possible previous errors + + if Index /= 0 then + pragma Assert (SCO_Table.Table (Index).C1 = 'P'); + SCO_Table.Table (Index).C2 := 'e'; + end if; + end Set_SCO_Pragma_Enabled; + --------------------- -- Set_Table_Entry -- --------------------- @@ -756,34 +900,73 @@ package body Par_SCO is -- Traverse_Declarations_Or_Statements -- ----------------------------------------- + -- Tables used by Traverse_Declarations_Or_Statements for temporarily + -- holding statement and decision entries. These are declared globally + -- since they are shared by recursive calls to this procedure. + + type SC_Entry is record + From : Source_Ptr; + To : Source_Ptr; + Typ : Character; + end record; + -- Used to store a single entry in the following table, From:To represents + -- the range of entries in the CS line entry, and typ is the type, with + -- space meaning that no type letter will accompany the entry. + + package SC is new Table.Table ( + Table_Component_Type => SC_Entry, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => 1000, + Table_Increment => 200, + Table_Name => "SCO_SC"); + -- Used to store statement components for a CS entry to be output + -- as a result of the call to this procedure. SC.Last is the last + -- entry stored, so the current statement sequence is represented + -- by SC_Array (SC_First .. SC.Last), where SC_First is saved on + -- entry to each recursive call to the routine. + -- + -- Extend_Statement_Sequence adds an entry to this array, and then + -- Set_Statement_Entry clears the entries starting with SC_First, + -- copying these entries to the main SCO output table. The reason that + -- we do the temporary caching of results in this array is that we want + -- the SCO table entries for a given CS line to be contiguous, and the + -- processing may output intermediate entries such as decision entries. + + type SD_Entry is record + Nod : Node_Id; + Lst : List_Id; + Typ : Character; + end record; + -- Used to store a single entry in the following table. Nod is the node to + -- be searched for decisions for the case of Process_Decisions_Defer with a + -- node argument (with Lst set to No_List. Lst is the list to be searched + -- for decisions for the case of Process_Decisions_Defer with a List + -- argument (in which case Nod is set to Empty). + + package SD is new Table.Table ( + Table_Component_Type => SD_Entry, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => 1000, + Table_Increment => 200, + Table_Name => "SCO_SD"); + -- Used to store possible decision information. Instead of calling the + -- Process_Decisions procedures directly, we call Process_Decisions_Defer, + -- which simply stores the arguments in this table. Then when we clear + -- out a statement sequence using Set_Statement_Entry, after generating + -- the CS lines for the statements, the entries in this table result in + -- calls to Process_Decision. The reason for doing things this way is to + -- ensure that decisions are output after the CS line for the statements + -- in which the decisions occur. + procedure Traverse_Declarations_Or_Statements (L : List_Id) is N : Node_Id; Dummy : Source_Ptr; - type SC_Entry is record - From : Source_Ptr; - To : Source_Ptr; - Typ : Character; - end record; - -- Used to store a single entry in the following array - - SC_Array : array (Nat range 1 .. 10_000) of SC_Entry; - SC_Last : Nat; - -- Used to store statement components for a CS entry to be output - -- as a result of the call to this procedure. SC_Last is the last - -- entry stored, so the current statement sequence is represented - -- by SC_Array (1 .. SC_Last). Extend_Statement_Sequence adds an - -- entry to this array, and Set_Statement_Entry clears it, copying - -- the entries to the main SCO output table. The reason that we do - -- the temporary caching of results in this array is that we want - -- the SCO table entries for a given CS line to be contiguous, and - -- the processing may output intermediate entries such as decision - -- entries. Note that the limit of 10_000 here is arbitrary, but does - -- not cause any trouble, if we encounter more than 10_000 statements - -- we simply break the current CS sequence at that point, which is - -- harmless, since this is only used for back annotation and it is - -- not critical that back annotation always work in all cases. Anyway - -- exceeding 10,000 statements in a basic block is very unlikely. + SC_First : constant Nat := SC.Last + 1; + SD_First : constant Nat := SD.Last + 1; + -- Record first entries used in SC/SD at this recursive level procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character); -- Extend the current statement sequence to encompass the node N. Typ @@ -806,32 +989,69 @@ package body Par_SCO is -- called when we find a statement or declaration that generates its -- own table entry, so that we must end the current statement sequence. + procedure Process_Decisions_Defer (N : Node_Id; T : Character); + pragma Inline (Process_Decisions_Defer); + -- This routine is logically the same as Process_Decisions, except that + -- the arguments are saved in the SD table, for later processing when + -- Set_Statement_Entry is called, which goes through the saved entries + -- making the corresponding calls to Process_Decision. + + procedure Process_Decisions_Defer (L : List_Id; T : Character); + pragma Inline (Process_Decisions_Defer); + -- Same case for list arguments, deferred call to Process_Decisions + ------------------------- -- Set_Statement_Entry -- ------------------------- procedure Set_Statement_Entry is - C1 : Character; + C1 : Character; + SC_Last : constant Int := SC.Last; + SD_Last : constant Int := SD.Last; begin - if SC_Last /= 0 then - for J in 1 .. SC_Last loop - if J = 1 then - C1 := 'S'; - else - C1 := 's'; - end if; + -- Output statement entries from saved entries in SC table + for J in SC_First .. SC_Last loop + if J = SC_First then + C1 := 'S'; + else + C1 := 's'; + end if; + + declare + SCE : SC_Entry renames SC.Table (J); + begin Set_Table_Entry (C1 => C1, - C2 => SC_Array (J).Typ, - From => SC_Array (J).From, - To => SC_Array (J).To, + C2 => SCE.Typ, + From => SCE.From, + To => SCE.To, Last => (J = SC_Last)); - end loop; + end; + end loop; - SC_Last := 0; - end if; + -- Clear out used section of SC table + + SC.Set_Last (SC_First - 1); + + -- Output any embedded decisions + + for J in SD_First .. SD_Last loop + declare + SDE : SD_Entry renames SD.Table (J); + begin + if Present (SDE.Nod) then + Process_Decisions (SDE.Nod, SDE.Typ); + else + Process_Decisions (SDE.Lst, SDE.Typ); + end if; + end; + end loop; + + -- Clear out used section of SD table + + SD.Set_Last (SD_First - 1); end Set_Statement_Entry; ------------------------------- @@ -839,20 +1059,11 @@ package body Par_SCO is ------------------------------- procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character) is + F : Source_Ptr; + T : Source_Ptr; begin - -- Clear out statement sequence if array full - - if SC_Last = SC_Array'Last then - Set_Statement_Entry; - else - SC_Last := SC_Last + 1; - end if; - - -- Record new entry - - Sloc_Range - (N, SC_Array (SC_Last).From, SC_Array (SC_Last).To); - SC_Array (SC_Last).Typ := Typ; + Sloc_Range (N, F, T); + SC.Append ((F, T, Typ)); end Extend_Statement_Sequence; procedure Extend_Statement_Sequence @@ -860,27 +1071,32 @@ package body Par_SCO is To : Node_Id; Typ : Character) is + F : Source_Ptr; + T : Source_Ptr; begin - -- Clear out statement sequence if array full + Sloc_Range (From, F, Dummy); + Sloc_Range (To, Dummy, T); + SC.Append ((F, T, Typ)); + end Extend_Statement_Sequence; - if SC_Last = SC_Array'Last then - Set_Statement_Entry; - else - SC_Last := SC_Last + 1; - end if; + ----------------------------- + -- Process_Decisions_Defer -- + ----------------------------- - -- Make new entry + procedure Process_Decisions_Defer (N : Node_Id; T : Character) is + begin + SD.Append ((N, No_List, T)); + end Process_Decisions_Defer; - Sloc_Range (From, SC_Array (SC_Last).From, Dummy); - Sloc_Range (To, Dummy, SC_Array (SC_Last).To); - SC_Array (SC_Last).Typ := Typ; - end Extend_Statement_Sequence; + procedure Process_Decisions_Defer (L : List_Id; T : Character) is + begin + SD.Append ((Empty, L, T)); + end Process_Decisions_Defer; -- Start of processing for Traverse_Declarations_Or_Statements begin if Is_Non_Empty_List (L) then - SC_Last := 0; -- Loop through statements or declarations @@ -915,17 +1131,18 @@ package body Par_SCO is -- Subprogram declaration when N_Subprogram_Declaration => - Set_Statement_Entry; - Process_Decisions + Process_Decisions_Defer (Parameter_Specifications (Specification (N)), 'X'); + Set_Statement_Entry; -- Generic subprogram declaration when N_Generic_Subprogram_Declaration => - Set_Statement_Entry; - Process_Decisions (Generic_Formal_Declarations (N), 'X'); - Process_Decisions + Process_Decisions_Defer + (Generic_Formal_Declarations (N), 'X'); + Process_Decisions_Defer (Parameter_Specifications (Specification (N)), 'X'); + Set_Statement_Entry; -- Subprogram_Body @@ -940,8 +1157,8 @@ package body Par_SCO is when N_Exit_Statement => Extend_Statement_Sequence (N, ' '); + Process_Decisions_Defer (Condition (N), 'E'); Set_Statement_Entry; - Process_Decisions (Condition (N), 'E'); -- Label, which breaks the current statement sequence, but the -- label itself is not included in the next statement sequence, @@ -963,16 +1180,33 @@ package body Par_SCO is when N_If_Statement => Extend_Statement_Sequence (N, Condition (N), 'I'); + Process_Decisions_Defer (Condition (N), 'I'); Set_Statement_Entry; - Process_Decisions (Condition (N), 'I'); + + -- Now we traverse the statements in the THEN part + Traverse_Declarations_Or_Statements (Then_Statements (N)); + -- Loop through ELSIF parts if present + if Present (Elsif_Parts (N)) then declare Elif : Node_Id := First (Elsif_Parts (N)); + begin while Present (Elif) loop - Process_Decisions (Condition (Elif), 'I'); + + -- We generate a statement sequence for the + -- construct "ELSIF condition", so that we have + -- a statement for the resulting decisions. + + Extend_Statement_Sequence + (Elif, Condition (Elif), 'I'); + Process_Decisions_Defer (Condition (Elif), 'I'); + Set_Statement_Entry; + + -- Traverse the statements in the ELSIF + Traverse_Declarations_Or_Statements (Then_Statements (Elif)); Next (Elif); @@ -980,6 +1214,8 @@ package body Par_SCO is end; end if; + -- Finally traverse the ELSE statements if present + Traverse_Declarations_Or_Statements (Else_Statements (N)); -- Case statement, which breaks the current statement sequence, @@ -987,14 +1223,13 @@ package body Par_SCO is when N_Case_Statement => Extend_Statement_Sequence (N, Expression (N), 'C'); + Process_Decisions_Defer (Expression (N), 'X'); Set_Statement_Entry; - Process_Decisions (Expression (N), 'X'); -- Process case branches declare Alt : Node_Id; - begin Alt := First (Alternatives (N)); while Present (Alt) loop @@ -1017,22 +1252,17 @@ package body Par_SCO is when N_Simple_Return_Statement => Extend_Statement_Sequence (N, ' '); + Process_Decisions_Defer (Expression (N), 'X'); Set_Statement_Entry; - Process_Decisions (Expression (N), 'X'); -- Extended return statement when N_Extended_Return_Statement => - declare - Odecl : constant Node_Id := - First (Return_Object_Declarations (N)); - begin - if Present (Expression (Odecl)) then - Extend_Statement_Sequence - (N, Expression (Odecl), 'R'); - Process_Decisions (Expression (Odecl), 'X'); - end if; - end; + Extend_Statement_Sequence + (N, Last (Return_Object_Declarations (N)), 'R'); + Process_Decisions_Defer + (Return_Object_Declarations (N), 'X'); + Set_Statement_Entry; Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N)); @@ -1057,13 +1287,13 @@ package body Par_SCO is if Present (Condition (ISC)) then Extend_Statement_Sequence (N, ISC, 'W'); - Process_Decisions (Condition (ISC), 'W'); + Process_Decisions_Defer (Condition (ISC), 'W'); -- For statement else Extend_Statement_Sequence (N, ISC, 'F'); - Process_Decisions + Process_Decisions_Defer (Loop_Parameter_Specification (ISC), 'X'); end if; end; @@ -1077,42 +1307,55 @@ package body Par_SCO is when N_Pragma => Extend_Statement_Sequence (N, 'P'); - -- For pragmas Assert, Check, Precondition, and - -- Postcondition, we generate decision entries for the - -- condition only if the pragma is enabled. For now, we just - -- check Assertions_Enabled, which will be set to reflect - -- the presence of -gnata. + -- Processing depends on the kind of pragma - -- Later we should move processing of the relevant pragmas - -- to Par_Prag, and properly set the flag Pragma_Enabled at - -- parse time, so that we can check this flag instead ??? + case Pragma_Name (N) is + when Name_Assert | + Name_Check | + Name_Precondition | + Name_Postcondition => - -- For all other pragmas, we always generate decision - -- entries for any embedded expressions. + -- For Assert/Check/Precondition/Postcondition, we + -- must generate a P entry for the decision. Note that + -- this is done unconditionally at this stage. Output + -- for disabled pragmas is suppressed later on, when + -- we output the decision line in Put_SCOs. - declare - Nam : constant Name_Id := - Chars (Pragma_Identifier (N)); - Arg : Node_Id := First (Pragma_Argument_Associations (N)); - begin - case Nam is - when Name_Assert | - Name_Check | - Name_Precondition | - Name_Postcondition => + declare + Nam : constant Name_Id := + Chars (Pragma_Identifier (N)); + Arg : Node_Id := + First (Pragma_Argument_Associations (N)); + begin if Nam = Name_Check then Next (Arg); end if; - if Assertions_Enabled then - Process_Decisions (Expression (Arg), 'P'); - end if; + Process_Decisions_Defer (Expression (Arg), 'P'); + end; - when others => - Process_Decisions (N, 'X'); - end case; - end; + -- For all other pragmas, we generate decision entries + -- for any embedded expressions. + + when others => + Process_Decisions_Defer (N, 'X'); + end case; + + -- Object declaration. Ignored if Prev_Ids is set, since the + -- parser generates multiple instances of the whole declaration + -- if there is more than one identifier declared, and we only + -- want one entry in the SCO's, so we take the first, for which + -- Prev_Ids is False. + + when N_Object_Declaration => + if not Prev_Ids (N) then + Extend_Statement_Sequence (N, 'o'); + + if Has_Decision (N) then + Process_Decisions_Defer (N, 'X'); + end if; + end if; -- All other cases, which extend the current statement sequence -- but do not terminate it, even if they have nested decisions. @@ -1135,9 +1378,6 @@ package body Par_SCO is when N_Subtype_Declaration => Typ := 's'; - when N_Object_Declaration => - Typ := 'o'; - when N_Renaming_Declaration => Typ := 'r'; @@ -1154,7 +1394,7 @@ package body Par_SCO is -- Process any embedded decisions if Has_Decision (N) then - Process_Decisions (N, 'X'); + Process_Decisions_Defer (N, 'X'); end if; end case; @@ -1165,6 +1405,30 @@ package body Par_SCO is end if; end Traverse_Declarations_Or_Statements; + ------------------------------------ + -- Traverse_Generic_Instantiation -- + ------------------------------------ + + procedure Traverse_Generic_Instantiation (N : Node_Id) is + First : Source_Ptr; + Last : Source_Ptr; + + begin + -- First we need a statement entry to cover the instantiation + + Sloc_Range (N, First, Last); + Set_Table_Entry + (C1 => 'S', + C2 => ' ', + From => First, + To => Last, + Last => True); + + -- Now output any embedded decisions + + Process_Decisions (N, 'X'); + end Traverse_Generic_Instantiation; + ------------------------------------------ -- Traverse_Generic_Package_Declaration -- ------------------------------------------ @@ -1183,7 +1447,6 @@ package body Par_SCO is Handler : Node_Id; begin - -- For package bodies without a statement part, the parser adds an empty -- one, to normalize the representation. The null statement therein, -- which does not come from source, does not get a SCO. @@ -1232,4 +1495,16 @@ package body Par_SCO is Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N)); end Traverse_Subprogram_Body; + ------------------------------------- + -- Traverse_Subprogram_Declaration -- + ------------------------------------- + + procedure Traverse_Subprogram_Declaration (N : Node_Id) is + ADN : constant Node_Id := Aux_Decls_Node (Parent (N)); + begin + Traverse_Declarations_Or_Statements (Config_Pragmas (ADN)); + Traverse_Declarations_Or_Statements (Declarations (ADN)); + Traverse_Declarations_Or_Statements (Pragmas_After (ADN)); + end Traverse_Subprogram_Declaration; + end Par_SCO; diff --git a/gcc/ada/par_sco.ads b/gcc/ada/par_sco.ads index 6cb68a71441..97e4a6a61af 100644 --- a/gcc/ada/par_sco.ads +++ b/gcc/ada/par_sco.ads @@ -25,156 +25,12 @@ -- This package contains the routines used to deal with generation and output -- of Soure Coverage Obligations (SCO's) used for coverage analysis purposes. +-- See package SCOs for full documentation of format of SCO information. with Types; use Types; package Par_SCO is - ---------------- - -- SCO Format -- - ---------------- - - -- Source coverage obligations are generated on a unit-by-unit basis in the - -- ALI file, using lines that start with the identifying character C. These - -- lines are generated if the -gnatC switch is set. - - -- Sloc Ranges - - -- In several places in the SCO lines, Sloc ranges appear. These are used - -- to indicate the first and last Sloc of some construct in the tree and - -- they have the form: - - -- line:col-line:col - - -- Note that SCO's are generated only for generic templates, not for - -- generic instances (since only the first are part of the source). So - -- we don't need generic instantiation stuff in these line:col items. - - -- SCO File headers - - -- The SCO information follows the cross-reference information, so it - -- need not be read by tools like gnatbind, gnatmake etc. The SCO output - -- is divided into sections, one section for each unit for which SCO's - -- are generated. A SCO section has a header of the form: - - -- C dependency-number filename - - -- This header precedes SCO information for the unit identified by - -- dependency number and file name. The dependency number is the - -- index into the generated D lines and is ones origin (i.e. 2 = - -- reference to second generated D line). - - -- Note that the filename here will reflect the original name if - -- a Source_Reference pragma was encountered (since all line number - -- references will be with respect to the original file). - - -- Statements - - -- For the purpose of SCO generation, the notion of statement includes - -- simple statements and also the following declaration types: - - -- type_declaration - -- subtype_declaration - -- object_declaration - -- renaming_declaration - -- generic_instantiation - - -- Statement lines - - -- These lines correspond to a sequence of one or more statements which - -- are always exeecuted in sequence, The first statement may be an entry - -- point (e.g. statement after a label), and the last statement may be - -- an exit point (e.g. an exit statement), but no other entry or exit - -- points may occur within the sequence of statements. The idea is that - -- the sequence can be treated as a single unit from a coverage point of - -- view, if any of the code for the statement sequence is executed, this - -- corresponds to coverage of the entire statement sequence. The form of - -- a statement line in the ALI file is: - - -- CS sloc-range - - -- Exit points - - -- An exit point is a statement that causes transfer of control. Examples - -- are exit statements, raise statements and return statements. The form - -- of an exit point in the ALI file is: - - -- CT sloc-range - - -- Decisions - - -- Decisions represent the most significant section of the SCO lines - - -- Note: in the following description, logical operator includes the - -- short circuited forms (so can be any of AND, OR, XOR, NOT, AND THEN, - -- or OR ELSE). - - -- Decisions are either simple or complex. A simple decision is a boolean - -- expresssion that occurs in the context of a control structure in the - -- source program, including WHILE, IF, EXIT WHEN. Note that a boolean - -- expression in any other context, e.g. on the right side of an - -- assignment, is not considered to be a decision. - - -- A complex decision is an occurrence of a logical operator which is not - -- itself an operand of some other logical operator. If any operand of - -- the logical operator is itself a logical operator, this is not a - -- separate decision, it is part of the same decision. - - -- So for example, if we have - - -- A, B, C, D : Boolean; - -- function F (Arg : Boolean) return Boolean); - -- ... - -- A and then (B or else F (C and then D)) - - -- There are two (complex) decisions here: - - -- 1. X and then (Y or else Z) - - -- where X = A, Y = B, and Z = F (C and then D) - - -- 2. C and then D - - -- For each decision, a decision line is generated with the form: - - -- C* expression - - -- Here * is one of the following characters: - - -- I decision in IF statement or conditional expression - -- E decision in EXIT WHEN statement - -- W decision in WHILE iteration scheme - -- X decision appearing in some other expression context - - -- The expression is a prefix polish form indicating the structure of - -- the decision, including logical operators and short circuit forms. - -- The following is a grammar showing the structure of expression: - - -- expression ::= term (if expr is not logical operator) - -- expression ::= & term term (if expr is AND THEN) - -- expression ::= | term term (if expr is OR ELSE) - -- expression ::= !term (if expr is NOT) - - -- term ::= element - -- term ::= expression - - -- element ::= outcome sloc-range - - -- outcome is one of the following letters: - - -- c condition - -- t true condition - -- f false condition - - -- where t/f are used to mark a condition that has been recognized by - -- the compiler as always being true or false. - - -- & indicates either AND THEN connecting two conditions - - -- | indicates either OR ELSE connection two conditions - - -- ! indicates NOT applied to the expression - ----------------- -- Subprograms -- ----------------- @@ -187,11 +43,19 @@ package Par_SCO is -- internal tables recording the SCO information. Note that this is done -- before any semantic analysis/expansion happens. - procedure Set_SCO_Condition (First_Loc : Source_Ptr; Typ : Character); + procedure Set_SCO_Condition (Cond : Node_Id; Val : Boolean); -- This procedure is called during semantic analysis to record a condition - -- which has been identified as always True (Typ = 't') or always False - -- (Typ = 'f') by the compiler. The condition is identified by the - -- First_Sloc value in the original tree. + -- which has been identified as always True or always False, as indicated + -- by Val. The condition is identified by the First_Sloc value in the + -- original tree associated with Cond. + + procedure Set_SCO_Pragma_Enabled (Loc : Source_Ptr); + -- This procedure is called from Sem_Prag when a pragma is enabled (i.e. + -- when the Pragma_Enabled flag is set). Loc is the Sloc of the N_Pragma + -- node. This is used to enable the corresponding SCO table entry. Note + -- that we use the Sloc as the key here, since in the generic case, the + -- analysis is on a copy of the node, which is different from the node + -- seen by Par_SCO in the parse tree (but the Sloc values are the same). procedure SCO_Output; -- Outputs SCO lines for all units, with appropriate section headers, for @@ -199,8 +63,8 @@ package Par_SCO is -- possibly modified by calls to Set_SCO_Condition. procedure dsco; - -- Debug routine to dump SCO table. This is a raw format dump showing - -- exactly what the tables contain. + -- Debug routine to dump internal SCO table. This is a raw format dump + -- showing exactly what the table contains. procedure pscos; -- Debugging procedure to output contents of SCO binary tables in the diff --git a/gcc/ada/prep.adb b/gcc/ada/prep.adb index 9a76dc94730..2fb64cc614d 100644 --- a/gcc/ada/prep.adb +++ b/gcc/ada/prep.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -411,7 +411,8 @@ package body Prep is Scan.all; else - Error_Msg ("`)` expected", Token_Ptr); + Error_Msg -- CODEFIX + ("`)` expected", Token_Ptr); end if; when Tok_Not => @@ -906,7 +907,8 @@ package body Prep is Scan.all; if Token /= Tok_Colon_Equal then - Error_Msg ("`:=` expected", Token_Ptr); + Error_Msg -- CODEFIX + ("`:=` expected", Token_Ptr); goto Cleanup; end if; @@ -1219,7 +1221,8 @@ package body Prep is elsif Pp_States.Table (Pp_States.Last).Else_Ptr /= 0 then - Error_Msg ("duplicate ELSE line", Token_Ptr); + Error_Msg -- CODEFIX + ("duplicate ELSE line", Token_Ptr); No_Error_Found := False; end if; @@ -1269,14 +1272,16 @@ package body Prep is Scan.all; if Token /= Tok_If then - Error_Msg ("IF expected", Token_Ptr); + Error_Msg -- CODEFIX + ("IF expected", Token_Ptr); No_Error_Found := False; else Scan.all; if Token /= Tok_Semicolon then - Error_Msg ("`;` Expected", Token_Ptr); + Error_Msg -- CODEFIX + ("`;` Expected", Token_Ptr); No_Error_Found := False; else @@ -1312,13 +1317,15 @@ package body Prep is No_Error_Found := False; if Pp_States.Last = 0 then - Error_Msg ("IF expected", Token_Ptr); + Error_Msg -- CODEFIX + ("IF expected", Token_Ptr); elsif Pp_States.Table (Pp_States.Last).Else_Ptr = 0 then - Error_Msg ("IF, ELSIF, ELSE, or `END IF` expected", - Token_Ptr); + Error_Msg + ("IF, ELSIF, ELSE, or `END IF` expected", + Token_Ptr); else Error_Msg ("IF or `END IF` expected", Token_Ptr); diff --git a/gcc/ada/prepcomp.adb b/gcc/ada/prepcomp.adb index ad14fc5e164..e36d59944ca 100644 --- a/gcc/ada/prepcomp.adb +++ b/gcc/ada/prepcomp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2003-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -342,7 +342,8 @@ package body Prepcomp is while Token /= Tok_End_Of_Line and then Token /= Tok_EOF loop if Token /= Tok_Minus then - Error_Msg ("`'-` expected", Token_Ptr); + Error_Msg -- CODEFIX + ("`'-` expected", Token_Ptr); Skip_To_End_Of_Line; goto Scan_Line; end if; @@ -463,7 +464,8 @@ package body Prepcomp is Scan; if Token /= Tok_Equal then - Error_Msg ("`=` expected", Token_Ptr); + Error_Msg -- CODEFIX + ("`=` expected", Token_Ptr); Skip_To_End_Of_Line; goto Scan_Line; end if; diff --git a/gcc/ada/prj-attr.adb b/gcc/ada/prj-attr.adb index d143a504a84..2e9255c47d2 100644 --- a/gcc/ada/prj-attr.adb +++ b/gcc/ada/prj-attr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -71,7 +71,6 @@ package body Prj.Attr is "SVRproject_dir#" & "lVmain#" & "LVlanguages#" & - "SVmain_language#" & "Lbroots#" & "SVexternally_built#" & diff --git a/gcc/ada/prj-conf.adb b/gcc/ada/prj-conf.adb index dfebd9a5d49..7ffa8d52b94 100644 --- a/gcc/ada/prj-conf.adb +++ b/gcc/ada/prj-conf.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2006-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2006-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -23,23 +23,25 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Directories; use Ada.Directories; -with GNAT.HTable; use GNAT.HTable; -with Makeutl; use Makeutl; +with Hostparm; +with Makeutl; use Makeutl; with MLib.Tgt; -with Opt; use Opt; -with Output; use Output; +with Opt; use Opt; +with Output; use Output; with Prj.Env; with Prj.Err; with Prj.Part; with Prj.PP; -with Prj.Proc; use Prj.Proc; -with Prj.Tree; use Prj.Tree; -with Prj.Util; use Prj.Util; -with Prj; use Prj; -with Snames; use Snames; -with System.Case_Util; use System.Case_Util; -with System; +with Prj.Proc; use Prj.Proc; +with Prj.Tree; use Prj.Tree; +with Prj.Util; use Prj.Util; +with Prj; use Prj; +with Snames; use Snames; + +with Ada.Directories; use Ada.Directories; + +with GNAT.Case_Util; use GNAT.Case_Util; +with GNAT.HTable; use GNAT.HTable; package body Prj.Conf is @@ -889,8 +891,18 @@ package body Prj.Conf is <> if Automatically_Generated then - -- This might raise an Invalid_Config exception - Do_Autoconf; + if Hostparm.OpenVMS then + + -- There is no gprconfig on VMS + + raise Invalid_Config + with "could not locate any configuration project file"; + + else + -- This might raise an Invalid_Config exception + + Do_Autoconf; + end if; end if; -- Parse the configuration file diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb index f7fc668dd8f..39bda01987e 100644 --- a/gcc/ada/prj-env.adb +++ b/gcc/ada/prj-env.adb @@ -1498,7 +1498,9 @@ package body Prj.Env is procedure Set_Ada_Paths (Project : Project_Id; In_Tree : Project_Tree_Ref; - Including_Libraries : Boolean) + Including_Libraries : Boolean; + Include_Path : Boolean := True; + Objects_Path : Boolean := True) is Source_Paths : Source_Path_Table.Instance; @@ -1570,7 +1572,7 @@ package body Prj.Env is -- If it is the first time we call this procedure for this project, -- compute the source path and/or the object path. - if Project.Include_Path_File = No_Path then + if Include_Path and then Project.Include_Path_File = No_Path then Source_Path_Table.Init (Source_Paths); Process_Source_Dirs := True; Create_New_Path_File @@ -1580,7 +1582,7 @@ package body Prj.Env is -- For the object path, we make a distinction depending on -- Including_Libraries. - if Including_Libraries then + if Objects_Path and Including_Libraries then if Project.Objects_Path_File_With_Libs = No_Path then Object_Path_Table.Init (Object_Paths); Process_Object_Dirs := True; @@ -1588,7 +1590,7 @@ package body Prj.Env is (In_Tree, Object_FD, Project.Objects_Path_File_With_Libs); end if; - else + elsif Objects_Path then if Project.Objects_Path_File_Without_Libs = No_Path then Object_Path_Table.Init (Object_Paths); Process_Object_Dirs := True; @@ -1662,7 +1664,8 @@ package body Prj.Env is -- Set the env vars, if they need to be changed, and set the -- corresponding flags. - if In_Tree.Private_Part.Current_Source_Path_File /= + if Include_Path and then + In_Tree.Private_Part.Current_Source_Path_File /= Project.Include_Path_File then In_Tree.Private_Part.Current_Source_Path_File := @@ -1672,28 +1675,30 @@ package body Prj.Env is Get_Name_String (In_Tree.Private_Part.Current_Source_Path_File)); end if; - if Including_Libraries then - if In_Tree.Private_Part.Current_Object_Path_File /= - Project.Objects_Path_File_With_Libs - then - In_Tree.Private_Part.Current_Object_Path_File := - Project.Objects_Path_File_With_Libs; - Set_Path_File_Var - (Project_Objects_Path_File, - Get_Name_String - (In_Tree.Private_Part.Current_Object_Path_File)); - end if; + if Objects_Path then + if Including_Libraries then + if In_Tree.Private_Part.Current_Object_Path_File /= + Project.Objects_Path_File_With_Libs + then + In_Tree.Private_Part.Current_Object_Path_File := + Project.Objects_Path_File_With_Libs; + Set_Path_File_Var + (Project_Objects_Path_File, + Get_Name_String + (In_Tree.Private_Part.Current_Object_Path_File)); + end if; - else - if In_Tree.Private_Part.Current_Object_Path_File /= - Project.Objects_Path_File_Without_Libs - then - In_Tree.Private_Part.Current_Object_Path_File := - Project.Objects_Path_File_Without_Libs; - Set_Path_File_Var - (Project_Objects_Path_File, - Get_Name_String - (In_Tree.Private_Part.Current_Object_Path_File)); + else + if In_Tree.Private_Part.Current_Object_Path_File /= + Project.Objects_Path_File_Without_Libs + then + In_Tree.Private_Part.Current_Object_Path_File := + Project.Objects_Path_File_Without_Libs; + Set_Path_File_Var + (Project_Objects_Path_File, + Get_Name_String + (In_Tree.Private_Part.Current_Object_Path_File)); + end if; end if; end if; diff --git a/gcc/ada/prj-env.ads b/gcc/ada/prj-env.ads index 27259c29b98..9dcde328038 100644 --- a/gcc/ada/prj-env.ads +++ b/gcc/ada/prj-env.ads @@ -94,7 +94,9 @@ package Prj.Env is procedure Set_Ada_Paths (Project : Project_Id; In_Tree : Project_Tree_Ref; - Including_Libraries : Boolean); + Including_Libraries : Boolean; + Include_Path : Boolean := True; + Objects_Path : Boolean := True); -- Set the environment variables for additional project path files, after -- creating the path files if necessary. diff --git a/gcc/ada/prj-ext.adb b/gcc/ada/prj-ext.adb index fe6216f82fa..51da2a3e82c 100644 --- a/gcc/ada/prj-ext.adb +++ b/gcc/ada/prj-ext.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2000-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -23,7 +23,6 @@ -- -- ------------------------------------------------------------------------------ -with System.OS_Lib; use System.OS_Lib; with Hostparm; with Makeutl; use Makeutl; with Opt; diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index ca6a732ac76..b502b2aebc9 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2000-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -26,6 +26,7 @@ with GNAT.Case_Util; use GNAT.Case_Util; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.Dynamic_HTables; +with GNAT.Table; with Err_Vars; use Err_Vars; with Opt; use Opt; @@ -54,10 +55,17 @@ package body Prj.Nmsc is Name : File_Name_Type; -- ??? duplicates the key Location : Source_Ptr; Source : Source_Id := No_Source; + Listed : Boolean := False; Found : Boolean := False; end record; + No_Name_Location : constant Name_Location := - (No_File, No_Location, No_Source, False); + (Name => No_File, + Location => No_Location, + Source => No_Source, + Listed => False, + Found => False); + package Source_Names_Htable is new GNAT.Dynamic_HTables.Simple_HTable (Header_Num => Header_Num, Element => Name_Location, @@ -65,11 +73,10 @@ package body Prj.Nmsc is Key => File_Name_Type, Hash => Hash, Equal => "="); - -- Information about file names found in string list attribute - -- (Source_Files or Source_List_File). - -- Except is set to True if source is a naming exception in the project. - -- This is used to check that all referenced files were indeed found on the - -- disk. + -- File name information found in string list attribute (Source_Files or + -- Source_List_File). Except is set to True if source is a naming exception + -- in the project. Used to check that all referenced files were indeed + -- found on the disk. type Unit_Exception is record Name : Name_Id; -- ??? duplicates the key @@ -151,6 +158,20 @@ package body Prj.Nmsc is -- This data must be initialized before processing any project, and the -- same data is used for processing all projects in the tree. + type Lib_Data is record + Name : Name_Id; + Proj : Project_Id; + end record; + + package Lib_Data_Table is new GNAT.Table + (Table_Component_Type => Lib_Data, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 100); + -- A table to record library names in order to check that two library + -- projects do not have the same library names. + procedure Initialize (Data : out Tree_Processing_Data; Tree : Project_Tree_Ref; @@ -234,13 +255,9 @@ package body Prj.Nmsc is procedure Check_Package_Naming (Project : Project_Id; - Data : in out Tree_Processing_Data; - Bodies : out Array_Element_Id; - Specs : out Array_Element_Id); + Data : in out Tree_Processing_Data); -- Check the naming scheme part of Data, and initialize the naming scheme - -- data in the config of the various languages. This also returns the - -- naming scheme exceptions for unit-based languages (Bodies and Specs are - -- associative arrays mapping individual unit names to source file names). + -- data in the config of the various languages. procedure Check_Configuration (Project : Project_Id; @@ -298,6 +315,7 @@ package body Prj.Nmsc is Data : in out Tree_Processing_Data; Source_Dir_Rank : Natural; Path : Path_Name_Type; + Display_Path : Path_Name_Type; File_Name : File_Name_Type; Display_File_Name : File_Name_Type; Locally_Removed : Boolean; @@ -307,11 +325,12 @@ package body Prj.Nmsc is -- schemes, it is added to various htables through Add_Source and to -- Source_Paths_Htable. -- - -- Name is the name of the candidate file. It hasn't been normalized yet - -- and is the direct result of readdir(). + -- File_Name is the same as Display_File_Name, but has been normalized. + -- They do not include the directory information. -- - -- File_Name is the same as Name, but has been normalized. - -- Display_File_Name, however, has not been normalized. + -- Path and Display_Path on the other hand are the full path to the file. + -- Path must have been normalized (canonical casing and possibly links + -- resolved). -- -- Source_Directory is the directory in which the file was found. It is -- neither normalized nor has had links resolved, and must not end with a @@ -448,6 +467,32 @@ package body Prj.Nmsc is -- Debug print a value for a specific property. Does nothing when not in -- debug mode + procedure Error_Or_Warning + (Flags : Processing_Flags; + Kind : Error_Warning; + Msg : String; + Location : Source_Ptr; + Project : Project_Id); + -- Emits either an error or warning message (or nothing), depending on Kind + + ---------------------- + -- Error_Or_Warning -- + ---------------------- + + procedure Error_Or_Warning + (Flags : Processing_Flags; + Kind : Error_Warning; + Msg : String; + Location : Source_Ptr; + Project : Project_Id) is + begin + case Kind is + when Error => Error_Msg (Flags, Msg, Location, Project); + when Warning => Error_Msg (Flags, "?" & Msg, Location, Project); + when Silent => null; + end case; + end Error_Or_Warning; + ------------------------------ -- Replace_Into_Name_Buffer -- ------------------------------ @@ -701,7 +746,7 @@ package body Prj.Nmsc is if Current_Verbosity = High then Write_Str ("Adding source File: "); - Write_Str (Get_Name_String (File_Name)); + Write_Str (Get_Name_String (Display_File)); if Index /= 0 then Write_Str (" at" & Index'Img); @@ -725,6 +770,7 @@ package body Prj.Nmsc is end if; Id.Project := Project; + Id.Location := Location; Id.Source_Dir_Rank := Source_Dir_Rank; Id.Language := Lang_Id; Id.Kind := Kind; @@ -736,6 +782,9 @@ package body Prj.Nmsc is Id.Dep_Name := Dependency_Name (File_Name, Lang_Id.Config.Dependency_Kind); Id.Naming_Exception := Naming_Exception; + Id.Object := Object_Name + (File_Name, Config.Object_File_Suffix); + Id.Switches := Switches_Name (File_Name); -- Add the source id to the Unit_Sources_HT hash table, if the unit name -- is not null. @@ -767,11 +816,6 @@ package body Prj.Nmsc is Override_Kind (Id, Kind); end if; - if Is_Compilable (Id) and then Config.Object_Generated then - Id.Object := Object_Name (File_Name, Config.Object_File_Suffix); - Id.Switches := Switches_Name (File_Name); - end if; - if Path /= No_Path_Information then Id.Path := Path; Source_Paths_Htable.Set (Data.Tree.Source_Paths_HT, Path.Name, Id); @@ -813,11 +857,9 @@ package body Prj.Nmsc is ----------- procedure Check - (Project : Project_Id; - Data : in out Tree_Processing_Data) + (Project : Project_Id; + Data : in out Tree_Processing_Data) is - Specs : Array_Element_Id; - Bodies : Array_Element_Id; Extending : Boolean := False; Prj_Data : Project_Processing_Data; @@ -889,7 +931,7 @@ package body Prj.Nmsc is Extending := Project.Extends /= No_Project; - Check_Package_Naming (Project, Data, Bodies => Bodies, Specs => Specs); + Check_Package_Naming (Project, Data); -- Find the sources @@ -1838,6 +1880,9 @@ package body Prj.Nmsc is elsif Name = Name_Gnu then Project.Config.Resp_File_Format := GNU; + elsif Name_Buffer (1 .. Name_Len) = "gcc" then + Project.Config.Resp_File_Format := GCC; + elsif Name = Name_Object_List then Project.Config.Resp_File_Format := Object_List; @@ -2719,9 +2764,7 @@ package body Prj.Nmsc is procedure Check_Package_Naming (Project : Project_Id; - Data : in out Tree_Processing_Data; - Bodies : out Array_Element_Id; - Specs : out Array_Element_Id) + Data : in out Tree_Processing_Data) is Naming_Id : constant Package_Id := Util.Value_Of @@ -2954,7 +2997,8 @@ package body Prj.Nmsc is Kind => Kind, File_Name => File_Name, Display_File => File_Name_Type (Element.Value), - Naming_Exception => True); + Naming_Exception => True, + Location => Element.Location); else -- Check if the file name is already recorded for another @@ -3377,9 +3421,6 @@ package body Prj.Nmsc is -- Start of processing for Check_Naming_Schemes begin - Specs := No_Array_Element; - Bodies := No_Array_Element; - -- No Naming package or parsing a configuration file? nothing to do if Naming_Id /= No_Package @@ -3633,99 +3674,103 @@ package body Prj.Nmsc is "library directory { does not exist", Lib_Dir.Location, Project); + elsif not Project.Externally_Built then + -- The library directory cannot be the same as the Object -- directory. - elsif Project.Library_Dir.Name = Project.Object_Directory.Name then - Error_Msg - (Data.Flags, - "library directory cannot be the same " & - "as object directory", - Lib_Dir.Location, Project); - Project.Library_Dir := No_Path_Information; - - else - declare - OK : Boolean := True; - Dirs_Id : String_List_Id; - Dir_Elem : String_Element; - Pid : Project_List; - - begin - -- The library directory cannot be the same as a source - -- directory of the current project. - - Dirs_Id := Project.Source_Dirs; - while Dirs_Id /= Nil_String loop - Dir_Elem := Data.Tree.String_Elements.Table (Dirs_Id); - Dirs_Id := Dir_Elem.Next; - - if Project.Library_Dir.Name = - Path_Name_Type (Dir_Elem.Value) - then - Err_Vars.Error_Msg_File_1 := - File_Name_Type (Dir_Elem.Value); - Error_Msg - (Data.Flags, - "library directory cannot be the same " & - "as source directory {", - Lib_Dir.Location, Project); - OK := False; - exit; - end if; - end loop; + if Project.Library_Dir.Name = Project.Object_Directory.Name then + Error_Msg + (Data.Flags, + "library directory cannot be the same " & + "as object directory", + Lib_Dir.Location, Project); + Project.Library_Dir := No_Path_Information; - if OK then + else + declare + OK : Boolean := True; + Dirs_Id : String_List_Id; + Dir_Elem : String_Element; + Pid : Project_List; + begin -- The library directory cannot be the same as a source - -- directory of another project either. + -- directory of the current project. - Pid := Data.Tree.Projects; - Project_Loop : loop - exit Project_Loop when Pid = null; + Dirs_Id := Project.Source_Dirs; + while Dirs_Id /= Nil_String loop + Dir_Elem := Data.Tree.String_Elements.Table (Dirs_Id); + Dirs_Id := Dir_Elem.Next; - if Pid.Project /= Project then - Dirs_Id := Pid.Project.Source_Dirs; + if Project.Library_Dir.Name = + Path_Name_Type (Dir_Elem.Value) + then + Err_Vars.Error_Msg_File_1 := + File_Name_Type (Dir_Elem.Value); + Error_Msg + (Data.Flags, + "library directory cannot be the same " & + "as source directory {", + Lib_Dir.Location, Project); + OK := False; + exit; + end if; + end loop; - Dir_Loop : while Dirs_Id /= Nil_String loop - Dir_Elem := - Data.Tree.String_Elements.Table (Dirs_Id); - Dirs_Id := Dir_Elem.Next; + if OK then - if Project.Library_Dir.Name = - Path_Name_Type (Dir_Elem.Value) - then - Err_Vars.Error_Msg_File_1 := - File_Name_Type (Dir_Elem.Value); - Err_Vars.Error_Msg_Name_1 := Pid.Project.Name; + -- The library directory cannot be the same as a + -- source directory of another project either. - Error_Msg - (Data.Flags, - "library directory cannot be the same " & - "as source directory { of project %%", - Lib_Dir.Location, Project); - OK := False; - exit Project_Loop; - end if; - end loop Dir_Loop; - end if; + Pid := Data.Tree.Projects; + Project_Loop : loop + exit Project_Loop when Pid = null; - Pid := Pid.Next; - end loop Project_Loop; - end if; + if Pid.Project /= Project then + Dirs_Id := Pid.Project.Source_Dirs; + + Dir_Loop : while Dirs_Id /= Nil_String loop + Dir_Elem := + Data.Tree.String_Elements.Table (Dirs_Id); + Dirs_Id := Dir_Elem.Next; + + if Project.Library_Dir.Name = + Path_Name_Type (Dir_Elem.Value) + then + Err_Vars.Error_Msg_File_1 := + File_Name_Type (Dir_Elem.Value); + Err_Vars.Error_Msg_Name_1 := + Pid.Project.Name; + + Error_Msg + (Data.Flags, + "library directory cannot be the same" & + " as source directory { of project %%", + Lib_Dir.Location, Project); + OK := False; + exit Project_Loop; + end if; + end loop Dir_Loop; + end if; - if not OK then - Project.Library_Dir := No_Path_Information; + Pid := Pid.Next; + end loop Project_Loop; + end if; - elsif Current_Verbosity = High then + if not OK then + Project.Library_Dir := No_Path_Information; - -- Display the Library directory in high verbosity + elsif Current_Verbosity = High then - Write_Attr - ("Library directory", - Get_Name_String (Project.Library_Dir.Display_Name)); - end if; - end; + -- Display the Library directory in high verbosity + + Write_Attr + ("Library directory", + Get_Name_String (Project.Library_Dir.Display_Name)); + end if; + end; + end if; end if; end if; @@ -3813,8 +3858,9 @@ package body Prj.Nmsc is Lib_ALI_Dir.Location, Project); end if; - if Project.Library_ALI_Dir /= Project.Library_Dir then - + if (not Project.Externally_Built) and then + Project.Library_ALI_Dir /= Project.Library_Dir + then -- The library ALI directory cannot be the same as the -- Object directory. @@ -4078,9 +4124,46 @@ package body Prj.Nmsc is end; end if; - if Project.Extends /= No_Project then + if Project.Extends /= No_Project and then Project.Extends.Library then + + -- Remove the library name from Lib_Data_Table + + for J in 1 .. Lib_Data_Table.Last loop + if Lib_Data_Table.Table (J).Proj = Project.Extends then + Lib_Data_Table.Table (J) := + Lib_Data_Table.Table (Lib_Data_Table.Last); + Lib_Data_Table.Set_Last (Lib_Data_Table.Last - 1); + exit; + end if; + end loop; + Project.Extends.Library := False; end if; + + if Project.Library and then not Lib_Name.Default then + + -- Check if the same library name is used in an other library project + + for J in 1 .. Lib_Data_Table.Last loop + if Lib_Data_Table.Table (J).Name = Project.Library_Name then + Error_Msg_Name_1 := Lib_Data_Table.Table (J).Proj.Name; + Error_Msg + (Data.Flags, + "Library name cannot be the same as in project %%", + Lib_Name.Location, Project); + Project.Library := False; + exit; + end if; + end loop; + end if; + + if Project.Library then + + -- Record the library name + + Lib_Data_Table.Append + ((Name => Project.Library_Name, Proj => Project)); + end if; end Check_Library_Attributes; --------------------------------- @@ -4780,14 +4863,14 @@ package body Prj.Nmsc is --------------------- procedure Get_Directories - (Project : Project_Id; - Data : in out Tree_Processing_Data) + (Project : Project_Id; + Data : in out Tree_Processing_Data) is package Recursive_Dirs is new GNAT.Dynamic_HTables.Simple_HTable (Header_Num => Header_Num, Element => Boolean, No_Element => False, - Key => Name_Id, + Key => Path_Name_Type, Hash => Hash, Equal => "="); -- Hash table stores recursive source directories, to avoid looking @@ -4834,123 +4917,127 @@ package body Prj.Nmsc is -- Find one or several source directories, and add (or remove, if -- Removed is True) them to list of source directories of the project. - ---------------------- - -- Find_Source_Dirs -- - ---------------------- - - procedure Find_Source_Dirs - (From : File_Name_Type; - Location : Source_Ptr; - Rank : Natural; - Removed : Boolean := False) + procedure Add_To_Or_Remove_From_Source_Dirs + (Path_Id : Path_Name_Type; + Display_Path_Id : Path_Name_Type; + Rank : Natural; + Removed : Boolean); + -- When Removed = False, the directory Path_Id to the list of + -- source_dirs if not already in the list. When Removed = True, + -- removed directory Path_Id if in the list. + + --------------------------------------- + -- Add_To_Or_Remove_From_Source_Dirs -- + --------------------------------------- + + procedure Add_To_Or_Remove_From_Source_Dirs + (Path_Id : Path_Name_Type; + Display_Path_Id : Path_Name_Type; + Rank : Natural; + Removed : Boolean) is - Directory : constant String := Get_Name_String (From); + List : String_List_Id; + Prev : String_List_Id; + Rank_List : Number_List_Index; + Prev_Rank : Number_List_Index; + Element : String_Element; - procedure Add_To_Or_Remove_From_List - (Path_Id : Name_Id; - Display_Path_Id : Name_Id); - -- When Removed = False, the directory Path_Id to the list of - -- source_dirs if not already in the list. When Removed = True, - -- removed directory Path_Id if in the list. + begin + Prev := Nil_String; + Prev_Rank := No_Number_List; + List := Project.Source_Dirs; + Rank_List := Project.Source_Dir_Ranks; + while List /= Nil_String loop + Element := Data.Tree.String_Elements.Table (List); + exit when Element.Value = Name_Id (Path_Id); + Prev := List; + List := Element.Next; + Prev_Rank := Rank_List; + Rank_List := Data.Tree.Number_Lists.Table (Prev_Rank).Next; + end loop; - procedure Recursive_Find_Dirs (Path : Name_Id); - -- Find all the subdirectories (recursively) of Path and add them - -- to the list of source directories of the project. + -- The directory is in the list if List is not Nil_String - -------------------------------- - -- Add_To_Or_Remove_From_List -- - -------------------------------- - - procedure Add_To_Or_Remove_From_List - (Path_Id : Name_Id; - Display_Path_Id : Name_Id) - is - List : String_List_Id; - Prev : String_List_Id; - Rank_List : Number_List_Index; - Prev_Rank : Number_List_Index; - Element : String_Element; + if not Removed and then List = Nil_String then + if Current_Verbosity = High then + Write_Str (" Adding Source Dir="); + Write_Line (Get_Name_String (Display_Path_Id)); + end if; - begin - Prev := Nil_String; - Prev_Rank := No_Number_List; - List := Project.Source_Dirs; - Rank_List := Project.Source_Dir_Ranks; - while List /= Nil_String loop - Element := Data.Tree.String_Elements.Table (List); - exit when Element.Value = Path_Id; - Prev := List; - List := Element.Next; - Prev_Rank := Rank_List; - Rank_List := Data.Tree.Number_Lists.Table (Prev_Rank).Next; - end loop; + String_Element_Table.Increment_Last (Data.Tree.String_Elements); + Element := + (Value => Name_Id (Path_Id), + Index => 0, + Display_Value => Name_Id (Display_Path_Id), + Location => No_Location, + Flag => False, + Next => Nil_String); - -- The directory is in the list if List is not Nil_String + Number_List_Table.Increment_Last (Data.Tree.Number_Lists); - if not Removed and then List = Nil_String then - if Current_Verbosity = High then - Write_Str (" Adding Source Dir="); - Write_Line (Get_Name_String (Path_Id)); - end if; + if Last_Source_Dir = Nil_String then - String_Element_Table.Increment_Last (Data.Tree.String_Elements); - Element := - (Value => Path_Id, - Index => 0, - Display_Value => Display_Path_Id, - Location => No_Location, - Flag => False, - Next => Nil_String); + -- This is the first source directory - Number_List_Table.Increment_Last (Data.Tree.Number_Lists); + Project.Source_Dirs := + String_Element_Table.Last (Data.Tree.String_Elements); + Project.Source_Dir_Ranks := + Number_List_Table.Last (Data.Tree.Number_Lists); - if Last_Source_Dir = Nil_String then + else + -- We already have source directories, link the previous + -- last to the new one. - -- This is the first source directory + Data.Tree.String_Elements.Table (Last_Source_Dir).Next := + String_Element_Table.Last (Data.Tree.String_Elements); + Data.Tree.Number_Lists.Table (Last_Src_Dir_Rank).Next := + Number_List_Table.Last (Data.Tree.Number_Lists); + end if; - Project.Source_Dirs := - String_Element_Table.Last (Data.Tree.String_Elements); - Project.Source_Dir_Ranks := - Number_List_Table.Last (Data.Tree.Number_Lists); + -- And register this source directory as the new last - else - -- We already have source directories, link the previous - -- last to the new one. + Last_Source_Dir := + String_Element_Table.Last (Data.Tree.String_Elements); + Data.Tree.String_Elements.Table (Last_Source_Dir) := Element; + Last_Src_Dir_Rank := + Number_List_Table.Last (Data.Tree.Number_Lists); + Data.Tree.Number_Lists.Table (Last_Src_Dir_Rank) := + (Number => Rank, Next => No_Number_List); - Data.Tree.String_Elements.Table (Last_Source_Dir).Next := - String_Element_Table.Last (Data.Tree.String_Elements); - Data.Tree.Number_Lists.Table (Last_Src_Dir_Rank).Next := - Number_List_Table.Last (Data.Tree.Number_Lists); - end if; + elsif Removed and then List /= Nil_String then - -- And register this source directory as the new last + -- Remove source dir, if present - Last_Source_Dir := - String_Element_Table.Last (Data.Tree.String_Elements); - Data.Tree.String_Elements.Table (Last_Source_Dir) := Element; - Last_Src_Dir_Rank := - Number_List_Table.Last (Data.Tree.Number_Lists); - Data.Tree.Number_Lists.Table (Last_Src_Dir_Rank) := - (Number => Rank, Next => No_Number_List); + if Prev = Nil_String then + Project.Source_Dirs := + Data.Tree.String_Elements.Table (List).Next; + Project.Source_Dir_Ranks := + Data.Tree.Number_Lists.Table (Rank_List).Next; - elsif Removed and then List /= Nil_String then + else + Data.Tree.String_Elements.Table (Prev).Next := + Data.Tree.String_Elements.Table (List).Next; + Data.Tree.Number_Lists.Table (Prev_Rank).Next := + Data.Tree.Number_Lists.Table (Rank_List).Next; + end if; + end if; + end Add_To_Or_Remove_From_Source_Dirs; - -- Remove source dir, if present + ---------------------- + -- Find_Source_Dirs -- + ---------------------- - if Prev = Nil_String then - Project.Source_Dirs := - Data.Tree.String_Elements.Table (List).Next; - Project.Source_Dir_Ranks := - Data.Tree.Number_Lists.Table (Rank_List).Next; + procedure Find_Source_Dirs + (From : File_Name_Type; + Location : Source_Ptr; + Rank : Natural; + Removed : Boolean := False) + is + Directory : constant String := Get_Name_String (From); - else - Data.Tree.String_Elements.Table (Prev).Next := - Data.Tree.String_Elements.Table (List).Next; - Data.Tree.Number_Lists.Table (Prev_Rank).Next := - Data.Tree.Number_Lists.Table (Rank_List).Next; - end if; - end if; - end Add_To_Or_Remove_From_List; + procedure Recursive_Find_Dirs (Path : Name_Id); + -- Find all the subdirectories (recursively) of Path and add them + -- to the list of source directories of the project. ------------------------- -- Recursive_Find_Dirs -- @@ -4961,8 +5048,8 @@ package body Prj.Nmsc is Name : String (1 .. 250); Last : Natural; - Non_Canonical_Path : Name_Id := No_Name; - Canonical_Path : Name_Id := No_Name; + Non_Canonical_Path : Path_Name_Type := No_Path; + Canonical_Path : Path_Name_Type := No_Path; The_Path : constant String := Normalize_Pathname @@ -4981,7 +5068,8 @@ package body Prj.Nmsc is The_Path (The_Path'First .. The_Path_Last); Non_Canonical_Path := Name_Find; Canonical_Path := - Name_Id (Canonical_Case_File_Name (Non_Canonical_Path)); + Path_Name_Type + (Canonical_Case_File_Name (Name_Id (Non_Canonical_Path))); -- To avoid processing the same directory several times, check -- if the directory is already in Recursive_Dirs. If it is, then @@ -4996,9 +5084,11 @@ package body Prj.Nmsc is end if; end if; - Add_To_Or_Remove_From_List + Add_To_Or_Remove_From_Source_Dirs (Path_Id => Canonical_Path, - Display_Path_Id => Non_Canonical_Path); + Display_Path_Id => Non_Canonical_Path, + Rank => Rank, + Removed => Removed); -- Now look for subdirectories. Do that even when this directory -- is already in the list, because some of its subdirectories may @@ -5095,7 +5185,7 @@ package body Prj.Nmsc is Base_Dir : constant File_Name_Type := Name_Find; Root_Dir : constant String := Normalize_Pathname - (Name => Get_Name_String (Base_Dir), + (Name => Name_Buffer (1 .. Name_Len), Directory => Get_Name_String (Project.Directory.Display_Name), @@ -5106,18 +5196,9 @@ package body Prj.Nmsc is begin if Root_Dir'Length = 0 then Err_Vars.Error_Msg_File_1 := Base_Dir; - - if Location = No_Location then - Error_Msg - (Data.Flags, - "{ is not a valid directory.", - Project.Location, Project); - else - Error_Msg - (Data.Flags, - "{ is not a valid directory.", - Location, Project); - end if; + Error_Or_Warning + (Data.Flags, Data.Flags.Missing_Source_Files, + "{ is not a valid directory.", Location, Project); else -- We have an existing directory, we register it and all of @@ -5155,57 +5236,18 @@ package body Prj.Nmsc is if not Dir_Exists then Err_Vars.Error_Msg_File_1 := From; - - if Location = No_Location then - Error_Msg - (Data.Flags, - "{ is not a valid directory", - Project.Location, Project); - else - Error_Msg - (Data.Flags, - "{ is not a valid directory", - Location, Project); - end if; + Error_Or_Warning + (Data.Flags, Data.Flags.Missing_Source_Files, + "{ is not a valid directory", Location, Project); else - declare - Path : constant String := - Normalize_Pathname - (Name => - Get_Name_String (Path_Name.Name), - Directory => - Get_Name_String (Project.Directory.Name), - Resolve_Links => Opt.Follow_Links_For_Dirs, - Case_Sensitive => True) & - Directory_Separator; - - Last_Path : constant Natural := - Compute_Directory_Last (Path); - Path_Id : Name_Id; - Display_Path : constant String := - Get_Name_String - (Path_Name.Display_Name); - Last_Display_Path : constant Natural := - Compute_Directory_Last - (Display_Path); - Display_Path_Id : Name_Id; - - begin - Name_Len := 0; - Add_Str_To_Name_Buffer (Path (Path'First .. Last_Path)); - Path_Id := Name_Find; - - Name_Len := 0; - Add_Str_To_Name_Buffer - (Display_Path - (Display_Path'First .. Last_Display_Path)); - Display_Path_Id := Name_Find; - - Add_To_Or_Remove_From_List - (Path_Id => Path_Id, - Display_Path_Id => Display_Path_Id); - end; + -- links have been resolved if necessary, and Path_Name + -- always ends with a directory separator + Add_To_Or_Remove_From_Source_Dirs + (Path_Id => Path_Name.Name, + Display_Path_Id => Path_Name.Display_Name, + Rank => Rank, + Removed => Removed); end if; end; end if; @@ -5275,21 +5317,9 @@ package body Prj.Nmsc is Err_Vars.Error_Msg_File_1 := File_Name_Type (Object_Dir.Value); - - case Data.Flags.Require_Obj_Dirs is - when Error => - Error_Msg - (Data.Flags, - "object directory { not found", - Project.Location, Project); - when Warning => - Error_Msg - (Data.Flags, - "?object directory { not found", - Project.Location, Project); - when Silent => - null; - end case; + Error_Or_Warning + (Data.Flags, Data.Flags.Require_Obj_Dirs, + "object directory { not found", Project.Location, Project); end if; end if; @@ -5375,7 +5405,7 @@ package body Prj.Nmsc is pragma Assert (Source_Dirs.Kind = List, "Source_Dirs is not a list"); - if (not Source_Files.Default) + if not Source_Files.Default and then Source_Files.Values = Nil_String then Project.Source_Dirs := Nil_String; @@ -5388,43 +5418,14 @@ package body Prj.Nmsc is end if; elsif Source_Dirs.Default then - -- No Source_Dirs specified: the single source directory is the one -- containing the project file. - String_Element_Table.Append (Data.Tree.String_Elements, - (Value => Name_Id (Project.Directory.Name), - Display_Value => Name_Id (Project.Directory.Display_Name), - Location => No_Location, - Flag => False, - Next => Nil_String, - Index => 0)); - - Project.Source_Dirs := - String_Element_Table.Last (Data.Tree.String_Elements); - - Number_List_Table.Append - (Data.Tree.Number_Lists, - (Number => 1, Next => No_Number_List)); - - Project.Source_Dir_Ranks := - Number_List_Table.Last (Data.Tree.Number_Lists); - - if Current_Verbosity = High then - Write_Attr - ("Default source directory", - Get_Name_String (Project.Directory.Display_Name)); - end if; - - elsif Source_Dirs.Values = Nil_String then - if Project.Qualifier = Standard then - Error_Msg - (Data.Flags, - "a standard project cannot have no source directories", - Source_Dirs.Location, Project); - end if; - - Project.Source_Dirs := Nil_String; + Add_To_Or_Remove_From_Source_Dirs + (Path_Id => Project.Directory.Name, + Display_Path_Id => Project.Directory.Display_Name, + Rank => 1, + Removed => False); else declare @@ -5443,6 +5444,15 @@ package body Prj.Nmsc is (File_Name_Type (Element.Value), Element.Location, Rank); Source_Dir := Element.Next; end loop; + + if Project.Source_Dirs = Nil_String + and then Project.Qualifier = Standard + then + Error_Msg + (Data.Flags, + "a standard project cannot have no source directories", + Source_Dirs.Location, Project); + end if; end; end if; @@ -5610,7 +5620,11 @@ package body Prj.Nmsc is (Name => Source_Name, Location => Location, Source => No_Source, + Listed => True, Found => False); + + else + Name_Loc.Listed := True; end if; Source_Names_Htable.Set @@ -6242,14 +6256,14 @@ package body Prj.Nmsc is ------------------ procedure Find_Sources - (Project : in out Project_Processing_Data; - Data : in out Tree_Processing_Data) + (Project : in out Project_Processing_Data; + Data : in out Tree_Processing_Data) is Sources : constant Variable_Value := Util.Value_Of (Name_Source_Files, - Project.Project.Decl.Attributes, - Data.Tree); + Project.Project.Decl.Attributes, + Data.Tree); Source_List_File : constant Variable_Value := Util.Value_Of @@ -6345,11 +6359,16 @@ package body Prj.Nmsc is (Name => Name, Location => Location, Source => No_Source, + Listed => True, Found => False); - Source_Names_Htable.Set - (Project.Source_Names, Name, Name_Loc); + + else + Name_Loc.Listed := True; end if; + Source_Names_Htable.Set + (Project.Source_Names, Name, Name_Loc); + Current := Element.Next; end loop; @@ -6396,6 +6415,57 @@ package body Prj.Nmsc is Has_Explicit_Sources := False; end if; + -- Remove any exception that is not in the specified list of sources + + if Has_Explicit_Sources then + declare + Source : Source_Id; + Iter : Source_Iterator; + NL : Name_Location; + Again : Boolean; + begin + Iter_Loop : + loop + Again := False; + Iter := For_Each_Source (Data.Tree, Project.Project); + + Source_Loop : + loop + Source := Prj.Element (Iter); + exit Source_Loop when Source = No_Source; + + if Source.Naming_Exception then + NL := Source_Names_Htable.Get + (Project.Source_Names, Source.File); + + if NL /= No_Name_Location and then not NL.Listed then + -- Remove the exception + Source_Names_Htable.Set + (Project.Source_Names, + Source.File, + No_Name_Location); + Remove_Source (Source, No_Source); + + Error_Msg_Name_1 := Name_Id (Source.File); + Error_Msg + (Data.Flags, + "? unknown source file %%", + NL.Location, + Project.Project); + + Again := True; + exit Source_Loop; + end if; + end if; + + Next (Iter); + end loop Source_Loop; + + exit Iter_Loop when not Again; + end loop Iter_Loop; + end; + end if; + Search_Directories (Project, Data => Data, @@ -6406,6 +6476,8 @@ package body Prj.Nmsc is declare Source : Source_Id; Iter : Source_Iterator; + Found : Boolean := False; + Path : Path_Information; begin Iter := For_Each_Source (Data.Tree, Project.Project); @@ -6417,26 +6489,31 @@ package body Prj.Nmsc is and then Source.Path = No_Path_Information then if Source.Unit /= No_Unit_Index then + Found := False; -- For multi-unit source files, source_id gets duplicated -- once for every unit. Only the first source_id got its - -- full path set. So if it isn't set for that first one, - -- the file wasn't found. Otherwise we need to update for - -- units after the first one. + -- full path set. - if Source.Index = 0 - or else Source.Index = 1 - then + if Source.Index /= 0 then + Path := Files_Htable.Get + (Data.File_To_Source, Source.File).Path; + + if Path /= No_Path_Information then + Found := True; + end if; + end if; + + if not Found then Error_Msg_Name_1 := Name_Id (Source.Display_File); Error_Msg_Name_2 := Name_Id (Source.Unit.Name); - Error_Msg - (Data.Flags, + Error_Or_Warning + (Data.Flags, Data.Flags.Missing_Source_Files, "source file %% for unit %% not found", No_Location, Project.Project); else - Source.Path := Files_Htable.Get - (Data.File_To_Source, Source.File).Path; + Source.Path := Path; if Current_Verbosity = High then if Source.Path /= No_Path_Information then @@ -6444,7 +6521,7 @@ package body Prj.Nmsc is & Get_Name_String (Source.File) & " at" & Source.Index'Img & " to " - & Get_Name_String (Source.Path.Name)); + & Get_Name_String (Path.Name)); end if; end if; end if; @@ -6473,17 +6550,15 @@ package body Prj.Nmsc is while NL /= No_Name_Location loop if not NL.Found then Err_Vars.Error_Msg_File_1 := NL.Name; - if First_Error then - Error_Msg - (Data.Flags, + Error_Or_Warning + (Data.Flags, Data.Flags.Missing_Source_Files, "source file { not found", NL.Location, Project.Project); First_Error := False; - else - Error_Msg - (Data.Flags, + Error_Or_Warning + (Data.Flags, Data.Flags.Missing_Source_Files, "\source file { not found", NL.Location, Project.Project); end if; @@ -6721,15 +6796,12 @@ package body Prj.Nmsc is Data : in out Tree_Processing_Data; Source_Dir_Rank : Natural; Path : Path_Name_Type; + Display_Path : Path_Name_Type; File_Name : File_Name_Type; Display_File_Name : File_Name_Type; Locally_Removed : Boolean; For_All_Sources : Boolean) is - Canonical_Path : constant Path_Name_Type := - Path_Name_Type - (Canonical_Case_File_Name (Name_Id (Path))); - Name_Loc : Name_Location := Source_Names_Htable.Get (Project.Source_Names, File_Name); @@ -6779,11 +6851,11 @@ package body Prj.Nmsc is Check_Name := True; else - Name_Loc.Source.Path := (Canonical_Path, Path); + Name_Loc.Source.Path := (Path, Display_Path); Source_Paths_Htable.Set (Data.Tree.Source_Paths_HT, - Canonical_Path, + Path, Name_Loc.Source); -- Check if this is a subunit @@ -6792,7 +6864,7 @@ package body Prj.Nmsc is and then Name_Loc.Source.Kind = Impl then Src_Ind := Sinput.P.Load_Project_File - (Get_Name_String (Canonical_Path)); + (Get_Name_String (Path)); if Sinput.P.Source_File_Is_Subunit (Src_Ind) then Override_Kind (Name_Loc.Source, Sep); @@ -6844,7 +6916,7 @@ package body Prj.Nmsc is Display_File => Display_File_Name, Unit => Unit, Locally_Removed => Locally_Removed, - Path => (Canonical_Path, Path)); + Path => (Path, Display_Path)); -- If it is a source specified in a list, update the entry in -- the Source_Names table. @@ -6891,32 +6963,36 @@ package body Prj.Nmsc is Num_Nod := Data.Tree.Number_Lists.Table (Src_Dir_Rank); Element := Data.Tree.String_Elements.Table (Source_Dir); - if Element.Value /= No_Name then - Get_Name_String (Element.Display_Value); - - if Current_Verbosity = High then - Write_Str ("Directory: "); - Write_Str (Name_Buffer (1 .. Name_Len)); - Write_Line (Num_Nod.Number'Img); - end if; + -- Use Element.Value in this test, not Display_Value, because we + -- want the symbolic links to be resolved when appropriate. + if Element.Value /= No_Name then declare Source_Directory : constant String := - Name_Buffer (1 .. Name_Len) & - Directory_Separator; + Get_Name_String (Element.Value) + & Directory_Separator; Dir_Last : constant Natural := - Compute_Directory_Last - (Source_Directory); + Compute_Directory_Last (Source_Directory); + + Display_Source_Directory : constant String := + Get_Name_String + (Element.Display_Value) + & Directory_Separator; + -- Display_Source_Directory is to allow us to open a UTF-8 + -- encoded directory on Windows. begin if Current_Verbosity = High then - Write_Attr ("Source_Dir", Source_Directory); + Write_Attr + ("Source_Dir", + Source_Directory (Source_Directory'First .. Dir_Last)); + Write_Line (Num_Nod.Number'Img); end if; -- We look to every entry in the source directory - Open (Dir, Source_Directory); + Open (Dir, Display_Source_Directory); loop Read (Dir, Name, Last); @@ -6931,7 +7007,7 @@ package body Prj.Nmsc is if not Opt.Follow_Links_For_Files or else Is_Regular_File - (Source_Directory & Name (1 .. Last)) + (Display_Source_Directory & Name (1 .. Last)) then if Current_Verbosity = High then Write_Str (" Checking "); @@ -6961,17 +7037,24 @@ package body Prj.Nmsc is Resolve_Links => Opt.Follow_Links_For_Files, Case_Sensitive => True); - -- Case_Sensitive set True (no folding) - Path : Path_Name_Type; - FF : File_Found := Excluded_Sources_Htable.Get - (Project.Excluded, File_Name); + Path : Path_Name_Type; + FF : File_Found := + Excluded_Sources_Htable.Get + (Project.Excluded, File_Name); To_Remove : Boolean := False; begin Name_Len := Path_Name'Length; Name_Buffer (1 .. Name_Len) := Path_Name; - Path := Name_Find; + + if Osint.File_Names_Case_Sensitive then + Path := Name_Find; + else + Canonical_Case_File_Name + (Name_Buffer (1 .. Name_Len)); + Path := Name_Find; + end if; if FF /= No_File_Found then if not FF.Found then @@ -6981,7 +7064,8 @@ package body Prj.Nmsc is if Current_Verbosity = High then Write_Str (" excluded source """); - Write_Str (Get_Name_String (File_Name)); + Write_Str + (Get_Name_String (Display_File_Name)); Write_Line (""""); end if; @@ -6995,11 +7079,20 @@ package body Prj.Nmsc is end if; end if; + -- Preserve the user's original casing and use of + -- links. The display_value (a directory) already + -- ends with a directory separator by construction, + -- so no need to add one. + + Get_Name_String (Element.Display_Value); + Get_Name_String_And_Append (Display_File_Name); + Check_File (Project => Project, Source_Dir_Rank => Num_Nod.Number, Data => Data, Path => Path, + Display_Path => Name_Find, File_Name => File_Name, Locally_Removed => To_Remove, Display_File_Name => Display_File_Name, @@ -7066,8 +7159,9 @@ package body Prj.Nmsc is K => Source.File, E => Name_Location' (Name => Source.File, - Location => No_Location, + Location => Source.Location, Source => Source, + Listed => False, Found => False)); -- If this is an Ada exception, record in table Unit_Exceptions @@ -7439,7 +7533,7 @@ package body Prj.Nmsc is while Current /= Nil_String loop Element := In_Tree.String_Elements.Table (Current); Write_Str (" "); - Write_Line (Get_Name_String (Element.Value)); + Write_Line (Get_Name_String (Element.Display_Value)); Current := Element.Next; end loop; @@ -7485,9 +7579,49 @@ package body Prj.Nmsc is -- Start of processing for Process_Naming_Scheme begin + Lib_Data_Table.Init; Initialize (Data, Tree => Tree, Flags => Flags); Check_All_Projects (Root_Project, Data, Imported_First => True); Free (Data); + + -- Adjust language configs for projects that are extended + + declare + List : Project_List; + Proj : Project_Id; + Exte : Project_Id; + Lang : Language_Ptr; + Elng : Language_Ptr; + + begin + List := Tree.Projects; + while List /= null loop + Proj := List.Project; + Exte := Proj; + while Exte.Extended_By /= No_Project loop + Exte := Exte.Extended_By; + end loop; + + if Exte /= Proj then + Lang := Proj.Languages; + + if Lang /= No_Language_Index then + loop + Elng := Get_Language_From_Name + (Exte, Get_Name_String (Lang.Name)); + exit when Elng /= No_Language_Index; + Exte := Exte.Extends; + end loop; + + if Elng /= Lang then + Lang.Config := Elng.Config; + end if; + end if; + end if; + + List := List.Next; + end loop; + end; end Process_Naming_Scheme; end Prj.Nmsc; diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb index c733f38365c..b8abe571bc4 100644 --- a/gcc/ada/prj-part.adb +++ b/gcc/ada/prj-part.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -36,12 +36,11 @@ with Sinput.P; use Sinput.P; with Snames; with Table; -with Ada.Characters.Handling; use Ada.Characters.Handling; -with Ada.Exceptions; use Ada.Exceptions; +with Ada.Characters.Handling; use Ada.Characters.Handling; +with Ada.Exceptions; use Ada.Exceptions; with GNAT.Directory_Operations; use GNAT.Directory_Operations; - -with System.HTable; use System.HTable; +with GNAT.HTable; use GNAT.HTable; package body Prj.Part is @@ -98,7 +97,7 @@ package body Prj.Part is -- limited imported projects when there is a circularity with at least -- one limited imported project file. - package Virtual_Hash is new System.HTable.Simple_HTable + package Virtual_Hash is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, Element => Project_Node_Id, No_Element => Empty_Node, @@ -108,7 +107,7 @@ package body Prj.Part is -- Hash table to store the node id of the project for which a virtual -- extending project need to be created. - package Processed_Hash is new System.HTable.Simple_HTable + package Processed_Hash is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, Element => Boolean, No_Element => False, @@ -119,7 +118,7 @@ package body Prj.Part is -- need to have a virtual extending project, to avoid processing the same -- project twice. - package Projects_Paths is new System.HTable.Simple_HTable + package Projects_Paths is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, Element => Path_Name_Type, No_Element => No_Path, diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb index 49841522dc9..5859a8afe82 100644 --- a/gcc/ada/prj-proc.adb +++ b/gcc/ada/prj-proc.adb @@ -87,15 +87,15 @@ package body Prj.Proc is -- based languages) procedure Copy_Package_Declarations - (From : Declarations; - To : in out Declarations; - New_Loc : Source_Ptr; - Naming_Restricted : Boolean; - In_Tree : Project_Tree_Ref); + (From : Declarations; + To : in out Declarations; + New_Loc : Source_Ptr; + Restricted : Boolean; + In_Tree : Project_Tree_Ref); -- Copy a package declaration From to To for a renamed package. Change the - -- locations of all the attributes to New_Loc. When Naming_Restricted is - -- True, do not copy attributes Body, Spec, Implementation and - -- Specification. + -- locations of all the attributes to New_Loc. When Restricted is + -- True, do not copy attributes Body, Spec, Implementation, Specification + -- and Linker_Options. function Expression (Project : Project_Id; @@ -314,11 +314,11 @@ package body Prj.Proc is ------------------------------- procedure Copy_Package_Declarations - (From : Declarations; - To : in out Declarations; - New_Loc : Source_Ptr; - Naming_Restricted : Boolean; - In_Tree : Project_Tree_Ref) + (From : Declarations; + To : in out Declarations; + New_Loc : Source_Ptr; + Restricted : Boolean; + In_Tree : Project_Tree_Ref) is V1 : Variable_Id; V2 : Variable_Id := No_Variable; @@ -346,6 +346,12 @@ package body Prj.Proc is Var := In_Tree.Variable_Elements.Table (V1); V1 := Var.Next; + -- Do not copy the value of attribute inker_Options if Restricted + + if Restricted and then Var.Name = Snames.Name_Linker_Options then + Var.Value.Values := Nil_String; + end if; + -- Remove the Next component Var.Next := No_Variable; @@ -376,16 +382,16 @@ package body Prj.Proc is Arr := In_Tree.Arrays.Table (A1); A1 := Arr.Next; - if not Naming_Restricted or else - (Arr.Name /= Snames.Name_Body - and then Arr.Name /= Snames.Name_Spec - and then Arr.Name /= Snames.Name_Implementation - and then Arr.Name /= Snames.Name_Specification) + if not Restricted + or else + (Arr.Name /= Snames.Name_Body and then + Arr.Name /= Snames.Name_Spec and then + Arr.Name /= Snames.Name_Implementation and then + Arr.Name /= Snames.Name_Specification) then -- Remove the Next component Arr.Next := No_Array; - Array_Table.Increment_Last (In_Tree.Arrays); -- Create new Array declaration @@ -1255,9 +1261,101 @@ package body Prj.Proc is Pkg : Package_Id; Item : Project_Node_Id) is + procedure Check_Or_Set_Typed_Variable + (Value : in out Variable_Value; + Declaration : Project_Node_Id); + -- Check whether Value is valid for this typed variable declaration. If + -- it is an error, the behavior depends on the flags: either an error is + -- reported, or a warning, or nothing. In the last two cases, the value + -- of the variable is set to a valid value, replacing Value. + + --------------------------------- + -- Check_Or_Set_Typed_Variable -- + --------------------------------- + + procedure Check_Or_Set_Typed_Variable + (Value : in out Variable_Value; + Declaration : Project_Node_Id) + is + Loc : constant Source_Ptr := + Location_Of (Declaration, From_Project_Node_Tree); + + Reset_Value : Boolean := False; + Current_String : Project_Node_Id; + + begin + -- Report an error for an empty string + + if Value.Value = Empty_String then + Error_Msg_Name_1 := Name_Of (Declaration, From_Project_Node_Tree); + + case Flags.Allow_Invalid_External is + when Error => + Error_Msg (Flags, "no value defined for %%", Loc, Project); + when Warning => + Reset_Value := True; + Error_Msg (Flags, "?no value defined for %%", Loc, Project); + when Silent => + Reset_Value := True; + end case; + + else + -- Loop through all the valid strings for the + -- string type and compare to the string value. + + Current_String := + First_Literal_String + (String_Type_Of (Declaration, From_Project_Node_Tree), + From_Project_Node_Tree); + while Present (Current_String) + and then String_Value_Of + (Current_String, From_Project_Node_Tree) /= Value.Value + loop + Current_String := + Next_Literal_String (Current_String, From_Project_Node_Tree); + end loop; + + -- Report error if string value is not one for the string type + + if No (Current_String) then + Error_Msg_Name_1 := Value.Value; + Error_Msg_Name_2 := + Name_Of (Declaration, From_Project_Node_Tree); + + case Flags.Allow_Invalid_External is + when Error => + Error_Msg + (Flags, "value %% is illegal for typed string %%", + Loc, Project); + when Warning => + Error_Msg + (Flags, "?value %% is illegal for typed string %%", + Loc, Project); + Reset_Value := True; + when Silent => + Reset_Value := True; + end case; + end if; + end if; + + if Reset_Value then + Current_String := + First_Literal_String + (String_Type_Of (Declaration, From_Project_Node_Tree), + From_Project_Node_Tree); + + Value.Value := String_Value_Of + (Current_String, From_Project_Node_Tree); + end if; + end Check_Or_Set_Typed_Variable; + + -- Local variables + Current_Declarative_Item : Project_Node_Id; Current_Item : Project_Node_Id; + -- Start of processing for Process_Declarative_Items + begin -- Loop through declarative items @@ -1353,15 +1451,15 @@ package body Prj.Proc is -- renaming declaration. Copy_Package_Declarations - (From => + (From => In_Tree.Packages.Table (Renamed_Package).Decl, - To => + To => In_Tree.Packages.Table (New_Pkg).Decl, - New_Loc => + New_Loc => Location_Of (Current_Item, From_Project_Node_Tree), - Naming_Restricted => False, - In_Tree => In_Tree); + Restricted => False, + In_Tree => In_Tree); end; -- Standard package declaration, not renaming @@ -1677,7 +1775,7 @@ package body Prj.Proc is else declare - New_Value : constant Variable_Value := + New_Value : Variable_Value := Expression (Project => Project, In_Tree => In_Tree, @@ -1713,59 +1811,9 @@ package body Prj.Proc is if Kind_Of (Current_Item, From_Project_Node_Tree) = N_Typed_Variable_Declaration then - -- Report an error for an empty string - - if New_Value.Value = Empty_String then - Error_Msg_Name_1 := - Name_Of (Current_Item, From_Project_Node_Tree); - Error_Msg - (Flags, - "no value defined for %%", - Location_Of - (Current_Item, From_Project_Node_Tree), - Project); - - else - declare - Current_String : Project_Node_Id; - - begin - -- Loop through all the valid strings for the - -- string type and compare to the string value. - - Current_String := - First_Literal_String - (String_Type_Of (Current_Item, - From_Project_Node_Tree), - From_Project_Node_Tree); - while Present (Current_String) - and then - String_Value_Of - (Current_String, From_Project_Node_Tree) /= - New_Value.Value - loop - Current_String := - Next_Literal_String - (Current_String, From_Project_Node_Tree); - end loop; - - -- Report an error if the string value is not - -- one for the string type. - - if No (Current_String) then - Error_Msg_Name_1 := New_Value.Value; - Error_Msg_Name_2 := - Name_Of - (Current_Item, From_Project_Node_Tree); - Error_Msg - (Flags, - "value %% is illegal for typed string %%", - Location_Of - (Current_Item, From_Project_Node_Tree), - Project); - end if; - end; - end if; + Check_Or_Set_Typed_Variable + (Value => New_Value, + Declaration => Current_Item); end if; -- Comment here ??? @@ -2274,13 +2322,13 @@ package body Prj.Proc is Is_Extending_All (From_Project_Node, From_Project_Node_Tree) then declare - Object_Dir : constant Path_Name_Type := - Project.Object_Directory.Name; + Object_Dir : constant Path_Information := + Project.Object_Directory; begin Prj := In_Tree.Projects; while Prj /= null loop if Prj.Project.Virtual then - Prj.Project.Object_Directory.Name := Object_Dir; + Prj.Project.Object_Directory := Object_Dir; end if; Prj := Prj.Next; end loop; @@ -2579,13 +2627,12 @@ package body Prj.Proc is Next => Project.Decl.Packages); Project.Decl.Packages := Current_Pkg; Copy_Package_Declarations - (From => Element.Decl, - To => + (From => Element.Decl, + To => In_Tree.Packages.Table (Current_Pkg).Decl, - New_Loc => No_Location, - Naming_Restricted => - Element.Name = Snames.Name_Naming, - In_Tree => In_Tree); + New_Loc => No_Location, + Restricted => True, + In_Tree => In_Tree); end if; Extended_Pkg := Element.Next; diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index 0bae53c23fc..be02a417014 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -34,10 +34,9 @@ with Uintp; use Uintp; with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Unchecked_Deallocation; +with GNAT.Case_Util; use GNAT.Case_Util; with GNAT.Directory_Operations; use GNAT.Directory_Operations; - -with System.Case_Util; use System.Case_Util; -with System.HTable; +with GNAT.HTable; package body Prj is @@ -568,7 +567,7 @@ package body Prj is -- Hash -- ---------- - function Hash is new System.HTable.Hash (Header_Num => Header_Num); + function Hash is new GNAT.HTable.Hash (Header_Num => Header_Num); -- Used in implementation of other functions Hash below function Hash (Name : File_Name_Type) return Header_Num is @@ -1226,11 +1225,13 @@ package body Prj is function Create_Flags (Report_Error : Error_Handler; When_No_Sources : Error_Warning; - Require_Sources_Other_Lang : Boolean := True; - Allow_Duplicate_Basenames : Boolean := True; - Compiler_Driver_Mandatory : Boolean := False; - Error_On_Unknown_Language : Boolean := True; - Require_Obj_Dirs : Error_Warning := Error) + Require_Sources_Other_Lang : Boolean := True; + Allow_Duplicate_Basenames : Boolean := True; + Compiler_Driver_Mandatory : Boolean := False; + Error_On_Unknown_Language : Boolean := True; + Require_Obj_Dirs : Error_Warning := Error; + Allow_Invalid_External : Error_Warning := Error; + Missing_Source_Files : Error_Warning := Error) return Processing_Flags is begin @@ -1241,7 +1242,9 @@ package body Prj is Allow_Duplicate_Basenames => Allow_Duplicate_Basenames, Error_On_Unknown_Language => Error_On_Unknown_Language, Compiler_Driver_Mandatory => Compiler_Driver_Mandatory, - Require_Obj_Dirs => Require_Obj_Dirs); + Require_Obj_Dirs => Require_Obj_Dirs, + Allow_Invalid_External => Allow_Invalid_External, + Missing_Source_Files => Missing_Source_Files); end Create_Flags; ------------ diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index 353138d2daf..a6a79646a53 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -667,6 +667,10 @@ package Prj is Project : Project_Id := No_Project; -- Project of the source + Location : Source_Ptr := No_Location; + -- Location in the project file of the declaration of the source in + -- package Naming. + Source_Dir_Rank : Natural := 0; -- The rank of the source directory in list declared with attribute -- Source_Dirs. Two source files with the same name cannot appears in @@ -768,6 +772,7 @@ package Prj is No_Source_Data : constant Source_Data := (Project => No_Project, + Location => No_Location, Source_Dir_Rank => 0, Language => No_Language_Index, In_Interfaces => True, @@ -894,6 +899,7 @@ package Prj is type Response_File_Format is (None, GNU, + GCC, Object_List, Option_List); -- The format of the different response files @@ -1448,11 +1454,13 @@ package Prj is function Create_Flags (Report_Error : Error_Handler; When_No_Sources : Error_Warning; - Require_Sources_Other_Lang : Boolean := True; - Allow_Duplicate_Basenames : Boolean := True; - Compiler_Driver_Mandatory : Boolean := False; - Error_On_Unknown_Language : Boolean := True; - Require_Obj_Dirs : Error_Warning := Error) + Require_Sources_Other_Lang : Boolean := True; + Allow_Duplicate_Basenames : Boolean := True; + Compiler_Driver_Mandatory : Boolean := False; + Error_On_Unknown_Language : Boolean := True; + Require_Obj_Dirs : Error_Warning := Error; + Allow_Invalid_External : Error_Warning := Error; + Missing_Source_Files : Error_Warning := Error) return Processing_Flags; -- Function used to create Processing_Flags structure -- @@ -1481,6 +1489,15 @@ package Prj is -- If Require_Obj_Dirs is true, then all object directories must exist -- (possibly after they have been created automatically if the appropriate -- switches were specified), or an error is raised. + -- + -- If Allow_Invalid_External is Silent, then no error is reported when an + -- invalid value is used for an external variable (and it doesn't match its + -- type). Instead, the first possible value is used. + -- + -- Missing_Source_Files indicates whether it is an error or a warning that + -- a source file mentioned in the Source_Files attributes is not actually + -- found in the source directories. This also impacts errors for missing + -- source directories. Gprbuild_Flags : constant Processing_Flags; Gprclean_Flags : constant Processing_Flags; @@ -1510,6 +1527,10 @@ package Prj is -- another program running on the same machine has recreated it. -- Does nothing if Debug.Debug_Flag_N is set + Virtual_Prefix : constant String := "v$"; + -- The prefix for virtual extending projects. Because of the '$', which is + -- normally forbidden for project names, there cannot be any name clash. + private All_Packages : constant String_List_Access := null; @@ -1524,10 +1545,6 @@ private Location => No_Location, Default => False); - Virtual_Prefix : constant String := "v$"; - -- The prefix for virtual extending projects. Because of the '$', which is - -- normally forbidden for project names, there cannot be any name clash. - type Source_Iterator is record In_Tree : Project_Tree_Ref; @@ -1589,6 +1606,8 @@ private Compiler_Driver_Mandatory : Boolean; Error_On_Unknown_Language : Boolean; Require_Obj_Dirs : Error_Warning; + Allow_Invalid_External : Error_Warning; + Missing_Source_Files : Error_Warning; end record; Gprbuild_Flags : constant Processing_Flags := @@ -1598,7 +1617,9 @@ private Allow_Duplicate_Basenames => False, Compiler_Driver_Mandatory => True, Error_On_Unknown_Language => True, - Require_Obj_Dirs => Error); + Require_Obj_Dirs => Error, + Allow_Invalid_External => Error, + Missing_Source_Files => Error); Gprclean_Flags : constant Processing_Flags := (Report_Error => null, @@ -1607,7 +1628,9 @@ private Allow_Duplicate_Basenames => False, Compiler_Driver_Mandatory => True, Error_On_Unknown_Language => True, - Require_Obj_Dirs => Warning); + Require_Obj_Dirs => Warning, + Allow_Invalid_External => Error, + Missing_Source_Files => Error); Gnatmake_Flags : constant Processing_Flags := (Report_Error => null, @@ -1616,6 +1639,8 @@ private Allow_Duplicate_Basenames => False, Compiler_Driver_Mandatory => False, Error_On_Unknown_Language => False, - Require_Obj_Dirs => Error); + Require_Obj_Dirs => Error, + Allow_Invalid_External => Error, + Missing_Source_Files => Error); end Prj; diff --git a/gcc/ada/projects.texi b/gcc/ada/projects.texi new file mode 100644 index 00000000000..20fb19c8ee1 --- /dev/null +++ b/gcc/ada/projects.texi @@ -0,0 +1,3889 @@ +@set gprconfig GPRconfig + +@c ------ projects.texi +@c This file is shared between the GNAT user's guide and gprbuild. It is not +@c compilable on its own, you should instead compile the other two manuals. +@c For that reason, there is no toplevel @menu + +@c --------------------------------------------- +@node GNAT Project Manager +@chapter GNAT Project Manager +@c --------------------------------------------- + +@noindent +@menu +* Introduction:: +* Building With Projects:: +* Organizing Projects into Subsystems:: +* Scenarios in Projects:: +* Library Projects:: +* Project Extension:: +* Project File Reference:: +@end menu + +@c --------------------------------------------- +@node Introduction +@section Introduction +@c --------------------------------------------- + +@noindent +This chapter describes GNAT's @emph{Project Manager}, a facility that allows +you to manage complex builds involving a number of source files, directories, +and options for different system configurations. In particular, +project files allow you to specify: + +@itemize @bullet +@item The directory or set of directories containing the source files, and/or the + names of the specific source files themselves +@item The directory in which the compiler's output + (@file{ALI} files, object files, tree files, etc.) is to be placed +@item The directory in which the executable programs are to be placed +@item Switch settings for any of the project-enabled tools; + you can apply these settings either globally or to individual compilation units. +@item The source files containing the main subprogram(s) to be built +@item The source programming language(s) +@item Source file naming conventions; you can specify these either globally or for + individual compilation units (@pxref{Naming Schemes}). +@item Change any of the above settings depending on external values, thus enabling + the reuse of the projects in various @b{scenarios} (@pxref{Scenarios + in Projects}). +@item Automatically build libraries as part of the build process + (@pxref{Library Projects}). + +@end itemize + +@noindent +Project files are written in a syntax close to that of Ada, using familiar +notions such as packages, context clauses, declarations, default values, +assignments, and inheritance (@pxref{Project File Reference}). + +Project files can be built hierarchically from other project files, simplifying +complex system integration and project reuse (@pxref{Organizing Projects into +Subsystems}). + +@itemize @bullet +@item One project can import other projects containing needed source files. + More generally, the Project Manager lets you structure large development + efforts into hierarchical subsystems, where build decisions are delegated + to the subsystem level, and thus different compilation environments + (switch settings) used for different subsystems. +@item You can organize GNAT projects in a hierarchy: a child project + can extend a parent project, inheriting the parent's source files and + optionally overriding any of them with alternative versions + (@pxref{Project Extension}). + +@end itemize + +@noindent +Several tools support project files, generally in addition to specifying +the information on the command line itself). They share common switches +to control the loading of the project (in particular +@option{^-P^/PROJECT_FILE=^@emph{projectfile}} and +@option{^-X^/EXTERNAL_REFERENCE=^@emph{vbl}=@emph{value}}). +@xref{Switches Related to Project Files}. + +The Project Manager supports a wide range of development strategies, +for systems of all sizes. Here are some typical practices that are +easily handled: + +@itemize @bullet +@item Using a common set of source files and generating object files in different + directories via different switch settings. It can be used for instance, for + generating separate sets of object files for debugging and for production. +@item Using a mostly-shared set of source files with different versions of + some units or subunits. It can be used for instance, for grouping and hiding +@end itemize + +@noindent +all OS dependencies in a small number of implementation units. + +Project files can be used to achieve some of the effects of a source +versioning system (for example, defining separate projects for +the different sets of sources that comprise different releases) but the +Project Manager is independent of any source configuration management tool +that might be used by the developers. + +The various sections below introduce the different concepts related to +projects. Each section starts with examples and use cases, and then goes into +the details of related project file capabilities. + +@c --------------------------------------------- +@node Building With Projects +@section Building With Projects +@c --------------------------------------------- + +@noindent +In its simplest form, a unique project is used to build a single executable. +This section concentrates on such a simple setup. Later sections will extend +this basic model to more complex setups. + +The following concepts are the foundation of project files, and will be further +detailed later in this documentation. They are summarized here as a reference. + +@table @asis +@item @b{Project file}: + A text file using an Ada-like syntax, generally using the @file{.gpr} + extension. It defines build-related characteristics of an application. + The characteristics include the list of sources, the location of those + sources, the location for the generated object files, the name of + the main program, and the options for the various tools involved in the + build process. + +@item @b{Project attribute}: + A specific project characteristic is defined by an attribute clause. Its + value is a string or a sequence of strings. All settings in a project + are defined through a list of predefined attributes with precise + semantics. @xref{Attributes}. + +@item @b{Package in a project}: + Global attributes are defined at the top level of a project. + Attributes affecting specific tools are grouped in a + package whose name is related to tool's function. The most common + packages are @code{Builder}, @code{Compiler}, @code{Binder}, + and @code{Linker}. @xref{Packages}. + +@item @b{Project variables}: + In addition to attributes, a project can use variables to store intermediate + values and avoid duplication in complex expressions. It can be initialized + with a value coming from the environment. + A frequent use of variables is to define scenarios. + @xref{External Values}, @xref{Scenarios in Projects}, and @xref{Variables}. + +@item @b{Source files} and @b{source directories}: + A source file is associated with a language through a naming convention. For + instance, @code{foo.c} is typically the name of a C source file; + @code{bar.ads} or @code{bar.1.ada} are two common naming conventions for a + file containing an Ada spec. A compilation unit is often composed of a main + source file and potentially several auxiliary ones, such as header files in C. + The naming conventions can be user defined @xref{Naming Schemes}, and will + drive the builder to call the appropriate compiler for the given source file. + Source files are searched for in the source directories associated with the + project through the @b{Source_Dirs} attribute. By default, all the files (in + these source directories) following the naming conventions associated with the + declared languages are considered to be part of the project. It is also + possible to limit the list of source files using the @b{Source_Files} or + @b{Source_List_File} attributes. Note that those last two attributes only + accept basenames with no directory information. + +@item @b{Object files} and @b{object directory}: + An object file is an intermediate file produced by the compiler from a + compilation unit. It is used by post-compilation tools to produce + final executables or libraries. Object files produced in the context of + a given project are stored in a single directory that can be specified by the + @b{Object_Dir} attribute. In order to store objects in + two or more object directories, the system must be split into + distinct subsystems with their own project file. + +@end table + +The following subsections introduce gradually all the attributes of interest +for simple build needs. Here is the simple setup that will be used in the +following examples. + +The Ada source files @file{pack.ads}, @file{pack.adb}, and @file{proc.adb} are in +the @file{common/} directory. The file @file{proc.adb} contains an Ada main +subprogram @code{Proc} that @code{with}s package @code{Pack}. We want to compile +these source files with the switch @option{-O2}, and put the resulting files in +the directory @file{obj/}. + +@smallexample +@group +^common/^[COMMON]^ + pack.ads + pack.adb + proc.adb +@end group +@group +^common/release/^[COMMON.RELEASE]^ + proc.ali, proc.o pack.ali, pack.o +@end group +@end smallexample + +@noindent +Our project is to be called @emph{Build}. The name of the +file is the name of the project (case-insensitive) with the +@file{.gpr} extension, therefore the project file name is @file{build.gpr}. This +is not mandatory, but a warning is issued when this convention is not followed. + +This is a very simple example, and as stated above, a single project +file is enough for it. We will thus create a new file, that for now +should contain the following code: + +@smallexample +@b{project} Build @b{is} +@b{end} Build; +@end smallexample + +@menu +* Source Files and Directories:: +* Object and Exec Directory:: +* Main Subprograms:: +* Tools Options in Project Files:: +* Compiling with Project Files:: +* Executable File Names:: +* Avoid Duplication With Variables:: +* Naming Schemes:: +@end menu + +@c --------------------------------------------- +@node Source Files and Directories +@subsection Source Files and Directories +@c --------------------------------------------- + +@noindent +When you create a new project, the first thing to describe is how to find the +corresponding source files. This is the only settings that are needed by all +the tools that will use this project (builder, compiler, binder and linker for +the compilation, IDEs to edit the source files,@dots{}). + +@cindex Source directories +First step is to declare the source directories, which are the directories +to be searched to find source files. In the case of the example, +the @file{common} directory is the only source directory. + +@cindex @code{Source_Dirs} +There are several ways of defining source directories: + +@itemize @bullet +@item When the attribute @b{Source_Dirs} is not used, a project contains a + single source directory which is the one where the project file itself + resides. In our example, if @file{build.gpr} is placed in the @file{common} + directory, the project has the needed implicit source directory. + +@item The attribute @b{Source_Dirs} can be set to a list of path names, one + for each of the source directories. Such paths can either be absolute + names (for instance @file{"/usr/local/common/"} on UNIX), or relative to the + directory in which the project file resides (for instance "." if + @file{build.gpr} is inside @file{common/}, or "common" if it is one level up). + Each of the source directories must exist and be readable. + +@cindex portability + The syntax for directories is platform specific. For portability, however, + the project manager will always properly translate UNIX-like path names to + the native format of specific platform. For instance, when the same project + file is to be used both on Unix and Windows, "/" should be used as the + directory separator rather than "\". + +@item The attribute @b{Source_Dirs} can automatically include subdirectories + using a special syntax inspired by some UNIX shells. If any of the path in + the list ends with @emph{"/**"}, then that path and all its subdirectories + (recursively) are included in the list of source directories. For instance, + @file{./**} represent the complete directory tree rooted at ".". +@cindex Source directories, recursive + +@cindex @code{Excluded_Source_Dirs} + When using that construct, it can sometimes be convenient to also use the + attribute @b{Excluded_Source_Dirs}, which is also a list of paths. Each entry + specifies a directory whose immediate content, not including subdirs, is to + be excluded. It is also possible to exclude a complete directory subtree + using the "/**" notation. + +@end itemize + +@noindent +When applied to the simple example, and because we generally prefer to have +the project file at the toplevel directory rather than mixed with the sources, +we will create the following file + +@smallexample + build.gpr + @b{project} Build @b{is} + @b{for} Source_Dirs @b{use} ("common"); -- <<<< + @b{end} Build; +@end smallexample + +@noindent +Once source directories have been specified, one may need to indicate +source files of interest. By default, all source files present in the source +directories are considered by the project manager. When this is not desired, +it is possible to specify the list of sources to consider explicitly. +In such a case, only source file base names are indicated and not +their absolute or relative path names. The project manager is in charge of +locating the specified source files in the specified source directories. + +@itemize @bullet +@item By default, the project manager search for all source files of all + specified languages in all the source directories. + + Since the project manager was initially developed for Ada environments, the + default language is usually Ada and the above project file is complete: it + defines without ambiguity the sources composing the project: that is to say, + all the sources in subdirectory "common" for the default language (Ada) using + the default naming convention. + +@cindex @code{Languages} + However, when compiling a multi-language application, or a pure C + application, the project manager must be told which languages are of + interest, which is done by setting the @b{Languages} attribute to a list of + strings, each of which is the name of a language. Tools like + @command{gnatmake} only know about Ada, while other tools like + @command{gprbuild} know about many more languages such as C, C++, Fortran, + assembly and others can be added dynamically. + +@cindex Naming scheme + Even when using only Ada, the default naming might not be suitable. Indeed, + how does the project manager recognizes an "Ada file" from any other + file? Project files can describe the naming scheme used for source files, + and override the default (@pxref{Naming Schemes}). The default is the + standard GNAT extension (@file{.adb} for bodies and @file{.ads} for + specs), which is what is used in our example, explaining why no naming scheme + is explicitly specified. + @xref{Naming Schemes}. + +@item @code{Source Files} + @cindex @code{Source_Files} + In some cases, source directories might contain files that should not be + included in a project. One can specify the explicit list of file names to + be considered through the @b{Source_Files} attribute. + When this attribute is defined, instead of looking at every file in the + source directories, the project manager takes only those names into + consideration reports errors if they cannot be found in the source + directories or does not correspond to the naming scheme. + +@item For various reasons, it is sometimes useful to have a project with no + sources (most of the time because the attributes defined in the project + file will be reused in other projects, as explained in @pxref{Organizing + Projects into Subsystems}. To do this, the attribute + @emph{Source_Files} is set to the empty list, i.e. @code{()}. Alternatively, + @emph{Source_Dirs} can be set to the empty list, with the same + result. + +@item @code{Source_List_File} +@cindex @code{Source_List_File} + If there is a great number of files, it might be more convenient to use + the attribute @b{Source_List_File}, which specifies the full path of a file. + This file must contain a list of source file names (one per line, no + directory information) that are searched as if they had been defined + through @emph{Source_Files}. Such a file can easily be created through + external tools. + + A warning is issued if both attributes @code{Source_Files} and + @code{Source_List_File} are given explicit values. In this case, the + attribute @code{Source_Files} prevails. + +@item @code{Excluded_Source_Files} +@cindex @code{Excluded_Source_Files} +@cindex @code{Locally_Removed_Files} +@cindex @code{Excluded_Source_List_File} + Specifying an explicit list of files is not always convenient.It might be + more convenient to use the default search rules with specific exceptions. + This can be done thanks to the attribute @b{Excluded_Source_Files} + (or its synonym @b{Locally_Removed_Files}). + Its value is the list of file names that should not be taken into account. + This attribute is often used when extending a project, @xref{Project + Extension}. A similar attribute @b{Excluded_Source_List_File} plays the same + role but takes the name of file containing file names similarly to + @code{Source_List_File}. + +@end itemize + +@noindent +In most simple cases, such as the above example, the default source file search +behavior provides the expected result, and we do not need to add anything after +setting @code{Source_Dirs}. The project manager automatically finds +@file{pack.ads}, @file{pack.adb} and @file{proc.adb} as source files of the +project. + +Note that it is considered an error for a project file to have no sources +attached to it unless explicitly declared as mentionend above. + +If the order of the source directories is known statically, that is if +@code{"/**"} is not used in the string list @code{Source_Dirs}, then there may +be several files with the same source file name sitting in different +directories of the project. In this case, only the file in the first directory +is considered as a source of the project and the others are hidden. If +@code{"/**"} is not used in the string list @code{Source_Dirs}, it is an error +to have several files with the same source file name in the same directory +@code{"/**"} subtree, since there would be an ambiguity as to which one should +be used. However, two files with the same source file name may in two single +directories or directory subtrees. In this case, the one in the first directory +or directory subtree is a source of the project. + +@c --------------------------------------------- +@node Object and Exec Directory +@subsection Object and Exec Directory +@c --------------------------------------------- + +@noindent +The next step when writing a project is to indicate where the compiler should +put the object files. In fact, the compiler and other tools might create +several different kind of files (for GNAT, there is the object file and the ALI +file for instance). One of the important concepts in projects is that most +tools may consider source directories as read-only and do not attempt to create +new or temporary files there. Instead, all files are created in the object +directory. It is of course not true for project-aware IDEs, whose purpose it is +to create the source files. + +@cindex @code{Object_Dir} +The object directory is specified through the @b{Object_Dir} attribute. +Its value is the path to the object directory, either absolute or +relative to the directory containing the project file. This +directory must already exist and be readable and writable, although +some tools have a switch to create the directory if needed (See +the switch @code{-p} for @command{gnatmake} and @command{gprbuild}). + +If the attribute @code{Object_Dir} is not specified, it defaults to +the project directory, that is the directory containing the project file. + +For our example, we can specify the object dir in this way: + +@smallexample + @b{project} Build @b{is} + @b{for} Source_Dirs @b{use} ("common"); + @b{for} Object_Dir @b{use} "obj"; -- <<<< + @b{end} Build; +@end smallexample + +@noindent +As mentioned earlier, there is a single object directory per project. As a +result, if you have an existing system where the object files are spread in +several directories, you can either move all of them into the same directory if +you want to build it with a single project file, or study the section on +subsystems (@pxref{Organizing Projects into Subsystems}) to see how each +separate object directory can be associated with one of the subsystem +constituting the application. + +When the @command{linker} is called, it usually creates an executable. By +default, this executable is placed in the object directory of the project. It +might be convenient to store it in its own directory. + +@cindex @code{Exec_Dir} +This can be done through the @code{Exec_Dir} attribute, which, like +@emph{Object_Dir} contains a single absolute or relative path and must point to +an existing and writable directory, unless you ask the tool to create it on +your behalf. When not specified, It defaults to the object directory and +therefore to the project file's directory if neither @emph{Object_Dir} nor +@emph{Exec_Dir} was specified. + +In the case of the example, let's place the executable in the root +of the hierarchy, ie the same directory as @file{build.gpr}. Hence +the project file is now + +@smallexample + @b{project} Build @b{is} + @b{for} Source_Dirs @b{use} ("common"); + @b{for} Object_Dir @b{use} "obj"; + @b{for} Exec_Dir @b{use} "."; -- <<<< + @b{end} Build; +@end smallexample + +@c --------------------------------------------- +@node Main Subprograms +@subsection Main Subprograms +@c --------------------------------------------- + +@noindent +In the previous section, executables were mentioned. The project manager needs +to be taught what they are. In a project file, an executable is indicated by +pointing to source file of the main subprogram. In C this is the file that +contains the @code{main} function, and in Ada the file that contains the main +unit. + +There can be any number of such main files within a given project, and thus +several executables can be built in the context of a single project file. Of +course, one given executable might not (and in fact will not) need all the +source files referenced by the project. As opposed to other build environments +such as @command{makefile}, one does not need to specify the list of +dependencies of each executable, the project-aware builders knows enough of the +semantics of the languages to build ands link only the necessary elements. + +@cindex @code{Main} +The list of main files is specified via the @b{Main} attribute. It contains +a list of file names (no directories). If a project defines this +attribute, it is not necessary to identify main files on the +command line when invoking a builder, and editors like +@command{GPS} will be able to create extra menus to spawn or debug the +corresponding executables. + +@smallexample + @b{project} Build @b{is} + @b{for} Source_Dirs @b{use} ("common"); + @b{for} Object_Dir @b{use} "obj"; + @b{for} Exec_Dir @b{use} "."; + @b{for} Main @b{use} ("proc.adb"); -- <<<< + @b{end} Build; +@end smallexample + +@noindent +If this attribute is defined in the project, then spawning the builder +with a command such as + +@smallexample + gnatmake ^-Pbuild^/PROJECT_FILE=build^ +@end smallexample + +@noindent +automatically builds all the executables corresponding to the files +listed in the @emph{Main} attribute. It is possible to specify one +or more executables on the command line to build a subset of them. + +@c --------------------------------------------- +@node Tools Options in Project Files +@subsection Tools Options in Project Files +@c --------------------------------------------- + +@noindent +We now have a project file that fully describes our environment, and can be +used to build the application with a simple @command{gnatmake} command as seen +in the previous section. In fact, the empty project we showed immediately at +the beginning (with no attribute at all) could already fullfill that need if it +was put in the @file{common} directory. + +Of course, we always want more control. This section will show you how to +specify the compilation switches that the various tools involved in the +building of the executable should use. + +@cindex command line length +Since source names and locations are described into the project file, it is not +necessary to use switches on the command line for this purpose (switches such +as -I for gcc). This removes a major source of command line length overflow. +Clearly, the builders will have to communicate this information one way or +another to the underlying compilers and tools they call but they usually use +response files for this and thus should not be subject to command line +overflows. + +Several tools are participating to the creation of an executable: the compiler +produces object files from the source files; the binder (in the Ada case) +creates an source file that takes care, among other things, of elaboration +issues and global variables initialization; and the linker gathers everything +into a single executable that users can execute. All these tools are known by +the project manager and will be called with user defined switches from the +project files. However, we need to introduce a new project file concept to +express which switches to be used for any of the tools involved in the build. + +@cindex project file packages +A project file is subdivided into zero or more @b{packages}, each of which +contains the attributes specific to one tool (or one set of tools). Project +files use an Ada-like syntax for packages. Package names permitted in project +files are restricted to a predefined set (@pxref{Packages}), and the contents +of packages are limited to a small set of constructs and attributes +(@pxref{Attributes}). + +Our example project file can be extended with the following empty packages. At +this stage, they could all be omitted since they are empty, but they show which +packages would be involved in the build process. + +@smallexample + @b{project} Build @b{is} + @b{for} Source_Dirs @b{use} ("common"); + @b{for} Object_Dir @b{use} "obj"; + @b{for} Exec_Dir @b{use} "."; + @b{for} Main @b{use} ("proc.adb"); + @b{end} Build; + + @b{package} Builder @b{is} --<<< for gnatmake and gprbuild + @b{end} Builder; + + @b{package} Compiler @b{is} --<<< for the compiler + @b{end} Builder; + + @b{package} Binder @b{is} --<<< for the binder + @b{end} Builder; + + @b{package} Linker @b{is} --<<< for the linker + @b{end} Builder; +@end smallexample + +@noindent +Let's first examine the compiler switches. As stated in the initial description +of the example, we want to compile all files with @option{-O2}. This is a +compiler switch, although it is usual, on the command line, to pass it to the +builder which then passes it to the compiler. It is recommended to use directly +the right package, which will make the setup easier to understand for other +people. + +Several attributes can be used to specify the switches: + +@table @asis +@item @b{Default_Switches}: +@cindex @code{Default_Switches} + This is the first mention in this manual of an @b{indexed attribute}. When + this attribute is defined, one must supply an @emph{index} in the form of a + literal string. + In the case of @emph{Default_Switches}, the index is the name of the + language to which the switches apply (since a different compiler will + likely be used for each language, and each compiler has its own set of + switches). The value of the attribute is a list of switches. + + In this example, we want to compile all Ada source files with the + @option{-O2} switch, and the resulting project file is as follows + (only the @code{Compiler} package is shown): + + @smallexample + @b{package} Compiler @b{is} + @b{for} Default_Switches ("Ada") @b{use} ("-O2"); + @b{end} Compiler; + @end smallexample + +@item @b{Switches}: +@cindex @code{Switches} + in some cases, we might want to use specific switches + for one or more files. For instance, compiling @file{proc.adb} might not be + possible at high level of optimization because of a compiler issue. + In such a case, the @emph{Switches} + attribute (indexed on the file name) can be used and will override the + switches defined by @emph{Default_Switches}. Our project file would + become: + + @smallexample + @b{package} Compiler @b{is} + @b{for} Default_Switches ("Ada") @b{use} ("-O2"); + @b{for} Switches ("proc.adb") @b{use} ("-O0"); + @b{end} Compiler; + @end smallexample + + @noindent + @code{Switches} can also be given a language name as index instead of a file + name in which case it has the same semantics as @emph{Default_Switches}. + +@item @b{Local_Configuration_Pragmas}: +@cindex @code{Local_Configuration_Pragmas} + this attribute may specify the path + of a file containing configuration pragmas for use by the Ada compiler, + such as @code{pragma Restrictions (No_Tasking)}. These pragmas will be + used for all the sources of the project. + +@end table + +The switches for the other tools are defined in a similar manner through the +@b{Default_Switches} and @b{Switches} attributes, respectively in the +@emph{Builder} package (for @command{gnatmake} and @command{gprbuild}), +the @emph{Binder} package (binding Ada executables) and the @emph{Linker} +package (for linking executables). + +@c --------------------------------------------- +@node Compiling with Project Files +@subsection Compiling with Project Files +@c --------------------------------------------- + +@noindent +Now that our project files are written, let's build our executable. +Here is the command we would use from the command line: + +@smallexample + gnatmake ^-Pbuild^/PROJECT_FILE=build^ +@end smallexample + +@noindent +This will automatically build the executables specified through the +@emph{Main} attribute: for each, it will compile or recompile the +sources for which the object file does not exist or is not up-to-date; it +will then run the binder; and finally run the linker to create the +executable itself. + +@command{gnatmake} only knows how to handle Ada files. By using +@command{gprbuild} as a builder, you could automatically manage C files the +same way: create the file @file{utils.c} in the @file{common} directory, +set the attribute @emph{Languages} to @code{"(Ada, C)"}, and run + +@smallexample + gprbuild ^-Pbuild^/PROJECT_FILE=build^ +@end smallexample + +@noindent +Gprbuild knows how to recompile the C files and will +recompile them only if one of their dependencies has changed. No direct +indication on how to build the various elements is given in the +project file, which describes the project properties rather than a +set of actions to be executed. Here is the invocation of +@command{gprbuild} when building a multi-language program: + +@smallexample +$ gprbuild -Pbuild +gcc -c proc.adb +gcc -c pack.adb +gcc -c utils.c +gprbind proc +... +gcc proc.o -o proc +@end smallexample + +@noindent +Notice the three steps described earlier: + +@itemize @bullet +@item The first three gcc commands correspond to the compilation phase. +@item The gprbind command corresponds to the post-compilation phase. +@item The last gcc command corresponds to the final link. + +@end itemize + +@noindent +@cindex @option{-v} option (for GPRbuild) +The default output of GPRbuild's execution is kept reasonably simple and easy +to understand. In particular, some of the less frequently used commands are not +shown, and some parameters are abbreviated. So it is not possible to rerun the +effect ofthe gprbuild command by cut-and-pasting its output. GPRbuild's option +@code{-v} provides a much more verbose output which includes, among other +information, more complete compilation, post-compilation and link commands. + +@c --------------------------------------------- +@node Executable File Names +@subsection Executable File Names +@c --------------------------------------------- + +@noindent +@cindex @code{Executable} +By default, the executable name corresponding to a main file is +computed from the main source file name. Through the attribute +@b{Builder.Executable}, it is possible to change this default. + +For instance, instead of building @command{proc} (or @command{proc.exe} +on Windows), we could configure our project file to build "proc1" +(resp proc1.exe) with the following addition: + +@smallexample @c projectfile + project Build is + ... -- same as before + package Builder is + for Executable ("proc.adb") use "proc1"; + end Builder + end Build; +@end smallexample + +@noindent +@cindex @code{Executable_Suffix} +Attribute @b{Executable_Suffix}, when specified, may change the suffix +of the executable files, when no attribute @code{Executable} applies: +its value replace the platform-specific executable suffix. +The default executable suffix is empty on UNIX and ".exe" on Windows. + +It is also possible to change the name of the produced executable by using the +command line switch @option{-o}. When several mains are defined in the project, +it is not possible to use the @option{-o} switch and the only way to change the +names of the executable is provided by Attributes @code{Executable} and +@code{Executable_Suffix}. + +@c --------------------------------------------- +@node Avoid Duplication With Variables +@subsection Avoid Duplication With Variables +@c --------------------------------------------- + +@noindent +To illustrate some other project capabilities, here is a slightly more complex +project using similar sources and a main program in C: + +@smallexample @c projectfile +project C_Main is + for Languages use ("Ada", "C"); + for Source_Dirs use ("common"); + for Object_Dir use "obj"; + for Main use ("main.c"); + package Compiler is + C_Switches := ("-pedantic"); + for Default_Switches ("C") use C_Switches; + for Default_Switches ("Ada") use ("-gnaty"); + for Switches ("main.c") use C_Switches & ("-g"); + end Compiler; +end C_Main; +@end smallexample + +@noindent +This project has many similarities with the previous one. +As expected, its @code{Main} attribute now refers to a C source. +The attribute @emph{Exec_Dir} is now omitted, thus the resulting +executable will be put in the directory @file{obj}. + +The most noticeable difference is the use of a variable in the +@emph{Compiler} package to store settings used in several attributes. +This avoids text duplication, and eases maintenance (a single place to +modify if we want to add new switches for C files). We will revisit +the use of variables in the context of scenarios (@pxref{Scenarios in +Projects}). + +In this example, we see how the file @file{main.c} can be compiled with +the switches used for all the other C files, plus @option{-g}. +In this specific situation the use of a variable could have been +replaced by a reference to the @code{Default_Switches} attribute: + +@smallexample @c projectfile + for Switches ("c_main.c") use Compiler'Default_Switches ("C") & ("-g"); +@end smallexample + +@noindent +Note the tick (@emph{'}) used to refer to attributes defined in a package. + +Here is the output of the GPRbuild command using this project: + +@smallexample +$gprbuild -Pc_main +gcc -c -pedantic -g main.c +gcc -c -gnaty proc.adb +gcc -c -gnaty pack.adb +gcc -c -pedantic utils.c +gprbind main.bexch +... +gcc main.o -o main +@end smallexample + +@noindent +The default switches for Ada sources, +the default switches for C sources (in the compilation of @file{lib.c}), +and the specific switches for @file{main.c} have all been taken into +account. + +@c --------------------------------------------- +@node Naming Schemes +@subsection Naming Schemes +@c --------------------------------------------- + +@noindent +Sometimes an Ada software system is ported from one compilation environment to +another (say GNAT), and the file are not named using the default GNAT +conventions. Instead of changing all the file names, which for a variety of +reasons might not be possible, you can define the relevant file naming scheme +in the @b{Naming} package of your project file. + +The naming scheme has two distinct goals for the project manager: it +allows finding of source files when searching in the source +directories, and given a source file name it makes it possible to guess +the associated language, and thus the compiler to use. + +Note that the use by the Ada compiler of pragmas Source_File_Name is not +supported when using project files. You must use the features described in this +paragraph. You can however specify other configuration pragmas +(@pxref{Specifying Configuration Pragmas}). + +The following attributes can be defined in package @code{Naming}: + +@table @asis +@item @b{Casing}: +@cindex @code{Casing} + Its value must be one of @code{"lowercase"} (the default if + unspecified), @code{"uppercase"} or @code{"mixedcase"}. It describes the + casing of file names with regards to the Ada unit name. Given an Ada unit + My_Unit, the file name will respectively be @file{my_unit.adb} (lowercase), + @file{MY_UNIT.ADB} (uppercase) or @file{My_Unit.adb} (mixedcase). + On Windows, file names are case insensitive, so this attribute is + irrelevant. + +@item @b{Dot_Replacement}: +@cindex @code{Dot_Replacement} + This attribute specifies the string that should replace the "." in unit + names. Its default value is @code{"-"} so that a unit + @code{Parent.Child} is expected to be found in the file + @file{parent-child.adb}. The replacement string must satisfy the following + requirements to avoid ambiguities in the naming scheme: + + @itemize - + @item It must not be empty + @item It cannot start or end with an alphanumeric character + @item It cannot be a single underscore + @item It cannot start with an underscore followed by an alphanumeric + @item It cannot contain a dot @code{'.'} except if the entire string + is @code{"."} + + @end itemize + +@item @b{Spec_Suffix} and @b{Specification_Suffix}: +@cindex @code{Spec_Suffix} +@cindex @code{Specification_Suffix} + For Ada, these attributes give the suffix used in file names that contain + specifications. For other languages, they give the extension for files + that contain declaration (header files in C for instance). The attribute + is indexed on the language. + The two attributes are equivalent, but the latter is obsolescent. + If @code{Spec_Suffix ("Ada")} is not specified, then the default is + @code{"^.ads^.ADS^"}. + The value must satisfy the following requirements: + + @itemize - + @item It must not be empty + @item It cannot start with an alphanumeric character + @item It cannot start with an underscore followed by an alphanumeric character + @item It must include at least one dot + + @end itemize + +@item @b{Body_Suffix} and @b{Implementation_Suffix}: +@cindex @code{Body_Suffix} +@cindex @code{Implementation_Suffix} + These attributes give the extension used for file names that contain + code (bodies in Ada). They are indexed on the language. The second + version is obsolescent and fully replaced by the first attribute. + + These attributes must satisfy the same requirements as @code{Spec_Suffix}. + In addition, they must be different from any of the values in + @code{Spec_Suffix}. + If @code{Body_Suffix ("Ada")} is not specified, then the default is + @code{"^.adb^.ADB^"}. + + If @code{Body_Suffix ("Ada")} and @code{Spec_Suffix ("Ada")} end with the + same string, then a file name that ends with the longest of these two + suffixes will be a body if the longest suffix is @code{Body_Suffix ("Ada")} + or a spec if the longest suffix is @code{Spec_Suffix ("Ada")}. + + If the suffix does not start with a '.', a file with a name exactly equal + to the suffix will also be part of the project (for instance if you define + the suffix as @code{Makefile}, a file called @file{Makefile} will be part + of the project. This capability is usually not interesting when building. + However, it might become useful when a project is also used to + find the list of source files in an editor, like the GNAT Programming System + (GPS). + +@item @b{Separate_Suffix}: +@cindex @code{Separate_Suffix} + This attribute is specific to Ada. It denotes the suffix used in file names + that contain separate bodies. If it is not specified, then it defaults to + same value as @code{Body_Suffix ("Ada")}. The same rules apply as for the + @code{Body_Suffix} attribute. The only accepted index is "Ada". + +@item @b{Spec} or @b{Specification}: +@cindex @code{Spec} +@cindex @code{Specification} + This attribute @code{Spec} can be used to define the source file name for a + given Ada compilation unit's spec. The index is the literal name of the Ada + unit (case insensitive). The value is the literal base name of the file that + contains this unit's spec (case sensitive or insensitive depending on the + operating system). This attribute allows the definition of exceptions to the + general naming scheme, in case some files do not follow the usual + convention. + + When a source file contains several units, the relative position of the unit + can be indicated. The first unit in the file is at position 1 + + @smallexample @c projectfile + for Spec ("MyPack.MyChild") use "mypack.mychild.spec"; + for Spec ("top") use "foo.a" at 1; + for Spec ("foo") use "foo.a" at 2; + @end smallexample + +@item @b{Body} or @b{Implementation}: +@cindex @code{Body} +@cindex @code{Implementation} + These attribute play the same role as @emph{Spec} for Ada bodies. + +@item @b{Specification_Exceptions} and @b{Implementation_Exceptions}: +@cindex @code{Specification_Exceptions} +@cindex @code{Implementation_Exceptions} + These attributes define exceptions to the naming scheme for languages + other than Ada. They are indexed on the language name, and contain + a list of file names respectively for headers and source code. + + +@end table + +@ifclear vms +For example, the following package models the Apex file naming rules: + +@smallexample @c projectfile +@group + package Naming is + for Casing use "lowercase"; + for Dot_Replacement use "."; + for Spec_Suffix ("Ada") use ".1.ada"; + for Body_Suffix ("Ada") use ".2.ada"; + end Naming; +@end group +@end smallexample +@end ifclear + +@ifset vms +For example, the following package models the DEC Ada file naming rules: + +@smallexample @c projectfile +@group + package Naming is + for Casing use "lowercase"; + for Dot_Replacement use "__"; + for Spec_Suffix ("Ada") use "_.ada"; + for Body_Suffix ("Ada") use ".ada"; + end Naming; +@end group +@end smallexample + +@noindent +(Note that @code{Casing} is @code{"lowercase"} because GNAT gets the file +names in lower case) +@end ifset + +@c --------------------------------------------- +@node Organizing Projects into Subsystems +@section Organizing Projects into Subsystems +@c --------------------------------------------- + +@noindent +A @b{subsystem} is a coherent part of the complete system to be built. It is +represented by a set of sources and one single object directory. A system can +be composed of a single subsystem when it is simple as we have seen in the +first section. Complex systems are usually composed of several interdependent +subsystems. A subsystem is dependent on another subsystem if knowledge of the +other one is required to build it, and in particular if visibility on some of +the sources of this other subsystem is required. Each subsystem is usually +represented by its own project file. + +In this section, the previous example is being extended. Let's assume some +sources of our @code{Build} project depend on other sources. +For instance, when building a graphical interface, it is usual to depend upon +a graphical library toolkit such as GtkAda. Furthermore, we also need +sources from a logging module we had previously written. + +@menu +* Project Dependencies:: +* Cyclic Project Dependencies:: +* Sharing Between Projects:: +* Global Attributes:: +@end menu + +@c --------------------------------------------- +@node Project Dependencies +@subsection Project Dependencies +@c --------------------------------------------- + +@noindent +GtkAda comes with its own project file (appropriately called +@file{gtkada.gpr}), and we will assume we have already built a project +called @file{logging.gpr} for the logging module. With the information provided +so far in @file{build.gpr}, building the application would fail with an error +indicating that the gtkada and logging units that are relied upon by the sources +of this project cannot be found. + +This is easily solved by adding the following @b{with} clauses at the beginning +of our project: + +@smallexample @c projectfile + with "gtkada.gpr"; + with "a/b/logging.gpr"; + project Build is + ... -- as before + end Build; +@end smallexample + +@noindent +@cindex @code{Externally_Built} +When such a project is compiled, @command{gnatmake} will automatically +check the other projects and recompile their sources when needed. It will also +recompile the sources from @code{Build} when needed, and finally create the +executable. In some cases, the implementation units needed to recompile a +project are not available, or come from some third-party and you do not want to +recompile it yourself. In this case, the attribute @b{Externally_Built} to +"true" can be set, indicating to the builder that this project can be assumed +to be up-to-date, and should not be considered for recompilation. In Ada, if +the sources of this externally built project were compiled with another version +of the compiler or with incompatible options, the binder will issue an error. + +The project's @code{with} clause has several effects. It provides source +visibility between projects during the compilation process. It also guarantees +that the necessary object files from @code{Logging} and @code{GtkAda} are +available when linking @code{Build}. + +As can be seen in this example, the syntax for importing projects is similar +to the syntax for importing compilation units in Ada. However, project files +use literal strings instead of names, and the @code{with} clause identifies +project files rather than packages. + +Each literal string after @code{with} is the path +(absolute or relative) to a project file. The @code{.gpr} extension is +optional, although we recommend adding it. If no extension is specified, +and no project file with the @file{^.gpr^.GPR^} extension is found, then +the file is searched for exactly as written in the @code{with} clause, +that is with no extension. + +@cindex project path +When a relative path or a base name is used, the +project files are searched relative to each of the directories in the +@b{project path}. This path includes all the directories found with the +following algorithm, in that order, as soon as a matching file is found, +the search stops: + +@itemize @bullet +@item First, the file is searched relative to the directory that contains the + current project file. +@item +@cindex @code{ADA_PROJECT_PATH} +@cindex @code{GPR_PROJECT_PATH} + Then it is searched relative to all the directories specified in the + ^environment variables^logical names^ @b{GPR_PROJECT_PATH} and + @b{ADA_PROJECT_PATH} (in that order) if they exist. The former is + recommended, the latter is kept for backward compatibility. +@item Finally, it is searched relative to the default project directories. + Such directories depends on the tool used. For @command{gnatmake}, there is + one default project directory: @file{/lib/gnat/}. In our example, + @file{gtkada.gpr} is found in the predefined directory if it was installed at + the same root as GNAT. + +@end itemize + +@noindent +Some tools also support extending the project path from the command line, +generally through the @option{-aP}. You can see the value of the project +path by using the @command{gnatls -v} command. + +Any symbolic link will be fully resolved in the directory of the +importing project file before the imported project file is examined. + +Any source file in the imported project can be used by the sources of the +importing project, transitively. +Thus if @code{A} imports @code{B}, which imports @code{C}, the sources of +@code{A} may depend on the sources of @code{C}, even if @code{A} does not +import @code{C} explicitly. However, this is not recommended, because if +and when @code{B} ceases to import @code{C}, some sources in @code{A} will +no longer compile. @command{gprbuild} has a switch @option{--no-indirect-imports} +that will report such indirect dependencies. + +One very important aspect of a project hierarchy is that +@b{a given source can only belong to one project} (otherwise the project manager +would not know which settings apply to it and when to recompile it). It means +that different project files do not usually share source directories or +when they do, they need to specify precisely which project owns which sources +using attribute @code{Source_Files} or equivalent. By contrast, 2 projects +can each own a source with the same base file name as long as they live in +different directories. The latter is not true for Ada Sources because of the +correlation betwen source files and Ada units. + +@c --------------------------------------------- +@node Cyclic Project Dependencies +@subsection Cyclic Project Dependencies +@c --------------------------------------------- + +@noindent +Cyclic dependencies are mostly forbidden: +if @code{A} imports @code{B} (directly or indirectly) then @code{B} +is not allowed to import @code{A}. However, there are cases when cyclic +dependencies would be beneficial. For these cases, another form of import +between projects exists: the @b{limited with}. A project @code{A} that +imports a project @code{B} with a straight @code{with} may also be imported, +directly or indirectly, by @code{B} through a @code{limited with}. + +The difference between straight @code{with} and @code{limited with} is that +the name of a project imported with a @code{limited with} cannot be used in the +project importing it. In particular, its packages cannot be renamed and +its variables cannot be referred to. + +@smallexample @c 0projectfile +with "b.gpr"; +with "c.gpr"; +project A is + For Exec_Dir use B'Exec_Dir; -- ok +end A; + +limited with "a.gpr"; -- Cyclic dependency: A -> B -> A +project B is + For Exec_Dir use A'Exec_Dir; -- not ok +end B; + +with "d.gpr"; +project C is +end C; + +limited with "a.gpr"; -- Cyclic dependency: A -> C -> D -> A +project D is + For Exec_Dir use A'Exec_Dir; -- not ok +end D; +@end smallexample + +@c --------------------------------------------- +@node Sharing Between Projects +@subsection Sharing Between Projects +@c --------------------------------------------- + +@noindent +When building an application, it is common to have similar needs in severa of +the projects corresponding to the subsystems under construction. For instance, +they will all have the same compilation switches. + +As seen before (@pxref{Tools Options in Project Files}), setting compilation +switches for all sources of a subsystem is simple: it is just a matter of +adding a @code{Compiler.Default_Switches} attribute to each project files with +the same value. Of course, that means duplication of data, and both places need +to be changed in order to recompile the whole application with different +switches. It can become a real problem if there are many subsystems and thus +many project files to edit. + +There are two main approaches to avoiding this duplication: + +@itemize @bullet +@item Since @file{build.gpr} imports @file{logging.gpr}, we could change it + to reference the attribute in Logging, either through a package renaming, + or by referencing the attribute. The following example shows both cases: + + @smallexample @c projectfile + project Logging is + package Compiler is + for Switches ("Ada") use ("-O2"); + end Compiler; + package Binder is + for Switches ("Ada") use ("-E"); + end Binder; + end Logging; + + with "logging.gpr"; + project Build is + package Compiler renames Logging.Compiler; + package Binder is + for Switches ("Ada") use Logging.Binder'Switches ("Ada"); + end Binder; + end Build; + @end smallexample + + @noindent + The solution used for @code{Compiler} gets the same value for all + attributes of the package, but you cannot modify anything from the + package (adding extra switches or some exceptions). The second + version is more flexible, but more verbose. + + If you need to refer to the value of a variable in an imported + project, rather than an attribute, the syntax is similar but uses + a "." rather than an apostrophe. For instance: + + @smallexample @c projectfile + with "imported"; + project Main is + Var1 := Imported.Var; + end Main; + @end smallexample + +@item The second approach is to define the switches in a third project. + That project is setup without any sources (so that, as opposed to + the first example, none of the project plays a special role), and + will only be used to define the attributes. Such a project is + typically called @file{shared.gpr}. + + @smallexample @c projectfile + abstract project Shared is + for Source_Files use (); -- no project + package Compiler is + for Switches ("Ada") use ("-O2"); + end Compiler; + end Shared; + + with "shared.gpr"; + project Logging is + package Compiler renames Shared.Compiler; + end Logging; + + with "shared.gpr"; + project Build is + package Compiler renames Shared.Compiler; + end Build; + @end smallexample + + @noindent + As for the first example, we could have chosen to set the attributes + one by one rather than to rename a package. The reason we explicitly + indicate that @code{Shared} has no sources is so that it can be created + in any directory and we are sure it shares no sources with @code{Build} + or @code{Logging}, which of course would be invalid. + +@cindex project qualifier + Note the additional use of the @b{abstract} qualifier in @file{shared.gpr}. + This qualifier is optional, but helps convey the message that we do not + intend this project to have sources (@pxref{Qualified Projects} for + more qualifiers). +@end itemize + + +@c --------------------------------------------- +@node Global Attributes +@subsection Global Attributes +@c --------------------------------------------- + +@noindent +We have already seen many examples of attributes used to specify a special +option of one of the tools involved in the build process. Most of those +attributes are project specific. That it to say, they only affect the invocation +of tools on the sources of the project where they are defined. + +There are a few additional attributes that apply to all projects in a +hierarchy as long as they are defined on the "main" project. +The main project is the project explicitly mentioned on the command-line. +The project hierarchy is the "with"-closure of the main project. + +Here is a list of commonly used global attributes: + +@table @asis +@item @b{Builder.Global_Configuration_Pragmas}: +@cindex @code{Global_Configuration_Pragmas} + This attribute points to a file that contains configuration pragmas + to use when building executables. These pragmas apply for all + executables build from this project hierarchy. As we have seen before, + additional pragmas can be specified on a per-project basis by setting the + @code{Compiler.Local_Configuration_Pragmas} attribute. + +@item @b{Builder.Global_Compilation_Switches}: +@cindex @code{Global_Compilation_Switches} + This attribute is a list of compiler switches to use when compiling any + source file in the project hierarchy. These switches are used in addition + to the ones defined in the @code{Compiler} package, which only apply to + the sources of the corresponding project. This attribute is indexed on + the name of the language. + +@end table + +Using such global capabilities is convenient. It can also lead to unexpected +behavior. Especially when several subsystems are shared among different main +projects and the different global attributes are not +compatible. Note that using aggregate projects can be a safer and more powerful +replacement to global attributes. + +@c --------------------------------------------- +@node Scenarios in Projects +@section Scenarios in Projects +@c --------------------------------------------- + +@noindent +Various aspects of the projects can be modified based on @b{scenarios}. These +are user-defined modes that change the behavior of a project. Typical +examples are the setup of platform-specific compiler options, or the use of +a debug and a release mode (the former would activate the generation of debug +information, when the second will focus on improving code optimization). + +Let's enhance our example to support a debug and a release modes.The issue is to +let the user choose what kind of system he is building: +use @option{-g} as compiler switches in debug mode and @option{-O2} +in release mode. We will also setup the projects so that we do not share the +same object directory in both modes, otherwise switching from one to the other +might trigger more recompilations than needed or mix objects from the 2 modes. + +One naive approach is to create two different project files, say +@file{build_debug.gpr} and @file{build_release.gpr}, that set the appropriate +attributes as explained in previous sections. This solution does not scale well, +because in presence of multiple projects depending on each other, +you will also have to duplicate the complete hierarchy and adapt the project +files to point to the right copies. + +@cindex scenarios +Instead, project files support the notion of scenarios controlled +by external values. Such values can come from several sources (in decreasing +order of priority): + +@table @asis +@item @b{Command line}: +@cindex @option{-X} + When launching @command{gnatmake} or @command{gprbuild}, the user can pass + extra @option{-X} switches to define the external value. In + our case, the command line might look like + + @smallexample + gnatmake -Pbuild.gpr -Xmode=debug + or gnatmake -Pbuild.gpr -Xmode=release + @end smallexample + +@item @b{^Environment variables^Logical names^}: + When the external value does not come from the command line, it can come from + the value of ^environment variables^logical names^ of the appropriate name. + In our case, if ^an environment variable^a logical name^ called "mode" + exist, its value will be taken into account. + +@item @b{External function second parameter} + +@end table + +@cindex @code{external} +We now need to get that value in the project. The general form is to use +the predefined function @b{external} which returns the current value of +the external. For instance, we could setup the object directory to point to +either @file{obj/debug} or @file{obj/release} by changing our project to + +@smallexample @c projectfile + project Build is + for Object_Dir use "obj/" & external ("mode", "debug"); + ... -- as before + end Build; +@end smallexample + +@noindent +The second parameter to @code{external} is optional, and is the default +value to use if "mode" is not set from the command line or the environment. + +In order to set the switches according to the different scenarios, other +constructs have to be introduced such as typed variables and case statements. + +@cindex typed variable +@cindex case statement +A @b{typed variable} is a variable that +can take only a limited number of values, similar to an enumeration in Ada. +Such a variable can then be used in a @b{case statement} and create conditional +sections in the project. The following example shows how this can be done: + +@smallexample @c projectfile + project Build is + type Mode_Type is ("debug", "release"); -- all possible values + Mode : Mode_Type := external ("mode", "debug"); -- a typed variable + + package Compiler is + case Mode is + when "debug" => + for Switches ("Ada") use ("-g"); + when "release" => + for Switches ("Ada") use ("-O2"); + end case; + end Compiler; + end Build; +@end smallexample + +@noindent +The project has suddenly grown in size, but has become much more flexible. +@code{Mode_Type} defines the only valid values for the @code{mode} variable. If +any other value is read from the environment, an error is reported and the +project is considered as invalid. + +The @code{Mode} variable is initialized with an external value +defaulting to @code{"debug"}. This default could be omitted and that would +force the user to define the value. Finally, we can use a case statement to set the +switches depending on the scenario the user has chosen. + +Most aspects of the projects can depend on scenarios. The notable exception +are project dependencies (@code{with} clauses), which may not depend on a scenario. + +Scenarios work the same way with @b{project hierarchies}: you can either +duplicate a variable similar to @code{Mode} in each of the project (as long +as the first argument to @code{external} is always the same and the type is +the same), or simply set the variable in the @file{shared.gpr} project +(@pxref{Sharing Between Projects}). + +@c --------------------------------------------- +@node Library Projects +@section Library Projects +@c --------------------------------------------- + +@noindent +So far, we have seen examples of projects that create executables. However, +it is also possible to create libraries instead. A @b{library} is a specific +type of subsystem where, for convenience, objects are grouped together +using system-specific means such as archives or windows DLLs. + +Library projects provide a system- and language-independent way of building both @b{static} +and @b{dynamic} libraries. They also support the concept of @b{standalone +libraries} (SAL) which offers two significant properties: the elaboration +(e.g. initialization) of the library is either automatic or very simple; +a change in the +implementation part of the library implies minimal post-compilation actions on +the complete system and potentially no action at all for the rest of the +system in the case of dynamic SALs. + +The GNAT Project Manager takes complete care of the library build, rebuild and +installation tasks, including recompilation of the source files for which +objects do not exist or are not up to date, assembly of the library archive, and +installation of the library (i.e., copying associated source, object and +@file{ALI} files to the specified location). + +@menu +* Building Libraries:: +* Using Library Projects:: +* Stand-alone Library Projects:: +* Installing a library with project files:: +@end menu + +@c --------------------------------------------- +@node Building Libraries +@subsection Building Libraries +@c --------------------------------------------- + +@noindent +Let's enhance our example and transform the @code{logging} subsystem into a +library.In orer to do so, a few changes need to be made to @file{logging.gpr}. +A number of specific attributes needs to be defined: at least @code{Library_Name} +and @code{Library_Dir}; in addition, a number of other attributes can be used +to specify specific aspects of the library. For readablility, it is also +recommended (although not mandatory), to use the qualifier @code{library} in +front of the @code{project} keyword. + +@table @asis +@item @b{Library_Name}: +@cindex @code{Library_Name} + This attribute is the name of the library to be built. There is no + restriction on the name of a library imposed by the project manager; + however, there may be system specific restrictions on the name. + In general, it is recommended to stick to alphanumeric characters + (and possibly underscores) to help portability. + +@item @b{Library_Dir}: +@cindex @code{Library_Dir} + This attribute is the path (absolute or relative) of the directory where + the library is to be installed. In the process of building a library, + the sources are compiled, the object files end up in the explicit or + implicit @code{Object_Dir} directory. When all sources of a library + are compiled, some of the compilation artifacts, including the library itself, + are copied to the library_dir directory. This directory must exists and be + writable. It must also be different from the object directory so that cleanup + activities in the Library_Dir do not affect recompilation needs. + +@end table + +Here is the new version of @file{logging.gpr} that makes it a library: + +@smallexample @c projectfile +library project Logging is -- "library" is optional + for Library_Name use "logging"; -- will create "liblogging.a" on Unix + for Object_Dir use "obj"; + for Library_Dir use "lib"; -- different from object_dir +end Logging; +@end smallexample + +@noindent +Once the above two attributes are defined, the library project is valid and +is enough for building a library with default characteristics. +Other library-related attributes can be used to change the defaults: + +@table @asis +@item @b{Library_Kind}: +@cindex @code{Library_Kind} + The value of this attribute must be either @code{"static"}, @code{"dynamic"} or + @code{"relocatable"} (the latter is a synonym for dynamic). It indicates + which kind of library should be build (the default is to build a + static library, that is an archive of object files that can potentially + be linked into a static executable). When the library is set to be dynamic, + a separate image is created that will be loaded independnently, usually + at the start of the main program execution. Support for dynamic libraries is + very platform specific, for instance on Windows it takes the form of a DLL + while on GNU/Linux, it is a dynamic elf image whose suffix is usually + @file{.so}. Library project files, on the other hand, can be written in + a platform independant way so that the same project file can be used to build + a library on different Oses. + + If you need to build both a static and a dynamic library, it is recommended + use two different object directories, since in some cases some extra code + needs to be generated for the latter. For such cases, one can + either define two different project files, or a single one which uses scenarios + to indicate at the various kinds of library to be build and their + corresponding object_dir. + +@cindex @code{Library_ALI_Dir} +@item @b{Library_ALI_Dir}: + This attribute may be specified to indicate the directory where the ALI + files of the library are installed. By default, they are copied into the + @code{Library_Dir} directory, but as for the executables where we have a + separate @code{Exec_Dir} attribute, you might want to put them in a separate + directory since there can be hundreds of them. The same restrictions as for + the @code{Library_Dir} attribute apply. + +@cindex @code{Library_Version} +@item @b{Library_Version}: + This attribute is platform dependent, and has no effect on VMS and Windows. + On Unix, it is used only for dynamic libraries as the internal + name of the library (the @code{"soname"}). If the library file name (built + from the @code{Library_Name}) is different from the @code{Library_Version}, + then the library file will be a symbolic link to the actual file whose name + will be @code{Library_Version}. This follows the usual installation schemes + for dynamic libraries on many Unix systems. + +@smallexample @c projectfile +@group + project Logging is + Version := "1"; + for Library_Dir use "lib"; + for Library_Name use "logging"; + for Library_Kind use "dynamic"; + for Library_Version use "liblogging.so." & Version; + end Logging; +@end group +@end smallexample + + @noindent + After the compilation, the directory @file{lib} will contain both a + @file{libdummy.so.1} library and a symbolic link to it called + @file{libdummy.so}. + +@cindex @code{Library_GCC} +@item @b{Library_GCC}: + This attribute is the name of the tool to use instead of "gcc" to link shared + libraries. A common use of this attribute is to define a wrapper script that + accomplishes specific actions before calling gcc (which itself is calling the + linker to build the library image). + +@cindex @code{Linker_Options} +@item @b{Linker.Linker_Options}: + This attribute specifies additional switches to be given to the linker when + linking an executable. It is ignored when defined in the main project and + taken into account in all other projects that are imported directly or + indirectly. These switches complement the @code{Linker.Switches} + defined in the main project. This is useful when a particular subsystem + depends on an external library: adding this dependency as a + @code{Linker_Options} in the project of the subsystem is more convenient than + adding it to all the @code{Linker.Switches} of the main projects that depend + upon this subsystem. +@end table + + +@c --------------------------------------------- +@node Using Library Projects +@subsection Using Library Projects +@c --------------------------------------------- + +@noindent +When the builder detects that a project file is a library project file, it +recompiles all sources of the project that need recompilation and rebuild the +library if any of the sources have been recompiled. It then groups all object +files into a single file, which is a shared or a static library. This library +can later on be linked with multiple executables. Note that the use +of shard libraries reduces the size of the final executable and can also reduce +the memory footprint at execution time when the library is shared among several +executables. + +It is also possible to build @b{multi-language libraries}. When using +@command{gprbuild} as a builder, multi-language library projects allow naturally +the creation of multi-language libraries . @command{gnatmake}, does n ot try to +compile non Ada sources. However, when the project is multi-language, it will +automatically link all object files found in the object directory, whether or +not they were compiled from an Ada source file. This specific behavior does not +apply to Ada-only projects which only take into account the objects +corresponding to the sources of the project. + +A non-library project can import a library project. When the builder is invoked +on the former, the library of the latter is only rebuilt when absolutely +necessary. For instance, if a unit of the +library is not up-to-date but non of the executables need this unit, then the +unit is not recompiled and the library is not reassembled. +For instance, let's assume in our example that logging has the following +sources: @file{log1.ads}, @file{log1.adb}, @file{log2.ads} and +@file{log2.adb}. If @file{log1.adb} has been modified, then the library +@file{liblogging} will be rebuilt when compiling all the sources of +@code{Build} only if @file{proc.ads}, @file{pack.ads} or @file{pack.adb} +include a @code{"with Log1"}. + +To ensure that all the sources in the @code{Logging} library are +up to date, and that all the sources of @code{Build} are also up to date, +the following two commands needs to be used: + +@smallexample +gnatmake -Plogging.gpr +gnatmake -Pbuild.gpr +@end smallexample + +@noindent +All @file{ALI} files will also be copied from the object directory to the +library directory. To build executables, @command{gnatmake} will use the +library rather than the individual object files. + +@ifclear vms +Library projects can also be useful to describe a library that need to be used +but, for some reason, cannot be rebuilt. For instance, it is the case when some +of the library sources are not available. Such library projects need simply to +use the @code{Externally_Built} attribute as in the example below: + +@smallexample @c projectfile +library project Extern_Lib is + for Languages use ("Ada", "C"); + for Source_Dirs use ("lib_src"); + for Library_Dir use "lib2"; + for Library_Kind use "dynamic"; + for Library_Name use "l2"; + for Externally_Built use "true"; -- <<<< +end Extern_Lib; +@end smallexample + +@noindent +In the case of externally built libraries, the @code{Object_Dir} +attribute does not need to be specified because it will never be +used. + +The main effect of using such an externally built library project is mostly to +affect the linker command in order to reference the desired library. It can +also be achieved by using @code{Linker.Linker_Options} or @code{Linker.Switches} +in the project corresponding to the subsystem needing this external library. +This latter method is more straightforward in simple cases but when several +subsystems depend upon the same external library, finding the proper place +for the @code{Linker.Linker_Options} might not be easy and if it is +not placed properly, the final link command is likely to present ordering issues. +In such a situation, it is better to use the externally built library project +so that all other subsystems depending on it can declare this dependency thanks +to a project @code{with} clause, which in turn will trigger the builder to find +the proper order of libraries in the final link command. +@end ifclear + +@c --------------------------------------------- +@node Stand-alone Library Projects +@subsection Stand-alone Library Projects +@c --------------------------------------------- + +@noindent +@cindex standalone libraries +A @b{stand-alone library} is a library that contains the necessary code to +elaborate the Ada units that are included in the library. A stand-alone +library is a convenient way to add an Ada subsystem to a more global system +whose main is not in Ada since it makes the elaboration of the Ada part mostly +transparent. However, stand-alone libraries are also useful when the main is in +Ada: they provide a means for minimizing relinking & redeployement of complex +systems when localized changes are made. + +The most proeminent characteristic of a stand-alone library is that it offers a +distinction between interface units and implementation units. Only the former +are visible to units outside the library. A stand-alone library project is thus +characterised by a third attribute, @b{Library_Interface}, in addition to the +two attributes that make a project a Library Project (@code{Library_Name} and +@code{Library_Dir}). + +@table @asis +@item @b{Library_Interface}: +@cindex @code{Library_Interface} + This attribute defines an explicit subset of the units of the project. + Projects importing this library project may only "with" units whose sources + are listed in the @code{Library_Interface}. Other sources are considered + implementation units. + +@smallexample @c projectfile +@group + for Library_Dir use "lib"; + for Library_Name use "loggin"; + for Library_Interface use ("lib1", "lib2"); -- unit names +@end group +@end smallexample + +@end table + +In order to include the elaboration code in the stand-alone library, the binder +is invoked on the closure of the library units creating a package whose name +depends on the library name (^b~logging.ads/b^B$LOGGING.ADS/B^ in the example). +This binder-generated package includes @b{initialization} and @b{finalization} +procedures whose names depend on the library name (@code{logginginit} and +@code{loggingfinal} in the example). The object corresponding to this package is +included in the library. + +@table @asis +@item @b{Library_Auto_Init}: +@cindex @code{Library_Auto_Init} + A dynamic stand-alone Library is automatically initialized + if automatic initialization of Stand-alone Libraries is supported on the + platform and if attribute @b{Library_Auto_Init} is not specified or + is specified with the value "true". A static Stand-alone Library is never + automatically initialized. Specifying "false" for this attribute + prevent automatic initialization. + + When a non-automatically initialized stand-alone library is used in an + executable, its initialization procedure must be called before any service of + the library is used. When the main subprogram is in Ada, it may mean that the + initialization procedure has to be called during elaboration of another + package. + +@item @b{Library_Dir}: +@cindex @code{Library_Dir} + For a stand-alone library, only the @file{ALI} files of the interface units + (those that are listed in attribute @code{Library_Interface}) are copied to + the library directory. As a consequence, only the interface units may be + imported from Ada units outside of the library. If other units are imported, + the binding phase will fail. + +@item @b{Binder.Default_Switches}: + When a stand-alone library is bound, the switches that are specified in + the attribute @b{Binder.Default_Switches ("Ada")} are + used in the call to @command{gnatbind}. + +@item @b{Library_Options}: +@cindex @code{Library_Options} + This attribute may be used to specified additional switches to @command{gcc} + when linking the library. + +@item @b{Library_Src_Dir}: +@cindex @code{Library_Src_Dir} + This attribute defines the location (absolute or relative to the project + directory) where the sources of the interface units are copied at + installation time. + These sources includes the specs of the interface units along with the closure + of sources necessary to compile them successfully. That may include bodies and + subunits, when pragmas @code{Inline} are used, or when there is a generic + units in the spec. This directory cannot point to the object directory or + one of the source directories, but it can point to the library directory, + which is the default value for this attribute. + +@item @b{Library_Symbol_Policy}: +@cindex @code{Library_Symbol_Policy} + This attribute controls the export of symbols and, on some platforms (like + VMS) that have the notions of major and minor IDs built in the library + files, it controls the setting of these IDs. It is not supported on all + platforms (where it will just have no effect). It may have one of the + following values: + + @itemize - + @item @code{"autonomous"} or @code{"default"}: exported symbols are not controlled + @item @code{"compliant"}: if attribute @b{Library_Reference_Symbol_File} + is not defined, then it is equivalent to policy "autonomous". If there + are exported symbols in the reference symbol file that are not in the + object files of the interfaces, the major ID of the library is increased. + If there are symbols in the object files of the interfaces that are not + in the reference symbol file, these symbols are put at the end of the list + in the newly created symbol file and the minor ID is increased. + @item @code{"controlled"}: the attribute @b{Library_Reference_Symbol_File} must be + defined. The library will fail to build if the exported symbols in the + object files of the interfaces do not match exactly the symbol in the + symbol file. + @item @code{"restricted"}: The attribute @b{Library_Symbol_File} must be defined. + The library will fail to build if there are symbols in the symbol file that + are not in the exported symbols of the object files of the interfaces. + Additional symbols in the object files are not added to the symbol file. + @item @code{"direct"}: The attribute @b{Library_Symbol_File} must be defined and + must designate an existing file in the object directory. This symbol file + is passed directly to the underlying linker without any symbol processing. + + @end itemize + +@item @b{Library_Reference_Symbol_File} +@cindex @code{Library_Reference_Symbol_File} + This attribute may define the path name of a reference symbol file that is + read when the symbol policy is either "compliant" or "controlled", on + platforms that support symbol control, such as VMS, when building a + stand-alone library. The path may be an absolute path or a path relative + to the project directory. + +@item @b{Library_Symbol_File} +@cindex @code{Library_Symbol_File} + This attribute may define the name of the symbol file to be created when + building a stand-alone library when the symbol policy is either "compliant", + "controlled" or "restricted", on platforms that support symbol control, + such as VMS. When symbol policy is "direct", then a file with this name + must exist in the object directory. +@end table + + +@c --------------------------------------------- +@node Installing a library with project files +@subsection Installing a library with project files +@c --------------------------------------------- + +@noindent +When using project files, library installation is part of the library build +process. Thus no further action is needed in order to make use of the +libraries that are built as part of the general application build. A usable +version of the library is installed in the directory specified by the +@code{Library_Dir} attribute of the library project file. + +You may want to install a library in a context different from where the library +is built. This situation arises with third party suppliers, who may want +to distribute a library in binary form where the user is not expected to be +able to recompile the library. The simplest option in this case is to provide +a project file slightly different from the one used to build the library, by +using the @code{externally_built} attribute. @ref{Using Library Projects} + +@c --------------------------------------------- +@node Project Extension +@section Project Extension +@c --------------------------------------------- + +@noindent +During development of a large system, it is sometimes necessary to use +modified versions of some of the source files, without changing the original +sources. This can be achieved through the @b{project extension} facility. + +Suppose for instance that our example @code{Build} project is build every night +for the whole team, in some shared directory. A developer usually need to work +on a small part of the system, and might not want to have a copy of all the +sources and all the object files (mostly because that would require too much +disk space, time to recompile everything). He prefers to be able to override +some of the source files in his directory, while taking advantage of all the +object files generated at night. + +Another example can be taken from large software systems, where it is common to have +multiple implementations of a common interface; in Ada terms, multiple +versions of a package body for the same spec. For example, one implementation +might be safe for use in tasking programs, while another might only be used +in sequential applications. This can be modeled in GNAT using the concept +of @emph{project extension}. If one project (the ``child'') @emph{extends} +another project (the ``parent'') then by default all source files of the +parent project are inherited by the child, but the child project can +override any of the parent's source files with new versions, and can also +add new files or remove unnecessary ones. +This facility is the project analog of a type extension in +object-oriented programming. Project hierarchies are permitted (an extending +project may itself be extended), and a project that +extends a project can also import other projects. + +A third example is that of using project extensions to provide different +versions of the same system. For instance, assume that a @code{Common} +project is used by two development branches. One of the branches has now +been frozen, and no further change can be done to it or to @code{Common}. +However, the other development branch still needs evolution of @code{Common}. +Project extensions provide a flexible solution to create a new version +of a subsystem while sharing and reusing as much as possible from the original +one. + +A project extension inherits implicitly all the sources and objects from the +project it extends. It is possible to create a new version of some of the +sources in one of the additional source dirs of the extending project. Those new +versions hide the original versions. Adding new sources or removing existing +ones is also possible. Here is an example on how to extend the project +@code{Build} from previous examples: + +@smallexample @c projectfile + project Work extends "../bld/build.gpr" is + end Work; +@end smallexample + +@noindent +The project after @b{extends} is the one being extended. As usual, it can be +specified using an absolute path, or a path relative to any of the directories +in the project path (@pxref{Project Dependencies}). This project does not +specify source or object directories, so the default value for these attribute +will be used that is to say the current directory (where project @code{Work} is +placed). We can already compile that project with + +@smallexample + gnatmake -Pwork +@end smallexample + +@noindent +If no sources have been placed in the current directory, this command +won't do anything, since this project does not change the +sources it inherited from @code{Build}, therefore all the object files +in @code{Build} and its dependencies are still valid and are reused +automatically. + +Suppose we now want to supply an alternate version of @file{pack.adb} +but use the existing versions of @file{pack.ads} and @file{proc.adb}. +We can create the new file Work's current directory (likely +by copying the one from the @code{Build} project and making changes to +it. If new packages are needed at the same time, we simply create +new files in the source directory of the extending project. + +When we recompile, @command{gnatmake} will now automatically recompile +this file (thus creating @file{pack.o} in the current directory) and +any file that depends on it (thus creating @file{proc.o}). Finally, the +executable is also linked locally. + +Note that we could have obtained the desired behavior using project import +rather than project inheritance. A @code{base} project would contain the +sources for @file{pack.ads} and @file{proc.adb}, and @code{Work} would +import @code{base} and add @file{pack.adb}. In this scenario, @code{base} +cannot contain the original version of @file{pack.adb} otherwise there would be +2 versions of the same unit in the closure of the project and this is not +allowed. Generally speaking, it is not recommended to put the spec and the +body of a unit in different projects since this affects their autonomy and +reusability. + +In a project file that extends another project, it is possible to +indicate that an inherited source is @b{not part} of the sources of the +extending project. This is necessary sometimes when a package spec has +been overridden and no longer requires a body: in this case, it is +necessary to indicate that the inherited body is not part of the sources +of the project, otherwise there will be a compilation error +when compiling the spec. + +@cindex @code{Excluded_Source_Files} +@cindex @code{Excluded_Source_List_File} +For that purpose, the attribute @b{Excluded_Source_Files} is used. +Its value is a list of file names. +It is also possible to use attribute @code{Excluded_Source_List_File}. +Its value is the path of a text file containing one file name per +line. + +@smallexample @c @projectfile +project Work extends "../bld/build.gpr" is + for Source_Files use ("pack.ads"); + -- New spec of Pkg does not need a completion + for Excluded_Source_Files use ("pack.adb"); +end Work; +@end smallexample + +@noindent +An extending project retains all the switches specified in the +extended project. + +@menu +* Project Hierarchy Extension:: +@end menu + +@c --------------------------------------------- +@node Project Hierarchy Extension +@subsection Project Hierarchy Extension +@c --------------------------------------------- + +@noindent +One of the fundamental restrictions in project extension is the following: +@b{A project is not allowed to import directly or indirectly at the same time an +extending project and one of its ancestors}. + +By means of example, consider the following hierarchy of projects. + +@smallexample + a.gpr contains package A1 + b.gpr, imports a.gpr and contains B1, which depends on A1 + c.gpr, imports b.gpr and contains C1, which depends on B1 +@end smallexample + +@noindent +If we want to locally extend the packages @code{A1} and @code{C1}, we need to +create several extending projects: + +@smallexample + a_ext.gpr which extends a.gpr, and overrides A1 + b_ext.gpr which extends b.gpr and imports a_ext.gpr + c_ext.gpr which extends c.gpr, imports b_ext.gpr and overrides C1 +@end smallexample + +@noindent +@smallexample @c projectfile + project A_Ext extends "a.gpr" is + for Source_Files use ("a1.adb", "a1.ads"); + end A_Ext; + + with "a_ext.gpr"; + project B_Ext extends "b.gpr" is + end B_Ext; + + with "b_ext.gpr"; + project C_Ext extends "c.gpr" is + for Source_Files use ("c1.adb"); + end C_Ext; +@end smallexample + +@noindent +The extension @file{b_ext.gpr} is required, even though we are not overriding +any of the sources of @file{b.gpr} because otherwise @file{c_expr.gpr} would +import @file{b.gpr} which itself knows nothing about @file{a_ext.gpr}. + +@cindex extends all +When extending a large system spanning multiple projects, it is often +inconvenient to extend every project in the hierarchy that is impacted by a +small change introduced in a low layer. In such cases, it is possible to create +an @b{implicit extension} of entire hierarchy using @b{extends all} +relationship. + +When the project is extended using @code{extends all} inheritance, all projects +that are imported by it, both directly and indirectly, are considered virtually +extended. That is, the project manager creates implicit projects +that extend every project in the hierarchy; all these implicit projects do not +control sources on their own and use the object directory of +the "extending all" project. + +It is possible to explicitly extend one or more projects in the hierarchy +in order to modify the sources. These extending projects must be imported by +the "extending all" project, which will replace the corresponding virtual +projects with the explicit ones. + +When building such a project hierarchy extension, the project manager will +ensure that both modified sources and sources in implicit extending projects +that depend on them, are recompiled. + +Thus, in our example we could create the following projects instead: + +@smallexample + a_ext.gpr, extends a.gpr and overrides A1 + c_ext.gpr, "extends all" c.gpr, imports a_ext.gpr and overrides C1 + +@end smallexample + +@noindent +@smallexample @c projectfile + project A_Ext extends "a.gpr" is + for Source_Files use ("a1.adb", "a1.ads"); + end A_Ext; + + with "a_ext.gpr"; + project C_Ext extends all "c.gpr" is + for Source_Files use ("c1.adb"); + end C_Ext; +@end smallexample + +@noindent +When building project @file{c_ext.gpr}, the entire modified project space is +considered for recompilation, including the sources of @file{b.gpr} that are +impacted by the changes in @code{A1} and @code{C1}. + +@c --------------------------------------------- +@node Project File Reference +@section Project File Reference +@c --------------------------------------------- + +@noindent +This section describes the syntactic structure of project files, the various +constructs that can be used. Finally, it ends with a summary of all available +attributes. + +@menu +* Project Declaration:: +* Qualified Projects:: +* Declarations:: +* Packages:: +* Expressions:: +* External Values:: +* Typed String Declaration:: +* Variables:: +* Attributes:: +* Case Statements:: +@end menu + +@c --------------------------------------------- +@node Project Declaration +@subsection Project Declaration +@c --------------------------------------------- + +@noindent +Project files have an Ada-like syntax. The minimal project file is: + +@smallexample @c projectfile +@group +project Empty is +end Empty; +@end group +@end smallexample + +@noindent +The identifier @code{Empty} is the name of the project. +This project name must be present after the reserved +word @code{end} at the end of the project file, followed by a semi-colon. + +@b{Identifiers} (ie the user-defined names such as project or variable names) +have the same syntax as Ada identifiers: they must start with a letter, +and be followed by zero or more letters, digits or underscore characters; +it is also illegal to have two underscores next to each other. Identifiers +are always case-insensitive ("Name" is the same as "name"). + +@smallexample +simple_name ::= identifier +name ::= simple_name @{ . simple_name @} +@end smallexample + +@noindent +@b{Strings} are used for values of attributes or as indexes for these +attributes. They are in general case sensitive, except when noted +otherwise (in particular, strings representing file names will be case +insensitive on some systems, so that "file.adb" and "File.adb" both +represent the same file). + +@b{Reserved words} are the same as for standard Ada 95, and cannot +be used for identifiers. In particular, the following words are currently +used in project files, but others could be added later on. In bold are the +extra reserved words in project files: @code{all, at, case, end, for, is, +limited, null, others, package, renames, type, use, when, with, @b{extends}, +@b{external}, @b{project}}. + +@b{Comments} in project files have the same syntax as in Ada, two consecutive +hyphens through the end of the line. + +A project may be an @b{independent project}, entirely defined by a single +project file. Any source file in an independent project depends only +on the predefined library and other source files in the same project. +But a project may also depend on other projects, either by importing them +through @b{with clauses}, or by @b{extending} at most one other project. Both +types of dependency can be used in the same project. + +A path name denotes a project file. It can be absolute or relative. +An absolute path name includes a sequence of directories, in the syntax of +the host operating system, that identifies uniquely the project file in the +file system. A relative path name identifies the project file, relative +to the directory that contains the current project, or relative to a +directory listed in the environment variables ADA_PROJECT_PATH and +GPR_PROJECT_PATH. Path names are case sensitive if file names in the host +operating system are case sensitive. As a special case, the directory +separator can always be "/" even on Windows systems, so that project files +can be made portable across architectures. +The syntax of the environment variable ADA_PROJECT_PATH and +GPR_PROJECT_PATH is a list of directory names separated by colons on UNIX and +semicolons on Windows. + +A given project name can appear only once in a context clause. + +It is illegal for a project imported by a context clause to refer, directly +or indirectly, to the project in which this context clause appears (the +dependency graph cannot contain cycles), except when one of the with clause +in the cycle is a @b{limited with}. +@c ??? Need more details here + +@smallexample @c projectfile +with "other_project.gpr"; +project My_Project extends "extended.gpr" is +end My_Project; +@end smallexample + +@noindent +These dependencies form a @b{directed graph}, potentially cyclic when using +@b{limited with}. The subprogram reflecting the @b{extends} relations is a +tree. + +A project's @b{immediate sources} are the source files directly defined by +that project, either implicitly by residing in the project source directories, +or explicitly through any of the source-related attributes. +More generally, a project sources are the immediate sources of the project +together with the immediate sources (unless overridden) of any +project on which it depends directly or indirectly. + +A @b{project hierarchy} can be created, where projects are children of +other projects. The name of such a child project must be @code{Parent.Child}, +where @code{Parent} is the name of the parent project. In particular, this +makes all @code{with} clauses of the parent project automatically visible +in the child project. + +@smallexample +project ::= context_clause project_declaration + +context_clause ::= @{with_clause@} +with_clause ::= @i{with} path_name @{ , path_name @} ; +path_name ::= string_literal + +project_declaration ::= simple_project_declaration | project_extension +simple_project_declaration ::= + @i{project} @i{}name @i{is} + @{declarative_item@} + @i{end} simple_name; +@end smallexample + +@c --------------------------------------------- +@node Qualified Projects +@subsection Qualified Projects +@c --------------------------------------------- + +@noindent +Before the reserved @code{project}, there may be one or two @b{qualifiers}, that +is identifiers or reserved words, to qualify the project. +The current list of qualifiers is: + +@table @asis +@item @b{abstract}: qualifies a project with no sources. Such a + project must either have no declaration of attributes @code{Source_Dirs}, + @code{Source_Files}, @code{Languages} or @code{Source_List_File}, or one of + @code{Source_Dirs}, @code{Source_Files}, or @code{Languages} must be declared + as empty. If it extends another project, the project it extends must also be a + qualified abstract project. +@item @b{standard}: a standard project is a non library project with sources. + This is the default (implicit) qualifier. +@item @b{aggregate}: for future extension +@item @b{aggregate library}: for future extension +@item @b{library}: a library project must declare both attributes + @code{Library_Name} and @code{Library_Dir}. +@item @b{configuration}: a configuration project cannot be in a project tree. + It describes compilers and other tools to @code{gprbuild}. +@end table + + +@c --------------------------------------------- +@node Declarations +@subsection Declarations +@c --------------------------------------------- + +@noindent +Declarations introduce new entities that denote types, variables, attributes, +and packages. Some declarations can only appear immediately within a project +declaration. Others can appear within a project or within a package. + +@smallexample +declarative_item ::= simple_declarative_item + | typed_string_declaration + | package_declaration + +simple_declarative_item ::= variable_declaration + | typed_variable_declaration + | attribute_declaration + | case_construction + | empty_declaration + +empty_declaration ::= @i{null} ; +@end smallexample + +@noindent +An empty declaration is allowed anywhere a declaration is allowed. It has +no effect. + +@c --------------------------------------------- +@node Packages +@subsection Packages +@c --------------------------------------------- + +@noindent +A project file may contain @b{packages}, that group attributes (typically +all the attributes that are used by one of the GNAT tools). + +A package with a given name may only appear once in a project file. +The following packages are currently supported in project files +(See @pxref{Attributes} for the list of attributes that each can contain). + +@table @code +@item Binder + This package specifies characteristics useful when invoking the binder either + directly via the @command{gnat} driver or when using a builder such as + @command{gnatmake} or @command{gprbuild}. @xref{Main Subprograms}. +@item Builder + This package specifies the compilation options used when building an + executable or a library for a project. Most of the options should be + set in one of @code{Compiler}, @code{Binder} or @code{Linker} packages, + but there are some general options that should be defined in this + package. @xref{Main Subprograms}, and @pxref{Executable File Names} in + particular. +@item Check + This package specifies the options used when calling the checking tool + @command{gnatcheck} via the @command{gnat} driver. Its attribute + @b{Default_Switches} has the same semantics as for the package + @code{Builder}. The first string should always be @code{-rules} to specify + that all the other options belong to the @code{-rules} section of the + parameters to @command{gnatcheck}. +@item Compiler + This package specifies the compilation options used by the compiler for + each languages. @xref{Tools Options in Project Files}. +@item Cross_Reference + This package specifies the options used when calling the library tool + @command{gnatxref} via the @command{gnat} driver. Its attributes + @b{Default_Switches} and @b{Switches} have the same semantics as for the + package @code{Builder}. +@item Eliminate + This package specifies the options used when calling the tool + @command{gnatelim} via the @command{gnat} driver. Its attributes + @b{Default_Switches} and @b{Switches} have the same semantics as for the + package @code{Builder}. +@item Finder + This package specifies the options used when calling the search tool + @command{gnatfind} via the @command{gnat} driver. Its attributes + @b{Default_Switches} and @b{Switches} have the same semantics as for the + package @code{Builder}. +@item Gnatls + This package the options to use when invoking @command{gnatls} via the + @command{gnat} driver. +@item Gnatstub + This package specifies the options used when calling the tool + @command{gnatstub} via the @command{gnat} driver. Its attributes + @b{Default_Switches} and @b{Switches} have the same semantics as for the + package @code{Builder}. +@item IDE + This package specifies the options used when starting an integrated + development environment, for instance @command{GPS} or @command{Gnatbench}. + @xref{The Development Environments}. +@item Linker + This package specifies the options used by the linker. + @xref{Main Subprograms}. +@item Metrics + This package specifies the options used when calling the tool + @command{gnatmetric} via the @command{gnat} driver. Its attributes + @b{Default_Switches} and @b{Switches} have the same semantics as for the + package @code{Builder}. +@item Naming + This package specifies the naming conventions that apply + to the source files in a project. In particular, these conventions are + used to automatically find all source files in the source directories, + or given a file name to find out its language for proper processing. + @xref{Naming Schemes}. +@item Pretty_Printer + This package specifies the options used when calling the formatting tool + @command{gnatpp} via the @command{gnat} driver. Its attributes + @b{Default_Switches} and @b{Switches} have the same semantics as for the + package @code{Builder}. +@item Stack + This package specifies the options used when calling the tool + @command{gnatstack} via the @command{gnat} driver. Its attributes + @b{Default_Switches} and @b{Switches} have the same semantics as for the + package @code{Builder}. +@item Synchronize + This package specifies the options used when calling the tool + @command{gnatsync} via the @command{gnat} driver. + +@end table + +In its simplest form, a package may be empty: + +@smallexample @c projectfile +@group +project Simple is + package Builder is + end Builder; +end Simple; +@end group +@end smallexample + +@noindent +A package may contain @b{attribute declarations}, +@b{variable declarations} and @b{case constructions}, as will be +described below. + +When there is ambiguity between a project name and a package name, +the name always designates the project. To avoid possible confusion, it is +always a good idea to avoid naming a project with one of the +names allowed for packages or any name that starts with @code{gnat}. + +A package can also be defined by a @b{renaming declaration}. The new package +renames a package declared in a different project file, and has the same +attributes as the package it renames. The name of the renamed package +must be the same as the name of the renaming package. The project must +contain a package declaration with this name, and the project +must appear in the context clause of the current project, or be its parent +project. It is not possible to add or override attributes to the renaming +project. If you need to do so, you should declare a standard package, and +assign the value of the attributes one by one (@code{for Switches ("Ada") +use Other_Project.Compiler'Switches ("Ada")}). + +Packages that are renamed in other project files often come from project files +that have no sources: they are just used as templates. Any modification in the +template will be reflected automatically in all the project files that rename +a package from the template. This is a very common way to share settings +between projects. + +@smallexample +package_declaration ::= package_spec | package_renaming +package_spec ::= + @i{package} @i{}simple_name @i{is} + @{simple_declarative_item@} + @i{end} package_identifier ; +package_renaming ::== + @i{package} @i{}simple_name @i{renames} @i{}simple_name.package_identifier ; +@end smallexample + +@c --------------------------------------------- +@node Expressions +@subsection Expressions +@c --------------------------------------------- + +@noindent +An expression is any value that can be assigned to an attribute or a +variable. It is either a litteral value, or a construct requiring runtime +computation by the project manager. In a project file, the computed value of +an expression is either a string or a list of strings. + +A string value is one of: +@itemize @bullet +@item A literal string, for instance @code{"comm/my_proj.gpr"} +@item The name of a variable that evaluates to a string (@pxref{Variables}) +@item The name of an attribute that evaluates to a string (@pxref{Attributes}) +@item An external reference (@pxref{External Values}) +@item A concatenation of the above, as in @code{"prefix_" & Var}. + +@end itemize + +@noindent +A list of strings is one of the following: + +@itemize @bullet +@item A parenthesized comma-separated list of zero or more string expressions, for + instance @code{(File_Name, "gnat.adc", File_Name & ".orig")} or @code{()}. +@item The name of a variable that evaluates to a list of strings +@item The name of an attribute that evaluates to a list of strings +@item A concatenation of a list of strings and a string (as defined above), for + instance @code{("A", "B") & "C"} +@item A concatenation of two lists of strings + +@end itemize + +@noindent +The following is the grammar for expressions + +@smallexample +string_literal ::= "@{string_element@}" -- Same as Ada +string_expression ::= string_literal + | @i{variable_}name + | external_value + | attribute_reference + | ( string_expression @{ & string_expression @} ) +string_list ::= ( string_expression @{ , string_expression @} ) + | @i{string_variable}_name + | @i{string_}attribute_reference +term ::= string_expression | string_list +expression ::= term @{ & term @} -- Concatenation +@end smallexample + +@noindent +Concatenation involves strings and list of strings. As soon as a list of +strings is involved, the result of the concatenation is a list of strings. The +following Ada declarations show the existing operators: + +@smallexample @c ada + function "&" (X : String; Y : String) return String; + function "&" (X : String_List; Y : String) return String_List; + function "&" (X : String_List; Y : String_List) return String_List; +@end smallexample + +@noindent +Here are some specific examples: + +@smallexample @c projectfile +@group + List := () & File_Name; -- One string in this list + List2 := List & (File_Name & ".orig"); -- Two strings + Big_List := List & Lists2; -- Three strings + Illegal := "gnat.adc" & List2; -- Illegal, must start with list +@end group +@end smallexample + +@c --------------------------------------------- +@node External Values +@subsection External Values +@c --------------------------------------------- + +@noindent +An external value is an expression whose value is obtained from the command +that invoked the processing of the current project file (typically a +gnatmake or gprbuild command). + +@smallexample +external_value ::= @i{external} ( string_literal [, string_literal] ) +@end smallexample + +@noindent +The first string_literal is the string to be used on the command line or +in the environment to specify the external value. The second string_literal, +if present, is the default to use if there is no specification for this +external value either on the command line or in the environment. + +Typically, the external value will either exist in the +^environment variables^logical name^ +or be specified on the command line through the +@option{^-X^/EXTERNAL_REFERENCE=^@emph{vbl}=@emph{value}} switch. If both +are specified, then the command line value is used, so that a user can more +easily override the value. + +The function @code{external} always returns a string, possibly empty if the +value was not found in the environment and no default was specified in the +call to @code{external}. + +An external reference may be part of a string expression or of a string +list expression, and can therefore appear in a variable declaration or +an attribute declaration. + +Most of the time, this construct is used to initialize typed variables, which +are then used in @b{case} statements to control the value assigned to +attributes in various scenarios. Thus such variables are often called +@b{scenario variables}. + +@c --------------------------------------------- +@node Typed String Declaration +@subsection Typed String Declaration +@c --------------------------------------------- + +@noindent +A @b{type declaration} introduces a discrete set of string literals. +If a string variable is declared to have this type, its value +is restricted to the given set of literals. These are the only named +types in project files. A string type may only be declared at the project +level, not inside a package. + +@smallexample +typed_string_declaration ::= + @i{type} @i{}_simple_name @i{is} ( string_literal @{, string_literal@} ); +@end smallexample + +@noindent +The string literals in the list are case sensitive and must all be different. +They may include any graphic characters allowed in Ada, including spaces. +Here is an example of a string type declaration: + +@smallexample @c projectfile + type OS is ("NT", "nt", "Unix", "GNU/Linux", "other OS"); +@end smallexample + +@noindent +Variables of a string type are called @b{typed variables}; all other +variables are called @b{untyped variables}. Typed variables are +particularly useful in @code{case} constructions, to support conditional +attribute declarations. (@pxref{Case Statements}). + +A string type may be referenced by its name if it has been declared in the same +project file, or by an expanded name whose prefix is the name of the project +in which it is declared. + +@c --------------------------------------------- +@node Variables +@subsection Variables +@c --------------------------------------------- + +@noindent +@b{Variables} store values (strings or list of strings) and can appear +as part of an expression. The declaration of a variable creates the +variable and assigns the value of the expression to it. The name of the +variable is available immediately after the assignment symbol, if you +need to reuse its old value to compute the new value. Before the completion +of its first declaration, the value of a variable defaults to the empty +string (""). + +A @b{typed} variable can be used as part of a @b{case} expression to +compute the value, but it can only be declared once in the project file, +so that all case statements see the same value for the variable. This +provides more consistency and makes the project easier to understand. +The syntax for its declaration is identical to the Ada syntax for an +object declaration. In effect, a typed variable acts as a constant. + +An @b{untyped} variable can be declared and overridden multiple times +within the same project. It is declared implicitly through an Ada +assignment. The first declaration establishes the kind of the variable +(string or list of strings) and successive declarations must respect +the initial kind. Assignments are executed in the order in which they +appear, so the new value replaces the old one and any subsequent reference +to the variable uses the new value. + +A variable may be declared at the project file level, or within a package. + +@smallexample +typed_variable_declaration ::= + @i{}simple_name : @i{}name := string_expression; +variable_declaration ::= @i{}simple_name := expression; +@end smallexample + +@noindent +Here are some examples of variable declarations: + +@smallexample @c projectfile +@group + This_OS : OS := external ("OS"); -- a typed variable declaration + That_OS := "GNU/Linux"; -- an untyped variable declaration + + Name := "readme.txt"; + Save_Name := Name & ".saved"; + + Empty_List := (); + List_With_One_Element := ("-gnaty"); + List_With_Two_Elements := List_With_One_Element & "-gnatg"; + Long_List := ("main.ada", "pack1_.ada", "pack1.ada", "pack2_.ada"); +@end group +@end smallexample + +@noindent +A @b{variable reference} may take several forms: + +@itemize @bullet +@item The simple variable name, for a variable in the current package (if any) + or in the current project +@item An expanded name, whose prefix is a context name. + +@end itemize + +@noindent +A @b{context} may be one of the following: + +@itemize @bullet +@item The name of an existing package in the current project +@item The name of an imported project of the current project +@item The name of an ancestor project (i.e., a project extended by the current + project, either directly or indirectly) +@item An expanded name whose prefix is an imported/parent project name, and + whose selector is a package name in that project. +@end itemize + + +@c --------------------------------------------- +@node Attributes +@subsection Attributes +@c --------------------------------------------- + +@noindent +A project (and its packages) may have @b{attributes} that define +the project's properties. Some attributes have values that are strings; +others have values that are string lists. + +@smallexample +attribute_declaration ::= + simple_attribute_declaration | indexed_attribute_declaration +simple_attribute_declaration ::= @i{for} attribute_designator @i{use} expression ; +indexed_attribute_declaration ::= + @i{for} @i{}simple_name ( string_literal) @i{use} expression ; +attribute_designator ::= + @i{}simple_name + | @i{}simple_name ( string_literal ) +@end smallexample + +@noindent +There are two categories of attributes: @b{simple attributes} +and @b{indexed attributes}. +Each simple attribute has a default value: the empty string (for string +attributes) and the empty list (for string list attributes). +An attribute declaration defines a new value for an attribute, and overrides +the previous value. The syntax of a simple attribute declaration is similar to +that of an attribute definition clause in Ada. + +Some attributes are indexed. These attributes are mappings whose +domain is a set of strings. They are declared one association +at a time, by specifying a point in the domain and the corresponding image +of the attribute. +Like untyped variables and simple attributes, indexed attributes +may be declared several times. Each declaration supplies a new value for the +attribute, and replaces the previous setting. + +Here are some examples of attribute declarations: + +@smallexample @c projectfile + -- simple attributes + for Object_Dir use "objects"; + for Source_Dirs use ("units", "test/drivers"); + + -- indexed attributes + for Body ("main") use "Main.ada"; + for Switches ("main.ada") use ("-v", "-gnatv"); + for Switches ("main.ada") use Builder'Switches ("main.ada") & "-g"; + + -- indexed attributes copy (from package Builder in project Default) + -- The package name must always be specified, even if it is the current + -- package. + for Default_Switches use Default.Builder'Default_Switches; +@end smallexample + +@noindent +Attributes references may be appear anywhere in expressions, and are used +to retrieve the value previously assigned to the attribute. If an attribute +has not been set in a given package or project, its value defaults to the +empty string or the empty list. + +@smallexample +attribute_reference ::= attribute_prefix ' @i{_}simple_name [ (string_literal) ] +attribute_prefix ::= @i{project} + | @i{}simple_name + | package_identifier + | @i{}simple_name . package_identifier +@end smallexample + +@noindent +Examples are: + +@smallexample @c projectfile + project'Object_Dir + Naming'Dot_Replacement + Imported_Project'Source_Dirs + Imported_Project.Naming'Casing + Builder'Default_Switches ("Ada") +@end smallexample + +@noindent +The prefix of an attribute may be: + +@itemize @bullet +@item @code{project} for an attribute of the current project +@item The name of an existing package of the current project +@item The name of an imported project +@item The name of a parent project that is extended by the current project +@item An expanded name whose prefix is imported/parent project name, + and whose selector is a package name + +@end itemize + +@noindent +Legal attribute names are listed below, including the package in +which they must be declared. These names are case-insensitive. The +semantics for the attributes is explained in great details in other sections. + +The column @emph{index} indicates whether the attribute is an indexed attribute, +and when it is whether its index is case sensitive (sensitive) or not (insensitive), or if case sensitivity depends is the same as file names sensitivity on the +system (file). The text is between brackets ([]) if the index is optional. + +@multitable @columnfractions .3 .1 .2 .4 +@headitem Attribute Name @tab Value @tab Package @tab Index +@headitem General attributes @tab @tab @tab @pxref{Building With Projects} +@item Name @tab string @tab - @tab (Read-only, name of project) +@item Project_Dir @tab string @tab - @tab (Read-only, directory of project) +@item Source_Files @tab list @tab - @tab - +@item Source_Dirs @tab list @tab - @tab - +@item Source_List_File @tab string @tab - @tab - +@item Locally_Removed_Files @tab list @tab - @tab - +@item Excluded_Source_Files @tab list @tab - @tab - +@item Object_Dir @tab string @tab - @tab - +@item Exec_Dir @tab string @tab - @tab - +@item Excluded_Source_Dirs @tab list @tab - @tab - +@item Excluded_Source_Files @tab list @tab - @tab - +@item Excluded_Source_List_File @tab list @tab - @tab - +@item Inherit_Source_Path @tab list @tab - @tab insensitive +@item Languages @tab list @tab - @tab - +@item Main @tab list @tab - @tab - +@item Main_Language @tab string @tab - @tab - +@item Externally_Built @tab string @tab - @tab - +@item Roots @tab list @tab - @tab file +@headitem + Library-related attributes @tab @tab @tab @pxref{Library Projects} +@item Library_Dir @tab string @tab - @tab - +@item Library_Name @tab string @tab - @tab - +@item Library_Kind @tab string @tab - @tab - +@item Library_Version @tab string @tab - @tab - +@item Library_Interface @tab string @tab - @tab - +@item Library_Auto_Init @tab string @tab - @tab - +@item Library_Options @tab list @tab - @tab - +@item Library_Src_Dir @tab string @tab - @tab - +@item Library_ALI_Dir @tab string @tab - @tab - +@item Library_GCC @tab string @tab - @tab - +@item Library_Symbol_File @tab string @tab - @tab - +@item Library_Symbol_Policy @tab string @tab - @tab - +@item Library_Reference_Symbol_File @tab string @tab - @tab - +@item Interfaces @tab list @tab - @tab - +@headitem + Naming @tab @tab @tab @pxref{Naming Schemes} +@item Spec_Suffix @tab string @tab Naming @tab insensitive (language) +@item Body_Suffix @tab string @tab Naming @tab insensitive (language) +@item Separate_Suffix @tab string @tab Naming @tab - +@item Casing @tab string @tab Naming @tab - +@item Dot_Replacement @tab string @tab Naming @tab - +@item Spec @tab string @tab Naming @tab insensitive (Ada unit) +@item Body @tab string @tab Naming @tab insensitive (Ada unit) +@item Specification_Exceptions @tab list @tab Naming @tab insensitive (language) +@item Implementation_Exceptions @tab list @tab Naming @tab insensitive (language) +@headitem + Building @tab @tab @tab @pxref{Switches and Project Files} +@item Default_Switches @tab list @tab Builder, Compiler, Binder, Linker, Cross_Reference, Finder, Pretty_Printer, gnatstub, Check, Synchronize, Eliminate, Metrics, IDE @tab insensitive (language name) +@item Switches @tab list @tab Builder, Compiler, Binder, Linker, Cross_Reference, Finder, gnatls, Pretty_Printer, gnatstub, Check, Synchronize, Eliminate, Metrics, Stack @tab [file] (file name) +@item Local_Configuration_Pragmas @tab string @tab Compiler @tab - +@item Local_Config_File @tab string @tab insensitive @tab - +@item Global_Configuration_Pragmas @tab list @tab Builder @tab - +@item Global_Compilation_Switches @tab list @tab Builder @tab language +@item Executable @tab string @tab Builder @tab [file] +@item Executable_Suffix @tab string @tab Builder @tab - +@item Global_Config_File @tab string @tab Builder @tab insensitive (language) +@headitem + IDE (used and created by GPS) @tab @tab @tab +@item Remote_Host @tab string @tab IDE @tab - +@item Program_Host @tab string @tab IDE @tab - +@item Communication_Protocol @tab string @tab IDE @tab - +@item Compiler_Command @tab string @tab IDE @tab insensitive (language) +@item Debugger_Command @tab string @tab IDE @tab - +@item Gnatlist @tab string @tab IDE @tab - +@item VCS_Kind @tab string @tab IDE @tab - +@item VCS_File_Check @tab string @tab IDE @tab - +@item VCS_Log_Check @tab string @tab IDE @tab - +@headitem + Configuration files @tab @tab @tab See gprbuild manual +@item Default_Language @tab string @tab - @tab - +@item Run_Path_Option @tab list @tab - @tab - +@item Run_Path_Origin @tab string @tab - @tab - +@item Separate_Run_Path_Options @tab string @tab - @tab - +@item Toolchain_Version @tab string @tab - @tab insensitive +@item Toolchain_Description @tab string @tab - @tab insensitive +@item Object_Generated @tab string @tab - @tab insensitive +@item Objects_Linked @tab string @tab - @tab insensitive +@item Target @tab string @tab - @tab - +@item Library_Builder @tab string @tab - @tab - +@item Library_Support @tab string @tab - @tab - +@item Archive_Builder @tab list @tab - @tab - +@item Archive_Builder_Append_Option @tab list @tab - @tab - +@item Archive_Indexer @tab list @tab - @tab - +@item Archive_Suffix @tab string @tab - @tab - +@item Library_Partial_Linker @tab list @tab - @tab - +@item Shared_Library_Prefix @tab string @tab - @tab - +@item Shared_Library_Suffix @tab string @tab - @tab - +@item Symbolic_Link_Supported @tab string @tab - @tab - +@item Library_Major_Minor_Id_Supported @tab string @tab - @tab - +@item Library_Auto_Init_Supported @tab string @tab - @tab - +@item Shared_Library_Minimum_Switches @tab list @tab - @tab - +@item Library_Version_Switches @tab list @tab - @tab - +@item Library_Install_Name_Option @tab string @tab - @tab - +@item Runtime_Library_Dir @tab string @tab - @tab insensitive +@item Runtime_Source_Dir @tab string @tab - @tab insensitive +@item Driver @tab string @tab Compiler,Binder,Linker @tab insensitive (language) +@item Required_Switches @tab list @tab Compiler,Binder,Linker @tab insensitive (language) +@item Leading_Required_Switches @tab list @tab Compiler @tab insensitive (language) +@item Trailing_Required_Switches @tab list @tab Compiler @tab insensitive (language) +@item Pic_Options @tab list @tab Compiler @tab insensitive (language) +@item Path_Syntax @tab string @tab Compiler @tab insensitive (language) +@item Object_File_Suffix @tab string @tab Compiler @tab insensitive (language) +@item Object_File_Switches @tab list @tab Compiler @tab insensitive (language) +@item Multi_Unit_Switches @tab list @tab Compiler @tab insensitive (language) +@item Multi_Unit_Object_Separator @tab string @tab Compiler @tab insensitve (language) +@item Mapping_File_Switches @tab list @tab Compiler @tab insensitive (language) +@item Mapping_Spec_Suffix @tab string @tab Compiler @tab insensitive (language) +@item Mapping_body_Suffix @tab string @tab Compiler @tab insensitive (language) +@item Config_File_Switches @tab list @tab Compiler @tab insensitive (language) +@item Config_Body_File_Name @tab string @tab Compiler @tab insensitive (language) +@item Config_Body_File_Name_Index @tab string @tab Compiler @tab insensitive (language) +@item Config_Body_File_Name_Pattern @tab string @tab Compiler @tab insensitive (language) +@item Config_Spec_File_Name @tab string @tab Compiler @tab insensitive (language) +@item Config_Spec_File_Name_Index @tab string @tab Compiler @tab insensitive (language) +@item Config_Spec_File_Name_Pattern @tab string @tab Compiler @tab insensitive (language) +@item Config_File_Unique @tab string @tab Compiler @tab insensitive (language) +@item Dependency_Switches @tab list @tab Compiler @tab insensitive (language) +@item Dependency_Driver @tab list @tab Compiler @tab insensitive (language) +@item Include_Switches @tab list @tab Compiler @tab insensitive (language) +@item Include_Path @tab string @tab Compiler @tab insensitive (language) +@item Include_Path_File @tab string @tab Compiler @tab insensitive (language) +@item Prefix @tab string @tab Binder @tab insensitive (language) +@item Objects_Path @tab string @tab Binder @tab insensitive (language) +@item Objects_Path_File @tab string @tab Binder @tab insensitive (language) +@item Linker_Options @tab list @tab Linker @tab - +@item Map_File_Options @tab string @tab Linker @tab - +@item Executable_Switches @tab list @tab Linker @tab - +@item Lib_Dir_Switch @tab string @tab Linker @tab - +@item Lib_Name_Switch @tab string @tab Linker @tab - +@item Max_Command_Line_Length @tab string @tab Linker @tab - +@item Response_File_Format @tab string @tab Linker @tab - +@item Response_File_Switches @tab list @tab Linker @tab - +@end multitable + +@c --------------------------------------------- +@node Case Statements +@subsection Case Statements +@c --------------------------------------------- + +@noindent +A @b{case} statement is used in a project file to effect conditional +behavior. Through this statement, you can set the value of attributes +and variables depending on the value previously assigned to a typed +variable. + +All choices in a choice list must be distinct. Unlike Ada, the choice +lists of all alternatives do not need to include all values of the type. +An @code{others} choice must appear last in the list of alternatives. + +The syntax of a @code{case} construction is based on the Ada case statement +(although the @code{null} statement for empty alternatives is optional). + +The case expression must be a typed string variable, whose value is often +given by an external reference (@pxref{External Values}). + +Each alternative starts with the reserved word @code{when}, either a list of +literal strings separated by the @code{"|"} character or the reserved word +@code{others}, and the @code{"=>"} token. +Each literal string must belong to the string type that is the type of the +case variable. +After each @code{=>}, there are zero or more statements. The only +statements allowed in a case construction are other case statements, +attribute declarations and variable declarations. String type declarations and +package declarations are not allowed. Variable declarations are restricted to +variables that have already been declared before the case construction. + +@smallexample +case_statement ::= + @i{case} @i{}name @i{is} @{case_item@} @i{end case} ; + +case_item ::= + @i{when} discrete_choice_list => + @{case_statement + | attribute_declaration + | variable_declaration + | empty_declaration@} + +discrete_choice_list ::= string_literal @{| string_literal@} | @i{others} +@end smallexample + +@noindent +Here is a typical example: + +@smallexample @c projectfile +@group +project MyProj is + type OS_Type is ("GNU/Linux", "Unix", "NT", "VMS"); + OS : OS_Type := external ("OS", "GNU/Linux"); + + package Compiler is + case OS is + when "GNU/Linux" | "Unix" => + for Switches ("Ada") use ("-gnath"); + when "NT" => + for Switches ("Ada") use ("-gnatP"); + when others => + null; + end case; + end Compiler; +end MyProj; +@end group +@end smallexample + +@c --------------------------------------------- +@node Tools Supporting Project Files +@chapter Tools Supporting Project Files +@c --------------------------------------------- + +@noindent + + +@menu +* gnatmake and Project Files:: +* The GNAT Driver and Project Files:: +* The Development Environments:: +* Cleaning up with GPRclean:: +@end menu + +@c --------------------------------------------- +@node gnatmake and Project Files +@section gnatmake and Project Files +@c --------------------------------------------- + +@noindent +This section covers several topics related to @command{gnatmake} and +project files: defining ^switches^switches^ for @command{gnatmake} +and for the tools that it invokes; specifying configuration pragmas; +the use of the @code{Main} attribute; building and rebuilding library project +files. + +@menu +* Switches Related to Project Files:: +* Switches and Project Files:: +* Specifying Configuration Pragmas:: +* Project Files and Main Subprograms:: +* Library Project Files:: +@end menu + +@c --------------------------------------------- +@node Switches Related to Project Files +@subsection Switches Related to Project Files +@c --------------------------------------------- + +@noindent +The following switches are used by GNAT tools that support project files: + +@table @option + +@item ^-P^/PROJECT_FILE=^@var{project} +@cindex @option{^-P^/PROJECT_FILE^} (any project-aware tool) +Indicates the name of a project file. This project file will be parsed with +the verbosity indicated by @option{^-vP^MESSAGE_PROJECT_FILES=^@emph{x}}, +if any, and using the external references indicated +by @option{^-X^/EXTERNAL_REFERENCE^} switches, if any. +@ifclear vms +There may zero, one or more spaces between @option{-P} and @var{project}. +@end ifclear + +There must be only one @option{^-P^/PROJECT_FILE^} switch on the command line. + +Since the Project Manager parses the project file only after all the switches +on the command line are checked, the order of the switches +@option{^-P^/PROJECT_FILE^}, +@option{^-vP^/MESSAGES_PROJECT_FILE=^@emph{x}} +or @option{^-X^/EXTERNAL_REFERENCE^} is not significant. + +@item ^-X^/EXTERNAL_REFERENCE=^@var{name=value} +@cindex @option{^-X^/EXTERNAL_REFERENCE^} (any project-aware tool) +Indicates that external variable @var{name} has the value @var{value}. +The Project Manager will use this value for occurrences of +@code{external(name)} when parsing the project file. + +@ifclear vms +If @var{name} or @var{value} includes a space, then @var{name=value} should be +put between quotes. +@smallexample + -XOS=NT + -X"user=John Doe" +@end smallexample +@end ifclear + +Several @option{^-X^/EXTERNAL_REFERENCE^} switches can be used simultaneously. +If several @option{^-X^/EXTERNAL_REFERENCE^} switches specify the same +@var{name}, only the last one is used. + +An external variable specified with a @option{^-X^/EXTERNAL_REFERENCE^} switch +takes precedence over the value of the same name in the environment. + +@item ^-vP^/MESSAGES_PROJECT_FILE=^@emph{x} +@cindex @option{^-vP^/MESSAGES_PROJECT_FILE^} (any project-aware tool) +Indicates the verbosity of the parsing of GNAT project files. + +@ifclear vms +@option{-vP0} means Default; +@option{-vP1} means Medium; +@option{-vP2} means High. +@end ifclear + +@ifset vms +There are three possible options for this qualifier: DEFAULT, MEDIUM and +HIGH. +@end ifset + +The default is ^Default^DEFAULT^: no output for syntactically correct +project files. +If several @option{^-vP^/MESSAGES_PROJECT_FILE=^@emph{x}} switches are present, +only the last one is used. + +@item ^-aP^/ADD_PROJECT_SEARCH_DIR=^ +@cindex @option{^-aP^/ADD_PROJECT_SEARCH_DIR=^} (any project-aware tool) +Add directory at the beginning of the project search path, in order, +after the current working directory. + +@ifclear vms +@item -eL +@cindex @option{-eL} (any project-aware tool) +Follow all symbolic links when processing project files. +@end ifclear + +@item ^--subdirs^/SUBDIRS^= +@cindex @option{^--subdirs^/SUBDIRS^=} (gnatmake and gnatclean) +This switch is recognized by gnatmake and gnatclean. It indicate that the real +directories (except the source directories) are the subdirectories +of the directories specified in the project files. This applies in particular +to object directories, library directories and exec directories. If the +subdirectories do not exist, they are created automatically. + +@end table + +@c --------------------------------------------- +@node Switches and Project Files +@subsection Switches and Project Files +@c --------------------------------------------- + +@noindent +@ifset vms +It is not currently possible to specify VMS style qualifiers in the project +files; only Unix style ^switches^switches^ may be specified. +@end ifset + +For each of the packages @code{Builder}, @code{Compiler}, @code{Binder}, and +@code{Linker}, you can specify a @code{^Default_Switches^Default_Switches^} +attribute, a @code{Switches} attribute, or both; +as their names imply, these ^switch^switch^-related +attributes affect the ^switches^switches^ that are used for each of these GNAT +components when +@command{gnatmake} is invoked. As will be explained below, these +component-specific ^switches^switches^ precede +the ^switches^switches^ provided on the @command{gnatmake} command line. + +The @code{^Default_Switches^Default_Switches^} attribute is an attribute +indexed by language name (case insensitive) whose value is a string list. +For example: + +@smallexample @c projectfile +@group +package Compiler is + for ^Default_Switches^Default_Switches^ ("Ada") + use ("^-gnaty^-gnaty^", + "^-v^-v^"); +end Compiler; +@end group +@end smallexample + +@noindent +The @code{Switches} attribute is indexed on a file name (which may or may +not be case sensitive, depending +on the operating system) whose value is a string list. For example: + +@smallexample @c projectfile +@group +package Builder is + for Switches ("main1.adb") + use ("^-O2^-O2^"); + for Switches ("main2.adb") + use ("^-g^-g^"); +end Builder; +@end group +@end smallexample + +@noindent +For the @code{Builder} package, the file names must designate source files +for main subprograms. For the @code{Binder} and @code{Linker} packages, the +file names must designate @file{ALI} or source files for main subprograms. +In each case just the file name without an explicit extension is acceptable. + +For each tool used in a program build (@command{gnatmake}, the compiler, the +binder, and the linker), the corresponding package @dfn{contributes} a set of +^switches^switches^ for each file on which the tool is invoked, based on the +^switch^switch^-related attributes defined in the package. +In particular, the ^switches^switches^ +that each of these packages contributes for a given file @var{f} comprise: + +@itemize @bullet +@item the value of attribute @code{Switches (@var{f})}, + if it is specified in the package for the given file, +@item otherwise, the value of @code{^Default_Switches^Default_Switches^ ("Ada")}, + if it is specified in the package. + +@end itemize + +@noindent +If neither of these attributes is defined in the package, then the package does +not contribute any ^switches^switches^ for the given file. + +When @command{gnatmake} is invoked on a file, the ^switches^switches^ comprise +two sets, in the following order: those contributed for the file +by the @code{Builder} package; +and the switches passed on the command line. + +When @command{gnatmake} invokes a tool (compiler, binder, linker) on a file, +the ^switches^switches^ passed to the tool comprise three sets, +in the following order: + +@enumerate +@item +the applicable ^switches^switches^ contributed for the file +by the @code{Builder} package in the project file supplied on the command line; + +@item +those contributed for the file by the package (in the relevant project file -- +see below) corresponding to the tool; and + +@item +the applicable switches passed on the command line. +@end enumerate + +The term @emph{applicable ^switches^switches^} reflects the fact that +@command{gnatmake} ^switches^switches^ may or may not be passed to individual +tools, depending on the individual ^switch^switch^. + +@command{gnatmake} may invoke the compiler on source files from different +projects. The Project Manager will use the appropriate project file to +determine the @code{Compiler} package for each source file being compiled. +Likewise for the @code{Binder} and @code{Linker} packages. + +As an example, consider the following package in a project file: + +@smallexample @c projectfile +@group +project Proj1 is + package Compiler is + for ^Default_Switches^Default_Switches^ ("Ada") + use ("^-g^-g^"); + for Switches ("a.adb") + use ("^-O1^-O1^"); + for Switches ("b.adb") + use ("^-O2^-O2^", + "^-gnaty^-gnaty^"); + end Compiler; +end Proj1; +@end group +@end smallexample + +@noindent +If @command{gnatmake} is invoked with this project file, and it needs to +compile, say, the files @file{a.adb}, @file{b.adb}, and @file{c.adb}, then +@file{a.adb} will be compiled with the ^switch^switch^ +@option{^-O1^-O1^}, +@file{b.adb} with ^switches^switches^ +@option{^-O2^-O2^} +and @option{^-gnaty^-gnaty^}, +and @file{c.adb} with @option{^-g^-g^}. + +The following example illustrates the ordering of the ^switches^switches^ +contributed by different packages: + +@smallexample @c projectfile +@group +project Proj2 is + package Builder is + for Switches ("main.adb") + use ("^-g^-g^", + "^-O1^-)1^", + "^-f^-f^"); + end Builder; +@end group + +@group + package Compiler is + for Switches ("main.adb") + use ("^-O2^-O2^"); + end Compiler; +end Proj2; +@end group +@end smallexample + +@noindent +If you issue the command: + +@smallexample + gnatmake ^-Pproj2^/PROJECT_FILE=PROJ2^ -O0 main +@end smallexample + +@noindent +then the compiler will be invoked on @file{main.adb} with the following +sequence of ^switches^switches^ + +@smallexample + ^-g -O1 -O2 -O0^-g -O1 -O2 -O0^ +@end smallexample + +@noindent +with the last @option{^-O^-O^} +^switch^switch^ having precedence over the earlier ones; +several other ^switches^switches^ +(such as @option{^-c^-c^}) are added implicitly. + +The ^switches^switches^ +@option{^-g^-g^} +and @option{^-O1^-O1^} are contributed by package +@code{Builder}, @option{^-O2^-O2^} is contributed +by the package @code{Compiler} +and @option{^-O0^-O0^} comes from the command line. + +The @option{^-g^-g^} +^switch^switch^ will also be passed in the invocation of +@command{Gnatlink.} + +A final example illustrates switch contributions from packages in different +project files: + +@smallexample @c projectfile +@group +project Proj3 is + for Source_Files use ("pack.ads", "pack.adb"); + package Compiler is + for ^Default_Switches^Default_Switches^ ("Ada") + use ("^-gnata^-gnata^"); + end Compiler; +end Proj3; +@end group + +@group +with "Proj3"; +project Proj4 is + for Source_Files use ("foo_main.adb", "bar_main.adb"); + package Builder is + for Switches ("foo_main.adb") + use ("^-s^-s^", + "^-g^-g^"); + end Builder; +end Proj4; +@end group + +@group +-- Ada source file: +with Pack; +procedure Foo_Main is + @dots{} +end Foo_Main; +@end group +@end smallexample + +@noindent +If the command is +@smallexample +gnatmake ^-PProj4^/PROJECT_FILE=PROJ4^ foo_main.adb -cargs -gnato +@end smallexample + +@noindent +then the ^switches^switches^ passed to the compiler for @file{foo_main.adb} are +@option{^-g^-g^} (contributed by the package @code{Proj4.Builder}) and +@option{^-gnato^-gnato^} (passed on the command line). +When the imported package @code{Pack} is compiled, the ^switches^switches^ used +are @option{^-g^-g^} from @code{Proj4.Builder}, +@option{^-gnata^-gnata^} (contributed from package @code{Proj3.Compiler}, +and @option{^-gnato^-gnato^} from the command line. + +When using @command{gnatmake} with project files, some ^switches^switches^ or +arguments may be expressed as relative paths. As the working directory where +compilation occurs may change, these relative paths are converted to absolute +paths. For the ^switches^switches^ found in a project file, the relative paths +are relative to the project file directory, for the switches on the command +line, they are relative to the directory where @command{gnatmake} is invoked. +The ^switches^switches^ for which this occurs are: +^-I^-I^, +^-A^-A^, +^-L^-L^, +^-aO^-aO^, +^-aL^-aL^, +^-aI^-aI^, as well as all arguments that are not switches (arguments to +^switch^switch^ +^-o^-o^, object files specified in package @code{Linker} or after +-largs on the command line). The exception to this rule is the ^switch^switch^ +^--RTS=^--RTS=^ for which a relative path argument is never converted. + +@c --------------------------------------------- +@node Specifying Configuration Pragmas +@subsection Specifying Configuration Pragmas +@c --------------------------------------------- + +@noindent +When using @command{gnatmake} with project files, if there exists a file +@file{gnat.adc} that contains configuration pragmas, this file will be +ignored. + +Configuration pragmas can be defined by means of the following attributes in +project files: @code{Global_Configuration_Pragmas} in package @code{Builder} +and @code{Local_Configuration_Pragmas} in package @code{Compiler}. + +Both these attributes are single string attributes. Their values is the path +name of a file containing configuration pragmas. If a path name is relative, +then it is relative to the project directory of the project file where the +attribute is defined. + +When compiling a source, the configuration pragmas used are, in order, +those listed in the file designated by attribute +@code{Global_Configuration_Pragmas} in package @code{Builder} of the main +project file, if it is specified, and those listed in the file designated by +attribute @code{Local_Configuration_Pragmas} in package @code{Compiler} of +the project file of the source, if it exists. + +@c --------------------------------------------- +@node Project Files and Main Subprograms +@subsection Project Files and Main Subprograms +@c --------------------------------------------- + +@noindent +When using a project file, you can invoke @command{gnatmake} +with one or several main subprograms, by specifying their source files on the +command line. + +@smallexample + gnatmake ^-P^/PROJECT_FILE=^prj main1 main2 main3 +@end smallexample + +@noindent +Each of these needs to be a source file of the same project, except +when the switch ^-u^/UNIQUE^ is used. + +When ^-u^/UNIQUE^ is not used, all the mains need to be sources of the +same project, one of the project in the tree rooted at the project specified +on the command line. The package @code{Builder} of this common project, the +"main project" is the one that is considered by @command{gnatmake}. + +When ^-u^/UNIQUE^ is used, the specified source files may be in projects +imported directly or indirectly by the project specified on the command line. +Note that if such a source file is not part of the project specified on the +command line, the ^switches^switches^ found in package @code{Builder} of the +project specified on the command line, if any, that are transmitted +to the compiler will still be used, not those found in the project file of +the source file. + +When using a project file, you can also invoke @command{gnatmake} without +explicitly specifying any main, and the effect depends on whether you have +defined the @code{Main} attribute. This attribute has a string list value, +where each element in the list is the name of a source file (the file +extension is optional) that contains a unit that can be a main subprogram. + +If the @code{Main} attribute is defined in a project file as a non-empty +string list and the switch @option{^-u^/UNIQUE^} is not used on the command +line, then invoking @command{gnatmake} with this project file but without any +main on the command line is equivalent to invoking @command{gnatmake} with all +the file names in the @code{Main} attribute on the command line. + +Example: +@smallexample @c projectfile +@group + project Prj is + for Main use ("main1", "main2", "main3"); + end Prj; +@end group +@end smallexample + +@noindent +With this project file, @code{"gnatmake ^-Pprj^/PROJECT_FILE=PRJ^"} +is equivalent to +@code{"gnatmake ^-Pprj^/PROJECT_FILE=PRJ^ main1 main2 main3"}. + +When the project attribute @code{Main} is not specified, or is specified +as an empty string list, or when the switch @option{-u} is used on the command +line, then invoking @command{gnatmake} with no main on the command line will +result in all immediate sources of the project file being checked, and +potentially recompiled. Depending on the presence of the switch @option{-u}, +sources from other project files on which the immediate sources of the main +project file depend are also checked and potentially recompiled. In other +words, the @option{-u} switch is applied to all of the immediate sources of the +main project file. + +When no main is specified on the command line and attribute @code{Main} exists +and includes several mains, or when several mains are specified on the +command line, the default ^switches^switches^ in package @code{Builder} will +be used for all mains, even if there are specific ^switches^switches^ +specified for one or several mains. + +But the ^switches^switches^ from package @code{Binder} or @code{Linker} will be +the specific ^switches^switches^ for each main, if they are specified. + +@c --------------------------------------------- +@node Library Project Files +@subsection Library Project Files +@c --------------------------------------------- + +@noindent +When @command{gnatmake} is invoked with a main project file that is a library +project file, it is not allowed to specify one or more mains on the command +line. + +When a library project file is specified, switches ^-b^/ACTION=BIND^ and +^-l^/ACTION=LINK^ have special meanings. + +@itemize @bullet +@item ^-b^/ACTION=BIND^ is only allowed for stand-alone libraries. It indicates + to @command{gnatmake} that @command{gnatbind} should be invoked for the + library. + +@item ^-l^/ACTION=LINK^ may be used for all library projects. It indicates + to @command{gnatmake} that the binder generated file should be compiled + (in the case of a stand-alone library) and that the library should be built. +@end itemize + + +@c --------------------------------------------- +@node The GNAT Driver and Project Files +@section The GNAT Driver and Project Files +@c --------------------------------------------- + +@noindent +A number of GNAT tools, other than @command{^gnatmake^gnatmake^} +can benefit from project files: +(@command{^gnatbind^gnatbind^}, +@command{^gnatcheck^gnatcheck^}, +@command{^gnatclean^gnatclean^}, +@command{^gnatelim^gnatelim^}, +@command{^gnatfind^gnatfind^}, +@command{^gnatlink^gnatlink^}, +@command{^gnatls^gnatls^}, +@command{^gnatmetric^gnatmetric^}, +@command{^gnatpp^gnatpp^}, +@command{^gnatstub^gnatstub^}, +and @command{^gnatxref^gnatxref^}). However, none of these tools can be invoked +directly with a project file switch (@option{^-P^/PROJECT_FILE=^}). +They must be invoked through the @command{gnat} driver. + +The @command{gnat} driver is a wrapper that accepts a number of commands and +calls the corresponding tool. It was designed initially for VMS platforms (to +convert VMS qualifiers to Unix-style switches), but it is now available on all +GNAT platforms. + +On non-VMS platforms, the @command{gnat} driver accepts the following commands +(case insensitive): + +@itemize @bullet +@item BIND to invoke @command{^gnatbind^gnatbind^} +@item CHOP to invoke @command{^gnatchop^gnatchop^} +@item CLEAN to invoke @command{^gnatclean^gnatclean^} +@item COMP or COMPILE to invoke the compiler +@item ELIM to invoke @command{^gnatelim^gnatelim^} +@item FIND to invoke @command{^gnatfind^gnatfind^} +@item KR or KRUNCH to invoke @command{^gnatkr^gnatkr^} +@item LINK to invoke @command{^gnatlink^gnatlink^} +@item LS or LIST to invoke @command{^gnatls^gnatls^} +@item MAKE to invoke @command{^gnatmake^gnatmake^} +@item NAME to invoke @command{^gnatname^gnatname^} +@item PREP or PREPROCESS to invoke @command{^gnatprep^gnatprep^} +@item PP or PRETTY to invoke @command{^gnatpp^gnatpp^} +@item METRIC to invoke @command{^gnatmetric^gnatmetric^} +@item STUB to invoke @command{^gnatstub^gnatstub^} +@item XREF to invoke @command{^gnatxref^gnatxref^} + +@end itemize + +@noindent +(note that the compiler is invoked using the command +@command{^gnatmake -f -u -c^gnatmake -f -u -c^}). + +On non-VMS platforms, between @command{gnat} and the command, two +special switches may be used: + +@itemize @bullet +@item @command{-v} to display the invocation of the tool. +@item @command{-dn} to prevent the @command{gnat} driver from removing + the temporary files it has created. These temporary files are + configuration files and temporary file list files. + +@end itemize + +@noindent +The command may be followed by switches and arguments for the invoked +tool. + +@smallexample + gnat bind -C main.ali + gnat ls -a main + gnat chop foo.txt +@end smallexample + +@noindent +Switches may also be put in text files, one switch per line, and the text +files may be specified with their path name preceded by '@@'. + +@smallexample + gnat bind @@args.txt main.ali +@end smallexample + +@noindent +In addition, for commands BIND, COMP or COMPILE, FIND, ELIM, LS or LIST, LINK, +METRIC, PP or PRETTY, STUB and XREF, the project file related switches +(@option{^-P^/PROJECT_FILE^}, +@option{^-X^/EXTERNAL_REFERENCE^} and +@option{^-vP^/MESSAGES_PROJECT_FILE=^x}) may be used in addition to +the switches of the invoking tool. + +When GNAT PP or GNAT PRETTY is used with a project file, but with no source +specified on the command line, it invokes @command{^gnatpp^gnatpp^} with all +the immediate sources of the specified project file. + +When GNAT METRIC is used with a project file, but with no source +specified on the command line, it invokes @command{^gnatmetric^gnatmetric^} +with all the immediate sources of the specified project file and with +@option{^-d^/DIRECTORY^} with the parameter pointing to the object directory +of the project. + +In addition, when GNAT PP, GNAT PRETTY or GNAT METRIC is used with +a project file, no source is specified on the command line and +switch ^-U^/ALL_PROJECTS^ is specified on the command line, then +the underlying tool (^gnatpp^gnatpp^ or +^gnatmetric^gnatmetric^) is invoked for all sources of all projects, +not only for the immediate sources of the main project. +@ifclear vms +(-U stands for Universal or Union of the project files of the project tree) +@end ifclear + +For each of the following commands, there is optionally a corresponding +package in the main project. + +@itemize @bullet +@item package @code{Binder} for command BIND (invoking @code{^gnatbind^gnatbind^}) + +@item package @code{Check} for command CHECK (invoking + @code{^gnatcheck^gnatcheck^}) + +@item package @code{Compiler} for command COMP or COMPILE (invoking the compiler) + +@item package @code{Cross_Reference} for command XREF (invoking + @code{^gnatxref^gnatxref^}) + +@item package @code{Eliminate} for command ELIM (invoking + @code{^gnatelim^gnatelim^}) + +@item package @code{Finder} for command FIND (invoking @code{^gnatfind^gnatfind^}) + +@item package @code{Gnatls} for command LS or LIST (invoking @code{^gnatls^gnatls^}) + +@item package @code{Gnatstub} for command STUB + (invoking @code{^gnatstub^gnatstub^}) + +@item package @code{Linker} for command LINK (invoking @code{^gnatlink^gnatlink^}) + +@item package @code{Check} for command CHECK + (invoking @code{^gnatcheck^gnatcheck^}) + +@item package @code{Metrics} for command METRIC + (invoking @code{^gnatmetric^gnatmetric^}) + +@item package @code{Pretty_Printer} for command PP or PRETTY + (invoking @code{^gnatpp^gnatpp^}) + +@end itemize + +@noindent +Package @code{Gnatls} has a unique attribute @code{Switches}, +a simple variable with a string list value. It contains ^switches^switches^ +for the invocation of @code{^gnatls^gnatls^}. + +@smallexample @c projectfile +@group +project Proj1 is + package gnatls is + for Switches + use ("^-a^-a^", + "^-v^-v^"); + end gnatls; +end Proj1; +@end group +@end smallexample + +@noindent +All other packages have two attribute @code{Switches} and +@code{^Default_Switches^Default_Switches^}. + +@code{Switches} is an indexed attribute, indexed by the +source file name, that has a string list value: the ^switches^switches^ to be +used when the tool corresponding to the package is invoked for the specific +source file. + +@code{^Default_Switches^Default_Switches^} is an attribute, +indexed by the programming language that has a string list value. +@code{^Default_Switches^Default_Switches^ ("Ada")} contains the +^switches^switches^ for the invocation of the tool corresponding +to the package, except if a specific @code{Switches} attribute +is specified for the source file. + +@smallexample @c projectfile +@group +project Proj is + + for Source_Dirs use ("./**"); + + package gnatls is + for Switches use + ("^-a^-a^", + "^-v^-v^"); + end gnatls; +@end group +@group + + package Compiler is + for ^Default_Switches^Default_Switches^ ("Ada") + use ("^-gnatv^-gnatv^", + "^-gnatwa^-gnatwa^"); + end Binder; +@end group +@group + + package Binder is + for ^Default_Switches^Default_Switches^ ("Ada") + use ("^-C^-C^", + "^-e^-e^"); + end Binder; +@end group +@group + + package Linker is + for ^Default_Switches^Default_Switches^ ("Ada") + use ("^-C^-C^"); + for Switches ("main.adb") + use ("^-C^-C^", + "^-v^-v^", + "^-v^-v^"); + end Linker; +@end group +@group + + package Finder is + for ^Default_Switches^Default_Switches^ ("Ada") + use ("^-a^-a^", + "^-f^-f^"); + end Finder; +@end group +@group + + package Cross_Reference is + for ^Default_Switches^Default_Switches^ ("Ada") + use ("^-a^-a^", + "^-f^-f^", + "^-d^-d^", + "^-u^-u^"); + end Cross_Reference; +end Proj; +@end group +@end smallexample + +@noindent +With the above project file, commands such as + +@smallexample + ^gnat comp -Pproj main^GNAT COMP /PROJECT_FILE=PROJ MAIN^ + ^gnat ls -Pproj main^GNAT LIST /PROJECT_FILE=PROJ MAIN^ + ^gnat xref -Pproj main^GNAT XREF /PROJECT_FILE=PROJ MAIN^ + ^gnat bind -Pproj main.ali^GNAT BIND /PROJECT_FILE=PROJ MAIN.ALI^ + ^gnat link -Pproj main.ali^GNAT LINK /PROJECT_FILE=PROJ MAIN.ALI^ +@end smallexample + +@noindent +will set up the environment properly and invoke the tool with the switches +found in the package corresponding to the tool: +@code{^Default_Switches^Default_Switches^ ("Ada")} for all tools, +except @code{Switches ("main.adb")} +for @code{^gnatlink^gnatlink^}. +It is also possible to invoke some of the tools, +(@code{^gnatcheck^gnatcheck^}, +@code{^gnatmetric^gnatmetric^}, +and @code{^gnatpp^gnatpp^}) +on a set of project units thanks to the combination of the switches +@option{-P}, @option{-U} and possibly the main unit when one is interested +in its closure. For instance, +@smallexample +gnat metric -Pproj +@end smallexample + +@noindent +will compute the metrics for all the immediate units of project +@code{proj}. +@smallexample +gnat metric -Pproj -U +@end smallexample + +@noindent +will compute the metrics for all the units of the closure of projects +rooted at @code{proj}. +@smallexample +gnat metric -Pproj -U main_unit +@end smallexample + +@noindent +will compute the metrics for the closure of units rooted at +@code{main_unit}. This last possibility relies implicitly +on @command{gnatbind}'s option @option{-R}. But if the argument files for the +tool invoked by the the @command{gnat} driver are explicitly specified +either directly or through the tool @option{-files} option, then the tool +is called only for these explicitly specified files. + +@c --------------------------------------------- +@node The Development Environments +@section The Development Environments +@c --------------------------------------------- + +@noindent +See the appropriate manuals for more details. These environments will +store a number of settings in the project itself, when they are meant +to be shared by the whole team working on the project. Here are the +attributes defined in the package @b{IDE} in projects. + +@table @code +@item Remote_Host +This is a simple attribute. Its value is a string that designates the remote +host in a cross-compilation environment, to be used for remote compilation and +debugging. This field should not be specified when running on the local +machine. + +@item Program_Host +This is a simple attribute. Its value is a string that specifies the +name of IP address of the embedded target in a cross-compilation environment, +on which the program should execute. + +@item Communication_Protocol +This is a simple string attribute. Its value is the name of the protocol +to use to communicate with the target in a cross-compilation environment, +e.g.@: @code{"wtx"} or @code{"vxworks"}. + +@item Compiler_Command +This is an associative array attribute, whose domain is a language name. Its +value is string that denotes the command to be used to invoke the compiler. +The value of @code{Compiler_Command ("Ada")} is expected to be compatible with +gnatmake, in particular in the handling of switches. + +@item Debugger_Command +This is simple attribute, Its value is a string that specifies the name of +the debugger to be used, such as gdb, powerpc-wrs-vxworks-gdb or gdb-4. + +@item Default_Switches +This is an associative array attribute. Its indexes are the name of the +external tools that the GNAT Programming System (GPS) is supporting. Its +value is a list of switches to use when invoking that tool. + +@item Gnatlist +This is a simple attribute. Its value is a string that specifies the name +of the @command{gnatls} utility to be used to retrieve information about the +predefined path; e.g., @code{"gnatls"}, @code{"powerpc-wrs-vxworks-gnatls"}. +@item VCS_Kind +This is a simple attribute. Its value is a string used to specify the +Version Control System (VCS) to be used for this project, e.g.@: CVS, RCS +ClearCase or Perforce. + +@item VCS_File_Check +This is a simple attribute. Its value is a string that specifies the +command used by the VCS to check the validity of a file, either +when the user explicitly asks for a check, or as a sanity check before +doing the check-in. + +@item VCS_Log_Check +This is a simple attribute. Its value is a string that specifies +the command used by the VCS to check the validity of a log file. + +@item VCS_Repository_Root +The VCS repository root path. This is used to create tags or branches +of the repository. For subversion the value should be the @code{URL} +as specified to check-out the working copy of the repository. + +@item VCS_Patch_Root +The local root directory to use for building patch file. All patch chunks +will be relative to this path. The root project directory is used if +this value is not defined. + +@end table + +@c --------------------------------------------- +@node Cleaning up with GPRclean +@section Cleaning up with GPRclean +@c --------------------------------------------- + +@noindent +The GPRclean tool removes the files created by GPRbuild. +At a minimum, to invoke GPRclean you must specify a main project file +in a command such as @code{gprclean proj.gpr} or @code{gprclean -P proj.gpr}. + +Examples of invocation of GPRclean: + +@smallexample + gprclean -r prj1.gpr + gprclean -c -P prj2.gpr +@end smallexample + +@menu +* Switches for GPRclean:: +@end menu + +@c --------------------------------------------- +@node Switches for GPRclean +@subsection Switches for GPRclean +@c --------------------------------------------- + +@noindent +The switches for GPRclean are: + +@itemize @bullet +@item @option{--config=
} : Specify the + configuration project file name + +@item @option{--autoconf=} + + This specifies a configuration project file name that already exists or will + be created automatically. Option @option{--autoconf=} + cannot be specified more than once. If the configuration project file + specified with @option{--autoconf=} exists, then it is used. Otherwise, + @value{gprconfig} is invoked to create it automatically. + +@item @option{-c} : Only delete compiler-generated files. Do not delete + executables and libraries. + +@item @option{-f} : Force deletions of unwritable files + +@item @option{-F} : Display full project path name in brief error messages + +@item @option{-h} : Display this message + +@item @option{-n} : Do not delete files, only list files to delete + +@item @option{-P} : Use Project File @emph{}. + +@item @option{-q} : Be quiet/terse. There is no output, except to report + problems. + +@item @option{-r} : (recursive) Clean all projects referenced by the main + project directly or indirectly. Without this switch, GPRclean only + cleans the main project. + +@item @option{-v} : Verbose mode + +@item @option{-vPx} : Specify verbosity when parsing Project Files. + x = 0 (default), 1 or 2. + +@item @option{-Xnm=val} : Specify an external reference for Project Files. + +@end itemize + + + diff --git a/gcc/ada/put_scos.adb b/gcc/ada/put_scos.adb index 39b6288520e..9d3bcd7bb2b 100644 --- a/gcc/ada/put_scos.adb +++ b/gcc/ada/put_scos.adb @@ -26,6 +26,38 @@ with SCOs; use SCOs; procedure Put_SCOs is + Ctr : Nat; + + procedure Output_Range (T : SCO_Table_Entry); + -- Outputs T.From and T.To in line:col-line:col format + + procedure Output_Source_Location (Loc : Source_Location); + -- Output source location in line:col format + + ------------------ + -- Output_Range -- + ------------------ + + procedure Output_Range (T : SCO_Table_Entry) is + begin + Output_Source_Location (T.From); + Write_Info_Char ('-'); + Output_Source_Location (T.To); + end Output_Range; + + ---------------------------- + -- Output_Source_Location -- + ---------------------------- + + procedure Output_Source_Location (Loc : Source_Location) is + begin + Write_Info_Nat (Nat (Loc.Line)); + Write_Info_Char (':'); + Write_Info_Nat (Nat (Loc.Col)); + end Output_Source_Location; + +-- Start of processing for Put_SCOs + begin -- Loop through entries in SCO_Unit_Table @@ -64,35 +96,16 @@ begin Output_SCO_Line : declare T : SCO_Table_Entry renames SCO_Table.Table (Start); - procedure Output_Range (T : SCO_Table_Entry); - -- Outputs T.From and T.To in line:col-line:col format - - ------------------ - -- Output_Range -- - ------------------ - - procedure Output_Range (T : SCO_Table_Entry) is - begin - Write_Info_Nat (Nat (T.From.Line)); - Write_Info_Char (':'); - Write_Info_Nat (Nat (T.From.Col)); - Write_Info_Char ('-'); - Write_Info_Nat (Nat (T.To.Line)); - Write_Info_Char (':'); - Write_Info_Nat (Nat (T.To.Col)); - end Output_Range; - - -- Start of processing for Output_SCO_Line - begin - Write_Info_Initiate ('C'); - Write_Info_Char (T.C1); - case T.C1 is -- Statements when 'S' => + Write_Info_Initiate ('C'); + Write_Info_Char ('S'); + + Ctr := 0; loop Write_Info_Char (' '); @@ -105,8 +118,22 @@ begin Start := Start + 1; pragma Assert (SCO_Table.Table (Start).C1 = 's'); + + Ctr := Ctr + 1; + + -- Up to 6 items on a line, if more than 6 items, + -- continuation lines are marked Cs. + + if Ctr = 6 then + Write_Info_Terminate; + Write_Info_Initiate ('C'); + Write_Info_Char ('s'); + Ctr := 0; + end if; end loop; + Write_Info_Terminate; + -- Statement continuations should not occur since they -- are supposed to have been handled in the loop above. @@ -116,41 +143,59 @@ begin -- Decision when 'I' | 'E' | 'P' | 'W' | 'X' => - if T.C2 = ' ' then - Start := Start + 1; - end if; + Start := Start + 1; - -- Loop through table entries for this decision + -- For disabled pragma, skip decision output - loop - declare - T : SCO_Table_Entry renames SCO_Table.Table (Start); + if T.C1 = 'P' and then T.C2 = 'd' then + while not SCO_Table.Table (Start).Last loop + Start := Start + 1; + end loop; + + -- For all other cases output decision line - begin + else + Write_Info_Initiate ('C'); + Write_Info_Char (T.C1); + + if T.C1 /= 'X' then Write_Info_Char (' '); + Output_Source_Location (T.From); + end if; - if T.C1 = '!' or else - T.C1 = '^' or else - T.C1 = '&' or else - T.C1 = '|' - then - Write_Info_Char (T.C1); + -- Loop through table entries for this decision - else - Write_Info_Char (T.C2); - Output_Range (T); - end if; + loop + declare + T : SCO_Table_Entry + renames SCO_Table.Table (Start); - exit when T.Last; - Start := Start + 1; - end; - end loop; + begin + Write_Info_Char (' '); + + if T.C1 = '!' or else + T.C1 = '&' or else + T.C1 = '|' + then + Write_Info_Char (T.C1); + Output_Source_Location (T.From); + + else + Write_Info_Char (T.C2); + Output_Range (T); + end if; + + exit when T.Last; + Start := Start + 1; + end; + end loop; + + Write_Info_Terminate; + end if; when others => raise Program_Error; end case; - - Write_Info_Terminate; end Output_SCO_Line; Start := Start + 1; diff --git a/gcc/ada/raise.h b/gcc/ada/raise.h index b0de4912f30..1ccc37bca01 100644 --- a/gcc/ada/raise.h +++ b/gcc/ada/raise.h @@ -29,7 +29,6 @@ * * ****************************************************************************/ - /* C counterparts of what System.Standard_Library defines. */ typedef unsigned Exception_Code; @@ -46,16 +45,6 @@ struct Exception_Data typedef struct Exception_Data *Exception_Id; -struct Exception_Occurrence -{ - int Max_Length; - Exception_Id Id; - int Msg_Length; - char Msg[0]; -}; - -typedef struct Exception_Occurrence *Exception_Occurrence_Access; - extern void _gnat_builtin_longjmp (void *, int); extern void __gnat_unhandled_terminate (void); extern void *__gnat_malloc (__SIZE_TYPE__); diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb index c84996e3ba7..362d1d8cead 100644 --- a/gcc/ada/repinfo.adb +++ b/gcc/ada/repinfo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -403,7 +403,6 @@ package body Repinfo is if List_Representation_Info >= 2 then List_Object_Info (E); end if; - end if; -- Recurse into nested package, but not if they are package diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb index a57ac4c66ee..f7d97baec67 100644 --- a/gcc/ada/restrict.adb +++ b/gcc/ada/restrict.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -256,6 +256,14 @@ package body Restrict is -- Start of processing for Check_Restriction begin + -- In CodePeer mode, we do not want to check for any restriction, or + -- set additional restrictions than those already set in gnat1drv.adb + -- so that we have consistency between each compilation. + + if CodePeer_Mode then + return; + end if; + if UI_Is_In_Int_Range (V) then VV := Integer (UI_To_Int (V)); else diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index 32323fc593e..9742cb20b95 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1333,8 +1333,8 @@ package body Rtsfind is -- The RT_Unit_Table entry that may need updating begin - -- If entry is not set, set it now, and indicate that it - -- was loaded through an explicit context clause.. + -- If entry is not set, set it now, and indicate that it was + -- loaded through an explicit context clause. if No (U.Entity) then U := (Entity => E, diff --git a/gcc/ada/s-auxdec-vms-alpha.adb b/gcc/ada/s-auxdec-vms-alpha.adb new file mode 100644 index 00000000000..063b296f3ac --- /dev/null +++ b/gcc/ada/s-auxdec-vms-alpha.adb @@ -0,0 +1,809 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . A U X _ D E C -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/Or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the Alpha/VMS version. + +pragma Style_Checks (All_Checks); +-- Turn off alpha ordering check on subprograms, this unit is laid +-- out to correspond to the declarations in the DEC 83 System unit. + +with System.Machine_Code; use System.Machine_Code; +package body System.Aux_DEC is + + ------------------------ + -- Fetch_From_Address -- + ------------------------ + + function Fetch_From_Address (A : Address) return Target is + type T_Ptr is access all Target; + function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr); + Ptr : constant T_Ptr := To_T_Ptr (A); + begin + return Ptr.all; + end Fetch_From_Address; + + ----------------------- + -- Assign_To_Address -- + ----------------------- + + procedure Assign_To_Address (A : Address; T : Target) is + type T_Ptr is access all Target; + function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr); + Ptr : constant T_Ptr := To_T_Ptr (A); + begin + Ptr.all := T; + end Assign_To_Address; + + ----------------------- + -- Clear_Interlocked -- + ----------------------- + + procedure Clear_Interlocked + (Bit : in out Boolean; + Old_Value : out Boolean) + is + use ASCII; + Clr_Bit : Boolean := Bit; + Old_Bit : Boolean; + + begin + -- All these ASM sequences should be commented. I suggest definining + -- a constant called E which is LF & HT and then you have more space + -- for line by line comments ??? + + System.Machine_Code.Asm + ( + "lda $16, %2" & LF & HT & + "mb" & LF & HT & + "sll $16, 3, $17 " & LF & HT & + "bis $31, 1, $1" & LF & HT & + "and $17, 63, $18" & LF & HT & + "bic $17, 63, $17" & LF & HT & + "sra $17, 3, $17" & LF & HT & + "bis $31, 1, %1" & LF & HT & + "sll %1, $18, $18" & LF & HT & + "1:" & LF & HT & + "ldq_l $1, 0($17)" & LF & HT & + "and $1, $18, %1" & LF & HT & + "bic $1, $18, $1" & LF & HT & + "stq_c $1, 0($17)" & LF & HT & + "cmpeq %1, 0, %1" & LF & HT & + "beq $1, 1b" & LF & HT & + "mb" & LF & HT & + "xor %1, 1, %1" & LF & HT & + "trapb", + Outputs => (Boolean'Asm_Output ("=m", Clr_Bit), + Boolean'Asm_Output ("=r", Old_Bit)), + Inputs => Boolean'Asm_Input ("m", Clr_Bit), + Clobber => "$1, $16, $17, $18", + Volatile => True); + + Bit := Clr_Bit; + Old_Value := Old_Bit; + end Clear_Interlocked; + + procedure Clear_Interlocked + (Bit : in out Boolean; + Old_Value : out Boolean; + Retry_Count : Natural; + Success_Flag : out Boolean) + is + use ASCII; + Clr_Bit : Boolean := Bit; + Succ, Old_Bit : Boolean; + + begin + System.Machine_Code.Asm + ( + "lda $16, %3" & LF & HT & + "mb" & LF & HT & + "sll $16, 3, $18 " & LF & HT & + "bis $31, 1, %1" & LF & HT & + "and $18, 63, $19" & LF & HT & + "bic $18, 63, $18" & LF & HT & + "sra $18, 3, $18" & LF & HT & + "bis $31, %4, $17" & LF & HT & + "sll %1, $19, $19" & LF & HT & + "1:" & LF & HT & + "ldq_l %2, 0($18)" & LF & HT & + "and %2, $19, %1" & LF & HT & + "bic %2, $19, %2" & LF & HT & + "stq_c %2, 0($18)" & LF & HT & + "beq %2, 2f" & LF & HT & + "cmpeq %1, 0, %1" & LF & HT & + "br 3f" & LF & HT & + "2:" & LF & HT & + "subq $17, 1, $17" & LF & HT & + "bgt $17, 1b" & LF & HT & + "3:" & LF & HT & + "mb" & LF & HT & + "xor %1, 1, %1" & LF & HT & + "trapb", + Outputs => (Boolean'Asm_Output ("=m", Clr_Bit), + Boolean'Asm_Output ("=r", Old_Bit), + Boolean'Asm_Output ("=r", Succ)), + Inputs => (Boolean'Asm_Input ("m", Clr_Bit), + Natural'Asm_Input ("rJ", Retry_Count)), + Clobber => "$16, $17, $18, $19", + Volatile => True); + + Bit := Clr_Bit; + Old_Value := Old_Bit; + Success_Flag := Succ; + end Clear_Interlocked; + + --------------------- + -- Set_Interlocked -- + --------------------- + + procedure Set_Interlocked + (Bit : in out Boolean; + Old_Value : out Boolean) + is + use ASCII; + Set_Bit : Boolean := Bit; + Old_Bit : Boolean; + + begin + -- Don't we need comments on these long asm sequences??? + + System.Machine_Code.Asm + ( + "lda $16, %2" & LF & HT & + "sll $16, 3, $17 " & LF & HT & + "bis $31, 1, $1" & LF & HT & + "and $17, 63, $18" & LF & HT & + "mb" & LF & HT & + "bic $17, 63, $17" & LF & HT & + "sra $17, 3, $17" & LF & HT & + "bis $31, 1, %1" & LF & HT & + "sll %1, $18, $18" & LF & HT & + "1:" & LF & HT & + "ldq_l $1, 0($17)" & LF & HT & + "and $1, $18, %1" & LF & HT & + "bis $1, $18, $1" & LF & HT & + "stq_c $1, 0($17)" & LF & HT & + "cmovne %1, 1, %1" & LF & HT & + "beq $1, 1b" & LF & HT & + "mb" & LF & HT & + "trapb", + Outputs => (Boolean'Asm_Output ("=m", Set_Bit), + Boolean'Asm_Output ("=r", Old_Bit)), + Inputs => Boolean'Asm_Input ("m", Set_Bit), + Clobber => "$1, $16, $17, $18", + Volatile => True); + + Bit := Set_Bit; + Old_Value := Old_Bit; + end Set_Interlocked; + + procedure Set_Interlocked + (Bit : in out Boolean; + Old_Value : out Boolean; + Retry_Count : Natural; + Success_Flag : out Boolean) + is + use ASCII; + Set_Bit : Boolean := Bit; + Succ, Old_Bit : Boolean; + + begin + System.Machine_Code.Asm + ( + "lda $16, %3" & LF & HT & + "mb" & LF & HT & + "sll $16, 3, $18 " & LF & HT & + "bis $31, 1, %1" & LF & HT & + "and $18, 63, $19" & LF & HT & + "bic $18, 63, $18" & LF & HT & + "sra $18, 3, $18" & LF & HT & + "bis $31, %4, $17" & LF & HT & + "sll %1, $19, $19" & LF & HT & + "1:" & LF & HT & + "ldq_l %2, 0($18)" & LF & HT & + "and %2, $19, %1" & LF & HT & + "bis %2, $19, %2" & LF & HT & + "stq_c %2, 0($18)" & LF & HT & + "beq %2, 2f" & LF & HT & + "cmovne %1, 1, %1" & LF & HT & + "br 3f" & LF & HT & + "2:" & LF & HT & + "subq $17, 1, $17" & LF & HT & + "bgt $17, 1b" & LF & HT & + "3:" & LF & HT & + "mb" & LF & HT & + "trapb", + Outputs => (Boolean'Asm_Output ("=m", Set_Bit), + Boolean'Asm_Output ("=r", Old_Bit), + Boolean'Asm_Output ("=r", Succ)), + Inputs => (Boolean'Asm_Input ("m", Set_Bit), + Natural'Asm_Input ("rJ", Retry_Count)), + Clobber => "$16, $17, $18, $19", + Volatile => True); + + Bit := Set_Bit; + Old_Value := Old_Bit; + Success_Flag := Succ; + end Set_Interlocked; + + --------------------- + -- Add_Interlocked -- + --------------------- + + procedure Add_Interlocked + (Addend : Short_Integer; + Augend : in out Aligned_Word; + Sign : out Integer) + is + use ASCII; + Overflowed : Boolean := False; + + begin + System.Machine_Code.Asm + ( + "lda $18, %0" & LF & HT & + "bic $18, 6, $21" & LF & HT & + "mb" & LF & HT & + "1:" & LF & HT & + "ldq_l $0, 0($21)" & LF & HT & + "extwl $0, $18, $19" & LF & HT & + "mskwl $0, $18, $0" & LF & HT & + "addq $19, %3, $20" & LF & HT & + "inswl $20, $18, $17" & LF & HT & + "xor $19, %3, $19" & LF & HT & + "bis $17, $0, $0" & LF & HT & + "stq_c $0, 0($21)" & LF & HT & + "beq $0, 1b" & LF & HT & + "srl $20, 16, $0" & LF & HT & + "mb" & LF & HT & + "srl $20, 12, $21" & LF & HT & + "zapnot $20, 3, $20" & LF & HT & + "and $0, 1, $0" & LF & HT & + "and $21, 8, $21" & LF & HT & + "bis $21, $0, $0" & LF & HT & + "cmpeq $20, 0, $21" & LF & HT & + "xor $20, 2, $20" & LF & HT & + "sll $21, 2, $21" & LF & HT & + "bis $21, $0, $0" & LF & HT & + "bic $20, $19, $21" & LF & HT & + "srl $21, 14, $21" & LF & HT & + "and $21, 2, $21" & LF & HT & + "bis $21, $0, $0" & LF & HT & + "and $0, 2, %2" & LF & HT & + "bne %2, 2f" & LF & HT & + "and $0, 4, %1" & LF & HT & + "cmpeq %1, 0, %1" & LF & HT & + "and $0, 8, $0" & LF & HT & + "lda $16, -1" & LF & HT & + "cmovne $0, $16, %1" & LF & HT & + "2:", + Outputs => (Aligned_Word'Asm_Output ("=m", Augend), + Integer'Asm_Output ("=r", Sign), + Boolean'Asm_Output ("=r", Overflowed)), + Inputs => (Short_Integer'Asm_Input ("r", Addend), + Aligned_Word'Asm_Input ("m", Augend)), + Clobber => "$0, $1, $16, $17, $18, $19, $20, $21", + Volatile => True); + + if Overflowed then + raise Constraint_Error; + end if; + end Add_Interlocked; + + ---------------- + -- Add_Atomic -- + ---------------- + + procedure Add_Atomic + (To : in out Aligned_Integer; + Amount : Integer) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "1:" & LF & HT & + "ldl_l $1, %0" & LF & HT & + "addl $1, %2, $0" & LF & HT & + "stl_c $0, %1" & LF & HT & + "beq $0, 1b" & LF & HT & + "mb", + Outputs => Aligned_Integer'Asm_Output ("=m", To), + Inputs => (Aligned_Integer'Asm_Input ("m", To), + Integer'Asm_Input ("rJ", Amount)), + Clobber => "$0, $1", + Volatile => True); + end Add_Atomic; + + procedure Add_Atomic + (To : in out Aligned_Integer; + Amount : Integer; + Retry_Count : Natural; + Old_Value : out Integer; + Success_Flag : out Boolean) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "bis $31, %5, $17" & LF & HT & + "1:" & LF & HT & + "ldl_l $1, %0" & LF & HT & + "addl $1, %4, $0" & LF & HT & + "stl_c $0, %3" & LF & HT & + "beq $0, 2f" & LF & HT & + "3:" & LF & HT & + "mb" & LF & HT & + "stq $0, %2" & LF & HT & + "stl $1, %1" & LF & HT & + "br 4f" & LF & HT & + "2:" & LF & HT & + "subq $17, 1, $17" & LF & HT & + "bgt $17, 1b" & LF & HT & + "br 3b" & LF & HT & + "4:", + Outputs => (Aligned_Integer'Asm_Output ("=m", To), + Integer'Asm_Output ("=m", Old_Value), + Boolean'Asm_Output ("=m", Success_Flag)), + Inputs => (Aligned_Integer'Asm_Input ("m", To), + Integer'Asm_Input ("rJ", Amount), + Natural'Asm_Input ("rJ", Retry_Count)), + Clobber => "$0, $1, $17", + Volatile => True); + end Add_Atomic; + + procedure Add_Atomic + (To : in out Aligned_Long_Integer; + Amount : Long_Integer) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "1:" & LF & HT & + "ldq_l $1, %0" & LF & HT & + "addq $1, %2, $0" & LF & HT & + "stq_c $0, %1" & LF & HT & + "beq $0, 1b" & LF & HT & + "mb", + Outputs => Aligned_Long_Integer'Asm_Output ("=m", To), + Inputs => (Aligned_Long_Integer'Asm_Input ("m", To), + Long_Integer'Asm_Input ("rJ", Amount)), + Clobber => "$0, $1", + Volatile => True); + end Add_Atomic; + + procedure Add_Atomic + (To : in out Aligned_Long_Integer; + Amount : Long_Integer; + Retry_Count : Natural; + Old_Value : out Long_Integer; + Success_Flag : out Boolean) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "bis $31, %5, $17" & LF & HT & + "1:" & LF & HT & + "ldq_l $1, %0" & LF & HT & + "addq $1, %4, $0" & LF & HT & + "stq_c $0, %3" & LF & HT & + "beq $0, 2f" & LF & HT & + "3:" & LF & HT & + "mb" & LF & HT & + "stq $0, %2" & LF & HT & + "stq $1, %1" & LF & HT & + "br 4f" & LF & HT & + "2:" & LF & HT & + "subq $17, 1, $17" & LF & HT & + "bgt $17, 1b" & LF & HT & + "br 3b" & LF & HT & + "4:", + Outputs => (Aligned_Long_Integer'Asm_Output ("=m", To), + Long_Integer'Asm_Output ("=m", Old_Value), + Boolean'Asm_Output ("=m", Success_Flag)), + Inputs => (Aligned_Long_Integer'Asm_Input ("m", To), + Long_Integer'Asm_Input ("rJ", Amount), + Natural'Asm_Input ("rJ", Retry_Count)), + Clobber => "$0, $1, $17", + Volatile => True); + end Add_Atomic; + + ---------------- + -- And_Atomic -- + ---------------- + + procedure And_Atomic + (To : in out Aligned_Integer; + From : Integer) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "1:" & LF & HT & + "ldl_l $1, %0" & LF & HT & + "and $1, %2, $0" & LF & HT & + "stl_c $0, %1" & LF & HT & + "beq $0, 1b" & LF & HT & + "mb", + Outputs => Aligned_Integer'Asm_Output ("=m", To), + Inputs => (Aligned_Integer'Asm_Input ("m", To), + Integer'Asm_Input ("rJ", From)), + Clobber => "$0, $1", + Volatile => True); + end And_Atomic; + + procedure And_Atomic + (To : in out Aligned_Integer; + From : Integer; + Retry_Count : Natural; + Old_Value : out Integer; + Success_Flag : out Boolean) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "bis $31, %5, $17" & LF & HT & + "1:" & LF & HT & + "ldl_l $1, %0" & LF & HT & + "and $1, %4, $0" & LF & HT & + "stl_c $0, %3" & LF & HT & + "beq $0, 2f" & LF & HT & + "3:" & LF & HT & + "mb" & LF & HT & + "stq $0, %2" & LF & HT & + "stl $1, %1" & LF & HT & + "br 4f" & LF & HT & + "2:" & LF & HT & + "subq $17, 1, $17" & LF & HT & + "bgt $17, 1b" & LF & HT & + "br 3b" & LF & HT & + "4:", + Outputs => (Aligned_Integer'Asm_Output ("=m", To), + Integer'Asm_Output ("=m", Old_Value), + Boolean'Asm_Output ("=m", Success_Flag)), + Inputs => (Aligned_Integer'Asm_Input ("m", To), + Integer'Asm_Input ("rJ", From), + Natural'Asm_Input ("rJ", Retry_Count)), + Clobber => "$0, $1, $17", + Volatile => True); + end And_Atomic; + + procedure And_Atomic + (To : in out Aligned_Long_Integer; + From : Long_Integer) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "1:" & LF & HT & + "ldq_l $1, %0" & LF & HT & + "and $1, %2, $0" & LF & HT & + "stq_c $0, %1" & LF & HT & + "beq $0, 1b" & LF & HT & + "mb", + Outputs => Aligned_Long_Integer'Asm_Output ("=m", To), + Inputs => (Aligned_Long_Integer'Asm_Input ("m", To), + Long_Integer'Asm_Input ("rJ", From)), + Clobber => "$0, $1", + Volatile => True); + end And_Atomic; + + procedure And_Atomic + (To : in out Aligned_Long_Integer; + From : Long_Integer; + Retry_Count : Natural; + Old_Value : out Long_Integer; + Success_Flag : out Boolean) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "bis $31, %5, $17" & LF & HT & + "1:" & LF & HT & + "ldq_l $1, %0" & LF & HT & + "and $1, %4, $0" & LF & HT & + "stq_c $0, %3" & LF & HT & + "beq $0, 2f" & LF & HT & + "3:" & LF & HT & + "mb" & LF & HT & + "stq $0, %2" & LF & HT & + "stq $1, %1" & LF & HT & + "br 4f" & LF & HT & + "2:" & LF & HT & + "subq $17, 1, $17" & LF & HT & + "bgt $17, 1b" & LF & HT & + "br 3b" & LF & HT & + "4:", + Outputs => (Aligned_Long_Integer'Asm_Output ("=m", To), + Long_Integer'Asm_Output ("=m", Old_Value), + Boolean'Asm_Output ("=m", Success_Flag)), + Inputs => (Aligned_Long_Integer'Asm_Input ("m", To), + Long_Integer'Asm_Input ("rJ", From), + Natural'Asm_Input ("rJ", Retry_Count)), + Clobber => "$0, $1, $17", + Volatile => True); + end And_Atomic; + + --------------- + -- Or_Atomic -- + --------------- + + procedure Or_Atomic + (To : in out Aligned_Integer; + From : Integer) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "1:" & LF & HT & + "ldl_l $1, %0" & LF & HT & + "bis $1, %2, $0" & LF & HT & + "stl_c $0, %1" & LF & HT & + "beq $0, 1b" & LF & HT & + "mb", + Outputs => Aligned_Integer'Asm_Output ("=m", To), + Inputs => (Aligned_Integer'Asm_Input ("m", To), + Integer'Asm_Input ("rJ", From)), + Clobber => "$0, $1", + Volatile => True); + end Or_Atomic; + + procedure Or_Atomic + (To : in out Aligned_Integer; + From : Integer; + Retry_Count : Natural; + Old_Value : out Integer; + Success_Flag : out Boolean) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "bis $31, %5, $17" & LF & HT & + "1:" & LF & HT & + "ldl_l $1, %0" & LF & HT & + "bis $1, %4, $0" & LF & HT & + "stl_c $0, %3" & LF & HT & + "beq $0, 2f" & LF & HT & + "3:" & LF & HT & + "mb" & LF & HT & + "stq $0, %2" & LF & HT & + "stl $1, %1" & LF & HT & + "br 4f" & LF & HT & + "2:" & LF & HT & + "subq $17, 1, $17" & LF & HT & + "bgt $17, 1b" & LF & HT & + "br 3b" & LF & HT & + "4:", + Outputs => (Aligned_Integer'Asm_Output ("=m", To), + Integer'Asm_Output ("=m", Old_Value), + Boolean'Asm_Output ("=m", Success_Flag)), + Inputs => (Aligned_Integer'Asm_Input ("m", To), + Integer'Asm_Input ("rJ", From), + Natural'Asm_Input ("rJ", Retry_Count)), + Clobber => "$0, $1, $17", + Volatile => True); + end Or_Atomic; + + procedure Or_Atomic + (To : in out Aligned_Long_Integer; + From : Long_Integer) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "1:" & LF & HT & + "ldq_l $1, %0" & LF & HT & + "bis $1, %2, $0" & LF & HT & + "stq_c $0, %1" & LF & HT & + "beq $0, 1b" & LF & HT & + "mb", + Outputs => Aligned_Long_Integer'Asm_Output ("=m", To), + Inputs => (Aligned_Long_Integer'Asm_Input ("m", To), + Long_Integer'Asm_Input ("rJ", From)), + Clobber => "$0, $1", + Volatile => True); + end Or_Atomic; + + procedure Or_Atomic + (To : in out Aligned_Long_Integer; + From : Long_Integer; + Retry_Count : Natural; + Old_Value : out Long_Integer; + Success_Flag : out Boolean) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "bis $31, %5, $17" & LF & HT & + "1:" & LF & HT & + "ldq_l $1, %0" & LF & HT & + "bis $1, %4, $0" & LF & HT & + "stq_c $0, %3" & LF & HT & + "beq $0, 2f" & LF & HT & + "3:" & LF & HT & + "mb" & LF & HT & + "stq $0, %2" & LF & HT & + "stq $1, %1" & LF & HT & + "br 4f" & LF & HT & + "2:" & LF & HT & + "subq $17, 1, $17" & LF & HT & + "bgt $17, 1b" & LF & HT & + "br 3b" & LF & HT & + "4:", + Outputs => (Aligned_Long_Integer'Asm_Output ("=m", To), + Long_Integer'Asm_Output ("=m", Old_Value), + Boolean'Asm_Output ("=m", Success_Flag)), + Inputs => (Aligned_Long_Integer'Asm_Input ("m", To), + Long_Integer'Asm_Input ("rJ", From), + Natural'Asm_Input ("rJ", Retry_Count)), + Clobber => "$0, $1, $17", + Volatile => True); + end Or_Atomic; + + ------------ + -- Insqhi -- + ------------ + + procedure Insqhi + (Item : Address; + Header : Address; + Status : out Insq_Status) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "bis $31, %1, $17" & LF & HT & + "bis $31, %2, $16" & LF & HT & + "mb" & LF & HT & + "call_pal 0x87" & LF & HT & + "mb", + Outputs => Insq_Status'Asm_Output ("=v", Status), + Inputs => (Address'Asm_Input ("rJ", Item), + Address'Asm_Input ("rJ", Header)), + Clobber => "$16, $17", + Volatile => True); + end Insqhi; + + ------------ + -- Remqhi -- + ------------ + + procedure Remqhi + (Header : Address; + Item : out Address; + Status : out Remq_Status) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "bis $31, %2, $16" & LF & HT & + "mb" & LF & HT & + "call_pal 0x93" & LF & HT & + "mb" & LF & HT & + "bis $31, $1, %1", + Outputs => (Remq_Status'Asm_Output ("=v", Status), + Address'Asm_Output ("=r", Item)), + Inputs => Address'Asm_Input ("rJ", Header), + Clobber => "$1, $16", + Volatile => True); + end Remqhi; + + ------------ + -- Insqti -- + ------------ + + procedure Insqti + (Item : Address; + Header : Address; + Status : out Insq_Status) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "bis $31, %1, $17" & LF & HT & + "bis $31, %2, $16" & LF & HT & + "mb" & LF & HT & + "call_pal 0x88" & LF & HT & + "mb", + Outputs => Insq_Status'Asm_Output ("=v", Status), + Inputs => (Address'Asm_Input ("rJ", Item), + Address'Asm_Input ("rJ", Header)), + Clobber => "$16, $17", + Volatile => True); + end Insqti; + + ------------ + -- Remqti -- + ------------ + + procedure Remqti + (Header : Address; + Item : out Address; + Status : out Remq_Status) + is + use ASCII; + + begin + System.Machine_Code.Asm + ( + "bis $31, %2, $16" & LF & HT & + "mb" & LF & HT & + "call_pal 0x94" & LF & HT & + "mb" & LF & HT & + "bis $31, $1, %1", + Outputs => (Remq_Status'Asm_Output ("=v", Status), + Address'Asm_Output ("=r", Item)), + Inputs => Address'Asm_Input ("rJ", Header), + Clobber => "$1, $16", + Volatile => True); + end Remqti; + +end System.Aux_DEC; diff --git a/gcc/ada/s-auxdec-vms_64.ads b/gcc/ada/s-auxdec-vms_64.ads index 3213e18a642..1480a441887 100644 --- a/gcc/ada/s-auxdec-vms_64.ads +++ b/gcc/ada/s-auxdec-vms_64.ads @@ -112,6 +112,9 @@ package System.Aux_DEC is function "-" (Left : Address; Right : Address) return Integer; function "-" (Left : Address; Right : Integer) return Address; + pragma Import (Intrinsic, "+"); + pragma Import (Intrinsic, "-"); + generic type Target is private; function Fetch_From_Address (A : Address) return Target; @@ -227,16 +230,16 @@ package System.Aux_DEC is type Unsigned_Quadword_Array is array (Integer range <>) of Unsigned_Quadword; - function To_Address (X : Integer) return Address; + function To_Address (X : Integer) return Short_Address; pragma Pure_Function (To_Address); - function To_Address_Long (X : Unsigned_Longword) return Address; + function To_Address_Long (X : Unsigned_Longword) return Short_Address; pragma Pure_Function (To_Address_Long); - function To_Integer (X : Address) return Integer; + function To_Integer (X : Short_Address) return Integer; - function To_Unsigned_Longword (X : Address) return Unsigned_Longword; - function To_Unsigned_Longword (X : AST_Handler) return Unsigned_Longword; + function To_Unsigned_Longword (X : Short_Address) return Unsigned_Longword; + function To_Unsigned_Longword (X : AST_Handler) return Unsigned_Longword; -- Conventional names for static subtypes of type UNSIGNED_LONGWORD @@ -461,12 +464,10 @@ private -- them intrinsic, since the backend can handle them, but the front -- end is not prepared to deal with them, so at least inline them. - pragma Inline_Always ("+"); - pragma Inline_Always ("-"); - pragma Inline_Always ("not"); - pragma Inline_Always ("and"); - pragma Inline_Always ("or"); - pragma Inline_Always ("xor"); + pragma Import (Intrinsic, "not"); + pragma Import (Intrinsic, "and"); + pragma Import (Intrinsic, "or"); + pragma Import (Intrinsic, "xor"); -- Other inlined subprograms @@ -578,6 +579,13 @@ private Mechanism => (Reference, Value, Value, Reference, Reference)); pragma Inline_Always (Or_Atomic); + -- Inline the VAX Queue Funtions + + pragma Inline_Always (Insqhi); + pragma Inline_Always (Remqhi); + pragma Inline_Always (Insqti); + pragma Inline_Always (Remqti); + -- Provide proper unchecked conversion definitions for transfer -- functions. Note that we need this level of indirection because -- the formal parameter name is X and not Source (and this is indeed @@ -649,31 +657,31 @@ private -- want warnings when we compile on such systems. function To_Address_A is new - Ada.Unchecked_Conversion (Integer, Address); + Ada.Unchecked_Conversion (Integer, Short_Address); pragma Pure_Function (To_Address_A); - function To_Address (X : Integer) return Address + function To_Address (X : Integer) return Short_Address renames To_Address_A; pragma Pure_Function (To_Address); function To_Address_Long_A is new - Ada.Unchecked_Conversion (Unsigned_Longword, Address); + Ada.Unchecked_Conversion (Unsigned_Longword, Short_Address); pragma Pure_Function (To_Address_Long_A); - function To_Address_Long (X : Unsigned_Longword) return Address + function To_Address_Long (X : Unsigned_Longword) return Short_Address renames To_Address_Long_A; pragma Pure_Function (To_Address_Long); function To_Integer_A is new - Ada.Unchecked_Conversion (Address, Integer); + Ada.Unchecked_Conversion (Short_Address, Integer); - function To_Integer (X : Address) return Integer + function To_Integer (X : Short_Address) return Integer renames To_Integer_A; function To_Unsigned_Longword_A is new - Ada.Unchecked_Conversion (Address, Unsigned_Longword); + Ada.Unchecked_Conversion (Short_Address, Unsigned_Longword); - function To_Unsigned_Longword (X : Address) return Unsigned_Longword + function To_Unsigned_Longword (X : Short_Address) return Unsigned_Longword renames To_Unsigned_Longword_A; function To_Unsigned_Longword_A is new diff --git a/gcc/ada/s-crtl.ads b/gcc/ada/s-crtl.ads index 7d5f1107add..345e9a570ea 100644 --- a/gcc/ada/s-crtl.ads +++ b/gcc/ada/s-crtl.ads @@ -59,6 +59,9 @@ package System.CRTL is type size_t is mod 2 ** Standard'Address_Size; + type ssize_t is range -(2 ** (Standard'Address_Size - 1)) + .. +(2 ** (Standard'Address_Size - 1)) - 1; + type Filename_Encoding is (UTF8, ASCII_8bits, Unspecified); for Filename_Encoding use (UTF8 => 0, ASCII_8bits => 1, Unspecified => 2); pragma Convention (C, Filename_Encoding); @@ -187,10 +190,10 @@ package System.CRTL is function close (fd : int) return int; pragma Import (C, close, "close"); - function read (fd : int; buffer : chars; nbytes : int) return int; + function read (fd : int; buffer : chars; count : size_t) return ssize_t; pragma Import (C, read, "read"); - function write (fd : int; buffer : chars; nbytes : int) return int; + function write (fd : int; buffer : chars; count : size_t) return ssize_t; pragma Import (C, write, "write"); end System.CRTL; diff --git a/gcc/ada/s-fileio.adb b/gcc/ada/s-fileio.adb index 60a96e427cf..185fc52cff9 100644 --- a/gcc/ada/s-fileio.adb +++ b/gcc/ada/s-fileio.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -104,7 +104,7 @@ package body System.File_IO is File_Names_Case_Sensitive : constant Boolean := Get_Case_Sensitive /= 0; -- Set to indicate whether the operating system convention is for file -- names to be case sensitive (e.g., in Unix, set True), or non case - -- sensitive (e.g., in OS/2, set False). + -- sensitive (e.g., in Windows, set False). ----------------------- -- Local Subprograms -- diff --git a/gcc/ada/s-filofl.ads b/gcc/ada/s-filofl.ads index 319fc8f41f0..e3aba15d571 100644 --- a/gcc/ada/s-filofl.ads +++ b/gcc/ada/s-filofl.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005,2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-finimp.adb b/gcc/ada/s-finimp.adb index 9a5e534b4d4..050f79995ec 100644 --- a/gcc/ada/s-finimp.adb +++ b/gcc/ada/s-finimp.adb @@ -332,10 +332,10 @@ package body System.Finalization_Implementation is P : Finalizable_Ptr := L; Q : Finalizable_Ptr; - type Fake_Exception_Occurence is record + type Fake_Exception_Occurrence is record Id : Exception_Id; end record; - type Ptr is access all Fake_Exception_Occurence; + type Ptr is access all Fake_Exception_Occurrence; function To_Ptr is new Ada.Unchecked_Conversion (Exception_Occurrence_Access, Ptr); diff --git a/gcc/ada/s-interr.adb b/gcc/ada/s-interr.adb index 02231a46328..3d33f6c9e13 100644 --- a/gcc/ada/s-interr.adb +++ b/gcc/ada/s-interr.adb @@ -367,11 +367,27 @@ package body System.Interrupts is -------------- procedure Finalize (Object : in out Static_Interrupt_Protection) is + function State + (Int : System.Interrupt_Management.Interrupt_ID) return Character; + pragma Import (C, State, "__gnat_get_interrupt_state"); + -- Get interrupt state for interrupt number Int. Defined in init.c + + Default : constant Character := 's'; + -- 's' Interrupt_State pragma set state to System (use "default" + -- system handler) + begin -- ??? loop to be executed only when we're not doing library level -- finalization, since in this case all interrupt tasks are gone. - if not Interrupt_Manager'Terminated then + -- If the Abort_Task signal is set to system, it means that we cannot + -- reset interrupt handlers since this would require sending the abort + -- signal to the Server_Task + + if not Interrupt_Manager'Terminated + and then State (System.Interrupt_Management.Abort_Task_Interrupt) + /= Default + then for N in reverse Object.Previous_Handlers'Range loop Interrupt_Manager.Attach_Handler (New_Handler => Object.Previous_Handlers (N).Handler, diff --git a/gcc/ada/s-intman-vxworks.ads b/gcc/ada/s-intman-vxworks.ads index be1165db448..5614553c77b 100644 --- a/gcc/ada/s-intman-vxworks.ads +++ b/gcc/ada/s-intman-vxworks.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -59,8 +59,7 @@ package System.Interrupt_Management is type Interrupt_Set is array (Interrupt_ID) of Boolean; - subtype Signal_ID is Interrupt_ID - range 0 .. Interfaces.C."-" (System.OS_Interface.NSIG, 1); + subtype Signal_ID is Interrupt_ID range 0 .. System.OS_Interface.NSIG - 1; type Signal_Set is array (Signal_ID) of Boolean; @@ -74,7 +73,7 @@ package System.Interrupt_Management is -- convention that ID zero is not used for any "real" signals, and SIGRARE -- = 0 when SIGRARE is not one of the locally supported signals, we can -- write: - -- Reserved (SIGRARE) := true; + -- Reserved (SIGRARE) := True; -- and the initialization code will be portable. Abort_Task_Interrupt : Signal_ID; diff --git a/gcc/ada/s-os_lib.adb b/gcc/ada/s-os_lib.adb index f7341367688..c7ca149ab68 100755 --- a/gcc/ada/s-os_lib.adb +++ b/gcc/ada/s-os_lib.adb @@ -2309,8 +2309,11 @@ package body System.OS_Lib is N : Integer) return Integer is begin - return Integer (System.CRTL.read - (System.CRTL.int (FD), System.CRTL.chars (A), System.CRTL.int (N))); + return + Integer (System.CRTL.read + (System.CRTL.int (FD), + System.CRTL.chars (A), + System.CRTL.size_t (N))); end Read; ----------------- @@ -2718,8 +2721,11 @@ package body System.OS_Lib is N : Integer) return Integer is begin - return Integer (System.CRTL.write - (System.CRTL.int (FD), System.CRTL.chars (A), System.CRTL.int (N))); + return + Integer (System.CRTL.write + (System.CRTL.int (FD), + System.CRTL.chars (A), + System.CRTL.size_t (N))); end Write; end System.OS_Lib; diff --git a/gcc/ada/s-oscons-tmplt.c b/gcc/ada/s-oscons-tmplt.c index 1e8bd520ceb..7e34a74b611 100644 --- a/gcc/ada/s-oscons-tmplt.c +++ b/gcc/ada/s-oscons-tmplt.c @@ -98,6 +98,22 @@ pragma Style_Checks ("M32766"); #include #include +#if defined (__alpha__) && defined (__osf__) +/** Tru64 is unable to do vector IO operations with default value of IOV_MAX, + ** so its value is redefined to a small one which is known to work properly. + **/ +#undef IOV_MAX +#define IOV_MAX 16 +#endif + +#if defined (__VMS) +/** VMS is unable to do vector IO operations with default value of IOV_MAX, + ** so its value is redefined to a small one which is known to work properly. + **/ +#undef IOV_MAX +#define IOV_MAX 16 +#endif + #if ! (defined (__vxworks) || defined (__VMS) || defined (__MINGW32__) || \ defined (__nucleus__)) # define HAVE_TERMIOS @@ -1215,24 +1231,11 @@ CND(SIZEOF_sockaddr_in6, "struct sockaddr_in6") #define SIZEOF_fd_set (sizeof (fd_set)) CND(SIZEOF_fd_set, "fd_set"); +#define SIZEOF_struct_hostent (sizeof (struct hostent)) +CND(SIZEOF_struct_hostent, "struct hostent"); + #define SIZEOF_struct_servent (sizeof (struct servent)) CND(SIZEOF_struct_servent, "struct servent"); -/* - - -- Fields of struct hostent -*/ - -#ifdef __MINGW32__ -# define h_addrtype_t "short" -# define h_length_t "short" -#else -# define h_addrtype_t "int" -# define h_length_t "int" -#endif - -TXT(" subtype H_Addrtype_T is Interfaces.C." h_addrtype_t ";") -TXT(" subtype H_Length_T is Interfaces.C." h_length_t ";") - /* -- Fields of struct msghdr @@ -1255,6 +1258,7 @@ TXT(" subtype Msg_Iovlen_T is Interfaces.C." msg_iovlen_t ";") */ CND(Need_Netdb_Buffer, "Need buffer for Netdb ops") +CND(Need_Netdb_Lock, "Need lock for Netdb ops") CND(Has_Sockaddr_Len, "Sockaddr has sa_len field") /** diff --git a/gcc/ada/s-osinte-hpux-dce.ads b/gcc/ada/s-osinte-hpux-dce.ads index 417aae98e91..f39cbfdec34 100644 --- a/gcc/ada/s-osinte-hpux-dce.ads +++ b/gcc/ada/s-osinte-hpux-dce.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2009, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-osinte-linux.ads b/gcc/ada/s-osinte-linux.ads index 323fc158f05..6c0f1353762 100644 --- a/gcc/ada/s-osinte-linux.ads +++ b/gcc/ada/s-osinte-linux.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2009, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-osinte-vxworks.ads b/gcc/ada/s-osinte-vxworks.ads index 0eda1ef603c..dd5f1eb1d6c 100644 --- a/gcc/ada/s-osinte-vxworks.ads +++ b/gcc/ada/s-osinte-vxworks.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2010, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -490,8 +490,6 @@ package System.OS_Interface is -- For uniprocessor systems return ERROR status. private - type sigset_t is new unsigned_long_long; - type pid_t is new int; ERROR_PID : constant pid_t := -1; @@ -499,4 +497,5 @@ private type clockid_t is new int; CLOCK_REALTIME : constant clockid_t := 0; + type sigset_t is new System.VxWorks.Ext.sigset_t; end System.OS_Interface; diff --git a/gcc/ada/s-rannum.adb b/gcc/ada/s-rannum.adb index 4480c693e8e..d85dd2efacf 100644 --- a/gcc/ada/s-rannum.adb +++ b/gcc/ada/s-rannum.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2007,2009 Free Software Foundation, Inc. -- +-- Copyright (C) 2007-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -86,44 +86,74 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Calendar; use Ada.Calendar; +with Ada.Calendar; use Ada.Calendar; with Ada.Unchecked_Conversion; -with Interfaces; use Interfaces; + +with Interfaces; use Interfaces; use Ada; package body System.Random_Numbers is - ------------------------- - -- Implementation Note -- - ------------------------- - - -- The design of this spec is very awkward, as a result of Ada 95 not - -- permitting in-out parameters for function formals (most naturally, - -- Generator values would be passed this way). In pure Ada 95, the only - -- solution is to use the heap and pointers, and, to avoid memory leaks, - -- controlled types. - - -- This is awfully heavy, so what we do is to use Unrestricted_Access to - -- get a pointer to the state in the passed Generator. This works because - -- Generator is a limited type and will thus always be passed by reference. - - Low31_Mask : constant := 2**31-1; - Bit31_Mask : constant := 2**31; - - Matrix_A_X : constant array (State_Val range 0 .. 1) of State_Val := - (0, 16#9908b0df#); - Y2K : constant Calendar.Time := Calendar.Time_Of (Year => 2000, Month => 1, Day => 1, Seconds => 0.0); - -- First Year 2000 day + -- First day of Year 2000 (what is this for???) + Image_Numeral_Length : constant := Max_Image_Width / N; subtype Image_String is String (1 .. Max_Image_Width); - -- Utility functions - - procedure Init (Gen : out Generator; Initiator : Unsigned_32); + ---------------------------- + -- Algorithmic Parameters -- + ---------------------------- + + Lower_Mask : constant := 2**31-1; + Upper_Mask : constant := 2**31; + + Matrix_A : constant array (State_Val range 0 .. 1) of State_Val + := (0, 16#9908b0df#); + -- The twist transformation is represented by a matrix of the form + -- + -- [ 0 I(31) ] + -- [ _a ] + -- + -- where 0 is a 31x31 block of 0s, I(31) is the 31x31 identity matrix and + -- _a is a particular bit row-vector, represented here by a 32-bit integer. + -- If integer x represents a row vector of bits (with x(0), the units bit, + -- last), then + -- x * A = [0 x(31..1)] xor Matrix_A(x(0)). + + U : constant := 11; + S : constant := 7; + B_Mask : constant := 16#9d2c5680#; + T : constant := 15; + C_Mask : constant := 16#efc60000#; + L : constant := 18; + -- The tempering shifts and bit masks, in the order applied + + Seed0 : constant := 5489; + -- Default seed, used to initialize the state vector when Reset not called + + Seed1 : constant := 19650218; + -- Seed used to initialize the state vector when calling Reset with an + -- initialization vector. + + Mult0 : constant := 1812433253; + -- Multiplier for a modified linear congruential generator used to + -- initialize the state vector when calling Reset with a single integer + -- seed. + + Mult1 : constant := 1664525; + Mult2 : constant := 1566083941; + -- Multipliers for two modified linear congruential generators used to + -- initialize the state vector when calling Reset with an initialization + -- vector. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Init (Gen : Generator; Initiator : Unsigned_32); -- Perform a default initialization of the state of Gen. The resulting -- state is identical for identical values of Initiator. @@ -147,75 +177,208 @@ package body System.Random_Numbers is ------------ function Random (Gen : Generator) return Unsigned_32 is - G : Generator renames Gen'Unrestricted_Access.all; + G : Generator renames Gen.Writable.Self.all; Y : State_Val; - I : Integer; + I : Integer; -- should avoid use of identifier I ??? begin I := G.I; if I < N - M then - Y := (G.S (I) and Bit31_Mask) or (G.S (I + 1) and Low31_Mask); - Y := G.S (I + M) xor Shift_Right (Y, 1) xor Matrix_A_X (Y and 1); + Y := (G.S (I) and Upper_Mask) or (G.S (I + 1) and Lower_Mask); + Y := G.S (I + M) xor Shift_Right (Y, 1) xor Matrix_A (Y and 1); I := I + 1; elsif I < N - 1 then - Y := (G.S (I) and Bit31_Mask) or (G.S (I + 1) and Low31_Mask); + Y := (G.S (I) and Upper_Mask) or (G.S (I + 1) and Lower_Mask); Y := G.S (I + (M - N)) xor Shift_Right (Y, 1) - xor Matrix_A_X (Y and 1); + xor Matrix_A (Y and 1); I := I + 1; elsif I = N - 1 then - Y := (G.S (I) and Bit31_Mask) or (G.S (0) and Low31_Mask); - Y := G.S (M - 1) xor Shift_Right (Y, 1) xor Matrix_A_X (Y and 1); + Y := (G.S (I) and Upper_Mask) or (G.S (0) and Lower_Mask); + Y := G.S (M - 1) xor Shift_Right (Y, 1) xor Matrix_A (Y and 1); I := 0; else - Init (G, 5489); + Init (G, Seed0); return Random (Gen); end if; G.S (G.I) := Y; G.I := I; - Y := Y xor Shift_Right (Y, 11); - Y := Y xor (Shift_Left (Y, 7) and 16#9d2c5680#); - Y := Y xor (Shift_Left (Y, 15) and 16#efc60000#); - Y := Y xor Shift_Right (Y, 18); + Y := Y xor Shift_Right (Y, U); + Y := Y xor (Shift_Left (Y, S) and B_Mask); + Y := Y xor (Shift_Left (Y, T) and C_Mask); + Y := Y xor Shift_Right (Y, L); return Y; end Random; - function Random (Gen : Generator) return Float is + generic + type Unsigned is mod <>; + type Real is digits <>; + with function Random (G : Generator) return Unsigned is <>; + function Random_Float_Template (Gen : Generator) return Real; + pragma Inline (Random_Float_Template); + -- Template for a random-number generator implementation that delivers + -- values of type Real in the range [0 .. 1], using values from Gen, + -- assuming that Unsigned is large enough to hold the bits of a mantissa + -- for type Real. + + --------------------------- + -- Random_Float_Template -- + --------------------------- - -- Note: The application of Float'Machine (...) is necessary to avoid - -- returning extra significand bits. Without it, the function's value - -- will change if it is spilled, for example, causing - -- gratuitous nondeterminism. + function Random_Float_Template (Gen : Generator) return Real is + + pragma Compile_Time_Error + (Unsigned'Last <= 2**(Real'Machine_Mantissa - 1), + "insufficiently large modular type used to hold mantissa"); - Result : constant Float := - Float'Machine - (Float (Unsigned_32'(Random (Gen))) * 2.0 ** (-32)); begin - if Result < 1.0 then - return Result; + -- This code generates random floating-point numbers from unsigned + -- integers. Assuming that Real'Machine_Radix = 2, it can deliver all + -- machine values of type Real (as implied by Real'Machine_Mantissa and + -- Real'Machine_Emin), which is not true of the standard method (to + -- which we fall back for non-binary radix): computing Real() / (+1). To do so, we first extract an + -- (M-1)-bit significand (where M is Real'Machine_Mantissa), and then + -- decide on a normalized exponent by repeated coin flips, decrementing + -- from 0 as long as we flip heads (1 bits). This process yields the + -- proper geometric distribution for the exponent: in a uniformly + -- distributed set of floating-point numbers, 1/2 of them will be in + -- (0.5, 1], 1/4 will be in (0.25, 0.5], and so forth. It makes a + -- further adjustment at binade boundaries (see comments below) to give + -- the effect of selecting a uniformly distributed real deviate in + -- [0..1] and then rounding to the nearest representable floating-point + -- number. The algorithm attempts to be stingy with random integers. In + -- the worst case, it can consume roughly -Real'Machine_Emin/32 32-bit + -- integers, but this case occurs with probability around + -- 2**Machine_Emin, and the expected number of calls to integer-valued + -- Random is 1. For another discussion of the issues addressed by this + -- process, see Allen Downey's unpublished paper at + -- http://allendowney.com/research/rand/downey07randfloat.pdf. + + if Real'Machine_Radix /= 2 then + return Real'Machine + (Real (Unsigned'(Random (Gen))) * 2.0**(-Unsigned'Size)); + else - return Float'Adjacent (1.0, 0.0); + declare + type Bit_Count is range 0 .. 4; + + subtype T is Real'Base; + + Trailing_Ones : constant array (Unsigned_32 range 0 .. 15) + of Bit_Count := + (2#00000# => 0, 2#00001# => 1, 2#00010# => 0, 2#00011# => 2, + 2#00100# => 0, 2#00101# => 1, 2#00110# => 0, 2#00111# => 3, + 2#01000# => 0, 2#01001# => 1, 2#01010# => 0, 2#01011# => 2, + 2#01100# => 0, 2#01101# => 1, 2#01110# => 0, 2#01111# => 4); + + Pow_Tab : constant array (Bit_Count range 0 .. 3) of Real + := (0 => 2.0**(0 - T'Machine_Mantissa), + 1 => 2.0**(-1 - T'Machine_Mantissa), + 2 => 2.0**(-2 - T'Machine_Mantissa), + 3 => 2.0**(-3 - T'Machine_Mantissa)); + + Extra_Bits : constant Natural := + (Unsigned'Size - T'Machine_Mantissa + 1); + -- Random bits left over after selecting mantissa + + Mantissa : Unsigned; + + X : Real; -- Scaled mantissa + R : Unsigned_32; -- Supply of random bits + R_Bits : Natural; -- Number of bits left in R + K : Bit_Count; -- Next decrement to exponent + + begin + Mantissa := Random (Gen) / 2**Extra_Bits; + R := Unsigned_32 (Mantissa mod 2**Extra_Bits); + R_Bits := Extra_Bits; + X := Real (2**(T'Machine_Mantissa - 1) + Mantissa); -- Exact + + if Extra_Bits < 4 and then R < 2 ** Extra_Bits - 1 then + + -- We got lucky and got a zero in our few extra bits + + K := Trailing_Ones (R); + + else + Find_Zero : loop + + -- R has R_Bits unprocessed random bits, a multiple of 4. + -- X needs to be halved for each trailing one bit. The + -- process stops as soon as a 0 bit is found. If R_Bits + -- becomes zero, reload R. + + -- Process 4 bits at a time for speed: the two iterations + -- on average with three tests each was still too slow, + -- probably because the branches are not predictable. + -- This loop now will only execute once 94% of the cases, + -- doing more bits at a time will not help. + + while R_Bits >= 4 loop + K := Trailing_Ones (R mod 16); + + exit Find_Zero when K < 4; -- Exits 94% of the time + + R_Bits := R_Bits - 4; + X := X / 16.0; + R := R / 16; + end loop; + + -- Do not allow us to loop endlessly even in the (very + -- unlikely) case that Random (Gen) keeps yielding all ones. + + exit Find_Zero when X = 0.0; + R := Random (Gen); + R_Bits := 32; + end loop Find_Zero; + end if; + + -- K has the count of trailing ones not reflected yet in X. The + -- following multiplication takes care of that, as well as the + -- correction to move the radix point to the left of the mantissa. + -- Doing it at the end avoids repeated rounding errors in the + -- exceedingly unlikely case of ever having a subnormal result. + + X := X * Pow_Tab (K); + + -- The smallest value in each binade is rounded to by 0.75 of + -- the span of real numbers as its next larger neighbor, and + -- 1.0 is rounded to by half of the span of real numbers as its + -- next smaller neighbor. To account for this, when we encounter + -- the smallest number in a binade, we substitute the smallest + -- value in the next larger binade with probability 1/2. + + if Mantissa = 0 and then Unsigned_32'(Random (Gen)) mod 2 = 0 then + X := 2.0 * X; + end if; + + return X; + end; end if; + end Random_Float_Template; + + ------------ + -- Random -- + ------------ + + function Random (Gen : Generator) return Float is + function F is new Random_Float_Template (Unsigned_32, Float); + begin + return F (Gen); end Random; function Random (Gen : Generator) return Long_Float is - Result : constant Long_Float := - Long_Float'Machine ((Long_Float (Unsigned_32'(Random (Gen))) - * 2.0 ** (-32)) - + (Long_Float (Unsigned_32'(Random (Gen))) * 2.0 ** (-64))); + function F is new Random_Float_Template (Unsigned_64, Long_Float); begin - if Result < 1.0 then - return Result; - else - return Long_Float'Adjacent (1.0, 0.0); - end if; + return F (Gen); end Random; function Random (Gen : Generator) return Unsigned_64 is @@ -244,10 +407,10 @@ package body System.Random_Numbers is declare -- In the 64-bit case, we have to be careful, since not all 64-bit -- unsigned values are representable in GNAT's root_integer type. - -- Ignore different-size warnings here; since GNAT's handling + -- Ignore different-size warnings here since GNAT's handling -- is correct. - pragma Warnings ("Z"); + pragma Warnings ("Z"); -- better to use msg string! ??? function Conv_To_Unsigned is new Unchecked_Conversion (Result_Subtype'Base, Unsigned_64); function Conv_To_Result is @@ -320,25 +483,30 @@ package body System.Random_Numbers is -- Reset -- ----------- - procedure Reset (Gen : out Generator) is - X : constant Unsigned_32 := Unsigned_32 ((Calendar.Clock - Y2K) * 64.0); + procedure Reset (Gen : Generator) is + Clock : constant Time := Calendar.Clock; + Duration_Since_Y2K : constant Duration := Clock - Y2K; + + X : constant Unsigned_32 := + Unsigned_32'Mod (Unsigned_64 (Duration_Since_Y2K) * 64); + begin Init (Gen, X); end Reset; - procedure Reset (Gen : out Generator; Initiator : Integer_32) is + procedure Reset (Gen : Generator; Initiator : Integer_32) is begin Init (Gen, To_Unsigned (Initiator)); end Reset; - procedure Reset (Gen : out Generator; Initiator : Unsigned_32) is + procedure Reset (Gen : Generator; Initiator : Unsigned_32) is begin Init (Gen, Initiator); end Reset; - procedure Reset (Gen : out Generator; Initiator : Integer) is + procedure Reset (Gen : Generator; Initiator : Integer) is begin - pragma Warnings ("C"); + pragma Warnings (Off, "condition is always *"); -- This is probably an unnecessary precaution against future change, but -- since the test is a static expression, no extra code is involved. @@ -358,30 +526,30 @@ package body System.Random_Numbers is end; end if; - pragma Warnings ("c"); + pragma Warnings (On, "condition is always *"); end Reset; - procedure Reset (Gen : out Generator; Initiator : Initialization_Vector) is + procedure Reset (Gen : Generator; Initiator : Initialization_Vector) is + G : Generator renames Gen.Writable.Self.all; I, J : Integer; begin - Init (Gen, 19650218); + Init (G, Seed1); I := 1; J := 0; if Initiator'Length > 0 then for K in reverse 1 .. Integer'Max (N, Initiator'Length) loop - Gen.S (I) := - (Gen.S (I) - xor ((Gen.S (I - 1) xor Shift_Right (Gen.S (I - 1), 30)) - * 1664525)) + G.S (I) := + (G.S (I) xor ((G.S (I - 1) + xor Shift_Right (G.S (I - 1), 30)) * Mult1)) + Initiator (J + Initiator'First) + Unsigned_32 (J); I := I + 1; J := J + 1; if I >= N then - Gen.S (0) := Gen.S (N - 1); + G.S (0) := G.S (N - 1); I := 1; end if; @@ -392,39 +560,42 @@ package body System.Random_Numbers is end if; for K in reverse 1 .. N - 1 loop - Gen.S (I) := - (Gen.S (I) xor ((Gen.S (I - 1) - xor Shift_Right (Gen.S (I - 1), 30)) * 1566083941)) + G.S (I) := + (G.S (I) xor ((G.S (I - 1) + xor Shift_Right (G.S (I - 1), 30)) * Mult2)) - Unsigned_32 (I); I := I + 1; if I >= N then - Gen.S (0) := Gen.S (N - 1); + G.S (0) := G.S (N - 1); I := 1; end if; end loop; - Gen.S (0) := Bit31_Mask; + G.S (0) := Upper_Mask; end Reset; - procedure Reset (Gen : out Generator; From_State : Generator) is + procedure Reset (Gen : Generator; From_State : Generator) is + G : Generator renames Gen.Writable.Self.all; begin - Gen.S := From_State.S; - Gen.I := From_State.I; + G.S := From_State.S; + G.I := From_State.I; end Reset; - procedure Reset (Gen : out Generator; From_State : State) is + procedure Reset (Gen : Generator; From_State : State) is + G : Generator renames Gen.Writable.Self.all; begin - Gen.I := 0; - Gen.S := From_State; + G.I := 0; + G.S := From_State; end Reset; - procedure Reset (Gen : out Generator; From_Image : String) is + procedure Reset (Gen : Generator; From_Image : String) is + G : Generator renames Gen.Writable.Self.all; begin - Gen.I := 0; + G.I := 0; for J in 0 .. N - 1 loop - Gen.S (J) := Extract_Value (From_Image, J); + G.S (J) := Extract_Value (From_Image, J); end loop; end Reset; @@ -468,7 +639,6 @@ package body System.Random_Numbers is begin Result := (others => ' '); - for J in 0 .. N - 1 loop Insert_Image (Result, J, Gen.S ((J + Gen.I) mod N)); end loop; @@ -493,18 +663,18 @@ package body System.Random_Numbers is -- Init -- ---------- - procedure Init (Gen : out Generator; Initiator : Unsigned_32) is + procedure Init (Gen : Generator; Initiator : Unsigned_32) is + G : Generator renames Gen.Writable.Self.all; begin - Gen.S (0) := Initiator; + G.S (0) := Initiator; for I in 1 .. N - 1 loop - Gen.S (I) := - 1812433253 - * (Gen.S (I - 1) xor Shift_Right (Gen.S (I - 1), 30)) + G.S (I) := + (G.S (I - 1) xor Shift_Right (G.S (I - 1), 30)) * Mult0 + Unsigned_32 (I); end loop; - Gen.I := 0; + G.I := 0; end Init; ------------------ @@ -526,9 +696,8 @@ package body System.Random_Numbers is ------------------- function Extract_Value (S : String; Index : Integer) return State_Val is + Start : constant Integer := S'First + Index * Image_Numeral_Length; begin - return State_Val'Value (S (S'First + Index * 11 .. - S'First + Index * 11 + 11)); + return State_Val'Value (S (Start .. Start + Image_Numeral_Length - 1)); end Extract_Value; - end System.Random_Numbers; diff --git a/gcc/ada/s-rannum.ads b/gcc/ada/s-rannum.ads index 28dcdc69215..0d2a7e9dee7 100644 --- a/gcc/ada/s-rannum.ads +++ b/gcc/ada/s-rannum.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2007,2009 Free Software Foundation, Inc. -- +-- Copyright (C) 2007-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -88,27 +88,27 @@ package System.Random_Numbers is -- in Reset). In general, there is little point in providing more than -- a certain number of values (currently 624). - procedure Reset (Gen : out Generator); + procedure Reset (Gen : Generator); -- Re-initialize the state of Gen from the time of day - procedure Reset (Gen : out Generator; Initiator : Initialization_Vector); - procedure Reset (Gen : out Generator; Initiator : Interfaces.Integer_32); - procedure Reset (Gen : out Generator; Initiator : Interfaces.Unsigned_32); - procedure Reset (Gen : out Generator; Initiator : Integer); + procedure Reset (Gen : Generator; Initiator : Initialization_Vector); + procedure Reset (Gen : Generator; Initiator : Interfaces.Integer_32); + procedure Reset (Gen : Generator; Initiator : Interfaces.Unsigned_32); + procedure Reset (Gen : Generator; Initiator : Integer); -- Re-initialize Gen based on the Initiator in various ways. Identical -- values of Initiator cause identical sequences of values. - procedure Reset (Gen : out Generator; From_State : Generator); + procedure Reset (Gen : Generator; From_State : Generator); -- Causes the state of Gen to be identical to that of From_State; Gen -- and From_State will produce identical sequences of values subsequently. - procedure Reset (Gen : out Generator; From_State : State); + procedure Reset (Gen : Generator; From_State : State); procedure Save (Gen : Generator; To_State : out State); -- The sequence -- Save (Gen2, S); Reset (Gen1, S) -- has the same effect as Reset (Gen2, Gen1). - procedure Reset (Gen : out Generator; From_Image : String); + procedure Reset (Gen : Generator; From_Image : String); function Image (Gen : Generator) return String; -- The call -- Reset (Gen2, Image (Gen1)) @@ -135,12 +135,19 @@ private subtype State_Val is Interfaces.Unsigned_32; type State is array (0 .. N - 1) of State_Val; + type Writable_Access (Self : access Generator) is limited null record; + -- Auxiliary type to make Generator a self-referential type + type Generator is limited record + Writable : Writable_Access (Generator'Access); + -- This self reference allows functions to modify Generator arguments + S : State := (others => 0); -- The shift register, a circular buffer I : Integer := N; - -- Current starting position in shift register S + -- Current starting position in shift register S (N means uninitialized) + -- We should avoid using the identifier I here ??? end record; end System.Random_Numbers; diff --git a/gcc/ada/s-regpat.adb b/gcc/ada/s-regpat.adb index dec4c1fcef0..1c0cf746a53 100755 --- a/gcc/ada/s-regpat.adb +++ b/gcc/ada/s-regpat.adb @@ -7,7 +7,7 @@ -- B o d y -- -- -- -- Copyright (C) 1986 by University of Toronto. -- --- Copyright (C) 1999-2009, AdaCore -- +-- Copyright (C) 1999-2010, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -47,12 +47,10 @@ with Ada.Unchecked_Conversion; package body System.Regpat is - MAGIC : constant Character := Character'Val (10#0234#); - -- The first byte of the regexp internal "program" is actually - -- this magic number; the start node begins in the second byte. - -- - -- This is used to make sure that a regular expression was correctly - -- compiled. + Debug : constant Boolean := False; + -- Set to True to activate debug traces. This is normally set to constant + -- False to simply delete all the trace code. It is to be edited to True + -- for internal debugging of the package. ---------------------------- -- Implementation details -- @@ -76,21 +74,19 @@ package body System.Regpat is -- You can see the exact byte-compiled version by using the Dump -- subprogram. However, here are a few examples: - -- (a|b): 1 : MAGIC - -- 2 : BRANCH (next at 10) - -- 5 : EXACT (next at 18) operand=a - -- 10 : BRANCH (next at 18) - -- 13 : EXACT (next at 18) operand=b - -- 18 : EOP (next at 0) + -- (a|b): 1 : BRANCH (next at 9) + -- 4 : EXACT (next at 17) operand=a + -- 9 : BRANCH (next at 17) + -- 12 : EXACT (next at 17) operand=b + -- 17 : EOP (next at 0) -- - -- (ab)*: 1 : MAGIC - -- 2 : CURLYX (next at 26) { 0, 32767} - -- 9 : OPEN 1 (next at 13) - -- 13 : EXACT (next at 19) operand=ab - -- 19 : CLOSE 1 (next at 23) - -- 23 : WHILEM (next at 0) - -- 26 : NOTHING (next at 29) - -- 29 : EOP (next at 0) + -- (ab)*: 1 : CURLYX (next at 25) { 0, 32767} + -- 8 : OPEN 1 (next at 12) + -- 12 : EXACT (next at 18) operand=ab + -- 18 : CLOSE 1 (next at 22) + -- 22 : WHILEM (next at 0) + -- 25 : NOTHING (next at 28) + -- 28 : EOP (next at 0) -- The opcodes are: @@ -186,6 +182,12 @@ package body System.Regpat is -- Using two bytes for the "next" pointer is vast overkill for most -- things, but allows patterns to get big without disasters. + Next_Pointer_Bytes : constant := 3; + -- Points after the "next pointer" data. An instruction is therefore: + -- 1 byte: instruction opcode + -- 2 bytes: pointer to next instruction + -- * bytes: optional data for the instruction + ----------------------- -- Character classes -- ----------------------- @@ -279,11 +281,6 @@ package body System.Regpat is Op : out Character_Class); -- Return a pointer to the string argument of the node at P - function Get_Next_Offset - (Program : Program_Data; - IP : Pointer) return Pointer; - -- Get the offset field of a node. Used by Get_Next - function Get_Next (Program : Program_Data; IP : Pointer) return Pointer; @@ -303,7 +300,6 @@ package body System.Regpat is pragma Inline (Is_Alnum); pragma Inline (Is_White_Space); pragma Inline (Get_Next); - pragma Inline (Get_Next_Offset); pragma Inline (Operand); pragma Inline (Read_Natural); pragma Inline (String_Length); @@ -318,6 +314,23 @@ package body System.Regpat is Worst_Expression : constant Expression_Flags := (others => False); -- Worst case + procedure Dump_Until + (Program : Program_Data; + Index : in out Pointer; + Till : Pointer; + Indent : Natural; + Do_Print : Boolean := True); + -- Dump the program until the node Till (not included) is met. Every line + -- is indented with Index spaces at the beginning Dumps till the end if + -- Till is 0. + + procedure Dump_Operation + (Program : Program_Data; + Index : Pointer; + Indent : Natural); + -- Same as above, but only dumps a single operation, and compute its + -- indentation from the program. + --------- -- "=" -- --------- @@ -340,7 +353,7 @@ package body System.Regpat is (Program_Data, Character_Class); begin - Op (0 .. 31) := Convert (Program (P + 3 .. P + 34)); + Op (0 .. 31) := Convert (Program (P + Next_Pointer_Bytes .. P + 34)); end Bitmap_Operand; ------------- @@ -369,7 +382,6 @@ package body System.Regpat is PM : Pattern_Matcher renames Matcher; Program : Program_Data renames PM.Program; - Emit_Code : constant Boolean := PM.Size > 0; Emit_Ptr : Pointer := Program_First; Parse_Pos : Natural := Expression'First; -- Input-scan pointer @@ -421,21 +433,31 @@ package body System.Regpat is (Expr_Flags : out Expression_Flags; IP : out Pointer); -- Parse_Atom is the lowest level parse procedure. - -- Optimization: gobbles an entire sequence of ordinary characters - -- so that it can turn them into a single node, which is smaller to - -- store and faster to run. Backslashed characters are exceptions, - -- each becoming a separate node; the code is simpler that way and - -- it's not worth fixing. + -- + -- Optimization: Gobbles an entire sequence of ordinary characters so + -- that it can turn them into a single node, which is smaller to store + -- and faster to run. Backslashed characters are exceptions, each + -- becoming a separate node; the code is simpler that way and it's + -- not worth fixing. procedure Insert_Operator (Op : Opcode; Operand : Pointer; Greedy : Boolean := True); - -- Insert_Operator inserts an operator in front of an - -- already-emitted operand and relocates the operand. - -- This applies to PLUS and STAR. + -- Insert_Operator inserts an operator in front of an already-emitted + -- operand and relocates the operand. This applies to PLUS and STAR. -- If Minmod is True, then the operator is non-greedy. + function Insert_Operator_Before + (Op : Opcode; + Operand : Pointer; + Greedy : Boolean; + Opsize : Pointer) return Pointer; + -- Insert an operator before Operand (and move the latter forward in the + -- program). Opsize is the size needed to represent the operator. This + -- returns the position at which the operator was inserted, and moves + -- Emit_Ptr after the new position of the operand. + procedure Insert_Curly_Operator (Op : Opcode; Min : Natural; @@ -451,9 +473,6 @@ package body System.Regpat is procedure Link_Operand_Tail (P, Val : Pointer); -- Link_Tail on operand of first argument; noop if operand-less - function Next_Instruction (P : Pointer) return Pointer; - -- Dig the "next" pointer out of a node - procedure Fail (M : String); pragma No_Return (Fail); -- Fail with a diagnostic message, if possible @@ -513,7 +532,7 @@ package body System.Regpat is procedure Emit (B : Character) is begin - if Emit_Code then + if Emit_Ptr <= PM.Size then Program (Emit_Ptr) := B; end if; @@ -531,7 +550,12 @@ package body System.Regpat is (Character_Class, Program31); begin - if Emit_Code then + -- What is the mysterious constant 31 here??? Can't it be expressed + -- symbolically (size of integer - 1 or some such???). In any case + -- it should be declared as a constant (and referenced presumably + -- as this constant + 1 below. + + if Emit_Ptr + 31 <= PM.Size then Program (Emit_Ptr .. Emit_Ptr + 31) := Convert (Bitmap); end if; @@ -544,7 +568,7 @@ package body System.Regpat is procedure Emit_Natural (IP : Pointer; N : Natural) is begin - if Emit_Code then + if IP + 1 <= PM.Size then Program (IP + 1) := Character'Val (N / 256); Program (IP) := Character'Val (N mod 256); end if; @@ -558,13 +582,13 @@ package body System.Regpat is Result : constant Pointer := Emit_Ptr; begin - if Emit_Code then + if Emit_Ptr + 2 <= PM.Size then Program (Emit_Ptr) := Character'Val (Opcode'Pos (Op)); Program (Emit_Ptr + 1) := ASCII.NUL; Program (Emit_Ptr + 2) := ASCII.NUL; end if; - Emit_Ptr := Emit_Ptr + 3; + Emit_Ptr := Emit_Ptr + Next_Pointer_Bytes; return Result; end Emit_Node; @@ -639,21 +663,38 @@ package body System.Regpat is Operand : Pointer; Greedy : Boolean := True) is - Dest : constant Pointer := Emit_Ptr; Old : Pointer; - Size : Pointer := 7; + begin + Old := Insert_Operator_Before (Op, Operand, Greedy, Opsize => 7); + Emit_Natural (Old + Next_Pointer_Bytes, Min); + Emit_Natural (Old + Next_Pointer_Bytes + 2, Max); + end Insert_Curly_Operator; + + ---------------------------- + -- Insert_Operator_Before -- + ---------------------------- + + function Insert_Operator_Before + (Op : Opcode; + Operand : Pointer; + Greedy : Boolean; + Opsize : Pointer) return Pointer + is + Dest : constant Pointer := Emit_Ptr; + Old : Pointer; + Size : Pointer := Opsize; begin - -- If the operand is not greedy, insert an extra operand before it + -- If not greedy, we have to emit another opcode first if not Greedy then - Size := Size + 3; + Size := Size + Next_Pointer_Bytes; end if; -- Move the operand in the byte-compilation, so that we can insert -- the operator before it. - if Emit_Code then + if Emit_Ptr + Size <= PM.Size then Program (Operand + Size .. Emit_Ptr + Size) := Program (Operand .. Emit_Ptr); end if; @@ -665,15 +706,13 @@ package body System.Regpat is if not Greedy then Old := Emit_Node (MINMOD); - Link_Tail (Old, Old + 3); + Link_Tail (Old, Old + Next_Pointer_Bytes); end if; Old := Emit_Node (Op); - Emit_Natural (Old + 3, Min); - Emit_Natural (Old + 5, Max); - Emit_Ptr := Dest + Size; - end Insert_Curly_Operator; + return Old; + end Insert_Operator_Before; --------------------- -- Insert_Operator -- @@ -684,40 +723,11 @@ package body System.Regpat is Operand : Pointer; Greedy : Boolean := True) is - Dest : constant Pointer := Emit_Ptr; - Old : Pointer; - Size : Pointer := 3; - Discard : Pointer; pragma Warnings (Off, Discard); - begin - -- If not greedy, we have to emit another opcode first - - if not Greedy then - Size := Size + 3; - end if; - - -- Move the operand in the byte-compilation, so that we can insert - -- the operator before it. - - if Emit_Code then - Program (Operand + Size .. Emit_Ptr + Size) := - Program (Operand .. Emit_Ptr); - end if; - - -- Insert the operator at the position previously occupied by the - -- operand. - - Emit_Ptr := Operand; - - if not Greedy then - Old := Emit_Node (MINMOD); - Link_Tail (Old, Old + 3); - end if; - - Discard := Emit_Node (Op); - Emit_Ptr := Dest + Size; + Discard := Insert_Operator_Before + (Op, Operand, Greedy, Opsize => Next_Pointer_Bytes); end Insert_Operator; ----------------------- @@ -784,7 +794,7 @@ package body System.Regpat is procedure Link_Operand_Tail (P, Val : Pointer) is begin - if Emit_Code and then Program (P) = BRANCH then + if P <= PM.Size and then Program (P) = BRANCH then Link_Tail (Operand (P), Val); end if; end Link_Operand_Tail; @@ -799,16 +809,13 @@ package body System.Regpat is Offset : Pointer; begin - if not Emit_Code then - return; - end if; - - -- Find last node + -- Find last node (the size of the pattern matcher might be too + -- small, so don't try to read past its end). Scan := P; - loop - Temp := Next_Instruction (Scan); - exit when Temp = 0; + while Scan + Next_Pointer_Bytes <= PM.Size loop + Temp := Get_Next (Program, Scan); + exit when Temp = Scan; Scan := Temp; end loop; @@ -817,47 +824,25 @@ package body System.Regpat is Emit_Natural (Scan + 1, Natural (Offset)); end Link_Tail; - ---------------------- - -- Next_Instruction -- - ---------------------- - - function Next_Instruction (P : Pointer) return Pointer is - Offset : Pointer; - - begin - if not Emit_Code then - return 0; - end if; - - Offset := Get_Next_Offset (Program, P); - - if Offset = 0 then - return 0; - end if; - - return P + Offset; - end Next_Instruction; - ----------- -- Parse -- ----------- - -- Combining parenthesis handling with the base level - -- of regular expression is a trifle forced, but the - -- need to tie the tails of the branches to what follows - -- makes it hard to avoid. + -- Combining parenthesis handling with the base level of regular + -- expression is a trifle forced, but the need to tie the tails of the + -- the branches to what follows makes it hard to avoid. procedure Parse - (Parenthesized : Boolean; - Flags : out Expression_Flags; - IP : out Pointer) + (Parenthesized : Boolean; + Flags : out Expression_Flags; + IP : out Pointer) is - E : String renames Expression; - Br : Pointer; - Ender : Pointer; - Par_No : Natural; - New_Flags : Expression_Flags; - Have_Branch : Boolean := False; + E : String renames Expression; + Br, Br2 : Pointer; + Ender : Pointer; + Par_No : Natural; + New_Flags : Expression_Flags; + Have_Branch : Boolean := False; begin Flags := (Has_Width => True, others => False); -- Tentatively @@ -938,15 +923,16 @@ package body System.Regpat is Link_Tail (IP, Ender); - if Have_Branch then + if Have_Branch and then Emit_Ptr <= PM.Size then -- Hook the tails of the branches to the closing node Br := IP; loop - exit when Br = 0; Link_Operand_Tail (Br, Ender); - Br := Next_Instruction (Br); + Br2 := Get_Next (Program, Br); + exit when Br2 = Br; + Br := Br2; end loop; end if; @@ -1639,13 +1625,13 @@ package body System.Regpat is -- is an initial string to emit, do it now. if Has_Special_Operator - and then Emit_Ptr >= Length_Ptr + 3 + and then Emit_Ptr >= Length_Ptr + Next_Pointer_Bytes then Emit_Ptr := Emit_Ptr - 1; Parse_Pos := Start_Pos; end if; - if Emit_Code then + if Length_Ptr <= PM.Size then Program (Length_Ptr) := Character'Val (Emit_Ptr - Length_Ptr - 2); end if; @@ -1987,7 +1973,6 @@ package body System.Regpat is -- Start of processing for Compile begin - Emit (MAGIC); Parse (False, Expr_Flags, Result); if Result = 0 then @@ -1999,7 +1984,7 @@ package body System.Regpat is -- Do we want to actually compile the expression, or simply get the -- code size ??? - if Emit_Code then + if Emit_Ptr <= PM.Size then Optimize (PM); end if; @@ -2010,19 +1995,38 @@ package body System.Regpat is (Expression : String; Flags : Regexp_Flags := No_Flags) return Pattern_Matcher is + -- Assume the compiled regexp will fit in 1000 chars. If it does not we + -- will have to compile a second time once the correct size is known. If + -- it fits, we save a significant amount of time by avoiding the second + -- compilation. + + Dummy : Pattern_Matcher (1000); Size : Program_Size; - Dummy : Pattern_Matcher (0); - pragma Unreferenced (Dummy); begin Compile (Dummy, Expression, Size, Flags); - declare - Result : Pattern_Matcher (Size); - begin - Compile (Result, Expression, Size, Flags); - return Result; - end; + if Size <= Dummy.Size then + return Pattern_Matcher' + (Size => Size, + First => Dummy.First, + Anchored => Dummy.Anchored, + Must_Have => Dummy.Must_Have, + Must_Have_Length => Dummy.Must_Have_Length, + Paren_Count => Dummy.Paren_Count, + Flags => Dummy.Flags, + Program => Dummy.Program + (Dummy.Program'First .. Dummy.Program'First + Size - 1)); + else + -- We have to recompile now that we know the size + -- ??? Can we use Ada05's return construct ? + declare + Result : Pattern_Matcher (Size); + begin + Compile (Result, Expression, Size, Flags); + return Result; + end; + end if; end Compile; procedure Compile @@ -2031,93 +2035,107 @@ package body System.Regpat is Flags : Regexp_Flags := No_Flags) is Size : Program_Size; - pragma Unreferenced (Size); + begin Compile (Matcher, Expression, Size, Flags); + + if Size > Matcher.Size then + raise Expression_Error with "Pattern_Matcher is too small"; + end if; end Compile; - ---------- - -- Dump -- - ---------- + -------------------- + -- Dump_Operation -- + -------------------- - procedure Dump (Self : Pattern_Matcher) is - Op : Opcode; - Program : Program_Data renames Self.Program; + procedure Dump_Operation + (Program : Program_Data; + Index : Pointer; + Indent : Natural) + is + Current : Pointer := Index; + begin + Dump_Until (Program, Current, Current + 1, Indent); + end Dump_Operation; + + ---------------- + -- Dump_Until -- + ---------------- + + procedure Dump_Until + (Program : Program_Data; + Index : in out Pointer; + Till : Pointer; + Indent : Natural; + Do_Print : Boolean := True) + is + function Image (S : String) return String; + -- Remove leading space - procedure Dump_Until - (Start : Pointer; - Till : Pointer; - Indent : Natural := 0); - -- Dump the program until the node Till (not included) is met. - -- Every line is indented with Index spaces at the beginning - -- Dumps till the end if Till is 0. + ----------- + -- Image -- + ----------- - ---------------- - -- Dump_Until -- - ---------------- + function Image (S : String) return String is + begin + if S (S'First) = ' ' then + return S (S'First + 1 .. S'Last); + else + return S; + end if; + end Image; - procedure Dump_Until - (Start : Pointer; - Till : Pointer; - Indent : Natural := 0) - is - Next : Pointer; - Index : Pointer; - Local_Indent : Natural := Indent; - Length : Pointer; + -- Local variables - begin - Index := Start; - while Index < Till loop - Op := Opcode'Val (Character'Pos ((Self.Program (Index)))); + Op : Opcode; + Next : Pointer; + Length : Pointer; + Local_Indent : Natural := Indent; - if Op = CLOSE then - Local_Indent := Local_Indent - 3; - end if; + -- Start of processing for Dump_Until - declare - Point : constant String := Pointer'Image (Index); + begin + while Index < Till loop + Op := Opcode'Val (Character'Pos ((Program (Index)))); + Next := Get_Next (Program, Index); + if Do_Print then + declare + Point : constant String := Pointer'Image (Index); begin - for J in 1 .. 6 - Point'Length loop - Put (' '); - end loop; - - Put (Point - & " : " - & (1 .. Local_Indent => ' ') - & Opcode'Image (Op)); + Put ((1 .. 4 - Point'Length => ' ') + & Point & ":" + & (1 .. Local_Indent * 2 => ' ') & Opcode'Image (Op)); end; -- Print the parenthesis number if Op = OPEN or else Op = CLOSE or else Op = REFF then - Put (Natural'Image (Character'Pos (Program (Index + 3)))); + Put (Image (Natural'Image + (Character'Pos + (Program (Index + Next_Pointer_Bytes))))); end if; - Next := Index + Get_Next_Offset (Program, Index); - if Next = Index then - Put (" (next at 0)"); + Put (" (-)"); else - Put (" (next at " & Pointer'Image (Next) & ")"); + Put (" (" & Image (Pointer'Image (Next)) & ")"); end if; + end if; - case Op is - - -- Character class operand - - when ANYOF => null; - declare - Bitmap : Character_Class; - Last : Character := ASCII.NUL; - Current : Natural := 0; + case Op is + when ANYOF => + declare + Bitmap : Character_Class; + Last : Character := ASCII.NUL; + Current : Natural := 0; + Current_Char : Character; - Current_Char : Character; + begin + Bitmap_Operand (Program, Index, Bitmap); - begin - Bitmap_Operand (Program, Index, Bitmap); - Put (" operand="); + if Do_Print then + Put ("["); while Current <= 255 loop Current_Char := Character'Val (Current); @@ -2135,17 +2153,16 @@ package body System.Regpat is Current_Char := Character'Val (Current); exit when not Get_From_Class (Bitmap, Current_Char); - end loop; - if Last <= ' ' then + if not Is_Graphic (Last) then Put (Last'Img); else Put (Last); end if; if Character'Succ (Last) /= Current_Char then - Put ("-" & Character'Pred (Current_Char)); + Put ("\-" & Character'Pred (Current_Char)); end if; else @@ -2153,76 +2170,93 @@ package body System.Regpat is end if; end loop; - New_Line; - Index := Index + 3 + Bitmap'Length; - end; + Put_Line ("]"); + end if; - -- string operand + Index := Index + Next_Pointer_Bytes + Bitmap'Length; + end; - when EXACT | EXACTF => - Length := String_Length (Program, Index); - Put (" operand (length:" & Program_Size'Image (Length + 1) - & ") =" - & String (Program (String_Operand (Index) - .. String_Operand (Index) - + Length))); - Index := String_Operand (Index) + Length + 1; - New_Line; + when EXACT | EXACTF => + Length := String_Length (Program, Index); + if Do_Print then + Put (" (" & Image (Program_Size'Image (Length + 1)) + & " chars) <" + & String (Program (String_Operand (Index) + .. String_Operand (Index) + + Length))); + Put_Line (">"); + end if; - -- Node operand + Index := String_Operand (Index) + Length + 1; - when BRANCH => - New_Line; - Dump_Until (Index + 3, Next, Local_Indent + 3); - Index := Next; + -- Node operand - when STAR | PLUS => + when BRANCH | STAR | PLUS => + if Do_Print then New_Line; + end if; - -- Only one instruction + Index := Index + Next_Pointer_Bytes; + Dump_Until (Program, Index, Pointer'Min (Next, Till), + Local_Indent + 1, Do_Print); + + when CURLY | CURLYX => + if Do_Print then + Put_Line + (" {" + & Image (Natural'Image + (Read_Natural (Program, Index + Next_Pointer_Bytes))) + & "," + & Image (Natural'Image (Read_Natural (Program, Index + 5))) + & "}"); + end if; - Dump_Until (Index + 3, Index + 4, Local_Indent + 3); - Index := Next; + Index := Index + 7; + Dump_Until (Program, Index, Pointer'Min (Next, Till), + Local_Indent + 1, Do_Print); - when CURLY | CURLYX => - Put (" {" - & Natural'Image (Read_Natural (Program, Index + 3)) - & "," - & Natural'Image (Read_Natural (Program, Index + 5)) - & "}"); + when OPEN => + if Do_Print then New_Line; - Dump_Until (Index + 7, Next, Local_Indent + 3); - Index := Next; + end if; - when OPEN => - New_Line; - Index := Index + 4; - Local_Indent := Local_Indent + 3; + Index := Index + 4; + Local_Indent := Local_Indent + 1; - when CLOSE | REFF => + when CLOSE | REFF => + if Do_Print then New_Line; - Index := Index + 4; + end if; - when EOP => - Index := Index + 3; - New_Line; - exit; + Index := Index + 4; - -- No operand + if Op = CLOSE then + Local_Indent := Local_Indent - 1; + end if; - when others => - Index := Index + 3; + when others => + Index := Index + Next_Pointer_Bytes; + + if Do_Print then New_Line; - end case; - end loop; - end Dump_Until; + end if; + + exit when Op = EOP; + end case; + end loop; + end Dump_Until; + + ---------- + -- Dump -- + ---------- + + procedure Dump (Self : Pattern_Matcher) is + Program : Program_Data renames Self.Program; + Index : Pointer := Program'First; -- Start of processing for Dump begin - pragma Assert (Self.Program (Program_First) = MAGIC, - "Corrupted Pattern_Matcher"); - Put_Line ("Must start with (Self.First) = " & Character'Image (Self.First)); @@ -2238,8 +2272,7 @@ package body System.Regpat is Put_Line (" Multiple_Lines mode"); end if; - Put_Line (" 1 : MAGIC"); - Dump_Until (Program_First + 1, Self.Program'Last + 1); + Dump_Until (Program, Index, Self.Program'Last + 1, 0); end Dump; -------------------- @@ -2261,27 +2294,10 @@ package body System.Regpat is -------------- function Get_Next (Program : Program_Data; IP : Pointer) return Pointer is - Offset : constant Pointer := Get_Next_Offset (Program, IP); begin - if Offset = 0 then - return 0; - else - return IP + Offset; - end if; + return IP + Pointer (Read_Natural (Program, IP + 1)); end Get_Next; - --------------------- - -- Get_Next_Offset -- - --------------------- - - function Get_Next_Offset - (Program : Program_Data; - IP : Pointer) return Pointer - is - begin - return Pointer (Read_Natural (Program, IP + 1)); - end Get_Next_Offset; - -------------- -- Is_Alnum -- -------------- @@ -2401,9 +2417,8 @@ package body System.Regpat is -- using a loop instead of recursion. -- Why is the above comment part of the spec rather than body ??? - function Match_Whilem (IP : Pointer) return Boolean; - -- Return True if a WHILEM matches - -- How come IP is unreferenced in the body ??? + function Match_Whilem return Boolean; + -- Return True if a WHILEM matches the Current_Curly function Recurse_Match (IP : Pointer; From : Natural) return Boolean; pragma Inline (Recurse_Match); @@ -2418,6 +2433,11 @@ package body System.Regpat is Greedy : Boolean) return Boolean; -- Return True it the simple operator (possibly non-greedy) matches + Dump_Indent : Integer := -1; + procedure Dump_Current (Scan : Pointer; Prefix : Boolean := True); + procedure Dump_Error (Msg : String); + -- Debug: print the current context + pragma Inline (Index); pragma Inline (Repeat); @@ -2446,15 +2466,15 @@ package body System.Regpat is ------------------- function Recurse_Match (IP : Pointer; From : Natural) return Boolean is - L : constant Natural := Last_Paren; - + L : constant Natural := Last_Paren; Tmp_F : constant Match_Array := Matches_Full (From + 1 .. Matches_Full'Last); - Start : constant Natural_Array := Matches_Tmp (From + 1 .. Matches_Tmp'Last); Input : constant Natural := Input_Pos; + Dump_Indent_Save : constant Integer := Dump_Indent; + begin if Match (IP) then return True; @@ -2464,9 +2484,45 @@ package body System.Regpat is Matches_Full (Tmp_F'Range) := Tmp_F; Matches_Tmp (Start'Range) := Start; Input_Pos := Input; + Dump_Indent := Dump_Indent_Save; return False; end Recurse_Match; + ------------------ + -- Dump_Current -- + ------------------ + + procedure Dump_Current (Scan : Pointer; Prefix : Boolean := True) is + Length : constant := 10; + Pos : constant String := Integer'Image (Input_Pos); + + begin + if Prefix then + Put ((1 .. 5 - Pos'Length => ' ')); + Put (Pos & " <" + & Data (Input_Pos + .. Integer'Min (Last_In_Data, Input_Pos + Length - 1))); + Put ((1 .. Length - 1 - Last_In_Data + Input_Pos => ' ')); + Put ("> |"); + + else + Put (" "); + end if; + + Dump_Operation (Program, Scan, Indent => Dump_Indent); + end Dump_Current; + + ---------------- + -- Dump_Error -- + ---------------- + + procedure Dump_Error (Msg : String) is + begin + Put (" | "); + Put ((1 .. Dump_Indent * 2 => ' ')); + Put_Line (Msg); + end Dump_Error; + ----------- -- Match -- ----------- @@ -2475,8 +2531,11 @@ package body System.Regpat is Scan : Pointer := IP; Next : Pointer; Op : Opcode; + Result : Boolean; begin + Dump_Indent := Dump_Indent + 1; + State_Machine : loop pragma Assert (Scan /= 0); @@ -2485,13 +2544,18 @@ package body System.Regpat is Op := Opcode'Val (Character'Pos (Program (Scan))); - -- Calculate offset of next instruction. - -- Second character is most significant in Program_Data. + -- Calculate offset of next instruction. Second character is most + -- significant in Program_Data. Next := Get_Next (Program, Scan); + if Debug then + Dump_Current (Scan); + end if; + case Op is when EOP => + Dump_Indent := Dump_Indent - 1; return True; -- Success ! when BRANCH => @@ -2501,6 +2565,7 @@ package body System.Regpat is else loop if Recurse_Match (Operand (Scan), 0) then + Dump_Indent := Dump_Indent - 1; return True; end if; @@ -2517,7 +2582,7 @@ package body System.Regpat is when BOL => exit State_Machine when Input_Pos /= BOL_Pos and then ((Self.Flags and Multiple_Lines) = 0 - or else Data (Input_Pos - 1) /= ASCII.LF); + or else Data (Input_Pos - 1) /= ASCII.LF); when MBOL => exit State_Machine when Input_Pos /= BOL_Pos @@ -2529,7 +2594,7 @@ package body System.Regpat is when EOL => exit State_Machine when Input_Pos <= Data'Last and then ((Self.Flags and Multiple_Lines) = 0 - or else Data (Input_Pos) /= ASCII.LF); + or else Data (Input_Pos) /= ASCII.LF); when MEOL => exit State_Machine when Input_Pos <= Data'Last @@ -2610,7 +2675,6 @@ package body System.Regpat is declare Opnd : Pointer := String_Operand (Scan); Current : Positive := Input_Pos; - Last : constant Pointer := Opnd + String_Length (Program, Scan); @@ -2686,6 +2750,12 @@ package body System.Regpat is -- If we haven't seen that parenthesis yet if Last_Paren < No then + Dump_Indent := Dump_Indent - 1; + + if Debug then + Dump_Error ("REFF: No match, backtracking"); + end if; + return False; end if; @@ -2695,6 +2765,12 @@ package body System.Regpat is if Input_Pos > Last_In_Data or else Data (Input_Pos) /= Data (Data_Pos) then + Dump_Indent := Dump_Indent - 1; + + if Debug then + Dump_Error ("REFF: No match, backtracking"); + end if; + return False; end if; @@ -2711,7 +2787,9 @@ package body System.Regpat is Greed : constant Boolean := Greedy; begin Greedy := True; - return Match_Simple_Operator (Op, Scan, Next, Greed); + Result := Match_Simple_Operator (Op, Scan, Next, Greed); + Dump_Indent := Dump_Indent - 1; + return Result; end; when CURLYX => @@ -2725,9 +2803,10 @@ package body System.Regpat is declare Min : constant Natural := - Read_Natural (Program, Scan + 3); + Read_Natural (Program, Scan + Next_Pointer_Bytes); Max : constant Natural := - Read_Natural (Program, Scan + 5); + Read_Natural + (Program, Scan + Next_Pointer_Bytes + 2); Cc : aliased Current_Curly_Record; Has_Match : Boolean; @@ -2742,25 +2821,46 @@ package body System.Regpat is Next => Next, Lastloc => 0, Old_Cc => Current_Curly); + Greedy := True; Current_Curly := Cc'Unchecked_Access; - Has_Match := Match (Next - 3); + Has_Match := Match (Next - Next_Pointer_Bytes); -- Start on the WHILEM Current_Curly := Cc.Old_Cc; + Dump_Indent := Dump_Indent - 1; + + if not Has_Match then + if Debug then + Dump_Error ("CURLYX failed..."); + end if; + end if; + return Has_Match; end; when WHILEM => - return Match_Whilem (IP); + Result := Match_Whilem; + Dump_Indent := Dump_Indent - 1; + + if Debug and then not Result then + Dump_Error ("WHILEM: no match, backtracking"); + end if; + + return Result; end case; Scan := Next; end loop State_Machine; - -- If we get here, there is no match. - -- For successful matches when EOP is the terminating point. + if Debug then + Dump_Error ("failed..."); + Dump_Indent := Dump_Indent - 1; + end if; + + -- If we get here, there is no match. For successful matches when EOP + -- is the terminating point. return False; end Match; @@ -2786,8 +2886,8 @@ package body System.Regpat is Save : constant Natural := Input_Pos; begin - -- Lookahead to avoid useless match attempts - -- when we know what character comes next. + -- Lookahead to avoid useless match attempts when we know what + -- character comes next. if Program (Next) = EXACT then Next_Char := Program (String_Operand (Next)); @@ -2806,21 +2906,31 @@ package body System.Regpat is Operand_Code := Operand (Scan); when others => - Min := Read_Natural (Program, Scan + 3); - Max := Read_Natural (Program, Scan + 5); + Min := Read_Natural (Program, Scan + Next_Pointer_Bytes); + Max := Read_Natural (Program, Scan + Next_Pointer_Bytes + 2); Operand_Code := Scan + 7; end case; + if Debug then + Dump_Current (Operand_Code, Prefix => False); + end if; + -- Non greedy operators if not Greedy then - -- Test the minimal repetitions + -- Test we can repeat at least Min times - if Min /= 0 - and then Repeat (Operand_Code, Min) < Min - then - return False; + if Min /= 0 then + No := Repeat (Operand_Code, Min); + + if No < Min then + if Debug then + Dump_Error ("failed... matched" & No'Img & " times"); + end if; + + return False; + end if; end if; Old := Input_Pos; @@ -2828,6 +2938,7 @@ package body System.Regpat is -- Find the place where 'next' could work if Next_Char_Known then + -- Last position to check if Max = Natural'Last then @@ -2842,6 +2953,10 @@ package body System.Regpat is -- Look for the first possible opportunity + if Debug then + Dump_Error ("Next_Char must be " & Next_Char); + end if; + loop -- Find the next possible position @@ -2855,8 +2970,8 @@ package body System.Regpat is return False; end if; - -- Check that we still match if we stop - -- at the position we just found. + -- Check that we still match if we stop at the position we + -- just found. declare Num : constant Natural := Input_Pos - Old; @@ -2864,6 +2979,10 @@ package body System.Regpat is begin Input_Pos := Old; + if Debug then + Dump_Error ("Would we still match at that position?"); + end if; + if Repeat (Operand_Code, Num) < Num then return False; end if; @@ -2879,14 +2998,18 @@ package body System.Regpat is Input_Pos := Input_Pos + 1; end loop; - -- We know what the next character is + -- We do not know what the next character is else while Max >= Min loop + if Debug then + Dump_Error ("Non-greedy repeat, N=" & Min'Img); + Dump_Error ("Do we still match Next if we stop here?"); + end if; -- If the next character matches - if Match (Next) then + if Recurse_Match (Next, 1) then return True; end if; @@ -2897,6 +3020,10 @@ package body System.Regpat is if Repeat (Operand_Code, 1) /= 0 then Min := Min + 1; else + if Debug then + Dump_Error ("Non-greedy repeat failed..."); + end if; + return False; end if; end loop; @@ -2909,12 +3036,15 @@ package body System.Regpat is else No := Repeat (Operand_Code, Max); - -- ??? Perl has some special code here in case the - -- next instruction is of type EOL, since $ and \Z - -- can match before *and* after newline at the end. + if Debug and then No < Min then + Dump_Error ("failed... matched" & No'Img & " times"); + end if; - -- ??? Perl has some special code here in case (paren) - -- is True. + -- ??? Perl has some special code here in case the next + -- instruction is of type EOL, since $ and \Z can match before + -- *and* after newline at the end. + + -- ??? Perl has some special code here in case (paren) is True -- Else, if we don't have any parenthesis @@ -2948,10 +3078,9 @@ package body System.Regpat is -- tree by recursing ever deeper. And if it fails, we have to reset -- our parent's current state that we can try again after backing off. - function Match_Whilem (IP : Pointer) return Boolean is - pragma Unreferenced (IP); - + function Match_Whilem return Boolean is Cc : constant Current_Curly_Access := Current_Curly; + N : constant Natural := Cc.Cur + 1; Ln : Natural := 0; @@ -2991,12 +3120,22 @@ package body System.Regpat is Cc.Cur := N; Cc.Lastloc := Input_Pos; + if Debug then + Dump_Error + ("Tests that we match at least" & Cc.Min'Img & " N=" & N'Img); + end if; + if Match (Cc.Scan) then return True; end if; Cc.Cur := N - 1; Cc.Lastloc := Lastloc; + + if Debug then + Dump_Error ("failed..."); + end if; + return False; end if; @@ -3022,6 +3161,9 @@ package body System.Regpat is -- Maximum greed exceeded ? if N >= Cc.Max then + if Debug then + Dump_Error ("failed..."); + end if; return False; end if; @@ -3029,6 +3171,10 @@ package body System.Regpat is Cc.Cur := N; Cc.Lastloc := Input_Pos; + if Debug then + Dump_Error ("Next failed, what about Current?"); + end if; + if Recurse_Match (Cc.Scan, Cc.Paren_Floor) then return True; end if; @@ -3044,6 +3190,10 @@ package body System.Regpat is Cc.Cur := N; Cc.Lastloc := Input_Pos; + if Debug then + Dump_Error ("Recurse at current position"); + end if; + if Recurse_Match (Cc.Scan, Cc.Paren_Floor) then return True; end if; @@ -3057,6 +3207,10 @@ package body System.Regpat is Ln := Current_Curly.Cur; end if; + if Debug then + Dump_Error ("Failed matching for later positions"); + end if; + if Match (Cc.Next) then return True; end if; @@ -3068,6 +3222,11 @@ package body System.Regpat is Current_Curly := Cc; Cc.Cur := N - 1; Cc.Lastloc := Lastloc; + + if Debug then + Dump_Error ("failed..."); + end if; + return False; end Match_Whilem; @@ -3200,7 +3359,7 @@ package body System.Regpat is Last_Paren := 0; Matches_Full := (others => No_Match); - if Match (Program_First + 1) then + if Match (Program_First) then Matches_Full (0) := (Pos, Input_Pos - 1); return True; end if; @@ -3218,12 +3377,6 @@ package body System.Regpat is return; end if; - -- Check validity of program - - pragma Assert - (Program (Program_First) = MAGIC, - "Corrupted Pattern_Matcher"); - -- If there is a "must appear" string, look for it if Self.Must_Have_Length > 0 then @@ -3430,7 +3583,7 @@ package body System.Regpat is function Operand (P : Pointer) return Pointer is begin - return P + 3; + return P + Next_Pointer_Bytes; end Operand; -------------- @@ -3452,7 +3605,7 @@ package body System.Regpat is Self.Must_Have := Program'Last + 1; Self.Must_Have_Length := 0; - Scan := Program_First + 1; -- First instruction (can be anything) + Scan := Program_First; -- First instruction (can be anything) if Program (Scan) = EXACT then Self.First := Program (String_Operand (Scan)); @@ -3547,7 +3700,7 @@ package body System.Regpat is is begin pragma Assert (Program (P) = EXACT or else Program (P) = EXACTF); - return Character'Pos (Program (P + 3)); + return Character'Pos (Program (P + Next_Pointer_Bytes)); end String_Length; -------------------- diff --git a/gcc/ada/s-shasto.adb b/gcc/ada/s-shasto.adb index 7038d796c28..783fdc4a95d 100644 --- a/gcc/ada/s-shasto.adb +++ b/gcc/ada/s-shasto.adb @@ -6,8 +6,8 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- --- -- +-- Copyright (C) 1998-2010, Free Software Foundation, Inc. -- +-- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- @@ -88,8 +88,8 @@ package body System.Shared_Storage is Item : AS.Stream_Element_Array); subtype Hash_Header is Natural range 0 .. 30; - -- Number of hash headers, related (for efficiency purposes only) - -- to the maximum number of lock files.. + -- Number of hash headers, related (for efficiency purposes only) to the + -- maximum number of lock files. type Shared_Var_File_Entry; type Shared_Var_File_Entry_Ptr is access Shared_Var_File_Entry; diff --git a/gcc/ada/s-stchop.adb b/gcc/ada/s-stchop.adb index d4aa675a857..b757c56532b 100644 --- a/gcc/ada/s-stchop.adb +++ b/gcc/ada/s-stchop.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2010, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -48,28 +48,24 @@ package body System.Stack_Checking.Operations is function Set_Stack_Info (Stack : not null access Stack_Access) return Stack_Access; - -- The function Set_Stack_Info is the actual function that updates the -- cache containing a pointer to the Stack_Info. It may also be used for -- detecting asynchronous abort in combination with Invalidate_Self_Cache. - + -- -- Set_Stack_Info should do the following things in order: -- 1) Get the Stack_Access value for the current task -- 2) Set Stack.all to the value obtained in 1) -- 3) Optionally Poll to check for asynchronous abort - + -- -- This order is important because if at any time a write to the stack -- cache is pending, that write should be followed by a Poll to prevent -- loosing signals. - + -- -- Note: This function must be compiled with Polling turned off - - -- Note: on systems like VxWorks and OS/2 with real thread-local storage, - -- Set_Stack_Info should return an access value for such local - -- storage. In those cases the cache will always be up-to-date. - - -- The following constants should be imported from some system-specific - -- constants package. The constants must be static for performance reasons. + -- + -- Note: on systems with real thread-local storage, Set_Stack_Info should + -- return an access value for such local storage. In those cases the cache + -- will always be up-to-date. ---------------------------- -- Invalidate_Stack_Cache -- diff --git a/gcc/ada/s-stoele.adb b/gcc/ada/s-stoele.adb index 0bab843c138..cd3e22ef907 100644 --- a/gcc/ada/s-stoele.adb +++ b/gcc/ada/s-stoele.adb @@ -37,6 +37,10 @@ package body System.Storage_Elements is pragma Suppress (All_Checks); + -- Conversion to/from address + + -- Note qualification below of To_Address to avoid ambiguities on VMS + function To_Address is new Ada.Unchecked_Conversion (Storage_Offset, Address); function To_Offset is @@ -47,38 +51,62 @@ package body System.Storage_Elements is -- These functions must be place first because they are inlined_always -- and are used and inlined in other subprograms defined in this unit. - function To_Integer (Value : Address) return Integer_Address is - begin - return Integer_Address (Value); - end To_Integer; + ---------------- + -- To_Address -- + ---------------- function To_Address (Value : Integer_Address) return Address is begin return Address (Value); end To_Address; + ---------------- + -- To_Integer -- + ---------------- + + function To_Integer (Value : Address) return Integer_Address is + begin + return Integer_Address (Value); + end To_Integer; + -- Address arithmetic + --------- + -- "+" -- + --------- + function "+" (Left : Address; Right : Storage_Offset) return Address is begin - return To_Address (To_Integer (Left) + To_Integer (To_Address (Right))); + return Storage_Elements.To_Address + (To_Integer (Left) + To_Integer (To_Address (Right))); end "+"; function "+" (Left : Storage_Offset; Right : Address) return Address is begin - return To_Address (To_Integer (To_Address (Left)) + To_Integer (Right)); + return Storage_Elements.To_Address + (To_Integer (To_Address (Left)) + To_Integer (Right)); end "+"; + --------- + -- "-" -- + --------- + function "-" (Left : Address; Right : Storage_Offset) return Address is begin - return To_Address (To_Integer (Left) - To_Integer (To_Address (Right))); + return Storage_Elements.To_Address + (To_Integer (Left) - To_Integer (To_Address (Right))); end "-"; function "-" (Left, Right : Address) return Storage_Offset is begin - return To_Offset (To_Address (To_Integer (Left) - To_Integer (Right))); + return To_Offset (Storage_Elements.To_Address + (To_Integer (Left) - To_Integer (Right))); end "-"; + ----------- + -- "mod" -- + ----------- + function "mod" (Left : Address; Right : Storage_Offset) return Storage_Offset @@ -98,4 +126,5 @@ package body System.Storage_Elements is raise Constraint_Error; end if; end "mod"; + end System.Storage_Elements; diff --git a/gcc/ada/s-taprop-vxworks.adb b/gcc/ada/s-taprop-vxworks.adb index 4cde338bfd3..2cf8131755b 100644 --- a/gcc/ada/s-taprop-vxworks.adb +++ b/gcc/ada/s-taprop-vxworks.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -99,10 +99,6 @@ package body System.Task_Primitives.Operations is Dispatching_Policy : Character; pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); - function Get_Policy (Prio : System.Any_Priority) return Character; - pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching"); - -- Get priority specific dispatching policy - Mutex_Protocol : Priority_Type; Foreign_Task_Elaborated : aliased Boolean := True; @@ -734,20 +730,13 @@ package body System.Task_Primitives.Operations is -- Set_Priority -- ------------------ - type Prio_Array_Type is array (System.Any_Priority) of Integer; - pragma Atomic_Components (Prio_Array_Type); - - Prio_Array : Prio_Array_Type; - -- Global array containing the id of the currently running task for each - -- priority. Note that we assume that we are on a single processor with - -- run-till-blocked scheduling. - procedure Set_Priority (T : Task_Id; Prio : System.Any_Priority; Loss_Of_Inheritance : Boolean := False) is - Array_Item : Integer; + pragma Unreferenced (Loss_Of_Inheritance); + Result : int; begin @@ -756,33 +745,16 @@ package body System.Task_Primitives.Operations is (T.Common.LL.Thread, To_VxWorks_Priority (int (Prio))); pragma Assert (Result = 0); - if (Dispatching_Policy = 'F' or else Get_Policy (Prio) = 'F') - and then Loss_Of_Inheritance - and then Prio < T.Common.Current_Priority - then - -- Annex D requirement (RM D.2.2(9)): - - -- If the task drops its priority due to the loss of inherited - -- priority, it is added at the head of the ready queue for its - -- new active priority. + -- Note: in VxWorks 6.6 (or earlier), the task is placed at the end of + -- the priority queue instead of the head. This is not the behavior + -- required by Annex D (RM D.2.3(5/2)), but we consider it an acceptable + -- variation (RM 1.1.3(6)), given this is the built-in behavior of the + -- operating system. VxWorks versions starting from 6.7 implement the + -- required Annex D semantics. - Array_Item := Prio_Array (T.Common.Base_Priority) + 1; - Prio_Array (T.Common.Base_Priority) := Array_Item; - - loop - -- Give some processes a chance to arrive - - taskDelay (0); - - -- Then wait for our turn to proceed - - exit when Array_Item = Prio_Array (T.Common.Base_Priority) - or else Prio_Array (T.Common.Base_Priority) = 1; - end loop; - - Prio_Array (T.Common.Base_Priority) := - Prio_Array (T.Common.Base_Priority) - 1; - end if; + -- In older versions we attempted to better approximate the Annex D + -- required behavior, but this simulation was not entirely accurate, + -- and it seems better to live with the standard VxWorks semantics. T.Common.Current_Priority := Prio; end Set_Priority; diff --git a/gcc/ada/s-tasdeb.adb b/gcc/ada/s-tasdeb.adb index 9fb0cd6e798..ccc81d9d53b 100644 --- a/gcc/ada/s-tasdeb.adb +++ b/gcc/ada/s-tasdeb.adb @@ -362,10 +362,11 @@ package body System.Tasking.Debug is ----------- procedure Write (Fd : Integer; S : String; Count : Integer) is - Discard : Integer; + Discard : System.CRTL.ssize_t; pragma Unreferenced (Discard); begin - Discard := System.CRTL.write (Fd, S (S'First)'Address, Count); + Discard := System.CRTL.write (Fd, S (S'First)'Address, + System.CRTL.size_t (Count)); -- Is it really right to ignore write errors here ??? end Write; diff --git a/gcc/ada/s-tpoben.adb b/gcc/ada/s-tpoben.adb index 4694310ebff..ba2bf6c267a 100644 --- a/gcc/ada/s-tpoben.adb +++ b/gcc/ada/s-tpoben.adb @@ -226,12 +226,12 @@ package body System.Tasking.Protected_Objects.Entries is raise Program_Error; end if; - -- pragma Assert (Self_Id.Deferral_Level = 0); -- If a PO is created from a controlled operation, abort is already - -- deferred at this point, so we need to use Defer_Abort_Nestable - -- In some cases, the above assertion can be useful to spot - -- inconsistencies, outside the above scenario involving controlled - -- types. + -- deferred at this point, so we need to use Defer_Abort_Nestable. In + -- some cases, the following assertion can help to spot inconsistencies, + -- outside the above scenario involving controlled types. + + -- pragma Assert (Self_Id.Deferral_Level = 0); Initialization.Defer_Abort_Nestable (Self_ID); Initialize_Lock (Init_Priority, Object.L'Access); diff --git a/gcc/ada/s-vxwext-kernel.ads b/gcc/ada/s-vxwext-kernel.ads index e450285ecbc..0df9211a68f 100644 --- a/gcc/ada/s-vxwext-kernel.ads +++ b/gcc/ada/s-vxwext-kernel.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2008-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2008-2010, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -39,6 +39,8 @@ package System.VxWorks.Ext is subtype SEM_ID is Long_Integer; -- typedef struct semaphore *SEM_ID; + type sigset_t is mod 2 ** Long_Long_Integer'Size; + type t_id is new Long_Integer; subtype int is Interfaces.C.int; diff --git a/gcc/ada/s-vxwext-rtp.ads b/gcc/ada/s-vxwext-rtp.ads index 22452a18e77..844d39415db 100644 --- a/gcc/ada/s-vxwext-rtp.ads +++ b/gcc/ada/s-vxwext-rtp.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2008-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2008-2010, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -39,6 +39,8 @@ package System.VxWorks.Ext is subtype SEM_ID is Long_Integer; -- typedef struct semaphore *SEM_ID; + type sigset_t is mod 2 ** Long_Long_Integer'Size; + type t_id is new Long_Integer; subtype int is Interfaces.C.int; diff --git a/gcc/ada/s-vxwext.ads b/gcc/ada/s-vxwext.ads index 42abdc1f355..1559d7d8e14 100644 --- a/gcc/ada/s-vxwext.ads +++ b/gcc/ada/s-vxwext.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2008-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2008-2010, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -39,7 +39,10 @@ package System.VxWorks.Ext is subtype SEM_ID is Long_Integer; -- typedef struct semaphore *SEM_ID; + type sigset_t is mod 2 ** Interfaces.C.long'Size; + type t_id is new Long_Integer; + subtype int is Interfaces.C.int; type Interrupt_Handler is access procedure (parameter : System.Address); diff --git a/gcc/ada/scil_ll.adb b/gcc/ada/scil_ll.adb new file mode 100644 index 00000000000..4591d8ef287 --- /dev/null +++ b/gcc/ada/scil_ll.adb @@ -0,0 +1,144 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S C I L _ L L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Alloc; use Alloc; +with Atree; use Atree; +with Opt; use Opt; +with Sinfo; use Sinfo; +with Table; + +package body SCIL_LL is + + procedure Copy_SCIL_Node (Target : Node_Id; Source : Node_Id); + -- Copy the SCIL field from Source to Target (it is used as the argument + -- for a call to Set_Reporting_Proc in package atree). + + function SCIL_Nodes_Table_Size return Pos; + -- Used to initialize the table of SCIL nodes because we do not want + -- to consume memory for this table if it is not required. + + ---------------------------- + -- SCIL_Nodes_Table_Size -- + ---------------------------- + + function SCIL_Nodes_Table_Size return Pos is + begin + if Generate_SCIL then + return Alloc.Orig_Nodes_Initial; + else + return 1; + end if; + end SCIL_Nodes_Table_Size; + + package SCIL_Nodes is new Table.Table ( + Table_Component_Type => Node_Id, + Table_Index_Type => Node_Id'Base, + Table_Low_Bound => First_Node_Id, + Table_Initial => SCIL_Nodes_Table_Size, + Table_Increment => Alloc.Orig_Nodes_Increment, + Table_Name => "SCIL_Nodes"); + -- This table records the value of attribute SCIL_Node of all the + -- tree nodes. + + -------------------- + -- Copy_SCIL_Node -- + -------------------- + + procedure Copy_SCIL_Node (Target : Node_Id; Source : Node_Id) is + begin + Set_SCIL_Node (Target, Get_SCIL_Node (Source)); + end Copy_SCIL_Node; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + SCIL_Nodes.Init; + Set_Reporting_Proc (Copy_SCIL_Node'Access); + end Initialize; + + ------------------- + -- Get_SCIL_Node -- + ------------------- + + function Get_SCIL_Node (N : Node_Id) return Node_Id is + begin + if Generate_SCIL + and then Present (N) + then + return SCIL_Nodes.Table (N); + else + return Empty; + end if; + end Get_SCIL_Node; + + ------------------- + -- Set_SCIL_Node -- + ------------------- + + procedure Set_SCIL_Node (N : Node_Id; Value : Node_Id) is + begin + pragma Assert (Generate_SCIL); + + if Present (Value) then + case Nkind (Value) is + when N_SCIL_Dispatch_Table_Tag_Init => + pragma Assert (Nkind (N) = N_Object_Declaration); + null; + + when N_SCIL_Dispatching_Call => + pragma Assert (Nkind_In (N, N_Function_Call, + N_Procedure_Call_Statement)); + null; + + when N_SCIL_Membership_Test => + pragma Assert (Nkind_In (N, N_Identifier, + N_And_Then, + N_Or_Else, + N_Expression_With_Actions)); + null; + + when others => + pragma Assert (False); + raise Program_Error; + end case; + end if; + + if Atree.Last_Node_Id > SCIL_Nodes.Last then + SCIL_Nodes.Set_Last (Atree.Last_Node_Id); + end if; + + SCIL_Nodes.Set_Item (N, Value); + end Set_SCIL_Node; + +end SCIL_LL; diff --git a/gcc/ada/scil_ll.ads b/gcc/ada/scil_ll.ads new file mode 100644 index 00000000000..8265a19df30 --- /dev/null +++ b/gcc/ada/scil_ll.ads @@ -0,0 +1,48 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S C I L _ L L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package extends the tree nodes with a field that is used to reference +-- the SCIL node. + +with Types; use Types; + +package SCIL_LL is + + function Get_SCIL_Node (N : Node_Id) return Node_Id; + -- Read the value of attribute SCIL node + + procedure Set_SCIL_Node (N : Node_Id; Value : Node_Id); + -- Set the value of attribute SCIL node + + procedure Initialize; + -- Initialize the table of SCIL nodes + +end SCIL_LL; diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb index af1f3bbc3a0..d4005b47989 100644 --- a/gcc/ada/scng.adb +++ b/gcc/ada/scng.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -37,9 +37,12 @@ with Uintp; use Uintp; with Urealp; use Urealp; with Widechar; use Widechar; +pragma Warnings (Off); +-- This package is used also by gnatcoll with System.CRC32; with System.UTF_32; use System.UTF_32; with System.WCh_Con; use System.WCh_Con; +pragma Warnings (On); package body Scng is @@ -325,7 +328,8 @@ package body Scng is and then Source (Scan_Ptr + 2) = C then Scan_Ptr := Scan_Ptr + 1; - Error_Msg_S ("no space allowed here"); + Error_Msg_S -- CODEFIX + ("no space allowed here"); Scan_Ptr := Scan_Ptr + 2; return True; @@ -380,16 +384,14 @@ package body Scng is Error_Msg_S -- CODEFIX ("two consecutive underlines not permitted"); else - Error_Msg_S -- CODEFIX??? - ("underline cannot follow punctuation character"); + Error_Msg_S ("underline cannot follow punctuation character"); end if; else if Source (Scan_Ptr - 1) = '_' then - Error_Msg_S -- CODEFIX??? - ("punctuation character cannot follow underline"); + Error_Msg_S ("punctuation character cannot follow underline"); else - Error_Msg_S -- CODEFIX??? + Error_Msg_S ("two consecutive punctuation characters not permitted"); end if; end if; @@ -572,8 +574,7 @@ package body Scng is if Warn_On_Obsolescent_Feature then Error_Msg_S ("use of "":"" is an obsolescent feature (RM J.2(3))?"); - Error_Msg_S - ("\use ""'#"" instead?"); + Error_Msg_S ("\use ""'#"" instead?"); end if; end if; @@ -658,9 +659,11 @@ package body Scng is elsif not Identifier_Char (C) then if Base_Char = '#' then - Error_Msg_S ("missing '#"); + Error_Msg_S -- CODEFIX + ("missing '#"); else - Error_Msg_S ("missing ':"); + Error_Msg_S -- CODEFIX + ("missing ':"); end if; exit; @@ -875,7 +878,7 @@ package body Scng is end if; end if; - Error_Msg_S -- CODEFIX + Error_Msg_S -- CODEFIX ("missing string quote"); end Error_Unterminated_String; @@ -1215,7 +1218,8 @@ package body Scng is Accumulate_Checksum ('&'); if Source (Scan_Ptr + 1) = '&' then - Error_Msg_S ("'&'& should be `AND THEN`"); + Error_Msg_S -- CODEFIX + ("'&'& should be `AND THEN`"); Scan_Ptr := Scan_Ptr + 2; Token := Tok_And; return; @@ -1263,7 +1267,8 @@ package body Scng is and then Source (Scan_Ptr + 2) /= '-' then Token := Tok_Colon_Equal; - Error_Msg (":- should be :=", Scan_Ptr); + Error_Msg -- CODEFIX + (":- should be :=", Scan_Ptr); Scan_Ptr := Scan_Ptr + 2; return; @@ -1367,7 +1372,8 @@ package body Scng is return; elsif Source (Scan_Ptr + 1) = '=' then - Error_Msg_S ("== should be ="); + Error_Msg_S -- CODEFIX + ("== should be ="); Scan_Ptr := Scan_Ptr + 1; end if; @@ -1588,8 +1594,7 @@ package body Scng is if Warn_On_Obsolescent_Feature then Error_Msg_S ("use of ""'%"" is an obsolescent feature (RM J.2(4))?"); - Error_Msg_S - ("\use """""" instead?"); + Error_Msg_S ("\use """""" instead?"); end if; Slit; @@ -1669,13 +1674,13 @@ package body Scng is elsif Ada_Version >= Ada_05 and then Is_UTF_32_Non_Graphic (UTF_32 (Code)) then - Error_Msg + Error_Msg -- CODEFIX???? ("(Ada 2005) non-graphic character not permitted " & "in character literal", Wptr); end if; if Source (Scan_Ptr) /= ''' then - Error_Msg_S ("missing apostrophe"); + Error_Msg_S ("missing apostrophe"); else Scan_Ptr := Scan_Ptr + 1; end if; @@ -1789,7 +1794,8 @@ package body Scng is -- Special check for || to give nice message if Source (Scan_Ptr + 1) = '|' then - Error_Msg_S ("""'|'|"" should be `OR ELSE`"); + Error_Msg_S -- CODEFIX + ("""'|'|"" should be `OR ELSE`"); Scan_Ptr := Scan_Ptr + 2; Token := Tok_Or; return; @@ -1815,12 +1821,12 @@ package body Scng is if Warn_On_Obsolescent_Feature then Error_Msg_S ("use of ""'!"" is an obsolescent feature (RM J.2(2))?"); - Error_Msg_S - ("\use ""'|"" instead?"); + Error_Msg_S ("\use ""'|"" instead?"); end if; if Source (Scan_Ptr + 1) = '=' then - Error_Msg_S ("'!= should be /="); + Error_Msg_S -- CODEFIX + ("'!= should be /="); Scan_Ptr := Scan_Ptr + 2; Token := Tok_Not_Equal; return; @@ -2068,8 +2074,7 @@ package body Scng is -- Punctuation is an error (at start of identifier) elsif Is_UTF_32_Punctuation (Cat) then - Error_Msg - ("identifier cannot start with punctuation", Wptr); + Error_Msg ("identifier cannot start with punctuation", Wptr); Scan_Ptr := Wptr; Name_Len := 0; Underline_Found := False; @@ -2078,8 +2083,7 @@ package body Scng is -- Mark character is an error (at start of identifier) elsif Is_UTF_32_Mark (Cat) then - Error_Msg - ("identifier cannot start with mark character", Wptr); + Error_Msg ("identifier cannot start with mark character", Wptr); Scan_Ptr := Wptr; Name_Len := 0; Underline_Found := False; diff --git a/gcc/ada/scng.ads b/gcc/ada/scng.ads index abcf3dad193..1988e26dd23 100644 --- a/gcc/ada/scng.ads +++ b/gcc/ada/scng.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -23,9 +23,9 @@ -- -- ------------------------------------------------------------------------------ --- This package contains a generic lexical analyzer. This is used --- for scanning Ada source files or text files with an Ada-like syntax, --- such as project files. It is instantiated in Scn and Prj.Err. +-- This package contains a generic lexical analyzer. This is used for scanning +-- Ada source files or text files with an Ada-like syntax, such as project +-- files. It is instantiated in Scn and Prj.Err. with Casing; use Casing; with Styleg; diff --git a/gcc/ada/scos.ads b/gcc/ada/scos.ads index 19804e4567b..7111287c0a6 100644 --- a/gcc/ada/scos.ads +++ b/gcc/ada/scos.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -148,21 +148,27 @@ package SCOs is -- o object declaration -- r renaming declaration -- i generic instantiation - -- C CASE statement (includes only the expression) + -- C CASE statement (from CASE through end of expression) -- E EXIT statement - -- F FOR loop statement (includes only the iteration scheme) - -- I IF statement (includes only the condition [in the RM sense, which - -- is a decision in the SCO sense]) + -- F FOR loop statement (from FOR through end of iteration scheme) + -- I IF statement (from IF through end of condition) -- P PRAGMA -- R extended RETURN statement - -- W WHILE loop statement (includes only the condition) + -- W WHILE loop statement (from WHILE through end of condition) + + -- Note: for I and W, condition above is in the RM syntax sense (this + -- condition is a decision in SCO terminology). -- and is omitted for all other cases. + -- Note: up to 6 entries can appear on a single CS line. If more than 6 + -- entries appear in one logical statement sequence, continuation lines + -- are marked by Cs and appear immediately after the CS line. + -- Decisions -- Note: in the following description, logical operator includes only the - -- short circuited forms and NOT (so can be only NOT, AND THEN, OR ELSE). + -- short-circuited forms and NOT (so can be only NOT, AND THEN, OR ELSE). -- The reason that we can exclude AND/OR/XOR is that we expect SCO's to -- be generated using the restriction No_Direct_Boolean_Operators if we -- are interested in decision coverage, which does not permit the use of @@ -171,18 +177,27 @@ package SCOs is -- we are generating SCO's only for simple coverage, then we are not -- interested in decisions in any case. - -- Decisions are either simple or complex. A simple decision is a boolean - -- expresssion that occurs in the context of a control structure in the - -- source program, including WHILE, IF, EXIT WHEN, or in an Assert, - -- Check, Pre_Condition or Post_Condition pragma. For pragmas, decision - -- SCOs are generated only if the corresponding pragma is enabled. Note - -- that a boolean expression in any other context, for example as right - -- hand side of an assignment, is not considered to be a simple decision. + -- Note: the reason we include NOT is for informational purposes. The + -- presence of NOT does not generate additional coverage obligations, + -- but if we know where the NOT's are, the coverage tool can generate + -- more accurate diagnostics on uncovered tests. + + -- A top level boolean expression is a boolean expression that is not an + -- operand of a logical operator. - -- A complex decision is an occurrence of a logical operator which is not - -- itself an operand of some other logical operator. If any operand of - -- the logical operator is itself a logical operator, this is not a - -- separate decision, it is part of the same decision. + -- Decisions are either simple or complex. A simple decision is a top + -- level boolean expresssion that has only one condition and that occurs + -- in the context of a control structure in the source program, including + -- WHILE, IF, EXIT WHEN, or in an Assert, Check, Pre_Condition or + -- Post_Condition pragma. For pragmas, decision SCOs are generated only + -- if the corresponding pragma is enabled. Note that a top level boolean + -- expression with only one condition that occurs in any other context, + -- for example as right hand side of an assignment, is not considered to + -- be a (simple) decision. + + -- A complex decision is a top level boolean expression that has more + -- than one condition. A complex decision may occur in any boolean + -- expression context. -- So for example, if we have @@ -201,7 +216,7 @@ package SCOs is -- For each decision, a decision line is generated with the form: - -- C*sloc expression + -- C* sloc expression -- Here * is one of the following characters: @@ -217,7 +232,7 @@ package SCOs is -- For X, sloc is omitted. -- The expression is a prefix polish form indicating the structure of - -- the decision, including logical operators and short circuit forms. + -- the decision, including logical operators and short-circuit forms. -- The following is a grammar showing the structure of expression: -- expression ::= term (if expr is not logical operator) @@ -248,8 +263,35 @@ package SCOs is -- ! indicates NOT applied to the expression. - -- In the context of Couverture, the No_Direct_Boolean_Opeartors - -- restriction is assumed, and no other operator can appear. + -- Note that complex decisions do NOT include non-short-circuited logical + -- operators (AND/XOR/OR). In the context of existing coverage tools the + -- No_Direct_Boolean_Operators restriction is assumed, so these operators + -- cannot appear in the source in any case. + + -- The SCO line for a decision always occurs after the CS line for the + -- enclosing statement. The SCO line for a nested decision always occurs + -- after the line for the enclosing decision. + + -- Note that membership tests are considered to be a single simple + -- condition, and that is true even if the Ada 2005 set membership + -- form is used, e.g. A in (2,7,11.15). + + -- Case Expressions + + -- For case statements, we rely on statement coverage to make sure that + -- all branches of a case statement are covered, but that does not work + -- for case expressions, since the entire expression is contained in a + -- single statement. However, for complete coverage we really should be + -- able to check that every branch of the case statement is covered, so + -- we generate a SCO of the form: + + -- CC sloc-range sloc-range ... + + -- where sloc-range covers the range of the case expression. + + -- Note: up to 6 entries can appear on a single CC line. If more than 6 + -- entries appear in one logical statement sequence, continuation lines + -- are marked by Cc and appear immediately after the CC line. --------------------------------------------------------------------- -- Internal table used to store Source Coverage Obligations (SCOs) -- @@ -289,19 +331,45 @@ package SCOs is -- Note: successive statements (possibly interspersed with entries of -- other kinds, that are ignored for this purpose), starting with one -- labeled with C1 = 'S', up to and including the first one labeled with - -- Last=True, indicate the sequence to be output for a sequence of - -- statements on a single CS line. + -- Last = True, indicate the sequence to be output for a sequence of + -- statements on a single CS line (possibly followed by Cs continuation + -- lines). + + -- Decision (IF/EXIT/WHILE) + -- C1 = 'I'/'E'/'W' (for IF/EXIT/WHILE) + -- C2 = ' ' + -- From = IF/EXIT/WHILE token + -- To = No_Source_Location + -- Last = unused + + -- Decision (PRAGMA) + -- C1 = 'P' + -- C2 = 'e'/'d' for enabled/disabled + -- From = PRAGMA token + -- To = No_Source_Location + -- Last = unused - -- Decision - -- C1 = decision type code + -- Note: when the parse tree is first scanned, we unconditionally build + -- a pragma decision entry for any decision in a pragma (here as always + -- in SCO contexts, the only pragmas with decisions are Assert, Check, + -- Precondition and Postcondition), and we mark the pragma as disabled. + -- + -- During analysis, if the pragma is enabled, Set_SCO_Pragma_Enabled to + -- mark the SCO decision table entry as enabled (C2 set to 'e'). Then + -- in Put_SCOs, we only output the decision for a pragma if C2 is 'e'. + -- + -- When we read SCOs from an ALI file (in Get_SCOs), we always set C2 + -- to 'e', since clearly the pragma is enabled if it was written out. + + -- Decision (Expression) + -- C1 = 'X' -- C2 = ' ' - -- From = location of IF/EXIT/PRAGMA/WHILE token, - -- No_Source_Location for X + -- From = No_Source_Location -- To = No_Source_Location -- Last = unused -- Operator - -- C1 = '!', '^', '&', '|' + -- C1 = '!', '&', '|' -- C2 = ' ' -- From = location of NOT/AND/OR token -- To = No_Source_Location @@ -316,8 +384,7 @@ package SCOs is -- Note: the sequence starting with a decision, and continuing with -- operators and elements up to and including the first one labeled with - -- Last = True, indicate the sequence to be output for a complex decision - -- on a single CD decision line. + -- Last = True, indicate the sequence to be output on one decision line. ---------------- -- Unit Table -- diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index caa73a0b82c..5e6d8b2766a 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -67,9 +67,9 @@ package body Sem is -- Controls debugging printouts for Walk_Library_Items Outer_Generic_Scope : Entity_Id := Empty; - -- Global reference to the outer scope that is generic. In a non - -- generic context, it is empty. At the moment, it is only used - -- for avoiding freezing of external references in generics. + -- Global reference to the outer scope that is generic. In a non- generic + -- context, it is empty. At the moment, it is only used for avoiding + -- freezing of external references in generics. Comp_Unit_List : Elist_Id := No_Elist; -- Used by Walk_Library_Items. This is a list of N_Compilation_Unit nodes @@ -80,9 +80,9 @@ package body Sem is generic with procedure Action (Withed_Unit : Node_Id); procedure Walk_Withs_Immediate (CU : Node_Id; Include_Limited : Boolean); - -- Walk all the with clauses of CU, and call Action for the with'ed - -- unit. Ignore limited withs, unless Include_Limited is True. - -- CU must be an N_Compilation_Unit. + -- Walk all the with clauses of CU, and call Action for the with'ed unit. + -- Ignore limited withs, unless Include_Limited is True. CU must be an + -- N_Compilation_Unit. generic with procedure Action (Withed_Unit : Node_Id); @@ -158,6 +158,9 @@ package body Sem is when N_Block_Statement => Analyze_Block_Statement (N); + when N_Case_Expression => + Analyze_Case_Expression (N); + when N_Case_Statement => Analyze_Case_Statement (N); @@ -221,6 +224,9 @@ package body Sem is when N_Explicit_Dereference => Analyze_Explicit_Dereference (N); + when N_Expression_With_Actions => + Analyze_Expression_With_Actions (N); + when N_Extended_Return_Statement => Analyze_Extended_Return_Statement (N); @@ -576,14 +582,14 @@ package body Sem is when N_With_Clause => Analyze_With_Clause (N); - -- A call to analyze the Empty node is an error, but most likely - -- it is an error caused by an attempt to analyze a malformed - -- piece of tree caused by some other error, so if there have - -- been any other errors, we just ignore it, otherwise it is - -- a real internal error which we complain about. + -- A call to analyze the Empty node is an error, but most likely it + -- is an error caused by an attempt to analyze a malformed piece of + -- tree caused by some other error, so if there have been any other + -- errors, we just ignore it, otherwise it is a real internal error + -- which we complain about. - -- We must also consider the case of call to a runtime function - -- that is not available in the configurable runtime. + -- We must also consider the case of call to a runtime function that + -- is not available in the configurable runtime. when N_Empty => pragma Assert (Serious_Errors_Detected /= 0 @@ -609,11 +615,9 @@ package body Sem is -- analyzed. when - N_SCIL_Dispatch_Table_Object_Init | - N_SCIL_Dispatch_Table_Tag_Init | - N_SCIL_Dispatching_Call | - N_SCIL_Membership_Test | - N_SCIL_Tag_Init => + N_SCIL_Dispatch_Table_Tag_Init | + N_SCIL_Dispatching_Call | + N_SCIL_Membership_Test => null; -- For the remaining node types, we generate compiler abort, because @@ -629,6 +633,7 @@ package body Sem is N_Access_Function_Definition | N_Access_Procedure_Definition | N_Access_To_Object_Definition | + N_Case_Expression_Alternative | N_Case_Statement_Alternative | N_Compilation_Unit_Aux | N_Component_Association | @@ -841,7 +846,7 @@ package body Sem is return; end if; - -- Now search the global entity suppress table for a matching entry + -- Now search the global entity suppress table for a matching entry. -- We also search this in reverse order so that if there are multiple -- pragmas for the same entity, the last one applies. @@ -1109,12 +1114,12 @@ package body Sem is Node := First (L); Insert_List_After (N, L); - -- Now just analyze from the original first node until we get to - -- the successor of the original insertion point (which may be - -- Empty if the insertion point was at the end of the list). Note - -- that this properly handles the case where any of the analyze - -- calls result in the insertion of nodes after the analyzed - -- node (possibly calling this routine recursively). + -- Now just analyze from the original first node until we get to the + -- successor of the original insertion point (which may be Empty if + -- the insertion point was at the end of the list). Note that this + -- properly handles the case where any of the analyze calls result in + -- the insertion of nodes after the analyzed node (possibly calling + -- this routine recursively). while Node /= After loop Analyze (Node); @@ -1160,9 +1165,9 @@ package body Sem is begin if Is_Non_Empty_List (L) then - -- Capture the Node_Id of the first list node to be inserted. - -- This will still be the first node after the insert operation, - -- since Insert_List_After does not modify the Node_Id values. + -- Capture the Node_Id of the first list node to be inserted. This + -- will still be the first node after the insert operation, since + -- Insert_List_After does not modify the Node_Id values. Node := First (L); Insert_List_Before (N, L); @@ -1217,9 +1222,9 @@ package body Sem is Ptr : Suppress_Stack_Entry_Ptr; begin - -- First search the local entity suppress stack, we search this from the - -- top of the stack down, so that we get the innermost entry that - -- applies to this case if there are nested entries. + -- First search the local entity suppress stack. We search this from the + -- top of the stack down so that we get the innermost entry that applies + -- to this case if there are nested entries. Ptr := Local_Suppress_Stack_Top; while Ptr /= null loop @@ -1232,7 +1237,7 @@ package body Sem is Ptr := Ptr.Prev; end loop; - -- Now search the global entity suppress table for a matching entry + -- Now search the global entity suppress table for a matching entry. -- We also search this from the top down so that if there are multiple -- pragmas for the same entity, the last one applies (not clear what -- or whether the RM specifies this handling, but it seems reasonable). @@ -1322,10 +1327,10 @@ package body Sem is procedure Semantics (Comp_Unit : Node_Id) is -- The following locations save the corresponding global flags and - -- variables so that they can be restored on completion. This is - -- needed so that calls to Rtsfind start with the proper default - -- values for these variables, and also that such calls do not - -- disturb the settings for units being analyzed at a higher level. + -- variables so that they can be restored on completion. This is needed + -- so that calls to Rtsfind start with the proper default values for + -- these variables, and also that such calls do not disturb the settings + -- for units being analyzed at a higher level. S_Current_Sem_Unit : constant Unit_Number_Type := Current_Sem_Unit; S_Full_Analysis : constant Boolean := Full_Analysis; @@ -1343,12 +1348,12 @@ package body Sem is -- context, is compiled with expansion disabled. Save_Config_Switches : Config_Switches_Type; - -- Variable used to save values of config switches while we analyze - -- the new unit, to be restored on exit for proper recursive behavior. + -- Variable used to save values of config switches while we analyze the + -- new unit, to be restored on exit for proper recursive behavior. procedure Do_Analyze; - -- Procedure to analyze the compilation unit. This is called more - -- than once when the high level optimizer is activated. + -- Procedure to analyze the compilation unit. This is called more than + -- once when the high level optimizer is activated. ---------------- -- Do_Analyze -- @@ -1517,6 +1522,9 @@ package body Sem is procedure Walk_Library_Items is type Unit_Number_Set is array (Main_Unit .. Last_Unit) of Boolean; pragma Pack (Unit_Number_Set); + + Main_CU : constant Node_Id := Cunit (Main_Unit); + Seen, Done : Unit_Number_Set := (others => False); -- Seen (X) is True after we have seen unit X in the walk. This is used -- to prevent processing the same unit more than once. Done (X) is True @@ -1537,6 +1545,17 @@ package body Sem is -- this unit. If it's an instance body, do the spec first. If it is -- an instance spec, do the body last. + procedure Do_Withed_Unit (Withed_Unit : Node_Id); + -- Apply Do_Unit_And_Dependents to a unit in a context clause. + + procedure Process_Bodies_In_Context (Comp : Node_Id); + -- The main unit and its spec may depend on bodies that contain generics + -- that are instantiated in them. Iterate through the corresponding + -- contexts before processing main (spec/body) itself, to process bodies + -- that may be present, together with their context. The spec of main + -- is processed wherever it appears in the list of units, while the body + -- is processed as the last unit in the list. + --------------- -- Do_Action -- --------------- @@ -1565,12 +1584,12 @@ package body Sem is when N_Package_Body => - -- Package bodies are processed immediately after the - -- corresponding spec. + -- Package bodies are processed separately if the main unit + -- depends on them. null; - when N_Subprogram_Body => + when N_Subprogram_Body => -- A subprogram body must be the main unit @@ -1578,14 +1597,17 @@ package body Sem is or else CU = Cunit (Main_Unit)); null; - -- All other cases cannot happen - when N_Function_Instantiation | N_Procedure_Instantiation | N_Package_Instantiation => - pragma Assert (False, "instantiation"); + + -- Can only happen if some generic body (needed for gnat2scil + -- traversal, but not by GNAT) is not available, ignore. + null; + -- All other cases cannot happen + when N_Subunit => pragma Assert (False, "subunit"); null; @@ -1622,6 +1644,7 @@ package body Sem is (Unit (Withed_Unit), N_Generic_Package_Declaration, N_Package_Body, + N_Package_Renaming_Declaration, N_Subprogram_Body) then Write_Unit_Name @@ -1647,12 +1670,14 @@ package body Sem is Write_Unit_Info (Unit_Num, Item, Withs => True); end if; - -- Main unit should come last (except in the case where we + -- Main unit should come last, except in the case where we -- skipped System_Aux_Id, in which case we missed the things it - -- depends on). + -- depends on, and in the case of parent bodies if present. pragma Assert - (not Done (Main_Unit) or else Present (System_Aux_Id)); + (not Done (Main_Unit) + or else Present (System_Aux_Id) + or else Nkind (Item) = N_Package_Body); -- We shouldn't do the same thing twice @@ -1677,38 +1702,38 @@ package body Sem is Action (Item); end Do_Action; - ---------------------------- - -- Do_Unit_And_Dependents -- - ---------------------------- + -------------------- + -- Do_Withed_Unit -- + -------------------- - procedure Do_Unit_And_Dependents (CU : Node_Id; Item : Node_Id) is - Unit_Num : constant Unit_Number_Type := - Get_Cunit_Unit_Number (CU); - - procedure Do_Withed_Unit (Withed_Unit : Node_Id); - -- Pass the buck to Do_Unit_And_Dependents + procedure Do_Withed_Unit (Withed_Unit : Node_Id) is + begin + Do_Unit_And_Dependents (Withed_Unit, Unit (Withed_Unit)); - -------------------- - -- Do_Withed_Unit -- - -------------------- + -- If the unit in the with_clause is a generic instance, the clause + -- now denotes the instance body. Traverse the corresponding spec + -- because there may be no other dependence that will force the + -- traversal of its own context. - procedure Do_Withed_Unit (Withed_Unit : Node_Id) is - Save_Do_Main : constant Boolean := Do_Main; + if Nkind (Unit (Withed_Unit)) = N_Package_Body + and then Is_Generic_Instance + (Defining_Entity (Unit (Library_Unit (Withed_Unit)))) + then + Do_Withed_Unit (Library_Unit (Withed_Unit)); + end if; + end Do_Withed_Unit; - begin - -- Do not process the main unit if coming from a with_clause, - -- as would happen with a parent body that has a child spec - -- in its context. + ---------------------------- + -- Do_Unit_And_Dependents -- + ---------------------------- - Do_Main := False; - Do_Unit_And_Dependents (Withed_Unit, Unit (Withed_Unit)); - Do_Main := Save_Do_Main; - end Do_Withed_Unit; + procedure Do_Unit_And_Dependents (CU : Node_Id; Item : Node_Id) is + Unit_Num : constant Unit_Number_Type := Get_Cunit_Unit_Number (CU); + Child : Node_Id; + Parent_CU : Node_Id; procedure Do_Withed_Units is new Walk_Withs (Do_Withed_Unit); - -- Start of processing for Do_Unit_And_Dependents - begin if not Seen (Unit_Num) then @@ -1716,99 +1741,132 @@ package body Sem is Do_Withed_Units (CU, Include_Limited => False); - -- Process the unit if it is a spec. If it is the main unit, - -- process it only if we have done all other units. + -- Process the unit if it is a spec or the the main unit, if it + -- has no previous spec or we have done all other units. if not Nkind_In (Item, N_Package_Body, N_Subprogram_Body) or else Acts_As_Spec (CU) then - if CU = Cunit (Main_Unit) and then not Do_Main then + if CU = Cunit (Main_Unit) + and then not Do_Main + then Seen (Unit_Num) := False; else Seen (Unit_Num) := True; + + if CU = Library_Unit (Main_CU) then + Process_Bodies_In_Context (CU); + + -- If main is a child unit, examine context of parent + -- units to see if they include instantiated units. + + if Is_Child_Unit (Cunit_Entity (Main_Unit)) then + Child := Cunit_Entity (Main_Unit); + while Is_Child_Unit (Child) loop + Parent_CU := + Cunit + (Get_Cunit_Entity_Unit_Number (Scope (Child))); + Process_Bodies_In_Context (Parent_CU); + Child := Scope (Child); + end loop; + end if; + end if; + Do_Action (CU, Item); Done (Unit_Num) := True; end if; end if; end if; + end Do_Unit_And_Dependents; - -- Process bodies. The spec, if present, has been processed already. - -- A body appears if it is the main, or the body of a spec that is - -- in the context of the main unit, and that is instantiated, or else - -- contains a generic that is instantiated, or a subprogram that is - -- or a subprogram that is inlined in the main unit. - - -- We exclude bodies that may appear in a circular dependency list, - -- where spec A depends on spec B and body of B depends on spec A. - -- This is not an elaboration issue, but body B must be excluded - -- from the processing. + ------------------------------- + -- Process_Bodies_In_Context -- + ------------------------------- - declare - Body_Unit : Node_Id := Empty; - Body_Num : Unit_Number_Type; + procedure Process_Bodies_In_Context (Comp : Node_Id) is + Body_CU : Node_Id; + Body_U : Unit_Number_Type; + Clause : Node_Id; + Spec : Node_Id; - function Circular_Dependence (B : Node_Id) return Boolean; - -- Check whether this body depends on a spec that is pending, - -- that is to say has been seen but not processed yet. + procedure Do_Withed_Units is new Walk_Withs (Do_Withed_Unit); - ------------------------- - -- Circular_Dependence -- - ------------------------- + function Depends_On_Main (CU : Node_Id) return Boolean; + -- The body of a unit that is withed by the spec of the main unit + -- may in turn have a with_clause on that spec. In that case do not + -- traverse the body, to prevent loops. It can also happen that the + -- main body as a with_clause on a child, which of course has an + -- implicit with on its parent. It's ok to traverse the child body + -- if the main spec has been processed, otherwise we also have a + -- circularity to avoid. - function Circular_Dependence (B : Node_Id) return Boolean is - Item : Node_Id; - UN : Unit_Number_Type; + --------------------- + -- Depends_On_Main -- + --------------------- - begin - Item := First (Context_Items (B)); - while Present (Item) loop - if Nkind (Item) = N_With_Clause then - UN := Get_Cunit_Unit_Number (Library_Unit (Item)); + function Depends_On_Main (CU : Node_Id) return Boolean is + CL : Node_Id; - if Seen (UN) - and then not Done (UN) - then - return True; - end if; - end if; + begin + CL := First (Context_Items (CU)); - Next (Item); - end loop; + -- Problem does not arise with main subprograms. + if Nkind (Unit (Main_CU)) /= N_Package_Body then return False; - end Circular_Dependence; + end if; - begin - if Nkind (Item) = N_Package_Declaration then - Body_Unit := Library_Unit (CU); + while Present (CL) loop + if Nkind (CL) = N_With_Clause + and then Library_Unit (CL) = Library_Unit (Main_CU) + and then + not Done (Get_Cunit_Unit_Number (Library_Unit (CL))) + then + return True; + end if; - elsif Nkind_In (Item, N_Package_Body, N_Subprogram_Body) then - Body_Unit := CU; - end if; + Next (CL); + end loop; - if Present (Body_Unit) + return False; + end Depends_On_Main; - -- Since specs and bodies are not done at the same time, - -- guard against listing a body more than once. Bodies are - -- only processed when the main unit is being processed, - -- after all other units in the list. The DEC extension - -- to System is excluded because of circularities. + -- Start of processing for Process_Bodies_In_Context - and then not Seen (Get_Cunit_Unit_Number (Body_Unit)) - and then - (No (System_Aux_Id) - or else Unit_Num /= Get_Source_Unit (System_Aux_Id)) - and then not Circular_Dependence (Body_Unit) - and then Do_Main - then - Body_Num := Get_Cunit_Unit_Number (Body_Unit); - Seen (Body_Num) := True; - Do_Action (Body_Unit, Unit (Body_Unit)); - Done (Body_Num) := True; + begin + Clause := First (Context_Items (Comp)); + while Present (Clause) loop + if Nkind (Clause) = N_With_Clause then + Spec := Library_Unit (Clause); + Body_CU := Library_Unit (Spec); + + -- If we are processing the spec of the main unit, load bodies + -- only if the with_clause indicates that it forced the loading + -- of the body for a generic instantiation. + + if Present (Body_CU) + and then Body_CU /= Cunit (Main_Unit) + and then Nkind (Unit (Body_CU)) /= N_Subprogram_Body + and then (Nkind (Unit (Comp)) /= N_Package_Declaration + or else Present (Withed_Body (Clause))) + then + Body_U := Get_Cunit_Unit_Number (Body_CU); + + if not Seen (Body_U) + and then not Depends_On_Main (Body_CU) + then + Seen (Body_U) := True; + Do_Withed_Units (Body_CU, Include_Limited => False); + Do_Action (Body_CU, Unit (Body_CU)); + Done (Body_U) := True; + end if; + end if; end if; - end; - end Do_Unit_And_Dependents; + + Next (Clause); + end loop; + end Process_Bodies_In_Context; -- Local Declarations @@ -1848,7 +1906,7 @@ package body Sem is end; end loop; - -- Now traverse compilation units in order + -- Now traverse compilation units (specs) in order Cur := First_Elmt (Comp_Unit_List); while Present (Cur) loop @@ -1861,15 +1919,37 @@ package body Sem is case Nkind (N) is - -- If it's a body, ignore it. Bodies appear in the list only - -- because of inlining/instantiations, and they are processed - -- immediately after the corresponding specs. The main unit is - -- processed separately after all other units. + -- If it is a subprogram body, process it if it has no + -- separate spec. + + -- If it's a package body, ignore it, unless it is a body + -- created for an instance that is the main unit. In the case + -- of subprograms, the body is the wrapper package. In case of + -- a package, the original file carries the body, and the spec + -- appears as a later entry in the units list. - when N_Package_Body | N_Subprogram_Body => - null; + -- Otherwise Bodies appear in the list only because of inlining + -- or instantiations, and they are processed only if relevant + -- to the main unit. The main unit itself is processed + -- separately after all other specs. - -- It's a spec, so just do it + when N_Subprogram_Body => + if Acts_As_Spec (N) then + Do_Unit_And_Dependents (CU, N); + end if; + + when N_Package_Body => + if CU = Main_CU + and then Nkind (Original_Node (Unit (Main_CU))) in + N_Generic_Instantiation + and then Present (Library_Unit (Main_CU)) + then + Do_Unit_And_Dependents + (Library_Unit (Main_CU), + Unit (Library_Unit (Main_CU))); + end if; + + -- It's a spec, process it, and the units it depends on when others => Do_Unit_And_Dependents (CU, N); @@ -1879,26 +1959,47 @@ package body Sem is Next_Elmt (Cur); end loop; + -- Now process package bodies on which main depends, followed by bodies + -- of parents, if present, and finally main itself. + if not Done (Main_Unit) then Do_Main := True; declare - Main_CU : constant Node_Id := Cunit (Main_Unit); + Parent_CU : Node_Id; + Body_CU : Node_Id; + Body_U : Unit_Number_Type; + Child : Entity_Id; begin - -- If the main unit is an instantiation, the body appears before - -- the instance spec, which is added later to the unit list. Do - -- the spec if present, body will follow. + Process_Bodies_In_Context (Main_CU); + + -- If the main unit is a child unit, parent bodies may be present + -- because they export instances or inlined subprograms. Check for + -- presence of these, which are not present in context clauses. + + if Is_Child_Unit (Cunit_Entity (Main_Unit)) then + Child := Cunit_Entity (Main_Unit); + while Is_Child_Unit (Child) loop + Parent_CU := + Cunit (Get_Cunit_Entity_Unit_Number (Scope (Child))); + Body_CU := Library_Unit (Parent_CU); + + if Present (Body_CU) + and then not Seen (Get_Cunit_Unit_Number (Body_CU)) + then + Body_U := Get_Cunit_Unit_Number (Body_CU); + Seen (Body_U) := True; + Do_Action (Body_CU, Unit (Body_CU)); + Done (Body_U) := True; + end if; - if Nkind (Original_Node (Unit (Main_CU))) - in N_Generic_Instantiation - and then Present (Library_Unit (Main_CU)) - then - Do_Unit_And_Dependents - (Library_Unit (Main_CU), Unit (Library_Unit (Main_CU))); - else - Do_Unit_And_Dependents (Main_CU, Unit (Main_CU)); + Child := Scope (Child); + end loop; end if; + + Do_Action (Main_CU, Unit (Main_CU)); + Done (Main_Unit) := True; end; end if; diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 3b0bda0753a..5ff55cec1b2 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -54,6 +54,7 @@ with Sinfo; use Sinfo; with Snames; use Snames; with Stringt; use Stringt; with Stand; use Stand; +with Style; use Style; with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; @@ -1443,8 +1444,9 @@ package body Sem_Aggr is -- a missing component association for a 1-aggregate. if Paren_Count (Expr) > 0 then - Error_Msg_N ("\if single-component aggregate is intended," - & " write e.g. (1 ='> ...)", Expr); + Error_Msg_N + ("\if single-component aggregate is intended," + & " write e.g. (1 ='> ...)", Expr); end if; return Failure; end if; @@ -1798,8 +1800,8 @@ package body Sem_Aggr is elsif Is_Tagged_Type (Etype (Expression (Assoc))) then Check_Dynamically_Tagged_Expression - (Expr => Expression (Assoc), - Typ => Component_Type (Etype (N)), + (Expr => Expression (Assoc), + Typ => Component_Type (Etype (N)), Related_Nod => N); end if; @@ -2288,6 +2290,18 @@ package body Sem_Aggr is then A_Type := Etype (Imm_Type); return True; + + -- The parent type may be a private extension. The aggregate is + -- legal if the type of the aggregate is an extension of it that + -- is not a private extension. + + elsif Is_Private_Type (A_Type) + and then not Is_Private_Type (Imm_Type) + and then Present (Full_View (A_Type)) + and then Base_Type (Full_View (A_Type)) = Etype (Imm_Type) + then + return True; + else Imm_Type := Etype (Base_Type (Imm_Type)); end if; @@ -2488,21 +2502,24 @@ package body Sem_Aggr is -- whose value may already have been specified by N's ancestor part. -- This routine checks whether this is indeed the case and if so returns -- False, signaling that no value for Discr should appear in N's - -- aggregate part. Also, in this case, the routine appends - -- New_Assoc_List Discr the discriminant value specified in the ancestor - -- part. - -- Can't parse previous sentence, appends what where??? + -- aggregate part. Also, in this case, the routine appends to + -- New_Assoc_List the discriminant value specified in the ancestor part. + -- + -- If the aggregate is in a context with expansion delayed, it will be + -- reanalyzed. The inherited discriminant values must not be reinserted + -- in the component list to prevent spurious errors, but they must be + -- present on first analysis to build the proper subtype indications. + -- The flag Inherited_Discriminant is used to prevent the re-insertion. function Get_Value (Compon : Node_Id; From : List_Id; Consider_Others_Choice : Boolean := False) return Node_Id; - -- Given a record component stored in parameter Compon, the following - -- function returns its value as it appears in the list From, which is - -- a list of N_Component_Association nodes. - -- What is this referring to??? There is no "following function" in - -- sight??? + -- Given a record component stored in parameter Compon, this function + -- returns its value as it appears in the list From, which is a list + -- of N_Component_Association nodes. + -- -- If no component association has a choice for the searched component, -- the value provided by the others choice is returned, if there is one, -- and Consider_Others_Choice is set to true. Otherwise Empty is @@ -2556,6 +2573,7 @@ package body Sem_Aggr is Loc : Source_Ptr; Ancestor : Node_Id; + Comp_Assoc : Node_Id; Discr_Expr : Node_Id; Ancestor_Typ : Entity_Id; @@ -2570,6 +2588,21 @@ package body Sem_Aggr is return True; end if; + -- Check whether inherited discriminant values have already been + -- inserted in the aggregate. This will be the case if we are + -- re-analyzing an aggregate whose expansion was delayed. + + if Present (Component_Associations (N)) then + Comp_Assoc := First (Component_Associations (N)); + while Present (Comp_Assoc) loop + if Inherited_Discriminant (Comp_Assoc) then + return True; + end if; + + Next (Comp_Assoc); + end loop; + end if; + Ancestor := Ancestor_Part (N); Ancestor_Typ := Etype (Ancestor); Loc := Sloc (Ancestor); @@ -2627,6 +2660,7 @@ package body Sem_Aggr is end if; Resolve_Aggr_Expr (Discr_Expr, Discr); + Set_Inherited_Discriminant (Last (New_Assoc_List)); return False; end if; @@ -2991,13 +3025,15 @@ package body Sem_Aggr is if Selector_Name /= First (Choices (Assoc)) or else Present (Next (Selector_Name)) then - Error_Msg_N ("OTHERS must appear alone in a choice list", - Selector_Name); + Error_Msg_N + ("OTHERS must appear alone in a choice list", + Selector_Name); return; elsif Present (Next (Assoc)) then - Error_Msg_N ("OTHERS must appear last in an aggregate", - Selector_Name); + Error_Msg_N + ("OTHERS must appear last in an aggregate", + Selector_Name); return; -- (Ada2005): If this is an association with a box, @@ -3213,18 +3249,17 @@ package body Sem_Aggr is Error_Msg_NE ("type of aggregate has private ancestor&!", N, Root_Typ); - Error_Msg_N ("must use extension aggregate!", N); + Error_Msg_N ("must use extension aggregate!", N); return; end if; Dnode := Declaration_Node (Base_Type (Root_Typ)); - -- If we don't get a full declaration, then we have some - -- error which will get signalled later so skip this part. - -- Otherwise, gather components of root that apply to the - -- aggregate type. We use the base type in case there is an - -- applicable stored constraint that renames the discriminants - -- of the root. + -- If we don't get a full declaration, then we have some error + -- which will get signalled later so skip this part. Otherwise + -- gather components of root that apply to the aggregate type. + -- We use the base type in case there is an applicable stored + -- constraint that renames the discriminants of the root. if Nkind (Dnode) = N_Full_Type_Declaration then Record_Def := Type_Definition (Dnode); @@ -3259,6 +3294,15 @@ package body Sem_Aggr is Ancestor_Part (N), Parent_Typ); return; end if; + + -- The current view of ancestor part may be a private type, + -- while the context type is always non-private. + + elsif Is_Private_Type (Root_Typ) + and then Present (Full_View (Root_Typ)) + and then Nkind (N) = N_Extension_Aggregate + then + exit when Base_Type (Full_View (Root_Typ)) = Parent_Typ; end if; end loop; @@ -3460,8 +3504,8 @@ package body Sem_Aggr is -- subaggregate is needed. Capture_Discriminants : declare - Loc : constant Source_Ptr := Sloc (N); - Expr : Node_Id; + Loc : constant Source_Ptr := Sloc (N); + Expr : Node_Id; procedure Add_Discriminant_Values (New_Aggr : Node_Id; @@ -3567,7 +3611,6 @@ package body Sem_Aggr is New_Aggr : Node_Id; begin - Inner_Comp := First_Component (Etype (Comp)); while Present (Inner_Comp) loop Comp_Type := Etype (Inner_Comp); @@ -3580,7 +3623,7 @@ package body Sem_Aggr is Set_Etype (New_Aggr, Comp_Type); Add_Association (Inner_Comp, New_Aggr, - Component_Associations (Aggr)); + Component_Associations (Aggr)); -- Collect discriminant values and recurse @@ -3630,7 +3673,7 @@ package body Sem_Aggr is else declare - Comp : Entity_Id; + Comp : Entity_Id; begin -- If the type has additional components, create @@ -3737,7 +3780,15 @@ package body Sem_Aggr is New_Assoc := First (New_Assoc_List); while Present (New_Assoc) loop Component := First (Choices (New_Assoc)); - exit when Chars (Selectr) = Chars (Component); + + if Chars (Selectr) = Chars (Component) then + if Style_Check then + Check_Identifier (Selectr, Entity (Component)); + end if; + + exit; + end if; + Next (New_Assoc); end loop; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index e37b216ca45..8b5fd1313da 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -136,6 +136,7 @@ package body Sem_Attr is Attribute_05 : constant Attribute_Class_Array := Attribute_Class_Array'( Attribute_Machine_Rounding | + Attribute_Mod | Attribute_Priority | Attribute_Stream_Size | Attribute_Wide_Wide_Width => True, @@ -2384,8 +2385,8 @@ package body Sem_Attr is and then Base_Type (Typ) = Typ and then Warn_On_Redundant_Constructs then - Error_Msg_NE - ("?redundant attribute, & is its own base type", N, Typ); + Error_Msg_NE -- CODEFIX + ("?redundant attribute, & is its own base type", N, Typ); end if; Set_Etype (N, Base_Type (Entity (P))); @@ -2775,10 +2776,8 @@ package body Sem_Attr is exit; elsif Ekind (Scope (Ent)) in Task_Kind - and then Ekind (S) /= E_Loop - and then Ekind (S) /= E_Block - and then Ekind (S) /= E_Entry - and then Ekind (S) /= E_Entry_Family + and then + not Ekind_In (S, E_Loop, E_Block, E_Entry, E_Entry_Family) then Error_Attr ("Attribute % cannot appear in inner unit", N); @@ -3546,13 +3545,9 @@ package body Sem_Attr is ---------------------- procedure Must_Be_Imported (Proc_Ent : Entity_Id) is - Pent : Entity_Id := Proc_Ent; + Pent : constant Entity_Id := Ultimate_Alias (Proc_Ent); begin - while Present (Alias (Pent)) loop - Pent := Alias (Pent); - end loop; - -- Ignore check if procedure not frozen yet (we will get -- another chance when the default parameter is reanalyzed) @@ -3654,6 +3649,7 @@ package body Sem_Attr is function Process (N : Node_Id) return Traverse_Result is begin if Is_Entity_Name (N) + and then Present (Entity (N)) and then not Is_Formal (Entity (N)) and then Enclosing_Subprogram (Entity (N)) = Subp then @@ -4809,9 +4805,11 @@ package body Sem_Attr is -- processing, since otherwise gigi might see an attribute which it is -- unprepared to deal with. - function Aft_Value return Nat; - -- Computes Aft value for current attribute prefix (used by Aft itself - -- and also by Width for computing the Width of a fixed point type). + procedure Check_Concurrent_Discriminant (Bound : Node_Id); + -- If Bound is a reference to a discriminant of a task or protected type + -- occurring within the object's body, rewrite attribute reference into + -- a reference to the corresponding discriminal. Use for the expansion + -- of checks against bounds of entry family index subtypes. procedure Check_Expressions; -- In case where the attribute is not foldable, the expressions, if @@ -4878,24 +4876,33 @@ package body Sem_Attr is -- Verify that the prefix of a potentially static array attribute -- satisfies the conditions of 4.9 (14). - --------------- - -- Aft_Value -- - --------------- + ----------------------------------- + -- Check_Concurrent_Discriminant -- + ----------------------------------- - function Aft_Value return Nat is - Result : Nat; - Delta_Val : Ureal; + procedure Check_Concurrent_Discriminant (Bound : Node_Id) is + Tsk : Entity_Id; + -- The concurrent (task or protected) type begin - Result := 1; - Delta_Val := Delta_Value (P_Type); - while Delta_Val < Ureal_Tenth loop - Delta_Val := Delta_Val * Ureal_10; - Result := Result + 1; - end loop; + if Nkind (Bound) = N_Identifier + and then Ekind (Entity (Bound)) = E_Discriminant + and then Is_Concurrent_Record_Type (Scope (Entity (Bound))) + then + Tsk := Corresponding_Concurrent_Type (Scope (Entity (Bound))); - return Result; - end Aft_Value; + if In_Open_Scopes (Tsk) and then Has_Completion (Tsk) then + + -- Find discriminant of original concurrent type, and use + -- its current discriminal, which is the renaming within + -- the task/protected body. + + Rewrite (N, + New_Occurrence_Of + (Find_Body_Discriminal (Entity (Bound)), Loc)); + end if; + end if; + end Check_Concurrent_Discriminant; ----------------------- -- Check_Expressions -- @@ -5626,10 +5633,10 @@ package body Sem_Attr is while Present (N) loop Static := Static and then Is_Static_Subtype (Etype (N)); - -- If however the index type is generic, attributes cannot - -- be folded. + -- If however the index type is generic, or derived from + -- one, attributes cannot be folded. - if Is_Generic_Type (Etype (N)) + if Is_Generic_Type (Root_Type (Etype (N))) and then Id /= Attribute_Component_Size then return; @@ -5756,7 +5763,7 @@ package body Sem_Attr is --------- when Attribute_Aft => - Fold_Uint (N, UI_From_Int (Aft_Value), True); + Fold_Uint (N, Aft_Value (P_Type), True); --------------- -- Alignment -- @@ -5984,6 +5991,9 @@ package body Sem_Attr is else Fold_Uint (N, Expr_Value (Lo_Bound), Static); end if; + + else + Check_Concurrent_Discriminant (Lo_Bound); end if; end First_Attr; @@ -6172,6 +6182,9 @@ package body Sem_Attr is else Fold_Uint (N, Expr_Value (Hi_Bound), Static); end if; + + else + Check_Concurrent_Discriminant (Hi_Bound); end if; end Last; @@ -6192,13 +6205,13 @@ package body Sem_Attr is Ind : Node_Id; begin - -- In the case of a generic index type, the bounds may appear static - -- but the computation is not meaningful in this case, and may - -- generate a spurious warning. + -- If any index type is a formal type, or derived from one, the + -- bounds are not static. Treating them as static can produce + -- spurious warnings or improper constant folding. Ind := First_Index (P_Type); while Present (Ind) loop - if Is_Generic_Type (Etype (Ind)) then + if Is_Generic_Type (Root_Type (Etype (Ind))) then return; end if; @@ -7328,7 +7341,8 @@ package body Sem_Attr is -- For fixed-point type width is Fore + 1 + Aft (RM 3.5(34)) Fold_Uint - (N, UI_From_Int (Fore_Value + 1 + Aft_Value), True); + (N, UI_From_Int (Fore_Value + 1) + Aft_Value (P_Type), + True); end if; -- Discrete types @@ -7645,8 +7659,7 @@ package body Sem_Attr is -- know will fail, so generate an appropriate warning. if In_Instance_Body then - Error_Msg_F - ("?non-local pointer cannot point to local object", P); + Error_Msg_F ("?non-local pointer cannot point to local object", P); Error_Msg_F ("\?Program_Error will be raised at run time", P); Rewrite (N, @@ -7656,8 +7669,7 @@ package body Sem_Attr is return; else - Error_Msg_F - ("non-local pointer cannot point to local object", P); + Error_Msg_F ("non-local pointer cannot point to local object", P); -- Check for case where we have a missing access definition @@ -7813,11 +7825,9 @@ package body Sem_Attr is -- also be accessibility checks on those, this is where the -- checks can eventually be centralized ??? - if Ekind (Btyp) = E_Access_Subprogram_Type - or else - Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type - or else - Ekind (Btyp) = E_Anonymous_Access_Protected_Subprogram_Type + if Ekind_In (Btyp, E_Access_Subprogram_Type, + E_Anonymous_Access_Subprogram_Type, + E_Anonymous_Access_Protected_Subprogram_Type) then -- Deal with convention mismatch @@ -8244,9 +8254,8 @@ package body Sem_Attr is end if; end if; - if Ekind (Btyp) = E_Access_Protected_Subprogram_Type - or else - Ekind (Btyp) = E_Anonymous_Access_Protected_Subprogram_Type + if Ekind_In (Btyp, E_Access_Protected_Subprogram_Type, + E_Anonymous_Access_Protected_Subprogram_Type) then if Is_Entity_Name (P) and then not Is_Protected_Type (Scope (Entity (P))) @@ -8268,9 +8277,8 @@ package body Sem_Attr is return; end if; - elsif (Ekind (Btyp) = E_Access_Subprogram_Type - or else - Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type) + elsif Ekind_In (Btyp, E_Access_Subprogram_Type, + E_Anonymous_Access_Subprogram_Type) and then Ekind (Etype (N)) = E_Access_Protected_Subprogram_Type then Error_Msg_F ("context requires a non-protected subprogram", P); diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index c1b3a331892..99bec9b72da 100755 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -312,8 +312,8 @@ package body Sem_Aux is Ent : Entity_Id; begin - -- If the base type has no freeze node, it is a type in Standard, - -- and always acts as its own first subtype unless it is one of the + -- If the base type has no freeze node, it is a type in Standard, and + -- always acts as its own first subtype, except where it is one of the -- predefined integer types. If the type is formal, it is also a first -- subtype, and its base type has no freeze node. On the other hand, a -- subtype of a generic formal is not its own first subtype. Its base @@ -321,7 +321,6 @@ package body Sem_Aux is -- the first subtype is obtained. if No (F) then - if B = Base_Type (Standard_Integer) then return Standard_Integer; @@ -800,4 +799,20 @@ package body Sem_Aux is Obsolescent_Warnings.Tree_Write; end Tree_Write; + -------------------- + -- Ultimate_Alias -- + -------------------- + + function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is + E : Entity_Id := Prim; + + begin + while Present (Alias (E)) loop + pragma Assert (Alias (E) /= E); + E := Alias (E); + end loop; + + return E; + end Ultimate_Alias; + end Sem_Aux; diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads index 464a764a3e3..8b763e05240 100755 --- a/gcc/ada/sem_aux.ads +++ b/gcc/ada/sem_aux.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -193,4 +193,9 @@ package Sem_Aux is function Number_Discriminants (Typ : Entity_Id) return Pos; -- Typ is a type with discriminants, yields number of discriminants in type + function Ultimate_Alias (Prim : Entity_Id) return Entity_Id; + pragma Inline (Ultimate_Alias); + -- Return the last entity in the chain of aliased entities of Prim. If Prim + -- has no alias return Prim. + end Sem_Aux; diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index da260f35c4a..fc8806a036f 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/sem_case.ads b/gcc/ada/sem_case.ads index dcc72931551..78ae7c61b3b 100644 --- a/gcc/ada/sem_case.ads +++ b/gcc/ada/sem_case.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1996-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -68,7 +68,7 @@ package Sem_Case is -- Processing to carry out for a non static Choice with procedure Process_Associated_Node (A : Node_Id); - -- Associated to each case alternative, aggregate component + -- Associated with each case alternative, aggregate component -- association or record variant A there is a node or list of nodes -- that need semantic processing. This routine implements that -- processing. @@ -76,9 +76,9 @@ package Sem_Case is package Generic_Choices_Processing is function Number_Of_Choices (N : Node_Id) return Nat; - -- Iterates through the choices of N, (N can be a case statement, - -- array aggregate or record variant), counting all the Choice nodes - -- except for the Others choice. + -- Iterates through the choices of N, (N can be a case expression, case + -- statement, array aggregate or record variant), counting all the + -- Choice nodes except for the Others choice. procedure Analyze_Choices (N : Node_Id; @@ -87,10 +87,10 @@ package Sem_Case is Last_Choice : out Nat; Raises_CE : out Boolean; Others_Present : out Boolean); - -- From a case statement, array aggregate or record variant N, this - -- routine analyzes the corresponding list of discrete choices. - -- Subtyp is the subtype of the discrete choices. The type against - -- which the discrete choices must be resolved is its base type. + -- From a case expression, case statement, array aggregate or record + -- variant N, this routine analyzes the corresponding list of discrete + -- choices. Subtyp is the subtype of the discrete choices. The type + -- against which the discrete choices must be resolved is its base type. -- -- On entry Choice_Table must be big enough to contain all the discrete -- choices encountered. The lower bound of Choice_Table must be one. diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb index c8d06e8cfec..1f4ed1069f6 100644 --- a/gcc/ada/sem_cat.adb +++ b/gcc/ada/sem_cat.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -78,12 +78,12 @@ package body Sem_Cat is function In_RCI_Declaration (N : Node_Id) return Boolean; -- Determines if a declaration is within the visible part of a Remote - -- Call Interface compilation unit, for semantic checking purposes only, + -- Call Interface compilation unit, for semantic checking purposes only -- (returns false within an instance and within the package body). function In_RT_Declaration return Boolean; - -- Determines if current scope is within a Remote Types compilation unit, - -- for semantic checking purposes. + -- Determines if current scope is within the declaration of a Remote Types + -- unit, for semantic checking purposes. function Is_Non_Remote_Access_Type (E : Entity_Id) return Boolean; -- Returns true if the entity is a type whose full view is a non-remote @@ -1061,28 +1061,25 @@ package body Sem_Cat is -- Exclude generic specs from the checks (this will get rechecked -- on instantiations). - if Inside_A_Generic - and then No (Enclosing_Generic_Body (Id)) - then + if Inside_A_Generic and then No (Enclosing_Generic_Body (Id)) then return; end if; - -- Required checks for declaration that is in a preelaborated - -- package and is not within some subprogram. + -- Required checks for declaration that is in a preelaborated package + -- and is not within some subprogram. if In_Preelaborated_Unit and then not In_Subprogram_Or_Concurrent_Unit then -- Check for default initialized variable case. Note that in - -- accordance with (RM B.1(24)) imported objects are not - -- subject to default initialization. + -- accordance with (RM B.1(24)) imported objects are not subject to + -- default initialization. -- If the initialization does not come from source and is an -- aggregate, it is a static initialization that replaces an -- implicit call, and must be treated as such. if Present (E) - and then - (Comes_From_Source (E) or else Nkind (E) /= N_Aggregate) + and then (Comes_From_Source (E) or else Nkind (E) /= N_Aggregate) then null; @@ -1210,13 +1207,8 @@ package body Sem_Cat is elsif Nkind (Odf) = N_Subtype_Indication then Ent := Etype (Subtype_Mark (Odf)); - elsif - Nkind (Odf) = N_Constrained_Array_Definition - then + elsif Nkind (Odf) = N_Constrained_Array_Definition then Ent := Component_Type (T); - - -- else - -- return; end if; if Is_Task_Type (Ent) @@ -1230,9 +1222,9 @@ package body Sem_Cat is end; end if; - -- Non-static discriminant not allowed in preelaborated unit - -- Controlled object of a type with a user-defined Initialize - -- is forbidden as well. + -- Non-static discriminants not allowed in preelaborated unit. + -- Objects of a controlled type with a user-defined Initialize + -- are forbidden as well. if Is_Record_Type (Etype (Id)) then declare @@ -1248,7 +1240,7 @@ package body Sem_Cat is if Nkind (PEE) = N_Full_Type_Declaration and then not Static_Discriminant_Expr - (Discriminant_Specifications (PEE)) + (Discriminant_Specifications (PEE)) then Error_Msg_N ("non-static discriminant in preelaborated unit", @@ -1270,23 +1262,21 @@ package body Sem_Cat is -- except within a subprogram, generic subprogram, task unit, or -- protected unit (RM 10.2.1(16)). - if In_Pure_Unit - and then not In_Subprogram_Task_Protected_Unit - then + if In_Pure_Unit and then not In_Subprogram_Task_Protected_Unit then Error_Msg_N ("declaration of variable not allowed in pure unit", N); -- The visible part of an RCI library unit must not contain the -- declaration of a variable (RM E.1.3(9)) elsif In_RCI_Declaration (N) then - Error_Msg_N ("declaration of variable not allowed in rci unit", N); + Error_Msg_N ("visible variable not allowed in 'R'C'I unit", N); -- The visible part of a Shared Passive library unit must not contain -- the declaration of a variable (RM E.2.2(7)) - elsif In_RT_Declaration then + elsif In_RT_Declaration and then not In_Private_Part (Id) then Error_Msg_N - ("variable declaration not allowed in remote types unit", N); + ("visible variable not allowed in remote types unit", N); end if; end Validate_Object_Declaration; @@ -1397,8 +1387,8 @@ package body Sem_Cat is null; - elsif Ekind (Param_Type) = E_Anonymous_Access_Type - or else Ekind (Param_Type) = E_Anonymous_Access_Subprogram_Type + elsif Ekind_In (Param_Type, E_Anonymous_Access_Type, + E_Anonymous_Access_Subprogram_Type) then -- From RM E.2.2(14), no anonymous access parameter other than -- controlling ones may be used (because an anonymous access @@ -1454,9 +1444,9 @@ package body Sem_Cat is ("limited type not allowed in rci unit", Parent (E)); Explain_Limited_Type (E, Parent (E)); - elsif Ekind (E) = E_Generic_Function - or else Ekind (E) = E_Generic_Package - or else Ekind (E) = E_Generic_Procedure + elsif Ekind_In (E, E_Generic_Function, + E_Generic_Package, + E_Generic_Procedure) then Error_Msg_N ("generic declaration not allowed in rci unit", Parent (E)); @@ -1551,7 +1541,6 @@ package body Sem_Cat is Type_Decl := Parent (Param_Type); if Ekind (Param_Type) = E_Anonymous_Access_Type then - if K = N_Subprogram_Declaration then Error_Node := Param_Spec; end if; diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 8a53d5891b6..1ce76e89c25 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -552,7 +552,8 @@ package body Sem_Ch10 is or else Used_In_Spec) then - Error_Msg_N ("?redundant with clause in body", Clause); + Error_Msg_N -- CODEFIX + ("?redundant with clause in body", Clause); end if; Used_In_Body := False; @@ -580,7 +581,8 @@ package body Sem_Ch10 is Exit_On_Self => True); if Withed then - Error_Msg_N ("?redundant with clause", Clause); + Error_Msg_N -- CODEFIX + ("?redundant with clause", Clause); end if; end; end if; @@ -690,8 +692,7 @@ package body Sem_Ch10 is end if; if Circularity then - Error_Msg_N - ("circular dependency caused by with_clauses", N); + Error_Msg_N ("circular dependency caused by with_clauses", N); Error_Msg_N ("\possibly missing limited_with clause" & " in one of the following", N); @@ -2139,6 +2140,19 @@ package body Sem_Ch10 is -- Start of processing for Analyze_Subunit begin + if Style_Check then + declare + Nam : Node_Id := Name (Unit (N)); + + begin + if Nkind (Nam) = N_Selected_Component then + Nam := Selector_Name (Nam); + end if; + + Check_Identifier (Nam, Par_Unit); + end; + end if; + if not Is_Empty_List (Context_Items (N)) then -- Save current use clauses @@ -2207,7 +2221,6 @@ package body Sem_Ch10 is if Present (Enclosing_Child) then Install_Siblings (Enclosing_Child, N); end if; - end if; Analyze (Proper_Body (Unit (N))); @@ -3373,6 +3386,11 @@ package body Sem_Ch10 is -- units. The shadow entities are created when the inserted clause is -- analyzed. Implements Ada 2005 (AI-50217). + function Is_Ancestor_Unit (U1 : Node_Id; U2 : Node_Id) return Boolean; + -- When compiling a unit Q descended from some parent unit P, a limited + -- with_clause in the context of P that names some other ancestor of Q + -- must not be installed because the ancestor is immediately visible. + --------------------- -- Check_Renamings -- --------------------- @@ -3645,6 +3663,22 @@ package body Sem_Ch10 is New_Nodes_OK := New_Nodes_OK - 1; end Expand_Limited_With_Clause; + ---------------------- + -- Is_Ancestor_Unit -- + ---------------------- + + function Is_Ancestor_Unit (U1 : Node_Id; U2 : Node_Id) return Boolean is + E1 : constant Entity_Id := Defining_Entity (Unit (U1)); + E2 : Entity_Id; + begin + if Nkind_In (Unit (U2), N_Package_Body, N_Subprogram_Body) then + E2 := Defining_Entity (Unit (Library_Unit (U2))); + return Is_Ancestor_Package (E1, E2); + else + return False; + end if; + end Is_Ancestor_Unit; + -- Start of processing for Install_Limited_Context_Clauses begin @@ -3678,6 +3712,9 @@ package body Sem_Ch10 is if Library_Unit (Item) /= Cunit (Current_Sem_Unit) and then not Limited_View_Installed (Item) + and then + not Is_Ancestor_Unit + (Library_Unit (Item), Cunit (Current_Sem_Unit)) then if not Private_Present (Item) or else Private_Present (N) @@ -4013,7 +4050,8 @@ package body Sem_Ch10 is function In_Context return Boolean; -- Scan context of current unit, to check whether there is -- a with_clause on the same unit as a private with-clause - -- on a parent, in which case child unit is visible. + -- on a parent, in which case child unit is visible. If the + -- unit is a grand-child, the same applies to its parent. ---------------- -- In_Context -- @@ -4027,10 +4065,15 @@ package body Sem_Ch10 is if Nkind (Clause) = N_With_Clause and then Comes_From_Source (Clause) and then Is_Entity_Name (Name (Clause)) - and then Entity (Name (Clause)) = Id and then not Private_Present (Clause) then - return True; + if Entity (Name (Clause)) = Id + or else + (Nkind (Name (Clause)) = N_Expanded_Name + and then Entity (Prefix (Name (Clause))) = Id) + then + return True; + end if; end if; Next (Clause); @@ -5346,7 +5389,7 @@ package body Sem_Ch10 is -- and the full-view. if No (Class_Wide_Type (T)) then - CW := Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + CW := Make_Temporary (Loc, 'S'); -- Set parent to be the same as the parent of the tagged type. -- We need a parent field set, and it is supposed to point to @@ -5398,9 +5441,7 @@ package body Sem_Ch10 is Sloc_Value : Source_Ptr; Id_Char : Character) return Entity_Id is - E : constant Entity_Id := - Make_Defining_Identifier (Sloc_Value, - Chars => New_Internal_Name (Id_Char)); + E : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char); begin Set_Ekind (E, Kind); @@ -5475,9 +5516,7 @@ package body Sem_Ch10 is -- Build the header of the limited_view - Lim_Header := - Make_Defining_Identifier (Sloc (N), - Chars => New_Internal_Name (Id_Char => 'Z')); + Lim_Header := Make_Temporary (Sloc (N), 'Z'); Set_Ekind (Lim_Header, E_Package); Set_Is_Internal (Lim_Header); Set_Limited_View (P, Lim_Header); @@ -5535,9 +5574,7 @@ package body Sem_Ch10 is then return True; - elsif Ekind (E) = E_Generic_Function - or else Ekind (E) = E_Generic_Procedure - then + elsif Ekind_In (E, E_Generic_Function, E_Generic_Procedure) then return True; elsif Ekind (E) = E_Generic_Package @@ -5578,10 +5615,7 @@ package body Sem_Ch10 is then Set_Body_Needed_For_SAL (Unit_Name); - elsif Ekind (Unit_Name) = E_Generic_Procedure - or else - Ekind (Unit_Name) = E_Generic_Function - then + elsif Ekind_In (Unit_Name, E_Generic_Procedure, E_Generic_Function) then Set_Body_Needed_For_SAL (Unit_Name); elsif Is_Subprogram (Unit_Name) @@ -5927,9 +5961,9 @@ package body Sem_Ch10 is if Nkind (Item) = N_With_Clause and then Private_Present (Item) then - -- If private_with_clause is redundant, remove it from - -- context, as a small optimization to subsequent handling - -- of private_with clauses in other nested packages.. + -- If private_with_clause is redundant, remove it from context, + -- as a small optimization to subsequent handling of private_with + -- clauses in other nested packages. if In_Regular_With_Clause (Entity (Name (Item))) then declare diff --git a/gcc/ada/sem_ch11.adb b/gcc/ada/sem_ch11.adb index d54c6f8a04f..cd6c10ba573 100644 --- a/gcc/ada/sem_ch11.adb +++ b/gcc/ada/sem_ch11.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 174811bb81a..a2009c2b66e 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -475,6 +475,12 @@ package body Sem_Ch12 is -- of generic formals of a generic package declared with a box or with -- partial parametrization. + procedure Mark_Context (Inst_Decl : Node_Id; Gen_Decl : Node_Id); + -- If the generic unit comes from a different unit, indicate that the + -- unit that contains the instance depends on the body that contains + -- the generic body. Used to determine a more precise dependency graph + -- for use by CodePeer. + procedure Set_Instance_Env (Gen_Unit : Entity_Id; Act_Unit : Entity_Id); @@ -2408,8 +2414,8 @@ package body Sem_Ch12 is end if; elsif Nkind (Prefix (Def)) = N_Selected_Component then - if Ekind (Entity (Selector_Name (Prefix (Def)))) - /= E_Entry_Family + if Ekind (Entity (Selector_Name (Prefix (Def)))) /= + E_Entry_Family then Error_Msg_N ("expect valid subprogram name as default", Def); end if; @@ -2592,7 +2598,7 @@ package body Sem_Ch12 is then Error_Msg_N ("premature usage of incomplete type", Def); - elsif Is_Internal (Designated_Type (T)) then + elsif not Is_Entity_Name (Subtype_Indication (Def)) then Error_Msg_N ("only a subtype mark is allowed in a formal", Def); end if; @@ -3231,7 +3237,8 @@ package body Sem_Ch12 is or else Enclosing_Body_Present or else Present (Corresponding_Body (Gen_Decl))) and then (Is_In_Main_Unit (N) - or else Might_Inline_Subp) + or else Might_Inline_Subp + or else CodePeer_Mode) and then not Is_Actual_Pack and then not Inline_Now and then (Operating_Mode = Generate_Code @@ -3387,7 +3394,8 @@ package body Sem_Ch12 is Expander_Status => Expander_Active, Current_Sem_Unit => Current_Sem_Unit, Scope_Suppress => Scope_Suppress, - Local_Suppress_Stack_Top => Local_Suppress_Stack_Top)); + Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, + Version => Ada_Version)); end if; end if; @@ -3694,7 +3702,8 @@ package body Sem_Ch12 is Expander_Status => Expander_Active, Current_Sem_Unit => Current_Sem_Unit, Scope_Suppress => Scope_Suppress, - Local_Suppress_Stack_Top => Local_Suppress_Stack_Top)), + Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, + Version => Ada_Version)), Inlined_Body => True); Pop_Scope; @@ -3809,7 +3818,8 @@ package body Sem_Ch12 is Expander_Status => Expander_Active, Current_Sem_Unit => Current_Sem_Unit, Scope_Suppress => Scope_Suppress, - Local_Suppress_Stack_Top => Local_Suppress_Stack_Top)), + Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, + Version => Ada_Version)), Inlined_Body => True); end if; end Inline_Instance_Body; @@ -3848,7 +3858,8 @@ package body Sem_Ch12 is Expander_Status => Expander_Active, Current_Sem_Unit => Current_Sem_Unit, Scope_Suppress => Scope_Suppress, - Local_Suppress_Stack_Top => Local_Suppress_Stack_Top)); + Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, + Version => Ada_Version)); return True; else return False; @@ -3999,11 +4010,14 @@ package body Sem_Ch12 is -- If the instance is a child unit, mark the Id accordingly. Mark -- the anonymous entity as well, which is the real subprogram and -- which is used when the instance appears in a context clause. + -- Similarly, propagate the Is_Eliminated flag to handle properly + -- nested eliminated subprograms. Set_Is_Child_Unit (Act_Decl_Id, Is_Child_Unit (Defining_Entity (N))); Set_Is_Child_Unit (Anon_Id, Is_Child_Unit (Defining_Entity (N))); New_Overloaded_Entity (Act_Decl_Id); Check_Eliminated (Act_Decl_Id); + Set_Is_Eliminated (Anon_Id, Is_Eliminated (Act_Decl_Id)); -- In compilation unit case, kill elaboration checks on the -- instantiation, since they are never needed -- the body is @@ -4072,9 +4086,7 @@ package body Sem_Ch12 is -- Verify that it is a generic subprogram of the right kind, and that -- it does not lead to a circular instantiation. - if Ekind (Gen_Unit) /= E_Generic_Procedure - and then Ekind (Gen_Unit) /= E_Generic_Function - then + if not Ekind_In (Gen_Unit, E_Generic_Procedure, E_Generic_Function) then Error_Msg_N ("expect generic subprogram in instantiation", Gen_Id); elsif In_Open_Scopes (Gen_Unit) then @@ -4223,7 +4235,8 @@ package body Sem_Ch12 is then Error_Msg_NE ("access parameter& is controlling,", N, Formal); - Error_Msg_NE ("\corresponding parameter of & must be" + Error_Msg_NE + ("\corresponding parameter of & must be" & " explicitly null-excluding", N, Gen_Id); end if; @@ -4848,8 +4861,13 @@ package body Sem_Ch12 is -- To detect this case we have to rescan the list of formals, which -- is usually short enough to ignore the resulting inefficiency. + ----------------------------- + -- Denotes_Previous_Actual -- + ----------------------------- + function Denotes_Previous_Actual (Typ : Entity_Id) return Boolean is Prev : Entity_Id; + begin Prev := First_Entity (Instance); while Present (Prev) loop @@ -4859,12 +4877,15 @@ package body Sem_Ch12 is and then Entity (Subtype_Indication (Parent (Prev))) = Typ then return True; + elsif Prev = E then return False; + else Next_Entity (Prev); end if; end loop; + return False; end Denotes_Previous_Actual; @@ -5874,7 +5895,7 @@ package body Sem_Ch12 is -- If we are not instantiating, then this is where we load and -- analyze subunits, i.e. at the point where the stub occurs. A - -- more permissible system might defer this analysis to the point + -- more permissive system might defer this analysis to the point -- of instantiation, but this seems to complicated for now. if not Instantiating then @@ -7853,8 +7874,7 @@ package body Sem_Ch12 is if not Box_Present (Formal) then declare I_Pack : constant Entity_Id := - Make_Defining_Identifier (Sloc (Actual), - Chars => New_Internal_Name ('P')); + Make_Temporary (Sloc (Actual), 'P'); begin Set_Is_Internal (I_Pack); @@ -8153,9 +8173,8 @@ package body Sem_Ch12 is -- to prevent freezing anomalies. declare - Anon_Id : constant Entity_Id := - Make_Defining_Identifier - (Loc, New_Internal_Name ('E')); + Anon_Id : constant Entity_Id := Make_Temporary (Loc, 'E'); + begin Set_Defining_Unit_Name (New_Spec, Anon_Id); Insert_Before (Instantiation_Node, Decl_Node); @@ -8302,8 +8321,7 @@ package body Sem_Ch12 is Subt_Decl := Make_Subtype_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, New_Internal_Name ('P')), + Defining_Identifier => Make_Temporary (Loc, 'P'), Subtype_Indication => New_Occurrence_Of (Ftyp, Loc)); Prepend (Subt_Decl, List); @@ -8576,6 +8594,7 @@ package body Sem_Ch12 is Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top; Scope_Suppress := Body_Info.Scope_Suppress; + Opt.Ada_Version := Body_Info.Version; if No (Gen_Body_Id) then Load_Parent_Of_Generic @@ -8583,6 +8602,8 @@ package body Sem_Ch12 is Gen_Body_Id := Corresponding_Body (Gen_Decl); end if; + Mark_Context (Act_Decl, Gen_Decl); + -- Establish global variable for sloc adjustment and for error recovery Instantiation_Node := Inst_Node; @@ -8732,11 +8753,16 @@ package body Sem_Ch12 is -- If we have no body, and the unit requires a body, then complain. This -- complaint is suppressed if we have detected other errors (since a -- common reason for missing the body is that it had errors). + -- In CodePeer mode, a warning has been emitted already, no need for + -- further messages. elsif Unit_Requires_Body (Gen_Unit) and then not Body_Optional then - if Serious_Errors_Detected = 0 then + if CodePeer_Mode then + null; + + elsif Serious_Errors_Detected = 0 then Error_Msg_NE ("cannot find body of generic package &", Inst_Node, Gen_Unit); @@ -8832,6 +8858,7 @@ package body Sem_Ch12 is Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top; Scope_Suppress := Body_Info.Scope_Suppress; + Opt.Ada_Version := Body_Info.Version; if No (Gen_Body_Id) then @@ -8859,6 +8886,7 @@ package body Sem_Ch12 is if Present (Gen_Body_Id) then Gen_Body := Unit_Declaration_Node (Gen_Body_Id); + Mark_Context (Inst_Node, Gen_Decl); if Nkind (Gen_Body) = N_Subprogram_Body_Stub then @@ -9213,8 +9241,10 @@ package body Sem_Ch12 is elsif Ekind (A_Gen_T) = E_General_Access_Type and then Ekind (Base_Type (Act_T)) /= E_General_Access_Type then - Error_Msg_N ("actual must be general access type!", Actual); - Error_Msg_NE ("add ALL to }!", Actual, Act_T); + Error_Msg_N -- CODEFIX + ("actual must be general access type!", Actual); + Error_Msg_NE -- CODEFIX + ("add ALL to }!", Actual, Act_T); Abandon_Instantiation (Actual); end if; end if; @@ -9843,9 +9873,7 @@ package body Sem_Ch12 is -- then so far the subprograms correspond, so -- now check that any result types correspond. - if No (Anc_Formal) - and then No (Act_Formal) - then + if No (Anc_Formal) and then No (Act_Formal) then Subprograms_Correspond := True; if Ekind (Act_Subp) = E_Function then @@ -10327,8 +10355,7 @@ package body Sem_Ch12 is Corr_Decl : Node_Id; begin - New_Corr := Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); + New_Corr := Make_Temporary (Loc, 'S'); Corr_Decl := Make_Subtype_Declaration (Loc, Defining_Identifier => New_Corr, @@ -10374,6 +10401,131 @@ package body Sem_Ch12 is end if; end Is_Generic_Formal; + ------------------ + -- Mark_Context -- + ------------------ + + procedure Mark_Context (Inst_Decl : Node_Id; Gen_Decl : Node_Id) is + Loc : constant Source_Ptr := Sloc (Inst_Decl); + Inst_CU : constant Unit_Number_Type := Get_Code_Unit (Inst_Decl); + + -- Note that we use Get_Code_Unit to determine the position of the + -- instantiation, because it may itself appear within another instance + -- and we need to mark the context of the enclosing unit, not that of + -- the unit that contains the generic. + + Gen_CU : constant Unit_Number_Type := Get_Source_Unit (Gen_Decl); + Inst : Entity_Id; + Clause : Node_Id; + Scop : Entity_Id; + + procedure Add_Implicit_With (CU : Unit_Number_Type); + -- If a generic is instantiated in the direct or indirect context of + -- the current unit, but there is no with_clause for it in the current + -- context, add a with_clause for it to indicate that the body of the + -- generic should be examined before the current unit. + + procedure Add_Implicit_With (CU : Unit_Number_Type) is + Withn : constant Node_Id := + Make_With_Clause (Loc, + Name => New_Occurrence_Of (Cunit_Entity (CU), Loc)); + begin + Set_Implicit_With (Withn); + Set_Library_Unit (Withn, Cunit (CU)); + Set_Withed_Body (Withn, Cunit (CU)); + Prepend (Withn, Context_Items (Cunit (Inst_CU))); + end Add_Implicit_With; + + begin + -- This is only relevant when compiling for CodePeer. In what follows, + -- C is the current unit containing the instance body, and G is the + -- generic unit in that instance. + + if not CodePeer_Mode then + return; + end if; + + -- Nothing to do if G is local. + + if Inst_CU = Gen_CU then + return; + end if; + + -- If G is itself declared within an instance, indicate that the + -- generic body of that instance is also needed by C. This must be + -- done recursively. + + Scop := Scope (Defining_Entity (Gen_Decl)); + + while Is_Generic_Instance (Scop) + and then Ekind (Scop) = E_Package + loop + Mark_Context + (Inst_Decl, + Unit_Declaration_Node + (Generic_Parent + (Specification (Unit_Declaration_Node (Scop))))); + Scop := Scope (Scop); + end loop; + + -- Add references to other generic units in the context of G, because + -- they may be instantiated within G, and their bodies needed by C. + + Clause := First (Context_Items (Cunit (Gen_CU))); + + while Present (Clause) loop + if Nkind (Clause) = N_With_Clause + and then + Nkind (Unit (Library_Unit (Clause))) + = N_Generic_Package_Declaration + then + Add_Implicit_With (Get_Source_Unit (Library_Unit (Clause))); + end if; + + Next (Clause); + end loop; + + -- Now indicate that the body of G is needed by C + + Clause := First (Context_Items (Cunit (Inst_CU))); + while Present (Clause) loop + if Nkind (Clause) = N_With_Clause + and then Library_Unit (Clause) = Cunit (Gen_CU) + then + Set_Withed_Body (Clause, Cunit (Gen_CU)); + return; + end if; + + Next (Clause); + end loop; + + -- If the with-clause for G is not in the context of C, it may appear in + -- some ancestor of C. + + Inst := Cunit_Entity (Inst_CU); + while Is_Child_Unit (Inst) loop + Inst := Scope (Inst); + + Clause := + First (Context_Items (Parent (Unit_Declaration_Node (Inst)))); + while Present (Clause) loop + if Nkind (Clause) = N_With_Clause + and then Library_Unit (Clause) = Cunit (Gen_CU) + then + Set_Withed_Body (Clause, Cunit (Gen_CU)); + return; + end if; + + Next (Clause); + end loop; + end loop; + + -- If not found, G comes from an instance elsewhere in the context. Make + -- the dependence explicit in the context of C. + + Add_Implicit_With (Gen_CU); + end Mark_Context; + --------------------- -- Is_In_Main_Unit -- --------------------- @@ -10434,8 +10586,8 @@ package body Sem_Ch12 is -- instantiations are available, we must analyze them, to ensure that -- the public symbols generated are the same when the unit is compiled -- to generate code, and when it is compiled in the context of a unit - -- that needs a particular nested instance. This process is applied - -- to both package and subprogram instances. + -- that needs a particular nested instance. This process is applied to + -- both package and subprogram instances. -------------------------------- -- Collect_Previous_Instances -- @@ -10480,10 +10632,18 @@ package body Sem_Ch12 is Collect_Previous_Instances (Private_Declarations (Specification (Decl))); + -- Previous non-generic bodies may contain instances as well + elsif Nkind (Decl) = N_Package_Body and then Ekind (Corresponding_Spec (Decl)) /= E_Generic_Package then Collect_Previous_Instances (Declarations (Decl)); + + elsif Nkind (Decl) = N_Subprogram_Body + and then not Acts_As_Spec (Decl) + and then not Is_Generic_Subprogram (Corresponding_Spec (Decl)) + then + Collect_Previous_Instances (Declarations (Decl)); end if; Next (Decl); @@ -10577,9 +10737,8 @@ package body Sem_Ch12 is -- enclosing body. Because the generic body we need may use -- global entities declared in the enclosing package (including -- aggregates) it is in general necessary to compile this body - -- with expansion enabled. The exception is if we are within a - -- generic package, in which case the usual generic rule - -- applies. + -- with expansion enabled, except if we are within a generic + -- package, in which case the usual generic rule applies. declare Exp_Status : Boolean := True; @@ -10648,7 +10807,8 @@ package body Sem_Ch12 is Get_Code_Unit (Sloc (Node (Decl))), Scope_Suppress => Scope_Suppress, Local_Suppress_Stack_Top => - Local_Suppress_Stack_Top); + Local_Suppress_Stack_Top, + Version => Ada_Version); -- Package instance @@ -10688,7 +10848,8 @@ package body Sem_Ch12 is Get_Code_Unit (Sloc (Inst_Node)), Scope_Suppress => Scope_Suppress, Local_Suppress_Stack_Top => - Local_Suppress_Stack_Top)), + Local_Suppress_Stack_Top, + Version => Ada_Version)), Body_Optional => Body_Optional); end; end if; @@ -10711,11 +10872,20 @@ package body Sem_Ch12 is Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit))); begin - Error_Msg_Unit_1 := Bname; - Error_Msg_N ("this instantiation requires$!", N); - Error_Msg_File_1 := Get_File_Name (Bname, Subunit => False); - Error_Msg_N ("\but file{ was not found!", N); - raise Unrecoverable_Error; + -- In CodePeer mode, the missing body may make the analysis + -- incomplete, but we do not treat it as fatal. + + if CodePeer_Mode then + return; + + else + Error_Msg_Unit_1 := Bname; + Error_Msg_N ("this instantiation requires$!", N); + Error_Msg_File_1 := + Get_File_Name (Bname, Subunit => False); + Error_Msg_N ("\but file{ was not found!", N); + raise Unrecoverable_Error; + end if; end; end if; end if; @@ -11225,9 +11395,9 @@ package body Sem_Ch12 is -- exchanged explicitly now, in order to remain consistent with the -- view of the parent type. - if Ekind (Typ) = E_Private_Type - or else Ekind (Typ) = E_Limited_Private_Type - or else Ekind (Typ) = E_Record_Type_With_Private + if Ekind_In (Typ, E_Private_Type, + E_Limited_Private_Type, + E_Record_Type_With_Private) then Dep_Elmt := First_Elmt (Private_Dependents (Typ)); while Present (Dep_Elmt) loop @@ -12023,18 +12193,17 @@ package body Sem_Ch12 is elsif Nkind (N2) = N_Explicit_Dereference then -- An identifier is rewritten as a dereference if it is the - -- prefix in an implicit dereference. - - -- Check whether corresponding entity in prefix is global + -- prefix in an implicit dereference (call or attribute). + -- The analysis of an instantiation will expand the node + -- again, so we preserve the original tree but link it to + -- the resolved entity in case it is global. if Is_Entity_Name (Prefix (N2)) and then Present (Entity (Prefix (N2))) and then Is_Global (Entity (Prefix (N2))) then - Rewrite (N, - Make_Explicit_Dereference (Loc, - Prefix => - New_Occurrence_Of (Entity (Prefix (N2)), Loc))); + Set_Associated_Node (N, Prefix (N2)); + elsif Nkind (Prefix (N2)) = N_Function_Call and then Is_Global (Entity (Name (Prefix (N2)))) then @@ -12156,6 +12325,26 @@ package body Sem_Ch12 is -- All other cases than aggregates else + -- For pragmas, we propagate the Enabled status for the + -- relevant pragmas to the original generic tree. This was + -- originally needed for SCO generation. It is no longer + -- needed there (since we use the Sloc value in calls to + -- Set_SCO_Pragma_Enabled), but it seems a generally good + -- idea to have this flag set properly. + + if Nkind (N) = N_Pragma + and then + (Pragma_Name (N) = Name_Assert or else + Pragma_Name (N) = Name_Check or else + Pragma_Name (N) = Name_Precondition or else + Pragma_Name (N) = Name_Postcondition) + and then Present (Associated_Node (Pragma_Identifier (N))) + then + Set_Pragma_Enabled (N, + Pragma_Enabled + (Parent (Associated_Node (Pragma_Identifier (N))))); + end if; + Save_Global_Descendant (Field1 (N)); Save_Global_Descendant (Field2 (N)); Save_Global_Descendant (Field3 (N)); @@ -12237,19 +12426,22 @@ package body Sem_Ch12 is Act_Unit : Entity_Id) is begin - -- Regardless of the current mode, predefined units are analyzed in - -- the most current Ada mode, and earlier version Ada checks do not - -- apply to predefined units. Nothing needs to be done for non-internal - -- units. These are always analyzed in the current mode. + -- Regardless of the current mode, predefined units are analyzed in the + -- most current Ada mode, and earlier version Ada checks do not apply + -- to predefined units. Nothing needs to be done for non-internal units. + -- These are always analyzed in the current mode. if Is_Internal_File_Name - (Fname => Unit_File_Name (Get_Source_Unit (Gen_Unit)), - Renamings_Included => True) + (Fname => Unit_File_Name (Get_Source_Unit (Gen_Unit)), + Renamings_Included => True) then Set_Opt_Config_Switches (True, Current_Sem_Unit = Main_Unit); end if; - Current_Instantiated_Parent := (Gen_Unit, Act_Unit, Assoc_Null); + Current_Instantiated_Parent := + (Gen_Id => Gen_Unit, + Act_Id => Act_Unit, + Next_In_HTable => Assoc_Null); end Set_Instance_Env; ----------------- diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 6542dd28174..8b1d60aa153 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -73,10 +73,6 @@ package body Sem_Ch13 is -- inherited from a derived type that is no longer appropriate for the -- new Esize value. In this case, we reset the Alignment to unknown. - procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id); - -- Given two entities for record components or discriminants, checks - -- if they have overlapping component clauses and issues errors if so. - function Get_Alignment_Value (Expr : Node_Id) return Uint; -- Given the expression for an alignment value, returns the corresponding -- Uint value. If the value is inappropriate, then error messages are @@ -180,265 +176,421 @@ package body Sem_Ch13 is ----------------------------------------- procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id) is - Max_Machine_Scalar_Size : constant Uint := - UI_From_Int - (Standard_Long_Long_Integer_Size); - -- We use this as the maximum machine scalar size in the sense of AI-133 - - Num_CC : Natural; - Comp : Entity_Id; - SSU : constant Uint := UI_From_Int (System_Storage_Unit); + Comp : Node_Id; + CC : Node_Id; begin - -- This first loop through components does two things. First it deals - -- with the case of components with component clauses whose length is - -- greater than the maximum machine scalar size (either accepting them - -- or rejecting as needed). Second, it counts the number of components - -- with component clauses whose length does not exceed this maximum for - -- later processing. - - Num_CC := 0; - Comp := First_Component_Or_Discriminant (R); - while Present (Comp) loop - declare - CC : constant Node_Id := Component_Clause (Comp); + -- Processing depends on version of Ada - begin - if Present (CC) then - declare - Fbit : constant Uint := Static_Integer (First_Bit (CC)); + case Ada_Version is - begin - -- Case of component with size > max machine scalar + -- For Ada 95, we just renumber bits within a storage unit. We do + -- the same for Ada 83 mode, since we recognize pragma Bit_Order + -- in Ada 83, and are free to add this extension. - if Esize (Comp) > Max_Machine_Scalar_Size then + when Ada_83 | Ada_95 => + Comp := First_Component_Or_Discriminant (R); + while Present (Comp) loop + CC := Component_Clause (Comp); - -- Must begin on byte boundary + -- If component clause is present, then deal with the non- + -- default bit order case for Ada 95 mode. - if Fbit mod SSU /= 0 then - Error_Msg_N - ("illegal first bit value for reverse bit order", - First_Bit (CC)); - Error_Msg_Uint_1 := SSU; - Error_Msg_Uint_2 := Max_Machine_Scalar_Size; + -- We only do this processing for the base type, and in + -- fact that's important, since otherwise if there are + -- record subtypes, we could reverse the bits once for + -- each subtype, which would be incorrect. - Error_Msg_N - ("\must be a multiple of ^ if size greater than ^", - First_Bit (CC)); + if Present (CC) + and then Ekind (R) = E_Record_Type + then + declare + CFB : constant Uint := Component_Bit_Offset (Comp); + CSZ : constant Uint := Esize (Comp); + CLC : constant Node_Id := Component_Clause (Comp); + Pos : constant Node_Id := Position (CLC); + FB : constant Node_Id := First_Bit (CLC); - -- Must end on byte boundary + Storage_Unit_Offset : constant Uint := + CFB / System_Storage_Unit; - elsif Esize (Comp) mod SSU /= 0 then - Error_Msg_N - ("illegal last bit value for reverse bit order", - Last_Bit (CC)); - Error_Msg_Uint_1 := SSU; - Error_Msg_Uint_2 := Max_Machine_Scalar_Size; + Start_Bit : constant Uint := + CFB mod System_Storage_Unit; - Error_Msg_N - ("\must be a multiple of ^ if size greater than ^", - Last_Bit (CC)); + begin + -- Cases where field goes over storage unit boundary - -- OK, give warning if enabled + if Start_Bit + CSZ > System_Storage_Unit then - elsif Warn_On_Reverse_Bit_Order then - Error_Msg_N - ("multi-byte field specified with non-standard" - & " Bit_Order?", CC); + -- Allow multi-byte field but generate warning - if Bytes_Big_Endian then + if Start_Bit mod System_Storage_Unit = 0 + and then CSZ mod System_Storage_Unit = 0 + then Error_Msg_N - ("\bytes are not reversed " - & "(component is big-endian)?", CC); + ("multi-byte field specified with non-standard" + & " Bit_Order?", CLC); + + if Bytes_Big_Endian then + Error_Msg_N + ("bytes are not reversed " + & "(component is big-endian)?", CLC); + else + Error_Msg_N + ("bytes are not reversed " + & "(component is little-endian)?", CLC); + end if; + + -- Do not allow non-contiguous field + else Error_Msg_N - ("\bytes are not reversed " - & "(component is little-endian)?", CC); + ("attempt to specify non-contiguous field " + & "not permitted", CLC); + Error_Msg_N + ("\caused by non-standard Bit_Order " + & "specified", CLC); + Error_Msg_N + ("\consider possibility of using " + & "Ada 2005 mode here", CLC); end if; - end if; - -- Case where size is not greater than max machine - -- scalar. For now, we just count these. + -- Case where field fits in one storage unit - else - Num_CC := Num_CC + 1; - end if; - end; - end if; - end; + else + -- Give warning if suspicious component clause - Next_Component_Or_Discriminant (Comp); - end loop; + if Intval (FB) >= System_Storage_Unit + and then Warn_On_Reverse_Bit_Order + then + Error_Msg_N + ("?Bit_Order clause does not affect " & + "byte ordering", Pos); + Error_Msg_Uint_1 := + Intval (Pos) + Intval (FB) / + System_Storage_Unit; + Error_Msg_N + ("?position normalized to ^ before bit " & + "order interpreted", Pos); + end if; - -- We need to sort the component clauses on the basis of the Position - -- values in the clause, so we can group clauses with the same Position. - -- together to determine the relevant machine scalar size. + -- Here is where we fix up the Component_Bit_Offset + -- value to account for the reverse bit order. + -- Some examples of what needs to be done are: - declare - Comps : array (0 .. Num_CC) of Entity_Id; - -- Array to collect component and discriminant entities. The data - -- starts at index 1, the 0'th entry is for the sort routine. + -- First_Bit .. Last_Bit Component_Bit_Offset + -- old new old new - function CP_Lt (Op1, Op2 : Natural) return Boolean; - -- Compare routine for Sort + -- 0 .. 0 7 .. 7 0 7 + -- 0 .. 1 6 .. 7 0 6 + -- 0 .. 2 5 .. 7 0 5 + -- 0 .. 7 0 .. 7 0 4 - procedure CP_Move (From : Natural; To : Natural); - -- Move routine for Sort + -- 1 .. 1 6 .. 6 1 6 + -- 1 .. 4 3 .. 6 1 3 + -- 4 .. 7 0 .. 3 4 0 - package Sorting is new GNAT.Heap_Sort_G (CP_Move, CP_Lt); + -- The general rule is that the first bit is + -- is obtained by subtracting the old ending bit + -- from storage_unit - 1. - Start : Natural; - Stop : Natural; - -- Start and stop positions in component list of set of components - -- with the same starting position (that constitute components in - -- a single machine scalar). + Set_Component_Bit_Offset + (Comp, + (Storage_Unit_Offset * System_Storage_Unit) + + (System_Storage_Unit - 1) - + (Start_Bit + CSZ - 1)); - MaxL : Uint; - -- Maximum last bit value of any component in this set + Set_Normalized_First_Bit + (Comp, + Component_Bit_Offset (Comp) mod + System_Storage_Unit); + end if; + end; + end if; - MSS : Uint; - -- Corresponding machine scalar size + Next_Component_Or_Discriminant (Comp); + end loop; - ----------- - -- CP_Lt -- - ----------- + -- For Ada 2005, we do machine scalar processing, as fully described + -- In AI-133. This involves gathering all components which start at + -- the same byte offset and processing them together - function CP_Lt (Op1, Op2 : Natural) return Boolean is - begin - return Position (Component_Clause (Comps (Op1))) < - Position (Component_Clause (Comps (Op2))); - end CP_Lt; + when Ada_05 .. Ada_Version_Type'Last => + declare + Max_Machine_Scalar_Size : constant Uint := + UI_From_Int + (Standard_Long_Long_Integer_Size); + -- We use this as the maximum machine scalar size - ------------- - -- CP_Move -- - ------------- + Num_CC : Natural; + SSU : constant Uint := UI_From_Int (System_Storage_Unit); - procedure CP_Move (From : Natural; To : Natural) is - begin - Comps (To) := Comps (From); - end CP_Move; + begin + -- This first loop through components does two things. First it + -- deals with the case of components with component clauses + -- whose length is greater than the maximum machine scalar size + -- (either accepting them or rejecting as needed). Second, it + -- counts the number of components with component clauses whose + -- length does not exceed this maximum for later processing. + + Num_CC := 0; + Comp := First_Component_Or_Discriminant (R); + while Present (Comp) loop + CC := Component_Clause (Comp); - begin - -- Collect the component clauses + if Present (CC) then + declare + Fbit : constant Uint := + Static_Integer (First_Bit (CC)); - Num_CC := 0; - Comp := First_Component_Or_Discriminant (R); - while Present (Comp) loop - if Present (Component_Clause (Comp)) - and then Esize (Comp) <= Max_Machine_Scalar_Size - then - Num_CC := Num_CC + 1; - Comps (Num_CC) := Comp; - end if; + begin + -- Case of component with size > max machine scalar + + if Esize (Comp) > Max_Machine_Scalar_Size then + + -- Must begin on byte boundary + + if Fbit mod SSU /= 0 then + Error_Msg_N + ("illegal first bit value for " + & "reverse bit order", + First_Bit (CC)); + Error_Msg_Uint_1 := SSU; + Error_Msg_Uint_2 := Max_Machine_Scalar_Size; + + Error_Msg_N + ("\must be a multiple of ^ " + & "if size greater than ^", + First_Bit (CC)); + + -- Must end on byte boundary + + elsif Esize (Comp) mod SSU /= 0 then + Error_Msg_N + ("illegal last bit value for " + & "reverse bit order", + Last_Bit (CC)); + Error_Msg_Uint_1 := SSU; + Error_Msg_Uint_2 := Max_Machine_Scalar_Size; + + Error_Msg_N + ("\must be a multiple of ^ if size " + & "greater than ^", + Last_Bit (CC)); + + -- OK, give warning if enabled + + elsif Warn_On_Reverse_Bit_Order then + Error_Msg_N + ("multi-byte field specified with " + & " non-standard Bit_Order?", CC); + + if Bytes_Big_Endian then + Error_Msg_N + ("\bytes are not reversed " + & "(component is big-endian)?", CC); + else + Error_Msg_N + ("\bytes are not reversed " + & "(component is little-endian)?", CC); + end if; + end if; - Next_Component_Or_Discriminant (Comp); - end loop; + -- Case where size is not greater than max machine + -- scalar. For now, we just count these. - -- Sort by ascending position number - - Sorting.Sort (Num_CC); - - -- We now have all the components whose size does not exceed the max - -- machine scalar value, sorted by starting position. In this loop - -- we gather groups of clauses starting at the same position, to - -- process them in accordance with Ada 2005 AI-133. - - Stop := 0; - while Stop < Num_CC loop - Start := Stop + 1; - Stop := Start; - MaxL := - Static_Integer (Last_Bit (Component_Clause (Comps (Start)))); - while Stop < Num_CC loop - if Static_Integer - (Position (Component_Clause (Comps (Stop + 1)))) = - Static_Integer - (Position (Component_Clause (Comps (Stop)))) - then - Stop := Stop + 1; - MaxL := - UI_Max - (MaxL, - Static_Integer - (Last_Bit (Component_Clause (Comps (Stop))))); - else - exit; - end if; - end loop; + else + Num_CC := Num_CC + 1; + end if; + end; + end if; - -- Now we have a group of component clauses from Start to Stop - -- whose positions are identical, and MaxL is the maximum last bit - -- value of any of these components. + Next_Component_Or_Discriminant (Comp); + end loop; - -- We need to determine the corresponding machine scalar size. - -- This loop assumes that machine scalar sizes are even, and that - -- each possible machine scalar has twice as many bits as the - -- next smaller one. + -- We need to sort the component clauses on the basis of the + -- Position values in the clause, so we can group clauses with + -- the same Position. together to determine the relevant + -- machine scalar size. - MSS := Max_Machine_Scalar_Size; - while MSS mod 2 = 0 - and then (MSS / 2) >= SSU - and then (MSS / 2) > MaxL - loop - MSS := MSS / 2; - end loop; + Sort_CC : declare + Comps : array (0 .. Num_CC) of Entity_Id; + -- Array to collect component and discriminant entities. The + -- data starts at index 1, the 0'th entry is for the sort + -- routine. - -- Here is where we fix up the Component_Bit_Offset value to - -- account for the reverse bit order. Some examples of what needs - -- to be done for the case of a machine scalar size of 8 are: + function CP_Lt (Op1, Op2 : Natural) return Boolean; + -- Compare routine for Sort - -- First_Bit .. Last_Bit Component_Bit_Offset - -- old new old new + procedure CP_Move (From : Natural; To : Natural); + -- Move routine for Sort - -- 0 .. 0 7 .. 7 0 7 - -- 0 .. 1 6 .. 7 0 6 - -- 0 .. 2 5 .. 7 0 5 - -- 0 .. 7 0 .. 7 0 4 + package Sorting is new GNAT.Heap_Sort_G (CP_Move, CP_Lt); - -- 1 .. 1 6 .. 6 1 6 - -- 1 .. 4 3 .. 6 1 3 - -- 4 .. 7 0 .. 3 4 0 + Start : Natural; + Stop : Natural; + -- Start and stop positions in component list of set of + -- components with the same starting position (that + -- constitute components in a single machine scalar). - -- The general rule is that the first bit is obtained by - -- subtracting the old ending bit from machine scalar size - 1. + MaxL : Uint; + -- Maximum last bit value of any component in this set - for C in Start .. Stop loop - declare - Comp : constant Entity_Id := Comps (C); - CC : constant Node_Id := Component_Clause (Comp); - LB : constant Uint := Static_Integer (Last_Bit (CC)); - NFB : constant Uint := MSS - Uint_1 - LB; - NLB : constant Uint := NFB + Esize (Comp) - 1; - Pos : constant Uint := Static_Integer (Position (CC)); + MSS : Uint; + -- Corresponding machine scalar size + + ----------- + -- CP_Lt -- + ----------- + + function CP_Lt (Op1, Op2 : Natural) return Boolean is + begin + return Position (Component_Clause (Comps (Op1))) < + Position (Component_Clause (Comps (Op2))); + end CP_Lt; + + ------------- + -- CP_Move -- + ------------- + + procedure CP_Move (From : Natural; To : Natural) is + begin + Comps (To) := Comps (From); + end CP_Move; + + -- Start of processing for Sort_CC begin - if Warn_On_Reverse_Bit_Order then - Error_Msg_Uint_1 := MSS; - Error_Msg_N - ("info: reverse bit order in machine " & - "scalar of length^?", First_Bit (CC)); - Error_Msg_Uint_1 := NFB; - Error_Msg_Uint_2 := NLB; + -- Collect the component clauses - if Bytes_Big_Endian then - Error_Msg_NE - ("?\info: big-endian range for " - & "component & is ^ .. ^", - First_Bit (CC), Comp); - else - Error_Msg_NE - ("?\info: little-endian range " - & "for component & is ^ .. ^", - First_Bit (CC), Comp); + Num_CC := 0; + Comp := First_Component_Or_Discriminant (R); + while Present (Comp) loop + if Present (Component_Clause (Comp)) + and then Esize (Comp) <= Max_Machine_Scalar_Size + then + Num_CC := Num_CC + 1; + Comps (Num_CC) := Comp; end if; - end if; - Set_Component_Bit_Offset (Comp, Pos * SSU + NFB); - Set_Normalized_First_Bit (Comp, NFB mod SSU); - end; - end loop; - end loop; - end; + Next_Component_Or_Discriminant (Comp); + end loop; + + -- Sort by ascending position number + + Sorting.Sort (Num_CC); + + -- We now have all the components whose size does not exceed + -- the max machine scalar value, sorted by starting + -- position. In this loop we gather groups of clauses + -- starting at the same position, to process them in + -- accordance with Ada 2005 AI-133. + + Stop := 0; + while Stop < Num_CC loop + Start := Stop + 1; + Stop := Start; + MaxL := + Static_Integer + (Last_Bit (Component_Clause (Comps (Start)))); + while Stop < Num_CC loop + if Static_Integer + (Position (Component_Clause (Comps (Stop + 1)))) = + Static_Integer + (Position (Component_Clause (Comps (Stop)))) + then + Stop := Stop + 1; + MaxL := + UI_Max + (MaxL, + Static_Integer + (Last_Bit + (Component_Clause (Comps (Stop))))); + else + exit; + end if; + end loop; + + -- Now we have a group of component clauses from Start to + -- Stop whose positions are identical, and MaxL is the + -- maximum last bit value of any of these components. + + -- We need to determine the corresponding machine scalar + -- size. This loop assumes that machine scalar sizes are + -- even, and that each possible machine scalar has twice + -- as many bits as the next smaller one. + + MSS := Max_Machine_Scalar_Size; + while MSS mod 2 = 0 + and then (MSS / 2) >= SSU + and then (MSS / 2) > MaxL + loop + MSS := MSS / 2; + end loop; + + -- Here is where we fix up the Component_Bit_Offset value + -- to account for the reverse bit order. Some examples of + -- what needs to be done for the case of a machine scalar + -- size of 8 are: + + -- First_Bit .. Last_Bit Component_Bit_Offset + -- old new old new + + -- 0 .. 0 7 .. 7 0 7 + -- 0 .. 1 6 .. 7 0 6 + -- 0 .. 2 5 .. 7 0 5 + -- 0 .. 7 0 .. 7 0 4 + + -- 1 .. 1 6 .. 6 1 6 + -- 1 .. 4 3 .. 6 1 3 + -- 4 .. 7 0 .. 3 4 0 + + -- The general rule is that the first bit is obtained by + -- subtracting the old ending bit from machine scalar + -- size - 1. + + for C in Start .. Stop loop + declare + Comp : constant Entity_Id := Comps (C); + CC : constant Node_Id := + Component_Clause (Comp); + LB : constant Uint := + Static_Integer (Last_Bit (CC)); + NFB : constant Uint := MSS - Uint_1 - LB; + NLB : constant Uint := NFB + Esize (Comp) - 1; + Pos : constant Uint := + Static_Integer (Position (CC)); + + begin + if Warn_On_Reverse_Bit_Order then + Error_Msg_Uint_1 := MSS; + Error_Msg_N + ("info: reverse bit order in machine " & + "scalar of length^?", First_Bit (CC)); + Error_Msg_Uint_1 := NFB; + Error_Msg_Uint_2 := NLB; + + if Bytes_Big_Endian then + Error_Msg_NE + ("?\info: big-endian range for " + & "component & is ^ .. ^", + First_Bit (CC), Comp); + else + Error_Msg_NE + ("?\info: little-endian range " + & "for component & is ^ .. ^", + First_Bit (CC), Comp); + end if; + end if; + + Set_Component_Bit_Offset (Comp, Pos * SSU + NFB); + Set_Normalized_First_Bit (Comp, NFB mod SSU); + end; + end loop; + end loop; + end Sort_CC; + end; + end case; end Adjust_Record_For_Reverse_Bit_Order; -------------------------------------- @@ -704,7 +856,8 @@ package body Sem_Ch13 is Attribute_Write => null; - -- Other cases are errors, which will be caught below + -- Other cases are errors ("attribute& cannot be set with + -- definition clause"), which will be caught below. when others => null; @@ -803,9 +956,7 @@ package body Sem_Ch13 is -- it imported. if Ignore_Rep_Clauses then - if Ekind (U_Ent) = E_Variable - or else Ekind (U_Ent) = E_Constant - then + if Ekind_In (U_Ent, E_Variable, E_Constant) then Record_Rep_Item (U_Ent, N); end if; @@ -1026,13 +1177,19 @@ package body Sem_Ch13 is -- check till after code generation to take full advantage -- of the annotation done by the back end. This entry is -- only made if the address clause comes from source. + -- If the entity has a generic type, the check will be + -- performed in the instance if the actual type justifies + -- it, and we do not insert the clause in the table to + -- prevent spurious warnings. if Address_Clause_Overlay_Warnings and then Comes_From_Source (N) and then Present (O_Ent) and then Is_Object (O_Ent) then - Address_Clause_Checks.Append ((N, U_Ent, O_Ent, Off)); + if not Is_Generic_Type (Etype (U_Ent)) then + Address_Clause_Checks.Append ((N, U_Ent, O_Ent, Off)); + end if; -- If variable overlays a constant view, and we are -- warning on overlays, then mark the variable as @@ -1528,8 +1685,8 @@ package body Sem_Ch13 is Nam); return; - elsif Ekind (U_Ent) /= E_Access_Type - and then Ekind (U_Ent) /= E_General_Access_Type + elsif not + Ekind_In (U_Ent, E_Access_Type, E_General_Access_Type) then Error_Msg_N ("storage pool can only be given for access types", Nam); @@ -1586,9 +1743,7 @@ package body Sem_Ch13 is if not Is_Entity_Name (Expr) and then Is_Object_Reference (Expr) then - Pool := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('P')); + Pool := Make_Temporary (Loc, 'P', Expr); declare Rnode : constant Node_Id := @@ -1596,7 +1751,7 @@ package body Sem_Ch13 is Defining_Identifier => Pool, Subtype_Mark => New_Occurrence_Of (Etype (Expr), Loc), - Name => Expr); + Name => Expr); begin Insert_Before (N, Rnode); @@ -1656,8 +1811,7 @@ package body Sem_Ch13 is Error_Msg_N ("storage size clause for task is an " & "obsolescent feature (RM J.9)?", N); - Error_Msg_N - ("\use Storage_Size pragma instead?", N); + Error_Msg_N ("\use Storage_Size pragma instead?", N); end if; FOnly := True; @@ -2213,7 +2367,9 @@ package body Sem_Ch13 is -- code because their main purpose was to provide support to initialize -- the secondary dispatch tables. They are now generated also when -- compiling with no code generation to provide ASIS the relationship - -- between interface primitives and tagged type primitives. + -- between interface primitives and tagged type primitives. They are + -- also used to locate primitives covering interfaces when processing + -- generics (see Derive_Subprograms). if Ada_Version >= Ada_05 and then Ekind (E) = E_Record_Type @@ -2221,6 +2377,12 @@ package body Sem_Ch13 is and then not Is_Interface (E) and then Has_Interfaces (E) then + -- This would be a good common place to call the routine that checks + -- overriding of interface primitives (and thus factorize calls to + -- Check_Abstract_Overriding located at different contexts in the + -- compiler). However, this is not possible because it causes + -- spurious errors in case of late overriding. + Add_Internal_Interface_Entities (E); end if; end Analyze_Freeze_Entity; @@ -2229,11 +2391,16 @@ package body Sem_Ch13 is -- Analyze_Record_Representation_Clause -- ------------------------------------------ + -- Note: we check as much as we can here, but we can't do any checks + -- based on the position values (e.g. overlap checks) until freeze time + -- because especially in Ada 2005 (machine scalar mode), the processing + -- for non-standard bit order can substantially change the positions. + -- See procedure Check_Record_Representation_Clause (called from Freeze) + -- for the remainder of this processing. + procedure Analyze_Record_Representation_Clause (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); Ident : constant Node_Id := Identifier (N); Rectype : Entity_Id; - Fent : Entity_Id; CC : Node_Id; Posit : Uint; Fbit : Uint; @@ -2241,33 +2408,8 @@ package body Sem_Ch13 is Hbit : Uint := Uint_0; Comp : Entity_Id; Ocomp : Entity_Id; - Pcomp : Entity_Id; Biased : Boolean; - Max_Bit_So_Far : Uint; - -- Records the maximum bit position so far. If all field positions - -- are monotonically increasing, then we can skip the circuit for - -- checking for overlap, since no overlap is possible. - - Tagged_Parent : Entity_Id := Empty; - -- This is set in the case of a derived tagged type for which we have - -- Is_Fully_Repped_Tagged_Type True (indicating that all components are - -- positioned by record representation clauses). In this case we must - -- check for overlap between components of this tagged type, and the - -- components of its parent. Tagged_Parent will point to this parent - -- type. For all other cases Tagged_Parent is left set to Empty. - - Parent_Last_Bit : Uint; - -- Relevant only if Tagged_Parent is set, Parent_Last_Bit indicates the - -- last bit position for any field in the parent type. We only need to - -- check overlap for fields starting below this point. - - Overlap_Check_Required : Boolean; - -- Used to keep track of whether or not an overlap check is required - - Ccount : Natural := 0; - -- Number of component clauses in record rep clause - CR_Pragma : Node_Id := Empty; -- Points to N_Pragma node if Complete_Representation pragma present @@ -2364,7 +2506,6 @@ package body Sem_Ch13 is -- Get the alignment value to perform error checking Mod_Val := Get_Alignment_Value (Expression (M)); - end if; end; end if; @@ -2383,39 +2524,6 @@ package body Sem_Ch13 is end loop; end if; - -- See if we have a fully repped derived tagged type - - declare - PS : constant Entity_Id := Parent_Subtype (Rectype); - - begin - if Present (PS) and then Is_Fully_Repped_Tagged_Type (PS) then - Tagged_Parent := PS; - - -- Find maximum bit of any component of the parent type - - Parent_Last_Bit := UI_From_Int (System_Address_Size - 1); - Pcomp := First_Entity (Tagged_Parent); - while Present (Pcomp) loop - if Ekind (Pcomp) = E_Discriminant - or else - Ekind (Pcomp) = E_Component - then - if Component_Bit_Offset (Pcomp) /= No_Uint - and then Known_Static_Esize (Pcomp) - then - Parent_Last_Bit := - UI_Max - (Parent_Last_Bit, - Component_Bit_Offset (Pcomp) + Esize (Pcomp) - 1); - end if; - - Next_Entity (Pcomp); - end if; - end loop; - end if; - end; - -- All done if no component clauses CC := First (Component_Clauses (N)); @@ -2424,51 +2532,12 @@ package body Sem_Ch13 is return; end if; - -- If a tag is present, then create a component clause that places it - -- at the start of the record (otherwise gigi may place it after other - -- fields that have rep clauses). - - Fent := First_Entity (Rectype); - - if Nkind (Fent) = N_Defining_Identifier - and then Chars (Fent) = Name_uTag - then - Set_Component_Bit_Offset (Fent, Uint_0); - Set_Normalized_Position (Fent, Uint_0); - Set_Normalized_First_Bit (Fent, Uint_0); - Set_Normalized_Position_Max (Fent, Uint_0); - Init_Esize (Fent, System_Address_Size); - - Set_Component_Clause (Fent, - Make_Component_Clause (Loc, - Component_Name => - Make_Identifier (Loc, - Chars => Name_uTag), - - Position => - Make_Integer_Literal (Loc, - Intval => Uint_0), - - First_Bit => - Make_Integer_Literal (Loc, - Intval => Uint_0), - - Last_Bit => - Make_Integer_Literal (Loc, - UI_From_Int (System_Address_Size)))); - - Ccount := Ccount + 1; - end if; - -- A representation like this applies to the base type Set_Has_Record_Rep_Clause (Base_Type (Rectype)); Set_Has_Non_Standard_Rep (Base_Type (Rectype)); Set_Has_Specified_Layout (Base_Type (Rectype)); - Max_Bit_So_Far := Uint_Minus_1; - Overlap_Check_Required := False; - -- Process the component clauses while Present (CC) loop @@ -2487,7 +2556,6 @@ package body Sem_Ch13 is -- Processing for real component clause else - Ccount := Ccount + 1; Posit := Static_Integer (Position (CC)); Fbit := Static_Integer (First_Bit (CC)); Lbit := Static_Integer (Last_Bit (CC)); @@ -2596,12 +2664,6 @@ package body Sem_Ch13 is Fbit := Fbit + UI_From_Int (SSU) * Posit; Lbit := Lbit + UI_From_Int (SSU) * Posit; - if Fbit <= Max_Bit_So_Far then - Overlap_Check_Required := True; - else - Max_Bit_So_Far := Lbit; - end if; - if Has_Size_Clause (Rectype) and then Esize (Rectype) <= Lbit then @@ -2615,17 +2677,6 @@ package body Sem_Ch13 is Set_Normalized_First_Bit (Comp, Fbit mod SSU); Set_Normalized_Position (Comp, Fbit / SSU); - Set_Normalized_Position_Max - (Fent, Normalized_Position (Fent)); - - if Is_Tagged_Type (Rectype) - and then Fbit < System_Address_Size - then - Error_Msg_NE - ("component overlaps tag field of&", - Component_Name (CC), Rectype); - end if; - -- This information is also set in the corresponding -- component of the base type, found by accessing the -- Original_Record_Component link if it is present. @@ -2668,27 +2719,6 @@ package body Sem_Ch13 is Error_Msg_N ("component size is negative", CC); end if; end if; - - -- If OK component size, check parent type overlap if - -- this component might overlap a parent field. - - if Present (Tagged_Parent) - and then Fbit <= Parent_Last_Bit - then - Pcomp := First_Entity (Tagged_Parent); - while Present (Pcomp) loop - if (Ekind (Pcomp) = E_Discriminant - or else - Ekind (Pcomp) = E_Component) - and then not Is_Tag (Pcomp) - and then Chars (Pcomp) /= Name_uParent - then - Check_Component_Overlap (Comp, Pcomp); - end if; - - Next_Entity (Pcomp); - end loop; - end if; end if; end if; end if; @@ -2697,268 +2727,20 @@ package body Sem_Ch13 is Next (CC); end loop; - -- Now that we have processed all the component clauses, check for - -- overlap. We have to leave this till last, since the components can - -- appear in any arbitrary order in the representation clause. + -- Check missing components if Complete_Representation pragma appeared - -- We do not need this check if all specified ranges were monotonic, - -- as recorded by Overlap_Check_Required being False at this stage. - - -- This first section checks if there are any overlapping entries at - -- all. It does this by sorting all entries and then seeing if there are - -- any overlaps. If there are none, then that is decisive, but if there - -- are overlaps, they may still be OK (they may result from fields in - -- different variants). - - if Overlap_Check_Required then - Overlap_Check1 : declare - - OC_Fbit : array (0 .. Ccount) of Uint; - -- First-bit values for component clauses, the value is the offset - -- of the first bit of the field from start of record. The zero - -- entry is for use in sorting. - - OC_Lbit : array (0 .. Ccount) of Uint; - -- Last-bit values for component clauses, the value is the offset - -- of the last bit of the field from start of record. The zero - -- entry is for use in sorting. - - OC_Count : Natural := 0; - -- Count of entries in OC_Fbit and OC_Lbit - - function OC_Lt (Op1, Op2 : Natural) return Boolean; - -- Compare routine for Sort - - procedure OC_Move (From : Natural; To : Natural); - -- Move routine for Sort - - package Sorting is new GNAT.Heap_Sort_G (OC_Move, OC_Lt); - - ----------- - -- OC_Lt -- - ----------- - - function OC_Lt (Op1, Op2 : Natural) return Boolean is - begin - return OC_Fbit (Op1) < OC_Fbit (Op2); - end OC_Lt; - - ------------- - -- OC_Move -- - ------------- - - procedure OC_Move (From : Natural; To : Natural) is - begin - OC_Fbit (To) := OC_Fbit (From); - OC_Lbit (To) := OC_Lbit (From); - end OC_Move; - - -- Start of processing for Overlap_Check - - begin - CC := First (Component_Clauses (N)); - while Present (CC) loop - if Nkind (CC) /= N_Pragma then - Posit := Static_Integer (Position (CC)); - Fbit := Static_Integer (First_Bit (CC)); - Lbit := Static_Integer (Last_Bit (CC)); - - if Posit /= No_Uint - and then Fbit /= No_Uint - and then Lbit /= No_Uint - then - OC_Count := OC_Count + 1; - Posit := Posit * SSU; - OC_Fbit (OC_Count) := Fbit + Posit; - OC_Lbit (OC_Count) := Lbit + Posit; - end if; - end if; - - Next (CC); - end loop; - - Sorting.Sort (OC_Count); - - Overlap_Check_Required := False; - for J in 1 .. OC_Count - 1 loop - if OC_Lbit (J) >= OC_Fbit (J + 1) then - Overlap_Check_Required := True; - exit; - end if; - end loop; - end Overlap_Check1; - end if; - - -- If Overlap_Check_Required is still True, then we have to do the full - -- scale overlap check, since we have at least two fields that do - -- overlap, and we need to know if that is OK since they are in - -- different variant, or whether we have a definite problem. - - if Overlap_Check_Required then - Overlap_Check2 : declare - C1_Ent, C2_Ent : Entity_Id; - -- Entities of components being checked for overlap - - Clist : Node_Id; - -- Component_List node whose Component_Items are being checked - - Citem : Node_Id; - -- Component declaration for component being checked - - begin - C1_Ent := First_Entity (Base_Type (Rectype)); - - -- Loop through all components in record. For each component check - -- for overlap with any of the preceding elements on the component - -- list containing the component and also, if the component is in - -- a variant, check against components outside the case structure. - -- This latter test is repeated recursively up the variant tree. - - Main_Component_Loop : while Present (C1_Ent) loop - if Ekind (C1_Ent) /= E_Component - and then Ekind (C1_Ent) /= E_Discriminant - then - goto Continue_Main_Component_Loop; - end if; - - -- Skip overlap check if entity has no declaration node. This - -- happens with discriminants in constrained derived types. - -- Probably we are missing some checks as a result, but that - -- does not seem terribly serious ??? - - if No (Declaration_Node (C1_Ent)) then - goto Continue_Main_Component_Loop; - end if; - - Clist := Parent (List_Containing (Declaration_Node (C1_Ent))); - - -- Loop through component lists that need checking. Check the - -- current component list and all lists in variants above us. - - Component_List_Loop : loop - - -- If derived type definition, go to full declaration - -- If at outer level, check discriminants if there are any. - - if Nkind (Clist) = N_Derived_Type_Definition then - Clist := Parent (Clist); - end if; - - -- Outer level of record definition, check discriminants - - if Nkind_In (Clist, N_Full_Type_Declaration, - N_Private_Type_Declaration) - then - if Has_Discriminants (Defining_Identifier (Clist)) then - C2_Ent := - First_Discriminant (Defining_Identifier (Clist)); - while Present (C2_Ent) loop - exit when C1_Ent = C2_Ent; - Check_Component_Overlap (C1_Ent, C2_Ent); - Next_Discriminant (C2_Ent); - end loop; - end if; - - -- Record extension case - - elsif Nkind (Clist) = N_Derived_Type_Definition then - Clist := Empty; - - -- Otherwise check one component list - - else - Citem := First (Component_Items (Clist)); - - while Present (Citem) loop - if Nkind (Citem) = N_Component_Declaration then - C2_Ent := Defining_Identifier (Citem); - exit when C1_Ent = C2_Ent; - Check_Component_Overlap (C1_Ent, C2_Ent); - end if; - - Next (Citem); - end loop; - end if; - - -- Check for variants above us (the parent of the Clist can - -- be a variant, in which case its parent is a variant part, - -- and the parent of the variant part is a component list - -- whose components must all be checked against the current - -- component for overlap). - - if Nkind (Parent (Clist)) = N_Variant then - Clist := Parent (Parent (Parent (Clist))); - - -- Check for possible discriminant part in record, this is - -- treated essentially as another level in the recursion. - -- For this case the parent of the component list is the - -- record definition, and its parent is the full type - -- declaration containing the discriminant specifications. - - elsif Nkind (Parent (Clist)) = N_Record_Definition then - Clist := Parent (Parent ((Clist))); - - -- If neither of these two cases, we are at the top of - -- the tree. - - else - exit Component_List_Loop; - end if; - end loop Component_List_Loop; - - <> - Next_Entity (C1_Ent); - - end loop Main_Component_Loop; - end Overlap_Check2; - end if; - - -- For records that have component clauses for all components, and whose - -- size is less than or equal to 32, we need to know the size in the - -- front end to activate possible packed array processing where the - -- component type is a record. - - -- At this stage Hbit + 1 represents the first unused bit from all the - -- component clauses processed, so if the component clauses are - -- complete, then this is the length of the record. - - -- For records longer than System.Storage_Unit, and for those where not - -- all components have component clauses, the back end determines the - -- length (it may for example be appropriate to round up the size - -- to some convenient boundary, based on alignment considerations, etc). - - if Unknown_RM_Size (Rectype) and then Hbit + 1 <= 32 then - - -- Nothing to do if at least one component has no component clause - - Comp := First_Component_Or_Discriminant (Rectype); - while Present (Comp) loop - exit when No (Component_Clause (Comp)); - Next_Component_Or_Discriminant (Comp); - end loop; - - -- If we fall out of loop, all components have component clauses - -- and so we can set the size to the maximum value. - - if No (Comp) then - Set_RM_Size (Rectype, Hbit + 1); - end if; - end if; - - -- Check missing components if Complete_Representation pragma appeared - - if Present (CR_Pragma) then - Comp := First_Component_Or_Discriminant (Rectype); - while Present (Comp) loop - if No (Component_Clause (Comp)) then - Error_Msg_NE - ("missing component clause for &", CR_Pragma, Comp); - end if; + if Present (CR_Pragma) then + Comp := First_Component_Or_Discriminant (Rectype); + while Present (Comp) loop + if No (Component_Clause (Comp)) then + Error_Msg_NE + ("missing component clause for &", CR_Pragma, Comp); + end if; Next_Component_Or_Discriminant (Comp); end loop; - -- If no Complete_Representation pragma, warn if missing components + -- If no Complete_Representation pragma, warn if missing components elsif Warn_On_Unrepped_Components then declare @@ -2996,8 +2778,8 @@ package body Sem_Ch13 is and then Comes_From_Source (Comp) and then Present (Underlying_Type (Etype (Comp))) and then (Is_Scalar_Type (Underlying_Type (Etype (Comp))) - or else Size_Known_At_Compile_Time - (Underlying_Type (Etype (Comp)))) + or else Size_Known_At_Compile_Time + (Underlying_Type (Etype (Comp)))) and then not Has_Warnings_Off (Rectype) then Error_Msg_Sloc := Sloc (Comp); @@ -3013,50 +2795,6 @@ package body Sem_Ch13 is end if; end Analyze_Record_Representation_Clause; - ----------------------------- - -- Check_Component_Overlap -- - ----------------------------- - - procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id) is - begin - if Present (Component_Clause (C1_Ent)) - and then Present (Component_Clause (C2_Ent)) - then - -- Exclude odd case where we have two tag fields in the same record, - -- both at location zero. This seems a bit strange, but it seems to - -- happen in some circumstances ??? - - if Chars (C1_Ent) = Name_uTag - and then Chars (C2_Ent) = Name_uTag - then - return; - end if; - - -- Here we check if the two fields overlap - - declare - S1 : constant Uint := Component_Bit_Offset (C1_Ent); - S2 : constant Uint := Component_Bit_Offset (C2_Ent); - E1 : constant Uint := S1 + Esize (C1_Ent); - E2 : constant Uint := S2 + Esize (C2_Ent); - - begin - if E2 <= S1 or else E1 <= S2 then - null; - else - Error_Msg_Node_2 := - Component_Name (Component_Clause (C2_Ent)); - Error_Msg_Sloc := Sloc (Error_Msg_Node_2); - Error_Msg_Node_1 := - Component_Name (Component_Clause (C1_Ent)); - Error_Msg_N - ("component& overlaps & #", - Component_Name (Component_Clause (C1_Ent))); - end if; - end; - end if; - end Check_Component_Overlap; - ----------------------------------- -- Check_Constant_Address_Clause -- ----------------------------------- @@ -3203,11 +2941,8 @@ package body Sem_Ch13 is -- Otherwise look at the identifier and see if it is OK - if Ekind (Ent) = E_Named_Integer - or else - Ekind (Ent) = E_Named_Real - or else - Is_Type (Ent) + if Ekind_In (Ent, E_Named_Integer, E_Named_Real) + or else Is_Type (Ent) then return; @@ -3221,190 +2956,757 @@ package body Sem_Ch13 is -- requirement is met since the unit containing Ent is -- already processed. - if not In_Same_Source_Unit (Ent, U_Ent) then - return; + if not In_Same_Source_Unit (Ent, U_Ent) then + return; + + -- Otherwise location of Ent must be before the location + -- of U_Ent, that's what prior defined means. + + elsif Sloc (Ent) < Loc_U_Ent then + return; + + else + Error_Msg_NE + ("invalid address clause for initialized object &!", + Nod, U_Ent); + Error_Msg_Node_2 := U_Ent; + Error_Msg_NE + ("\& must be defined before & (RM 13.1(22))!", + Nod, Ent); + end if; + + elsif Nkind (Original_Node (Nod)) = N_Function_Call then + Check_Expr_Constants (Original_Node (Nod)); + + else + Error_Msg_NE + ("invalid address clause for initialized object &!", + Nod, U_Ent); + + if Comes_From_Source (Ent) then + Error_Msg_NE + ("\reference to variable& not allowed" + & " (RM 13.1(22))!", Nod, Ent); + else + Error_Msg_N + ("non-static expression not allowed" + & " (RM 13.1(22))!", Nod); + end if; + end if; + + when N_Integer_Literal => + + -- If this is a rewritten unchecked conversion, in a system + -- where Address is an integer type, always use the base type + -- for a literal value. This is user-friendly and prevents + -- order-of-elaboration issues with instances of unchecked + -- conversion. + + if Nkind (Original_Node (Nod)) = N_Function_Call then + Set_Etype (Nod, Base_Type (Etype (Nod))); + end if; + + when N_Real_Literal | + N_String_Literal | + N_Character_Literal => + return; + + when N_Range => + Check_Expr_Constants (Low_Bound (Nod)); + Check_Expr_Constants (High_Bound (Nod)); + + when N_Explicit_Dereference => + Check_Expr_Constants (Prefix (Nod)); + + when N_Indexed_Component => + Check_Expr_Constants (Prefix (Nod)); + Check_List_Constants (Expressions (Nod)); + + when N_Slice => + Check_Expr_Constants (Prefix (Nod)); + Check_Expr_Constants (Discrete_Range (Nod)); + + when N_Selected_Component => + Check_Expr_Constants (Prefix (Nod)); + + when N_Attribute_Reference => + if Attribute_Name (Nod) = Name_Address + or else + Attribute_Name (Nod) = Name_Access + or else + Attribute_Name (Nod) = Name_Unchecked_Access + or else + Attribute_Name (Nod) = Name_Unrestricted_Access + then + Check_At_Constant_Address (Prefix (Nod)); + + else + Check_Expr_Constants (Prefix (Nod)); + Check_List_Constants (Expressions (Nod)); + end if; + + when N_Aggregate => + Check_List_Constants (Component_Associations (Nod)); + Check_List_Constants (Expressions (Nod)); + + when N_Component_Association => + Check_Expr_Constants (Expression (Nod)); + + when N_Extension_Aggregate => + Check_Expr_Constants (Ancestor_Part (Nod)); + Check_List_Constants (Component_Associations (Nod)); + Check_List_Constants (Expressions (Nod)); + + when N_Null => + return; + + when N_Binary_Op | N_Short_Circuit | N_Membership_Test => + Check_Expr_Constants (Left_Opnd (Nod)); + Check_Expr_Constants (Right_Opnd (Nod)); + + when N_Unary_Op => + Check_Expr_Constants (Right_Opnd (Nod)); + + when N_Type_Conversion | + N_Qualified_Expression | + N_Allocator => + Check_Expr_Constants (Expression (Nod)); + + when N_Unchecked_Type_Conversion => + Check_Expr_Constants (Expression (Nod)); + + -- If this is a rewritten unchecked conversion, subtypes in + -- this node are those created within the instance. To avoid + -- order of elaboration issues, replace them with their base + -- types. Note that address clauses can cause order of + -- elaboration problems because they are elaborated by the + -- back-end at the point of definition, and may mention + -- entities declared in between (as long as everything is + -- static). It is user-friendly to allow unchecked conversions + -- in this context. + + if Nkind (Original_Node (Nod)) = N_Function_Call then + Set_Etype (Expression (Nod), + Base_Type (Etype (Expression (Nod)))); + Set_Etype (Nod, Base_Type (Etype (Nod))); + end if; + + when N_Function_Call => + if not Is_Pure (Entity (Name (Nod))) then + Error_Msg_NE + ("invalid address clause for initialized object &!", + Nod, U_Ent); + + Error_Msg_NE + ("\function & is not pure (RM 13.1(22))!", + Nod, Entity (Name (Nod))); + + else + Check_List_Constants (Parameter_Associations (Nod)); + end if; + + when N_Parameter_Association => + Check_Expr_Constants (Explicit_Actual_Parameter (Nod)); + + when others => + Error_Msg_NE + ("invalid address clause for initialized object &!", + Nod, U_Ent); + Error_Msg_NE + ("\must be constant defined before& (RM 13.1(22))!", + Nod, U_Ent); + end case; + end Check_Expr_Constants; + + -------------------------- + -- Check_List_Constants -- + -------------------------- + + procedure Check_List_Constants (Lst : List_Id) is + Nod1 : Node_Id; + + begin + if Present (Lst) then + Nod1 := First (Lst); + while Present (Nod1) loop + Check_Expr_Constants (Nod1); + Next (Nod1); + end loop; + end if; + end Check_List_Constants; + + -- Start of processing for Check_Constant_Address_Clause + + begin + -- If rep_clauses are to be ignored, no need for legality checks. In + -- particular, no need to pester user about rep clauses that violate + -- the rule on constant addresses, given that these clauses will be + -- removed by Freeze before they reach the back end. + + if not Ignore_Rep_Clauses then + Check_Expr_Constants (Expr); + end if; + end Check_Constant_Address_Clause; + + ---------------------------------------- + -- Check_Record_Representation_Clause -- + ---------------------------------------- + + procedure Check_Record_Representation_Clause (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Ident : constant Node_Id := Identifier (N); + Rectype : Entity_Id; + Fent : Entity_Id; + CC : Node_Id; + Fbit : Uint; + Lbit : Uint; + Hbit : Uint := Uint_0; + Comp : Entity_Id; + Pcomp : Entity_Id; + + Max_Bit_So_Far : Uint; + -- Records the maximum bit position so far. If all field positions + -- are monotonically increasing, then we can skip the circuit for + -- checking for overlap, since no overlap is possible. + + Tagged_Parent : Entity_Id := Empty; + -- This is set in the case of a derived tagged type for which we have + -- Is_Fully_Repped_Tagged_Type True (indicating that all components are + -- positioned by record representation clauses). In this case we must + -- check for overlap between components of this tagged type, and the + -- components of its parent. Tagged_Parent will point to this parent + -- type. For all other cases Tagged_Parent is left set to Empty. + + Parent_Last_Bit : Uint; + -- Relevant only if Tagged_Parent is set, Parent_Last_Bit indicates the + -- last bit position for any field in the parent type. We only need to + -- check overlap for fields starting below this point. + + Overlap_Check_Required : Boolean; + -- Used to keep track of whether or not an overlap check is required + + Ccount : Natural := 0; + -- Number of component clauses in record rep clause + + procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id); + -- Given two entities for record components or discriminants, checks + -- if they have overlapping component clauses and issues errors if so. + + procedure Find_Component; + -- Finds component entity corresponding to current component clause (in + -- CC), and sets Comp to the entity, and Fbit/Lbit to the zero origin + -- start/stop bits for the field. If there is no matching component or + -- if the matching component does not have a component clause, then + -- that's an error and Comp is set to Empty, but no error message is + -- issued, since the message was already given. Comp is also set to + -- Empty if the current "component clause" is in fact a pragma. + + ----------------------------- + -- Check_Component_Overlap -- + ----------------------------- + + procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id) is + CC1 : constant Node_Id := Component_Clause (C1_Ent); + CC2 : constant Node_Id := Component_Clause (C2_Ent); + begin + if Present (CC1) and then Present (CC2) then + + -- Exclude odd case where we have two tag fields in the same + -- record, both at location zero. This seems a bit strange, but + -- it seems to happen in some circumstances, perhaps on an error. + + if Chars (C1_Ent) = Name_uTag + and then + Chars (C2_Ent) = Name_uTag + then + return; + end if; + + -- Here we check if the two fields overlap + + declare + S1 : constant Uint := Component_Bit_Offset (C1_Ent); + S2 : constant Uint := Component_Bit_Offset (C2_Ent); + E1 : constant Uint := S1 + Esize (C1_Ent); + E2 : constant Uint := S2 + Esize (C2_Ent); + + begin + if E2 <= S1 or else E1 <= S2 then + null; + else + Error_Msg_Node_2 := Component_Name (CC2); + Error_Msg_Sloc := Sloc (Error_Msg_Node_2); + Error_Msg_Node_1 := Component_Name (CC1); + Error_Msg_N + ("component& overlaps & #", Component_Name (CC1)); + end if; + end; + end if; + end Check_Component_Overlap; + + -------------------- + -- Find_Component -- + -------------------- + + procedure Find_Component is + + procedure Search_Component (R : Entity_Id); + -- Search components of R for a match. If found, Comp is set. + + ---------------------- + -- Search_Component -- + ---------------------- + + procedure Search_Component (R : Entity_Id) is + begin + Comp := First_Component_Or_Discriminant (R); + while Present (Comp) loop + + -- Ignore error of attribute name for component name (we + -- already gave an error message for this, so no need to + -- complain here) + + if Nkind (Component_Name (CC)) = N_Attribute_Reference then + null; + else + exit when Chars (Comp) = Chars (Component_Name (CC)); + end if; + + Next_Component_Or_Discriminant (Comp); + end loop; + end Search_Component; + + -- Start of processing for Find_Component + + begin + -- Return with Comp set to Empty if we have a pragma + + if Nkind (CC) = N_Pragma then + Comp := Empty; + return; + end if; + + -- Search current record for matching component + + Search_Component (Rectype); + + -- If not found, maybe component of base type that is absent from + -- statically constrained first subtype. + + if No (Comp) then + Search_Component (Base_Type (Rectype)); + end if; + + -- If no component, or the component does not reference the component + -- clause in question, then there was some previous error for which + -- we already gave a message, so just return with Comp Empty. + + if No (Comp) + or else Component_Clause (Comp) /= CC + then + Comp := Empty; + + -- Normal case where we have a component clause + + else + Fbit := Component_Bit_Offset (Comp); + Lbit := Fbit + Esize (Comp) - 1; + end if; + end Find_Component; + + -- Start of processing for Check_Record_Representation_Clause + + begin + Find_Type (Ident); + Rectype := Entity (Ident); + + if Rectype = Any_Type then + return; + else + Rectype := Underlying_Type (Rectype); + end if; + + -- See if we have a fully repped derived tagged type + + declare + PS : constant Entity_Id := Parent_Subtype (Rectype); + + begin + if Present (PS) and then Is_Fully_Repped_Tagged_Type (PS) then + Tagged_Parent := PS; + + -- Find maximum bit of any component of the parent type + + Parent_Last_Bit := UI_From_Int (System_Address_Size - 1); + Pcomp := First_Entity (Tagged_Parent); + while Present (Pcomp) loop + if Ekind_In (Pcomp, E_Discriminant, E_Component) then + if Component_Bit_Offset (Pcomp) /= No_Uint + and then Known_Static_Esize (Pcomp) + then + Parent_Last_Bit := + UI_Max + (Parent_Last_Bit, + Component_Bit_Offset (Pcomp) + Esize (Pcomp) - 1); + end if; + + Next_Entity (Pcomp); + end if; + end loop; + end if; + end; + + -- All done if no component clauses + + CC := First (Component_Clauses (N)); + + if No (CC) then + return; + end if; + + -- If a tag is present, then create a component clause that places it + -- at the start of the record (otherwise gigi may place it after other + -- fields that have rep clauses). + + Fent := First_Entity (Rectype); + + if Nkind (Fent) = N_Defining_Identifier + and then Chars (Fent) = Name_uTag + then + Set_Component_Bit_Offset (Fent, Uint_0); + Set_Normalized_Position (Fent, Uint_0); + Set_Normalized_First_Bit (Fent, Uint_0); + Set_Normalized_Position_Max (Fent, Uint_0); + Init_Esize (Fent, System_Address_Size); + + Set_Component_Clause (Fent, + Make_Component_Clause (Loc, + Component_Name => + Make_Identifier (Loc, + Chars => Name_uTag), + + Position => + Make_Integer_Literal (Loc, + Intval => Uint_0), + + First_Bit => + Make_Integer_Literal (Loc, + Intval => Uint_0), + + Last_Bit => + Make_Integer_Literal (Loc, + UI_From_Int (System_Address_Size)))); + + Ccount := Ccount + 1; + end if; + + Max_Bit_So_Far := Uint_Minus_1; + Overlap_Check_Required := False; + + -- Process the component clauses + + while Present (CC) loop + Find_Component; + + if Present (Comp) then + Ccount := Ccount + 1; + + if Fbit <= Max_Bit_So_Far then + Overlap_Check_Required := True; + else + Max_Bit_So_Far := Lbit; + end if; + + -- Check bit position out of range of specified size + + if Has_Size_Clause (Rectype) + and then Esize (Rectype) <= Lbit + then + Error_Msg_N + ("bit number out of range of specified size", + Last_Bit (CC)); + + -- Check for overlap with tag field + + else + if Is_Tagged_Type (Rectype) + and then Fbit < System_Address_Size + then + Error_Msg_NE + ("component overlaps tag field of&", + Component_Name (CC), Rectype); + end if; + + if Hbit < Lbit then + Hbit := Lbit; + end if; + end if; + + -- Check parent overlap if component might overlap parent field + + if Present (Tagged_Parent) + and then Fbit <= Parent_Last_Bit + then + Pcomp := First_Component_Or_Discriminant (Tagged_Parent); + while Present (Pcomp) loop + if not Is_Tag (Pcomp) + and then Chars (Pcomp) /= Name_uParent + then + Check_Component_Overlap (Comp, Pcomp); + end if; + + Next_Component_Or_Discriminant (Pcomp); + end loop; + end if; + end if; + + Next (CC); + end loop; + + -- Now that we have processed all the component clauses, check for + -- overlap. We have to leave this till last, since the components can + -- appear in any arbitrary order in the representation clause. + + -- We do not need this check if all specified ranges were monotonic, + -- as recorded by Overlap_Check_Required being False at this stage. + + -- This first section checks if there are any overlapping entries at + -- all. It does this by sorting all entries and then seeing if there are + -- any overlaps. If there are none, then that is decisive, but if there + -- are overlaps, they may still be OK (they may result from fields in + -- different variants). + + if Overlap_Check_Required then + Overlap_Check1 : declare + + OC_Fbit : array (0 .. Ccount) of Uint; + -- First-bit values for component clauses, the value is the offset + -- of the first bit of the field from start of record. The zero + -- entry is for use in sorting. + + OC_Lbit : array (0 .. Ccount) of Uint; + -- Last-bit values for component clauses, the value is the offset + -- of the last bit of the field from start of record. The zero + -- entry is for use in sorting. + + OC_Count : Natural := 0; + -- Count of entries in OC_Fbit and OC_Lbit + + function OC_Lt (Op1, Op2 : Natural) return Boolean; + -- Compare routine for Sort + + procedure OC_Move (From : Natural; To : Natural); + -- Move routine for Sort + + package Sorting is new GNAT.Heap_Sort_G (OC_Move, OC_Lt); + + ----------- + -- OC_Lt -- + ----------- + + function OC_Lt (Op1, Op2 : Natural) return Boolean is + begin + return OC_Fbit (Op1) < OC_Fbit (Op2); + end OC_Lt; + + ------------- + -- OC_Move -- + ------------- + + procedure OC_Move (From : Natural; To : Natural) is + begin + OC_Fbit (To) := OC_Fbit (From); + OC_Lbit (To) := OC_Lbit (From); + end OC_Move; + + -- Start of processing for Overlap_Check + + begin + CC := First (Component_Clauses (N)); + while Present (CC) loop + + -- Exclude component clause already marked in error + + if not Error_Posted (CC) then + Find_Component; + + if Present (Comp) then + OC_Count := OC_Count + 1; + OC_Fbit (OC_Count) := Fbit; + OC_Lbit (OC_Count) := Lbit; + end if; + end if; + + Next (CC); + end loop; + + Sorting.Sort (OC_Count); + + Overlap_Check_Required := False; + for J in 1 .. OC_Count - 1 loop + if OC_Lbit (J) >= OC_Fbit (J + 1) then + Overlap_Check_Required := True; + exit; + end if; + end loop; + end Overlap_Check1; + end if; + + -- If Overlap_Check_Required is still True, then we have to do the full + -- scale overlap check, since we have at least two fields that do + -- overlap, and we need to know if that is OK since they are in + -- different variant, or whether we have a definite problem. - -- Otherwise location of Ent must be before the location - -- of U_Ent, that's what prior defined means. + if Overlap_Check_Required then + Overlap_Check2 : declare + C1_Ent, C2_Ent : Entity_Id; + -- Entities of components being checked for overlap - elsif Sloc (Ent) < Loc_U_Ent then - return; + Clist : Node_Id; + -- Component_List node whose Component_Items are being checked - else - Error_Msg_NE - ("invalid address clause for initialized object &!", - Nod, U_Ent); - Error_Msg_Node_2 := U_Ent; - Error_Msg_NE - ("\& must be defined before & (RM 13.1(22))!", - Nod, Ent); - end if; + Citem : Node_Id; + -- Component declaration for component being checked - elsif Nkind (Original_Node (Nod)) = N_Function_Call then - Check_Expr_Constants (Original_Node (Nod)); + begin + C1_Ent := First_Entity (Base_Type (Rectype)); - else - Error_Msg_NE - ("invalid address clause for initialized object &!", - Nod, U_Ent); + -- Loop through all components in record. For each component check + -- for overlap with any of the preceding elements on the component + -- list containing the component and also, if the component is in + -- a variant, check against components outside the case structure. + -- This latter test is repeated recursively up the variant tree. - if Comes_From_Source (Ent) then - Error_Msg_NE - ("\reference to variable& not allowed" - & " (RM 13.1(22))!", Nod, Ent); - else - Error_Msg_N - ("non-static expression not allowed" - & " (RM 13.1(22))!", Nod); - end if; + Main_Component_Loop : while Present (C1_Ent) loop + if not Ekind_In (C1_Ent, E_Component, E_Discriminant) then + goto Continue_Main_Component_Loop; end if; - when N_Integer_Literal => - - -- If this is a rewritten unchecked conversion, in a system - -- where Address is an integer type, always use the base type - -- for a literal value. This is user-friendly and prevents - -- order-of-elaboration issues with instances of unchecked - -- conversion. + -- Skip overlap check if entity has no declaration node. This + -- happens with discriminants in constrained derived types. + -- Probably we are missing some checks as a result, but that + -- does not seem terribly serious ??? - if Nkind (Original_Node (Nod)) = N_Function_Call then - Set_Etype (Nod, Base_Type (Etype (Nod))); + if No (Declaration_Node (C1_Ent)) then + goto Continue_Main_Component_Loop; end if; - when N_Real_Literal | - N_String_Literal | - N_Character_Literal => - return; + Clist := Parent (List_Containing (Declaration_Node (C1_Ent))); - when N_Range => - Check_Expr_Constants (Low_Bound (Nod)); - Check_Expr_Constants (High_Bound (Nod)); + -- Loop through component lists that need checking. Check the + -- current component list and all lists in variants above us. - when N_Explicit_Dereference => - Check_Expr_Constants (Prefix (Nod)); + Component_List_Loop : loop - when N_Indexed_Component => - Check_Expr_Constants (Prefix (Nod)); - Check_List_Constants (Expressions (Nod)); + -- If derived type definition, go to full declaration + -- If at outer level, check discriminants if there are any. - when N_Slice => - Check_Expr_Constants (Prefix (Nod)); - Check_Expr_Constants (Discrete_Range (Nod)); + if Nkind (Clist) = N_Derived_Type_Definition then + Clist := Parent (Clist); + end if; - when N_Selected_Component => - Check_Expr_Constants (Prefix (Nod)); + -- Outer level of record definition, check discriminants - when N_Attribute_Reference => - if Attribute_Name (Nod) = Name_Address - or else - Attribute_Name (Nod) = Name_Access - or else - Attribute_Name (Nod) = Name_Unchecked_Access - or else - Attribute_Name (Nod) = Name_Unrestricted_Access - then - Check_At_Constant_Address (Prefix (Nod)); + if Nkind_In (Clist, N_Full_Type_Declaration, + N_Private_Type_Declaration) + then + if Has_Discriminants (Defining_Identifier (Clist)) then + C2_Ent := + First_Discriminant (Defining_Identifier (Clist)); + while Present (C2_Ent) loop + exit when C1_Ent = C2_Ent; + Check_Component_Overlap (C1_Ent, C2_Ent); + Next_Discriminant (C2_Ent); + end loop; + end if; - else - Check_Expr_Constants (Prefix (Nod)); - Check_List_Constants (Expressions (Nod)); - end if; + -- Record extension case - when N_Aggregate => - Check_List_Constants (Component_Associations (Nod)); - Check_List_Constants (Expressions (Nod)); + elsif Nkind (Clist) = N_Derived_Type_Definition then + Clist := Empty; - when N_Component_Association => - Check_Expr_Constants (Expression (Nod)); + -- Otherwise check one component list - when N_Extension_Aggregate => - Check_Expr_Constants (Ancestor_Part (Nod)); - Check_List_Constants (Component_Associations (Nod)); - Check_List_Constants (Expressions (Nod)); + else + Citem := First (Component_Items (Clist)); - when N_Null => - return; + while Present (Citem) loop + if Nkind (Citem) = N_Component_Declaration then + C2_Ent := Defining_Identifier (Citem); + exit when C1_Ent = C2_Ent; + Check_Component_Overlap (C1_Ent, C2_Ent); + end if; - when N_Binary_Op | N_Short_Circuit | N_Membership_Test => - Check_Expr_Constants (Left_Opnd (Nod)); - Check_Expr_Constants (Right_Opnd (Nod)); + Next (Citem); + end loop; + end if; - when N_Unary_Op => - Check_Expr_Constants (Right_Opnd (Nod)); + -- Check for variants above us (the parent of the Clist can + -- be a variant, in which case its parent is a variant part, + -- and the parent of the variant part is a component list + -- whose components must all be checked against the current + -- component for overlap). - when N_Type_Conversion | - N_Qualified_Expression | - N_Allocator => - Check_Expr_Constants (Expression (Nod)); + if Nkind (Parent (Clist)) = N_Variant then + Clist := Parent (Parent (Parent (Clist))); - when N_Unchecked_Type_Conversion => - Check_Expr_Constants (Expression (Nod)); + -- Check for possible discriminant part in record, this + -- is treated essentially as another level in the + -- recursion. For this case the parent of the component + -- list is the record definition, and its parent is the + -- full type declaration containing the discriminant + -- specifications. - -- If this is a rewritten unchecked conversion, subtypes in - -- this node are those created within the instance. To avoid - -- order of elaboration issues, replace them with their base - -- types. Note that address clauses can cause order of - -- elaboration problems because they are elaborated by the - -- back-end at the point of definition, and may mention - -- entities declared in between (as long as everything is - -- static). It is user-friendly to allow unchecked conversions - -- in this context. + elsif Nkind (Parent (Clist)) = N_Record_Definition then + Clist := Parent (Parent ((Clist))); - if Nkind (Original_Node (Nod)) = N_Function_Call then - Set_Etype (Expression (Nod), - Base_Type (Etype (Expression (Nod)))); - Set_Etype (Nod, Base_Type (Etype (Nod))); - end if; + -- If neither of these two cases, we are at the top of + -- the tree. - when N_Function_Call => - if not Is_Pure (Entity (Name (Nod))) then - Error_Msg_NE - ("invalid address clause for initialized object &!", - Nod, U_Ent); + else + exit Component_List_Loop; + end if; + end loop Component_List_Loop; - Error_Msg_NE - ("\function & is not pure (RM 13.1(22))!", - Nod, Entity (Name (Nod))); + <> + Next_Entity (C1_Ent); - else - Check_List_Constants (Parameter_Associations (Nod)); - end if; + end loop Main_Component_Loop; + end Overlap_Check2; + end if; - when N_Parameter_Association => - Check_Expr_Constants (Explicit_Actual_Parameter (Nod)); + -- For records that have component clauses for all components, and whose + -- size is less than or equal to 32, we need to know the size in the + -- front end to activate possible packed array processing where the + -- component type is a record. - when others => - Error_Msg_NE - ("invalid address clause for initialized object &!", - Nod, U_Ent); - Error_Msg_NE - ("\must be constant defined before& (RM 13.1(22))!", - Nod, U_Ent); - end case; - end Check_Expr_Constants; + -- At this stage Hbit + 1 represents the first unused bit from all the + -- component clauses processed, so if the component clauses are + -- complete, then this is the length of the record. - -------------------------- - -- Check_List_Constants -- - -------------------------- + -- For records longer than System.Storage_Unit, and for those where not + -- all components have component clauses, the back end determines the + -- length (it may for example be appropriate to round up the size + -- to some convenient boundary, based on alignment considerations, etc). - procedure Check_List_Constants (Lst : List_Id) is - Nod1 : Node_Id; + if Unknown_RM_Size (Rectype) and then Hbit + 1 <= 32 then - begin - if Present (Lst) then - Nod1 := First (Lst); - while Present (Nod1) loop - Check_Expr_Constants (Nod1); - Next (Nod1); - end loop; - end if; - end Check_List_Constants; + -- Nothing to do if at least one component has no component clause - -- Start of processing for Check_Constant_Address_Clause + Comp := First_Component_Or_Discriminant (Rectype); + while Present (Comp) loop + exit when No (Component_Clause (Comp)); + Next_Component_Or_Discriminant (Comp); + end loop; - begin - Check_Expr_Constants (Expr); - end Check_Constant_Address_Clause; + -- If we fall out of loop, all components have component clauses + -- and so we can set the size to the maximum value. + + if No (Comp) then + Set_RM_Size (Rectype, Hbit + 1); + end if; + end if; + end Check_Record_Representation_Clause; ---------------- -- Check_Size -- @@ -3879,9 +4181,10 @@ package body Sem_Ch13 is Out_Present => Out_P, Parameter_Type => T_Ref)); - Spec := Make_Procedure_Specification (Loc, - Defining_Unit_Name => Subp_Id, - Parameter_Specifications => Formals); + Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Subp_Id, + Parameter_Specifications => Formals); end if; return Spec; @@ -3955,8 +4258,7 @@ package body Sem_Ch13 is elsif Is_Type (T) and then Is_Generic_Type (Root_Type (T)) then - Error_Msg_N - ("representation item not allowed for generic type", N); + Error_Msg_N ("representation item not allowed for generic type", N); return True; end if; diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads index 93587fd38d2..b95eed60a92 100644 --- a/gcc/ada/sem_ch13.ads +++ b/gcc/ada/sem_ch13.ads @@ -38,9 +38,17 @@ package Sem_Ch13 is procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id); -- Called from Freeze where R is a record entity for which reverse bit -- order is specified and there is at least one component clause. Adjusts - -- component positions according to Ada 2005 AI-133. Note that this is only - -- called in Ada 2005 mode. The Ada 95 handling for bit order is entirely - -- contained in Freeze. + -- component positions according to either Ada 95 or Ada 2005 (AI-133). + + procedure Check_Record_Representation_Clause (N : Node_Id); + -- This procedure completes the analysis of a record representation clause + -- N. It is called at freeze time after adjustment of component clause bit + -- positions for possible non-standard bit order. In the case of Ada 2005 + -- (machine scalar) mode, this adjustment can make substantial changes, so + -- some checks, in particular for component overlaps cannot be done at the + -- time the record representation clause is first seen, but must be delayed + -- till freeze time, and in particular is called after calling the above + -- procedure for adjusting record bit positions for reverse bit order. procedure Initialize; -- Initialize internal tables for new compilation diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index f0463aaac94..d5b39f99f9d 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -68,6 +68,7 @@ with Sem_Util; use Sem_Util; with Sem_Warn; use Sem_Warn; with Stand; use Stand; with Sinfo; use Sinfo; +with Sinput; use Sinput; with Snames; use Snames; with Targparm; use Targparm; with Tbuild; use Tbuild; @@ -1037,8 +1038,8 @@ package body Sem_Ch3 is begin -- Associate the Itype node with the inner full-type declaration or - -- subprogram spec. This is required to handle nested anonymous - -- declarations. For example: + -- subprogram spec or entry body. This is required to handle nested + -- anonymous declarations. For example: -- procedure P -- (X : access procedure @@ -1050,7 +1051,9 @@ package body Sem_Ch3 is N_Private_Type_Declaration, N_Private_Extension_Declaration, N_Procedure_Specification, - N_Function_Specification) + N_Function_Specification, + N_Entry_Body) + or else Nkind_In (D_Ityp, N_Object_Declaration, N_Object_Renaming_Declaration, @@ -1364,7 +1367,7 @@ package body Sem_Ch3 is Subtype_Indication => New_Occurrence_Of (RTE (RE_Interface_Tag), Loc)); - Tag := Make_Defining_Identifier (Loc, New_Internal_Name ('V')); + Tag := Make_Temporary (Loc, 'V'); Decl := Make_Component_Declaration (Loc, @@ -1406,8 +1409,7 @@ package body Sem_Ch3 is Subtype_Indication => New_Occurrence_Of (RTE (RE_Storage_Offset), Loc)); - Offset := - Make_Defining_Identifier (Loc, New_Internal_Name ('V')); + Offset := Make_Temporary (Loc, 'V'); Decl := Make_Component_Declaration (Loc, @@ -1515,13 +1517,14 @@ package body Sem_Ch3 is ------------------------------------- procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id) is - Elmt : Elmt_Id; - Iface : Entity_Id; - Iface_Elmt : Elmt_Id; - Iface_Prim : Entity_Id; - Ifaces_List : Elist_Id; - New_Subp : Entity_Id := Empty; - Prim : Entity_Id; + Elmt : Elmt_Id; + Iface : Entity_Id; + Iface_Elmt : Elmt_Id; + Iface_Prim : Entity_Id; + Ifaces_List : Elist_Id; + New_Subp : Entity_Id := Empty; + Prim : Entity_Id; + Restore_Scope : Boolean := False; begin pragma Assert (Ada_Version >= Ada_05 @@ -1530,74 +1533,127 @@ package body Sem_Ch3 is and then Has_Interfaces (Tagged_Type) and then not Is_Interface (Tagged_Type)); + -- Ensure that the internal entities are added to the scope of the type + + if Scope (Tagged_Type) /= Current_Scope then + Push_Scope (Scope (Tagged_Type)); + Restore_Scope := True; + end if; + Collect_Interfaces (Tagged_Type, Ifaces_List); Iface_Elmt := First_Elmt (Ifaces_List); while Present (Iface_Elmt) loop Iface := Node (Iface_Elmt); - -- Exclude from this processing interfaces that are parents of - -- Tagged_Type because their primitives are located in the primary - -- dispatch table (and hence no auxiliary internal entities are - -- required to handle secondary dispatch tables in such case). + -- Originally we excluded here from this processing interfaces that + -- are parents of Tagged_Type because their primitives are located + -- in the primary dispatch table (and hence no auxiliary internal + -- entities are required to handle secondary dispatch tables in such + -- case). However, these auxiliary entities are also required to + -- handle derivations of interfaces in formals of generics (see + -- Derive_Subprograms). - if not Is_Ancestor (Iface, Tagged_Type) then - Elmt := First_Elmt (Primitive_Operations (Iface)); - while Present (Elmt) loop - Iface_Prim := Node (Elmt); + Elmt := First_Elmt (Primitive_Operations (Iface)); + while Present (Elmt) loop + Iface_Prim := Node (Elmt); - if not Is_Predefined_Dispatching_Operation (Iface_Prim) then - Prim := - Find_Primitive_Covering_Interface - (Tagged_Type => Tagged_Type, - Iface_Prim => Iface_Prim); - - pragma Assert (Present (Prim)); - - Derive_Subprogram - (New_Subp => New_Subp, - Parent_Subp => Iface_Prim, - Derived_Type => Tagged_Type, - Parent_Type => Iface); - - -- Ada 2005 (AI-251): Decorate internal entity Iface_Subp - -- associated with interface types. These entities are - -- only registered in the list of primitives of its - -- corresponding tagged type because they are only used - -- to fill the contents of the secondary dispatch tables. - -- Therefore they are removed from the homonym chains. - - Set_Is_Hidden (New_Subp); - Set_Is_Internal (New_Subp); - Set_Alias (New_Subp, Prim); - Set_Is_Abstract_Subprogram (New_Subp, - Is_Abstract_Subprogram (Prim)); - Set_Interface_Alias (New_Subp, Iface_Prim); - - -- Internal entities associated with interface types are - -- only registered in the list of primitives of the tagged - -- type. They are only used to fill the contents of the - -- secondary dispatch tables. Therefore they are not needed - -- in the homonym chains. - - Remove_Homonym (New_Subp); - - -- Hidden entities associated with interfaces must have set - -- the Has_Delay_Freeze attribute to ensure that, in case of - -- locally defined tagged types (or compiling with static - -- dispatch tables generation disabled) the corresponding - -- entry of the secondary dispatch table is filled when - -- such an entity is frozen. - - Set_Has_Delayed_Freeze (New_Subp); + if not Is_Predefined_Dispatching_Operation (Iface_Prim) then + Prim := + Find_Primitive_Covering_Interface + (Tagged_Type => Tagged_Type, + Iface_Prim => Iface_Prim); + + -- Handle cases where the type has no primitive covering this + -- interface primitive. + + if No (Prim) then + + -- if the tagged type is defined at library level then we + -- invoke Check_Abstract_Overriding to report the error + -- and thus avoid generating the dispatch tables. + + if Is_Library_Level_Tagged_Type (Tagged_Type) then + Check_Abstract_Overriding (Tagged_Type); + pragma Assert (Serious_Errors_Detected > 0); + return; + + -- For tagged types defined in nested scopes it is still + -- possible to cover this interface primitive by means of + -- late overriding (see Override_Dispatching_Operation). + + -- Search in the list of primitives of the type for the + -- entity that will be overridden in such case to reference + -- it in the internal entity that we build here. If the + -- primitive is not overridden then the error will be + -- reported later as part of the analysis of entities + -- defined in the enclosing scope. + + else + declare + El : Elmt_Id; + + begin + El := First_Elmt (Primitive_Operations (Tagged_Type)); + while Present (El) + and then Alias (Node (El)) /= Iface_Prim + loop + Next_Elmt (El); + end loop; + + pragma Assert (Present (El)); + Prim := Node (El); + end; + end if; end if; - Next_Elmt (Elmt); - end loop; - end if; + Derive_Subprogram + (New_Subp => New_Subp, + Parent_Subp => Iface_Prim, + Derived_Type => Tagged_Type, + Parent_Type => Iface); + + -- Ada 2005 (AI-251): Decorate internal entity Iface_Subp + -- associated with interface types. These entities are + -- only registered in the list of primitives of its + -- corresponding tagged type because they are only used + -- to fill the contents of the secondary dispatch tables. + -- Therefore they are removed from the homonym chains. + + Set_Is_Hidden (New_Subp); + Set_Is_Internal (New_Subp); + Set_Alias (New_Subp, Prim); + Set_Is_Abstract_Subprogram + (New_Subp, Is_Abstract_Subprogram (Prim)); + Set_Interface_Alias (New_Subp, Iface_Prim); + + -- Internal entities associated with interface types are + -- only registered in the list of primitives of the tagged + -- type. They are only used to fill the contents of the + -- secondary dispatch tables. Therefore they are not needed + -- in the homonym chains. + + Remove_Homonym (New_Subp); + + -- Hidden entities associated with interfaces must have set + -- the Has_Delay_Freeze attribute to ensure that, in case of + -- locally defined tagged types (or compiling with static + -- dispatch tables generation disabled) the corresponding + -- entry of the secondary dispatch table is filled when + -- such an entity is frozen. + + Set_Has_Delayed_Freeze (New_Subp); + end if; + + Next_Elmt (Elmt); + end loop; Next_Elmt (Iface_Elmt); end loop; + + if Restore_Scope then + Pop_Scope; + end if; end Add_Internal_Interface_Entities; ----------------------------------- @@ -1913,8 +1969,7 @@ package body Sem_Ch3 is if Is_Interface (Root_Type (Current_Scope)) then Error_Msg_N ("\limitedness is not inherited from limited interface", N); - Error_Msg_N - ("\add LIMITED to type indication", N); + Error_Msg_N ("\add LIMITED to type indication", N); end if; Explain_Limited_Type (T, N); @@ -2141,17 +2196,6 @@ package body Sem_Ch3 is or else Synchronized_Present (Def) or else Task_Present (Def)); - Set_Is_Protected_Interface (T, Protected_Present (Def)); - Set_Is_Task_Interface (T, Task_Present (Def)); - - -- Type is a synchronized interface if it includes the keyword task, - -- protected, or synchronized. - - Set_Is_Synchronized_Interface - (T, Synchronized_Present (Def) - or else Protected_Present (Def) - or else Task_Present (Def)); - Set_Interfaces (T, New_Elmt_List); Set_Primitive_Operations (T, New_Elmt_List); @@ -2161,9 +2205,6 @@ package body Sem_Ch3 is if Present (CW) then Set_Is_Interface (CW); Set_Is_Limited_Interface (CW, Is_Limited_Interface (T)); - Set_Is_Protected_Interface (CW, Is_Protected_Interface (T)); - Set_Is_Synchronized_Interface (CW, Is_Synchronized_Interface (T)); - Set_Is_Task_Interface (CW, Is_Task_Interface (T)); end if; -- Check runtime support for synchronized interfaces @@ -3285,9 +3326,7 @@ package body Sem_Ch3 is ("parent of type extension must be a tagged type ", Indic); return; - elsif Ekind (Parent_Type) = E_Void - or else Ekind (Parent_Type) = E_Incomplete_Type - then + elsif Ekind_In (Parent_Type, E_Void, E_Incomplete_Type) then Error_Msg_N ("premature derivation of incomplete type", Indic); return; @@ -3750,10 +3789,10 @@ package body Sem_Ch3 is if Present (Generic_Parent_Type (N)) and then (Nkind - (Parent (Generic_Parent_Type (N))) /= N_Formal_Type_Declaration + (Parent (Generic_Parent_Type (N))) /= N_Formal_Type_Declaration or else Nkind (Formal_Type_Definition (Parent (Generic_Parent_Type (N)))) - /= N_Formal_Private_Type_Definition) + /= N_Formal_Private_Type_Definition) then if Is_Tagged_Type (Id) then @@ -4325,9 +4364,7 @@ package body Sem_Ch3 is Decl : Entity_Id; begin - New_E := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); + New_E := Make_Temporary (Loc, 'T'); Set_Is_Internal (New_E); Decl := @@ -4576,10 +4613,7 @@ package body Sem_Ch3 is Curr_Scope : constant Scope_Stack_Entry := Scope_Stack.Table (Scope_Stack.Last); - Anon : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); - + Anon : constant Entity_Id := Make_Temporary (Loc, 'S'); Acc : Node_Id; Comp : Node_Id; Decl : Node_Id; @@ -4921,9 +4955,7 @@ package body Sem_Ch3 is is Loc : constant Source_Ptr := Sloc (N); - Corr_Record : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('C')); - + Corr_Record : constant Entity_Id := Make_Temporary (Loc, 'C'); Corr_Decl : Node_Id; Corr_Decl_Needed : Boolean; -- If the derived type has fewer discriminants than its parent, the @@ -5726,9 +5758,7 @@ package body Sem_Ch3 is and then Expander_Active then declare - Full_Der : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); + Full_Der : constant Entity_Id := Make_Temporary (Loc, 'T'); New_Ext : constant Node_Id := Copy_Separate_Tree (Record_Extension_Part (Type_Definition (N))); @@ -6778,6 +6808,15 @@ package body Sem_Ch3 is Mark_Rewrite_Insertion (New_Decl); Insert_Before (N, New_Decl); + -- In the extension case, make sure ancestor is frozen appropriately + -- (see also non-discriminated case below). + + if Present (Record_Extension_Part (Type_Def)) + or else Is_Interface (Parent_Base) + then + Freeze_Before (New_Decl, Parent_Type); + end if; + -- Note that this call passes False for the Derive_Subps parameter -- because subprogram derivation is deferred until after creating -- the subtype (see below). @@ -6868,9 +6907,7 @@ package body Sem_Ch3 is -- The declaration of a specific descendant of an interface type -- freezes the interface type (RM 13.14). - if not Private_Extension - or else Is_Interface (Parent_Base) - then + if not Private_Extension or else Is_Interface (Parent_Base) then Freeze_Before (N, Parent_Type); end if; @@ -6954,9 +6991,8 @@ package body Sem_Ch3 is -- Ada 2005 (AI-251) - if Ada_Version = Ada_05 - and then Is_Tagged - then + if Ada_Version >= Ada_05 and then Is_Tagged then + -- "The declaration of a specific descendant of an interface type -- freezes the interface type" (RM 13.14). @@ -7356,6 +7392,27 @@ package body Sem_Ch3 is Exclude_Parents => True); Set_Interfaces (Derived_Type, Ifaces_List); + + -- If the derived type is the anonymous type created for + -- a declaration whose parent has a constraint, propagate + -- the interface list to the source type. This must be done + -- prior to the completion of the analysis of the source type + -- because the components in the extension may contain current + -- instances whose legality depends on some ancestor. + + if Is_Itype (Derived_Type) then + declare + Def : constant Node_Id := + Associated_Node_For_Itype (Derived_Type); + begin + if Present (Def) + and then Nkind (Def) = N_Full_Type_Declaration + then + Set_Interfaces + (Defining_Identifier (Def), Ifaces_List); + end if; + end; + end if; end; end if; @@ -7527,9 +7584,7 @@ package body Sem_Ch3 is begin D := First_Entity (Derived_Type); while Present (D) loop - if Ekind (D) = E_Discriminant - or else Ekind (D) = E_Component - then + if Ekind_In (D, E_Discriminant, E_Component) then if Is_Itype (Etype (D)) and then Ekind (Etype (D)) = E_Anonymous_Access_Type then @@ -7704,6 +7759,7 @@ package body Sem_Ch3 is Set_Ekind (D_Minal, E_In_Parameter); Set_Mechanism (D_Minal, Default_Mechanism); Set_Etype (D_Minal, Etype (Discrim)); + Set_Scope (D_Minal, Current_Scope); Set_Discriminal (Discrim, D_Minal); Set_Discriminal_Link (D_Minal, Discrim); @@ -7720,6 +7776,7 @@ package body Sem_Ch3 is Set_Ekind (CR_Disc, E_In_Parameter); Set_Mechanism (CR_Disc, Default_Mechanism); Set_Etype (CR_Disc, Etype (Discrim)); + Set_Scope (CR_Disc, Current_Scope); Set_Discriminal_Link (CR_Disc, Discrim); Set_CR_Discriminant (Discrim, CR_Disc); end if; @@ -8566,8 +8623,7 @@ package body Sem_Ch3 is -- them all, and not just the first one). Error_Msg_Node_2 := Subp; - Error_Msg_N - ("nonabstract type& has abstract subprogram&!", T); + Error_Msg_N ("nonabstract type& has abstract subprogram&!", T); end if; end if; @@ -8720,9 +8776,7 @@ package body Sem_Ch3 is begin if not Comes_From_Source (E) then - if Ekind (E) = E_Task_Type - or else Ekind (E) = E_Protected_Type - then + if Ekind_In (E, E_Task_Type, E_Protected_Type) then -- It may be an anonymous protected type created for a -- single variable. Post error on variable, if present. @@ -8770,8 +8824,7 @@ package body Sem_Ch3 is Error_Msg_NE ("missing full declaration for }", Parent (E), E); else - Error_Msg_NE - ("missing body for &", Parent (E), E); + Error_Msg_NE ("missing body for &", Parent (E), E); end if; -- Package body has no completion for a declaration that appears @@ -8782,8 +8835,7 @@ package body Sem_Ch3 is Error_Msg_Sloc := Sloc (E); if Is_Type (E) then - Error_Msg_NE - ("missing full declaration for }!", Body_Id, E); + Error_Msg_NE ("missing full declaration for }!", Body_Id, E); elsif Is_Overloadable (E) and then Current_Entity_In_Scope (E) /= E @@ -9563,7 +9615,14 @@ package body Sem_Ch3 is if Is_Tagged_Type (Full_Base) then Set_Is_Tagged_Type (Full); Set_Primitive_Operations (Full, Primitive_Operations (Full_Base)); - Set_Class_Wide_Type (Full, Class_Wide_Type (Full_Base)); + + -- Inherit class_wide type of full_base in case the partial view was + -- not tagged. Otherwise it has already been created when the private + -- subtype was analyzed. + + if No (Class_Wide_Type (Full)) then + Set_Class_Wide_Type (Full, Class_Wide_Type (Full_Base)); + end if; -- If this is a subtype of a protected or task type, constrain its -- corresponding record, unless this is a subtype without constraints, @@ -9633,14 +9692,11 @@ package body Sem_Ch3 is then declare Loc : constant Source_Ptr := Sloc (N); - Def_Id : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('S')); - Decl : constant Node_Id := + Def_Id : constant Entity_Id := Make_Temporary (Loc, 'S'); + Decl : constant Node_Id := Make_Subtype_Declaration (Loc, - Defining_Identifier => - Def_Id, - Subtype_Indication => + Defining_Identifier => Def_Id, + Subtype_Indication => Relocate_Node (Curr_Obj_Def)); begin @@ -9802,13 +9858,15 @@ package body Sem_Ch3 is and then not In_Private_Part (Current_Scope) then Error_Msg_Sloc := Sloc (Prev); - Error_Msg_N ("full constant for declaration#" - & " must be in private part", N); + Error_Msg_N + ("full constant for declaration#" + & " must be in private part", N); elsif Ekind (Current_Scope) = E_Package - and then List_Containing (Parent (Prev)) - /= Visible_Declarations - (Specification (Unit_Declaration_Node (Current_Scope))) + and then + List_Containing (Parent (Prev)) /= + Visible_Declarations + (Specification (Unit_Declaration_Node (Current_Scope))) then Error_Msg_N ("deferred constant must be declared in visible part", @@ -10055,8 +10113,7 @@ package body Sem_Ch3 is -- is such an array type... (RM 3.6.1) if Is_Constrained (T) then - Error_Msg_N - ("array type is already constrained", Subtype_Mark (SI)); + Error_Msg_N ("array type is already constrained", Subtype_Mark (SI)); Constraint_OK := False; else @@ -10804,8 +10861,7 @@ package body Sem_Ch3 is Error_Msg_N ("(Ada 2005) incomplete subtype may not be constrained", C); else - Error_Msg_N - ("invalid constraint: type has no discriminant", C); + Error_Msg_N ("invalid constraint: type has no discriminant", C); end if; Fixup_Bad_Constraint; @@ -11043,6 +11099,7 @@ package body Sem_Ch3 is else Set_Ekind (Def_Id, E_Enumeration_Subtype); Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); + Set_First_Literal (Def_Id, First_Literal (T)); end if; Set_Size_Info (Def_Id, (T)); @@ -11283,6 +11340,7 @@ package body Sem_Ch3 is Set_Is_Public (Full, Is_Public (Priv)); Set_Is_Pure (Full, Is_Pure (Priv)); Set_Is_Tagged_Type (Full, Is_Tagged_Type (Priv)); + Set_Has_Pragma_Unmodified (Full, Has_Pragma_Unmodified (Priv)); Set_Has_Pragma_Unreferenced (Full, Has_Pragma_Unreferenced (Priv)); Set_Has_Pragma_Unreferenced_Objects (Full, Has_Pragma_Unreferenced_Objects @@ -11318,10 +11376,10 @@ package body Sem_Ch3 is Access_Types_To_Process (Freeze_Node (Priv))); end if; - -- Swap the two entities. Now Privat is the full type entity and - -- Full is the private one. They will be swapped back at the end - -- of the private part. This swapping ensures that the entity that - -- is visible in the private part is the full declaration. + -- Swap the two entities. Now Privat is the full type entity and Full is + -- the private one. They will be swapped back at the end of the private + -- part. This swapping ensures that the entity that is visible in the + -- private part is the full declaration. Exchange_Entities (Priv, Full); Append_Entity (Full, Scope (Full)); @@ -11927,7 +11985,7 @@ package body Sem_Ch3 is -- non-abstract tagged types that can reference abstract primitives -- through its Alias attribute are the internal entities that have -- attribute Interface_Alias, and these entities are generated later - -- by Freeze_Record_Type). + -- by Add_Internal_Interface_Entities). if In_Private_Part (Current_Scope) and then Is_Abstract_Type (Parent_Type) @@ -12706,6 +12764,12 @@ package body Sem_Ch3 is -- corresponding operations of the actual. else + pragma Assert (No (Node (Act_Elmt)) + or else (Primitive_Names_Match (Subp, Node (Act_Elmt)) + and then + Type_Conformant (Subp, Node (Act_Elmt), + Skip_Controlling_Formals => True))); + Derive_Subprogram (New_Subp, Subp, Derived_Type, Parent_Base, Node (Act_Elmt)); @@ -12790,13 +12854,13 @@ package body Sem_Ch3 is Subp := Node (Elmt); Alias_Subp := Ultimate_Alias (Subp); - -- At this early stage Derived_Type has no entities with attribute - -- Interface_Alias. In addition, such primitives are always - -- located at the end of the list of primitives of Parent_Type. - -- Therefore, if found we can safely stop processing pending - -- entities. + -- Do not derive internal entities of the parent that link + -- interface primitives and its covering primitive. These + -- entities will be added to this type when frozen. - exit when Present (Interface_Alias (Subp)); + if Present (Interface_Alias (Subp)) then + goto Continue; + end if; -- If the generic actual is present find the corresponding -- operation in the generic actual. If the parent type is a @@ -12810,27 +12874,88 @@ package body Sem_Ch3 is if Need_Search or else (Present (Generic_Actual) - and then Present (Act_Subp) - and then not Primitive_Names_Match (Subp, Act_Subp)) + and then Present (Act_Subp) + and then not + (Primitive_Names_Match (Subp, Act_Subp) + and then + Type_Conformant (Subp, Act_Subp, + Skip_Controlling_Formals => True))) then pragma Assert (not Is_Ancestor (Parent_Base, Generic_Actual)); - pragma Assert (Is_Interface (Parent_Base)); - -- Remember that we need searching for all the pending - -- primitives + -- Remember that we need searching for all pending primitives Need_Search := True; -- Handle entities associated with interface primitives - if Present (Alias (Subp)) - and then Is_Interface (Find_Dispatching_Type (Alias (Subp))) + if Present (Alias_Subp) + and then Is_Interface (Find_Dispatching_Type (Alias_Subp)) and then not Is_Predefined_Dispatching_Operation (Subp) then + -- Search for the primitive in the homonym chain + Act_Subp := Find_Primitive_Covering_Interface (Tagged_Type => Generic_Actual, - Iface_Prim => Subp); + Iface_Prim => Alias_Subp); + + -- Previous search may not locate primitives covering + -- interfaces defined in generics units or instantiations. + -- (it fails if the covering primitive has formals whose + -- type is also defined in generics or instantiations). + -- In such case we search in the list of primitives of the + -- generic actual for the internal entity that links the + -- interface primitive and the covering primitive. + + if No (Act_Subp) + and then Is_Generic_Type (Parent_Type) + then + -- This code has been designed to handle only generic + -- formals that implement interfaces that are defined + -- in a generic unit or instantiation. If this code is + -- needed for other cases we must review it because + -- (given that it relies on Original_Location to locate + -- the primitive of Generic_Actual that covers the + -- interface) it could leave linked through attribute + -- Alias entities of unrelated instantiations). + + pragma Assert + (Is_Generic_Unit + (Scope (Find_Dispatching_Type (Alias_Subp))) + or else + Instantiation_Depth + (Sloc (Find_Dispatching_Type (Alias_Subp))) > 0); + + declare + Iface_Prim_Loc : constant Source_Ptr := + Original_Location (Sloc (Alias_Subp)); + Elmt : Elmt_Id; + Prim : Entity_Id; + begin + Elmt := + First_Elmt (Primitive_Operations (Generic_Actual)); + + Search : while Present (Elmt) loop + Prim := Node (Elmt); + + if Present (Interface_Alias (Prim)) + and then Original_Location + (Sloc (Interface_Alias (Prim))) + = Iface_Prim_Loc + then + Act_Subp := Alias (Prim); + exit Search; + end if; + + Next_Elmt (Elmt); + end loop Search; + end; + end if; + + pragma Assert (Present (Act_Subp) + or else Is_Abstract_Type (Generic_Actual) + or else Serious_Errors_Detected > 0); -- Handle predefined primitives plus the rest of user-defined -- primitives @@ -12841,12 +12966,17 @@ package body Sem_Ch3 is Act_Subp := Node (Act_Elmt); exit when Primitive_Names_Match (Subp, Act_Subp) - and then Type_Conformant (Subp, Act_Subp, - Skip_Controlling_Formals => True) + and then Type_Conformant + (Subp, Act_Subp, + Skip_Controlling_Formals => True) and then No (Interface_Alias (Act_Subp)); Next_Elmt (Act_Elmt); end loop; + + if No (Act_Elmt) then + Act_Subp := Empty; + end if; end if; end if; @@ -12871,7 +13001,7 @@ package body Sem_Ch3 is and then Is_Interface (Find_Dispatching_Type (Alias_Subp)) and then not (Nkind (Parent (Alias_Subp)) = N_Procedure_Specification - and then Null_Present (Parent (Alias_Subp))) + and then Null_Present (Parent (Alias_Subp))) then Derive_Subprogram (New_Subp => New_Subp, @@ -12905,6 +13035,7 @@ package body Sem_Ch3 is Act_Subp := Node (Act_Elmt); end if; + <> Next_Elmt (Elmt); end loop; @@ -13334,9 +13465,7 @@ package body Sem_Ch3 is -- Check for early use of incomplete or private type - if Ekind (Parent_Type) = E_Void - or else Ekind (Parent_Type) = E_Incomplete_Type - then + if Ekind_In (Parent_Type, E_Void, E_Incomplete_Type) then Error_Msg_N ("premature derivation of incomplete type", Indic); return; @@ -13480,8 +13609,9 @@ package body Sem_Ch3 is (not Is_Interface (Parent_Type) or else not Is_Limited_Interface (Parent_Type)) then - Error_Msg_NE ("parent type& of limited type must be limited", - N, Parent_Type); + Error_Msg_NE + ("parent type& of limited type must be limited", + N, Parent_Type); end if; end if; end Derived_Type_Declaration; @@ -13934,9 +14064,9 @@ package body Sem_Ch3 is elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition then if No (Record_Extension_Part (Type_Definition (N))) then - Error_Msg_NE ( - "full declaration of } must be a record extension", - Prev, Id); + Error_Msg_NE + ("full declaration of } must be a record extension", + Prev, Id); -- Set some attributes to produce a usable full view @@ -14757,8 +14887,8 @@ package body Sem_Ch3 is then null; - elsif Ekind (Derived_Base) = E_Private_Type - or else Ekind (Derived_Base) = E_Limited_Private_Type + elsif Ekind_In (Derived_Base, E_Private_Type, + E_Limited_Private_Type) then null; @@ -14926,9 +15056,7 @@ package body Sem_Ch3 is -- Start of processing for Is_Visible_Component begin - if Ekind (C) = E_Component - or else Ekind (C) = E_Discriminant - then + if Ekind_In (C, E_Component, E_Discriminant) then Original_Comp := Original_Record_Component (C); end if; @@ -16246,15 +16374,17 @@ package body Sem_Ch3 is Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces); if Present (Iface) then - Error_Msg_NE ("interface & not implemented by full type " & - "(RM-2005 7.3 (7.3/2))", Priv_T, Iface); + Error_Msg_NE + ("interface & not implemented by full type " & + "(RM-2005 7.3 (7.3/2))", Priv_T, Iface); end if; Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces); if Present (Iface) then - Error_Msg_NE ("interface & not implemented by partial view " & - "(RM-2005 7.3 (7.3/2))", Full_T, Iface); + Error_Msg_NE + ("interface & not implemented by partial view " & + "(RM-2005 7.3 (7.3/2))", Full_T, Iface); end if; end; end if; @@ -16463,9 +16593,9 @@ package body Sem_Ch3 is while Present (Priv_Elmt) loop Priv := Node (Priv_Elmt); - if Ekind (Priv) = E_Private_Subtype - or else Ekind (Priv) = E_Limited_Private_Subtype - or else Ekind (Priv) = E_Record_Subtype_With_Private + if Ekind_In (Priv, E_Private_Subtype, + E_Limited_Private_Subtype, + E_Record_Subtype_With_Private) then Full := Make_Defining_Identifier (Sloc (Priv), Chars (Priv)); Set_Is_Itype (Full); @@ -16613,10 +16743,7 @@ package body Sem_Ch3 is Prim := Next_Entity (Full_T); while Present (Prim) and then Prim /= Priv_T loop - if Ekind (Prim) = E_Procedure - or else - Ekind (Prim) = E_Function - then + if Ekind_In (Prim, E_Procedure, E_Function) then Disp_Typ := Find_Dispatching_Type (Prim); if Disp_Typ = Full_T @@ -16646,10 +16773,9 @@ package body Sem_Ch3 is end loop; end if; - -- For the tagged case, the two views can share the same - -- Primitive Operation list and the same class wide type. - -- Update attributes of the class-wide type which depend on - -- the full declaration. + -- For the tagged case, the two views can share the same primitive + -- operations list and the same class-wide type. Update attributes + -- of the class-wide type which depend on the full declaration. if Is_Tagged_Type (Priv_T) then Set_Primitive_Operations (Priv_T, Full_List); @@ -17480,19 +17606,27 @@ package body Sem_Ch3 is and then Ekind (Current_Entity (Typ)) = E_Incomplete_Type and then Full_View (Current_Entity (Typ)) = Typ then + if Is_Tagged + and then Comes_From_Source (Current_Entity (Typ)) + and then not Is_Tagged_Type (Current_Entity (Typ)) + then + Make_Class_Wide_Type (Typ); + Error_Msg_N + ("incomplete view of tagged type should be declared tagged?", + Parent (Current_Entity (Typ))); + end if; return; else Inc_T := Make_Defining_Identifier (Loc, Chars (Typ)); Decl := Make_Incomplete_Type_Declaration (Loc, Inc_T); - -- Type has already been inserted into the current scope. - -- Remove it, and add incomplete declaration for type, so - -- that subsequent anonymous access types can use it. - -- The entity is unchained from the homonym list and from - -- immediate visibility. After analysis, the entity in the - -- incomplete declaration becomes immediately visible in the - -- record declaration that follows. + -- Type has already been inserted into the current scope. Remove + -- it, and add incomplete declaration for type, so that subsequent + -- anonymous access types can use it. The entity is unchained from + -- the homonym list and from immediate visibility. After analysis, + -- the entity in the incomplete declaration becomes immediately + -- visible in the record declaration that follows. H := Current_Entity (Typ); @@ -17513,8 +17647,9 @@ package body Sem_Ch3 is Set_Full_View (Inc_T, Typ); if Is_Tagged then - -- Create a common class-wide type for both views, and set - -- the Etype of the class-wide type to the full view. + + -- Create a common class-wide type for both views, and set the + -- Etype of the class-wide type to the full view. Make_Class_Wide_Type (Inc_T); Set_Class_Wide_Type (Typ, Class_Wide_Type (Inc_T)); @@ -17676,9 +17811,7 @@ package body Sem_Ch3 is (Access_Definition (Comp_Def)); Build_Incomplete_Type_Declaration; - Anon_Access := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); + Anon_Access := Make_Temporary (Loc, 'S'); -- Create a declaration for the anonymous access type: either -- an access_to_object or an access_to_subprogram. diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads index 6bfa52844d0..18b585f04aa 100644 --- a/gcc/ada/sem_ch3.ads +++ b/gcc/ada/sem_ch3.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -84,13 +84,11 @@ package Sem_Ch3 is procedure Access_Type_Declaration (T : Entity_Id; Def : Node_Id); -- Process an access type declaration - procedure Build_Itype_Reference - (Ityp : Entity_Id; - Nod : Node_Id); + procedure Build_Itype_Reference (Ityp : Entity_Id; Nod : Node_Id); -- Create a reference to an internal type, for use by Gigi. The back-end - -- elaborates itypes on demand, i.e. when their first use is seen. This - -- can lead to scope anomalies if the first use is within a scope that is - -- nested within the scope that contains the point of definition of the + -- elaborates itypes on demand, i.e. when their first use is seen. This can + -- lead to scope anomalies if the first use is within a scope that is + -- nested within the scope that contains the point of definition of the -- itype. The Itype_Reference node forces the elaboration of the itype -- in the proper scope. The node is inserted after Nod, which is the -- enclosing declaration that generated Ityp. diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 899b1a05878..743d128e65d 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -43,17 +43,18 @@ with Restrict; use Restrict; with Rident; use Rident; with Sem; use Sem; with Sem_Aux; use Sem_Aux; +with Sem_Case; use Sem_Case; with Sem_Cat; use Sem_Cat; with Sem_Ch3; use Sem_Ch3; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; -with Sem_SCIL; use Sem_SCIL; with Sem_Disp; use Sem_Disp; with Sem_Dist; use Sem_Dist; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; -with Sem_Util; use Sem_Util; with Sem_Type; use Sem_Type; +with Sem_Util; use Sem_Util; +with Sem_Warn; use Sem_Warn; with Stand; use Stand; with Sinfo; use Sinfo; with Snames; use Snames; @@ -305,8 +306,7 @@ package body Sem_Ch4 is end if; if Opnd = Left_Opnd (N) then - Error_Msg_N - ("\left operand has the following interpretations", N); + Error_Msg_N ("\left operand has the following interpretations", N); else Error_Msg_N ("\right operand has the following interpretations", N); @@ -472,8 +472,7 @@ package body Sem_Ch4 is end if; if Expander_Active then - Def_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + Def_Id := Make_Temporary (Loc, 'S'); Insert_Action (E, Make_Subtype_Declaration (Loc, @@ -818,10 +817,10 @@ package body Sem_Ch4 is elsif Nkind (Nam) = N_Selected_Component then Nam_Ent := Entity (Selector_Name (Nam)); - if Ekind (Nam_Ent) /= E_Entry - and then Ekind (Nam_Ent) /= E_Entry_Family - and then Ekind (Nam_Ent) /= E_Function - and then Ekind (Nam_Ent) /= E_Procedure + if not Ekind_In (Nam_Ent, E_Entry, + E_Entry_Family, + E_Function, + E_Procedure) then Error_Msg_N ("name in call is not a callable entity", Nam); Set_Etype (N, Any_Type); @@ -923,7 +922,21 @@ package body Sem_Ch4 is end if; end if; - Analyze_One_Call (N, Nam_Ent, False, Success); + -- If the call has been rewritten from a prefixed call, the first + -- parameter has been analyzed, but may need a subsequent + -- dereference, so skip its analysis now. + + if N /= Original_Node (N) + and then Nkind (Original_Node (N)) = Nkind (N) + and then Nkind (Name (N)) /= Nkind (Name (Original_Node (N))) + and then Present (Parameter_Associations (N)) + and then Present (Etype (First (Parameter_Associations (N)))) + then + Analyze_One_Call + (N, Nam_Ent, False, Success, Skip_First => True); + else + Analyze_One_Call (N, Nam_Ent, False, Success); + end if; -- If the interpretation succeeds, mark the proper type of the -- prefix (any valid candidate will do). If not, remove the @@ -1035,6 +1048,141 @@ package body Sem_Ch4 is end if; end Analyze_Call; + ----------------------------- + -- Analyze_Case_Expression -- + ----------------------------- + + procedure Analyze_Case_Expression (N : Node_Id) is + Expr : constant Node_Id := Expression (N); + FirstX : constant Node_Id := Expression (First (Alternatives (N))); + Alt : Node_Id; + Exp_Type : Entity_Id; + Exp_Btype : Entity_Id; + + Last_Choice : Nat; + Dont_Care : Boolean; + Others_Present : Boolean; + + procedure Non_Static_Choice_Error (Choice : Node_Id); + -- Error routine invoked by the generic instantiation below when + -- the case expression has a non static choice. + + package Case_Choices_Processing is new + Generic_Choices_Processing + (Get_Alternatives => Alternatives, + Get_Choices => Discrete_Choices, + Process_Empty_Choice => No_OP, + Process_Non_Static_Choice => Non_Static_Choice_Error, + Process_Associated_Node => No_OP); + use Case_Choices_Processing; + + Case_Table : Choice_Table_Type (1 .. Number_Of_Choices (N)); + + ----------------------------- + -- Non_Static_Choice_Error -- + ----------------------------- + + procedure Non_Static_Choice_Error (Choice : Node_Id) is + begin + Flag_Non_Static_Expr + ("choice given in case expression is not static!", Choice); + end Non_Static_Choice_Error; + + -- Start of processing for Analyze_Case_Expression + + begin + if Comes_From_Source (N) then + Check_Compiler_Unit (N); + end if; + + Analyze_And_Resolve (Expr, Any_Discrete); + Check_Unset_Reference (Expr); + Exp_Type := Etype (Expr); + Exp_Btype := Base_Type (Exp_Type); + + Alt := First (Alternatives (N)); + while Present (Alt) loop + Analyze (Expression (Alt)); + Next (Alt); + end loop; + + if not Is_Overloaded (FirstX) then + Set_Etype (N, Etype (FirstX)); + + else + declare + I : Interp_Index; + It : Interp; + + begin + Set_Etype (N, Any_Type); + + Get_First_Interp (FirstX, I, It); + while Present (It.Nam) loop + + -- For each intepretation of the first expression, we only + -- add the intepretation if every other expression in the + -- case expression alternatives has a compatible type. + + Alt := Next (First (Alternatives (N))); + while Present (Alt) loop + exit when not Has_Compatible_Type (Expression (Alt), It.Typ); + Next (Alt); + end loop; + + if No (Alt) then + Add_One_Interp (N, It.Typ, It.Typ); + end if; + + Get_Next_Interp (I, It); + end loop; + end; + end if; + + Exp_Btype := Base_Type (Exp_Type); + + -- The expression must be of a discrete type which must be determinable + -- independently of the context in which the expression occurs, but + -- using the fact that the expression must be of a discrete type. + -- Moreover, the type this expression must not be a character literal + -- (which is always ambiguous). + + -- If error already reported by Resolve, nothing more to do + + if Exp_Btype = Any_Discrete + or else Exp_Btype = Any_Type + then + return; + + elsif Exp_Btype = Any_Character then + Error_Msg_N + ("character literal as case expression is ambiguous", Expr); + return; + end if; + + -- If the case expression is a formal object of mode in out, then + -- treat it as having a nonstatic subtype by forcing use of the base + -- type (which has to get passed to Check_Case_Choices below). Also + -- use base type when the case expression is parenthesized. + + if Paren_Count (Expr) > 0 + or else (Is_Entity_Name (Expr) + and then Ekind (Entity (Expr)) = E_Generic_In_Out_Parameter) + then + Exp_Type := Exp_Btype; + end if; + + -- Call instantiated Analyze_Choices which does the rest of the work + + Analyze_Choices + (N, Exp_Type, Case_Table, Last_Choice, Dont_Care, Others_Present); + + if Exp_Type = Universal_Integer and then not Others_Present then + Error_Msg_N + ("case on universal integer requires OTHERS choice", Expr); + end if; + end Analyze_Case_Expression; + --------------------------- -- Analyze_Comparison_Op -- --------------------------- @@ -1160,7 +1308,6 @@ package body Sem_Ch4 is if Present (Op_Id) then if Ekind (Op_Id) = E_Operator then - LT := Base_Type (Etype (L)); RT := Base_Type (Etype (R)); @@ -1237,9 +1384,17 @@ package body Sem_Ch4 is procedure Analyze_Conditional_Expression (N : Node_Id) is Condition : constant Node_Id := First (Expressions (N)); Then_Expr : constant Node_Id := Next (Condition); - Else_Expr : constant Node_Id := Next (Then_Expr); + Else_Expr : Node_Id; begin + -- Defend against error of missing expressions from previous error + + if No (Then_Expr) then + return; + end if; + + Else_Expr := Next (Then_Expr); + if Comes_From_Source (N) then Check_Compiler_Unit (N); end if; @@ -1251,8 +1406,13 @@ package body Sem_Ch4 is Analyze_Expression (Else_Expr); end if; + -- If then expression not overloaded, then that decides the type + if not Is_Overloaded (Then_Expr) then Set_Etype (N, Etype (Then_Expr)); + + -- Case where then expression is overloaded + else declare I : Interp_Index; @@ -1262,6 +1422,12 @@ package body Sem_Ch4 is Set_Etype (N, Any_Type); Get_First_Interp (Then_Expr, I, It); while Present (It.Nam) loop + + -- For each possible intepretation of the Then Expression, + -- add it only if the else expression has a compatible type. + + -- Is this right if Else_Expr is empty? + if Has_Compatible_Type (Else_Expr, It.Typ) then Add_One_Interp (N, It.Typ, It.Typ); end if; @@ -1577,6 +1743,25 @@ package body Sem_Ch4 is Check_Parameterless_Call (N); end Analyze_Expression; + ------------------------------------- + -- Analyze_Expression_With_Actions -- + ------------------------------------- + + procedure Analyze_Expression_With_Actions (N : Node_Id) is + A : Node_Id; + + begin + A := First (Actions (N)); + loop + Analyze (A); + Next (A); + exit when No (A); + end loop; + + Analyze_Expression (Expression (N)); + Set_Etype (N, Etype (Expression (N))); + end Analyze_Expression_With_Actions; + ------------------------------------ -- Analyze_Indexed_Component_Form -- ------------------------------------ @@ -1930,7 +2115,8 @@ package body Sem_Ch4 is elsif Ekind (Etype (P)) = E_Subprogram_Type or else (Is_Access_Type (Etype (P)) and then - Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type) + Ekind (Designated_Type (Etype (P))) = + E_Subprogram_Type) then -- Call to access_to-subprogram with possible implicit dereference @@ -1955,7 +2141,7 @@ package body Sem_Ch4 is if Ekind (P_T) = E_Subprogram_Type or else (Is_Access_Type (P_T) and then - Ekind (Designated_Type (P_T)) = E_Subprogram_Type) + Ekind (Designated_Type (P_T)) = E_Subprogram_Type) then Process_Function_Call; @@ -2158,7 +2344,7 @@ package body Sem_Ch4 is Analyze_Expression (L); if No (R) - and then Extensions_Allowed + and then Ada_Version >= Ada_12 then Analyze_Set_Membership; return; @@ -3092,8 +3278,8 @@ package body Sem_Ch4 is -- Analyze_Selected_Component -- -------------------------------- - -- Prefix is a record type or a task or protected type. In the - -- later case, the selector must denote a visible entry. + -- Prefix is a record type or a task or protected type. In the latter case, + -- the selector must denote a visible entry. procedure Analyze_Selected_Component (N : Node_Id) is Name : constant Node_Id := Prefix (N); @@ -3111,6 +3297,9 @@ package body Sem_Ch4 is -- a class-wide type, we use its root type, whose components are -- present in the class-wide type. + Is_Single_Concurrent_Object : Boolean; + -- Set True if the prefix is a single task or a single protected object + function Has_Mode_Conformant_Spec (Comp : Entity_Id) return Boolean; -- It is known that the parent of N denotes a subprogram call. Comp -- is an overloadable component of the concurrent type of the prefix. @@ -3281,6 +3470,15 @@ package body Sem_Ch4 is Type_To_Use := Root_Type (Prefix_Type); end if; + -- If the prefix is a single concurrent object, use its name in error + -- messages, rather than that of its anonymous type. + + Is_Single_Concurrent_Object := + Is_Concurrent_Type (Prefix_Type) + and then Is_Internal_Name (Chars (Prefix_Type)) + and then not Is_Derived_Type (Prefix_Type) + and then Is_Entity_Name (Name); + Comp := First_Entity (Type_To_Use); -- If the selector has an original discriminant, the node appears in @@ -3519,9 +3717,8 @@ package body Sem_Ch4 is return; else - Error_Msg_NE - ("invisible selector for }", - N, First_Subtype (Prefix_Type)); + Error_Msg_Node_2 := First_Subtype (Prefix_Type); + Error_Msg_NE ("invisible selector& for }", N, Sel); Set_Entity (Sel, Any_Id); Set_Etype (N, Any_Type); end if; @@ -3566,10 +3763,13 @@ package body Sem_Ch4 is Has_Candidate := True; end if; - elsif Ekind (Comp) = E_Discriminant - or else Ekind (Comp) = E_Entry_Family + -- Note: a selected component may not denote a component of a + -- protected type (4.1.3(7)). + + elsif Ekind_In (Comp, E_Discriminant, E_Entry_Family) or else (In_Scope - and then Is_Entity_Name (Name)) + and then not Is_Protected_Type (Prefix_Type) + and then Is_Entity_Name (Name)) then Set_Entity_With_Style_Check (Sel, Comp); Generate_Reference (Comp, Sel); @@ -3633,6 +3833,28 @@ package body Sem_Ch4 is end if; end if; + if Etype (N) = Any_Type and then Is_Protected_Type (Prefix_Type) then + -- Case of a prefix of a protected type: selector might denote + -- an invisible private component. + + Comp := First_Private_Entity (Base_Type (Prefix_Type)); + while Present (Comp) and then Chars (Comp) /= Chars (Sel) loop + Next_Entity (Comp); + end loop; + + if Present (Comp) then + if Is_Single_Concurrent_Object then + Error_Msg_Node_2 := Entity (Name); + Error_Msg_NE ("invisible selector& for &", N, Sel); + + else + Error_Msg_Node_2 := First_Subtype (Prefix_Type); + Error_Msg_NE ("invisible selector& for }", N, Sel); + end if; + return; + end if; + end if; + Set_Is_Overloaded (N, Is_Overloaded (Sel)); else @@ -3645,15 +3867,7 @@ package body Sem_Ch4 is if Etype (N) = Any_Type then - -- If the prefix is a single concurrent object, use its name in the - -- error message, rather than that of its anonymous type. - - if Is_Concurrent_Type (Prefix_Type) - and then Is_Internal_Name (Chars (Prefix_Type)) - and then not Is_Derived_Type (Prefix_Type) - and then Is_Entity_Name (Name) - then - + if Is_Single_Concurrent_Object then Error_Msg_Node_2 := Entity (Name); Error_Msg_NE ("no selector& for&", N, Sel); @@ -3890,15 +4104,6 @@ package body Sem_Ch4 is T : Entity_Id; begin - -- Check if the expression is a function call for which we need to - -- adjust a SCIL dispatching node. - - if Generate_SCIL - and then Nkind (Expr) = N_Function_Call - then - Adjust_SCIL_Node (N, Expr); - end if; - -- If Conversion_OK is set, then the Etype is already set, and the -- only processing required is to analyze the expression. This is -- used to construct certain "illegal" conversions which are not @@ -4488,9 +4693,7 @@ package body Sem_Ch4 is if Nkind (N) = N_Function_Call then Get_First_Interp (Nam, X, It); while Present (It.Nam) loop - if Ekind (It.Nam) = E_Function - or else Ekind (It.Nam) = E_Operator - then + if Ekind_In (It.Nam, E_Function, E_Operator) then return; else Get_Next_Interp (X, It); @@ -5302,10 +5505,11 @@ package body Sem_Ch4 is end if; end if; - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("operator for} is not directly visible!", N, First_Subtype (Candidate_Type)); - Error_Msg_N ("use clause would make operation legal!", N); + Error_Msg_N -- CODEFIX + ("use clause would make operation legal!", N); return; -- If either operand is a junk operand (e.g. package name), then @@ -6180,8 +6384,20 @@ package body Sem_Ch4 is if Is_Overloaded (Subprog) then Save_Interps (Subprog, Node_To_Replace); + else Analyze (Node_To_Replace); + + -- If the operation has been rewritten into a call, which may + -- get subsequently an explicit dereference, preserve the + -- type on the original node (selected component or indexed + -- component) for subsequent legality tests, e.g. Is_Variable. + -- which examines the original node. + + if Nkind (Node_To_Replace) = N_Function_Call then + Set_Etype + (Original_Node (Node_To_Replace), Etype (Node_To_Replace)); + end if; end if; end Complete_Object_Operation; @@ -6649,29 +6865,31 @@ package body Sem_Ch4 is if Is_Derived_Type (T) then return Primitive_Operations (T); - elsif Ekind (Scope (T)) = E_Procedure - or else Ekind (Scope (T)) = E_Function - then + elsif Ekind_In (Scope (T), E_Procedure, E_Function) then + -- Scan the list of generic formals to find subprograms -- that may have a first controlling formal of the type. - declare - Decl : Node_Id; - - begin - Decl := - First (Generic_Formal_Declarations - (Unit_Declaration_Node (Scope (T)))); - while Present (Decl) loop - if Nkind (Decl) in N_Formal_Subprogram_Declaration then - Subp := Defining_Entity (Decl); - Check_Candidate; - end if; - - Next (Decl); - end loop; - end; + if Nkind (Unit_Declaration_Node (Scope (T))) + = N_Generic_Subprogram_Declaration + then + declare + Decl : Node_Id; + + begin + Decl := + First (Generic_Formal_Declarations + (Unit_Declaration_Node (Scope (T)))); + while Present (Decl) loop + if Nkind (Decl) in N_Formal_Subprogram_Declaration then + Subp := Defining_Entity (Decl); + Check_Candidate; + end if; + Next (Decl); + end loop; + end; + end if; return Candidates; else @@ -6681,7 +6899,15 @@ package body Sem_Ch4 is -- declaration or body (either the one that declares T, or a -- child unit). - Subp := First_Entity (Scope (T)); + -- For a subtype representing a generic actual type, go to the + -- base type. + + if Is_Generic_Actual_Type (T) then + Subp := First_Entity (Scope (Base_Type (T))); + else + Subp := First_Entity (Scope (T)); + end if; + while Present (Subp) loop if Is_Overloadable (Subp) then Check_Candidate; @@ -6754,13 +6980,14 @@ package body Sem_Ch4 is -- corresponding record (base) type. if Is_Concurrent_Type (Obj_Type) then - if not Present (Corresponding_Record_Type (Obj_Type)) then - return False; + if Present (Corresponding_Record_Type (Obj_Type)) then + Corr_Type := Base_Type (Corresponding_Record_Type (Obj_Type)); + Elmt := First_Elmt (Primitive_Operations (Corr_Type)); + else + Corr_Type := Obj_Type; + Elmt := First_Elmt (Collect_Generic_Type_Ops (Obj_Type)); end if; - Corr_Type := Base_Type (Corresponding_Record_Type (Obj_Type)); - Elmt := First_Elmt (Primitive_Operations (Corr_Type)); - elsif not Is_Generic_Type (Obj_Type) then Corr_Type := Obj_Type; Elmt := First_Elmt (Primitive_Operations (Obj_Type)); @@ -6777,7 +7004,7 @@ package body Sem_Ch4 is and then Present (First_Formal (Prim_Op)) and then Valid_First_Argument_Of (Prim_Op) and then - (Nkind (Call_Node) = N_Function_Call) + (Nkind (Call_Node) = N_Function_Call) = (Ekind (Prim_Op) = E_Function) then -- Ada 2005 (AI-251): If this primitive operation corresponds diff --git a/gcc/ada/sem_ch4.ads b/gcc/ada/sem_ch4.ads index 6c8d1a33b55..e5c646f9bb8 100644 --- a/gcc/ada/sem_ch4.ads +++ b/gcc/ada/sem_ch4.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -30,11 +30,13 @@ package Sem_Ch4 is procedure Analyze_Allocator (N : Node_Id); procedure Analyze_Arithmetic_Op (N : Node_Id); procedure Analyze_Call (N : Node_Id); + procedure Analyze_Case_Expression (N : Node_Id); procedure Analyze_Comparison_Op (N : Node_Id); procedure Analyze_Concatenation (N : Node_Id); procedure Analyze_Conditional_Expression (N : Node_Id); procedure Analyze_Equality_Op (N : Node_Id); procedure Analyze_Explicit_Dereference (N : Node_Id); + procedure Analyze_Expression_With_Actions (N : Node_Id); procedure Analyze_Logical_Op (N : Node_Id); procedure Analyze_Membership_Op (N : Node_Id); procedure Analyze_Negation (N : Node_Id); diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 1f6806b231a..816e12b979e 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -46,7 +46,6 @@ with Sem_Disp; use Sem_Disp; with Sem_Elab; use Sem_Elab; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; -with Sem_SCIL; use Sem_SCIL; with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Sem_Warn; use Sem_Warn; @@ -448,14 +447,14 @@ package body Sem_Ch5 is end if; return; - -- Enforce RM 3.9.3 (8): left-hand side cannot be abstract + -- Enforce RM 3.9.3 (8): the target of an assignment operation cannot be + -- abstract. This is only checked when the assignment Comes_From_Source, + -- because in some cases the expander generates such assignments (such + -- in the _assign operation for an abstract type). - elsif Is_Interface (T1) - and then not Is_Class_Wide_Type (T1) - then + elsif Is_Abstract_Type (T1) and then Comes_From_Source (N) then Error_Msg_N - ("target of assignment operation may not be abstract", Lhs); - return; + ("target of assignment operation must not be abstract", Lhs); end if; -- Resolution may have updated the subtype, in case the left-hand @@ -693,10 +692,10 @@ package body Sem_Ch5 is and then Nkind (Original_Node (Rhs)) not in N_Op then if Nkind (Lhs) in N_Has_Entity then - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("?useless assignment of & to itself!", N, Entity (Lhs)); else - Error_Msg_N + Error_Msg_N -- CODEFIX ("?useless assignment of object to itself!", N); end if; end if; @@ -948,7 +947,7 @@ package body Sem_Ch5 is -- the case statement has a non static choice. procedure Process_Statements (Alternative : Node_Id); - -- Analyzes all the statements associated to a case alternative. + -- Analyzes all the statements associated with a case alternative. -- Needed by the generic instantiation below. package Case_Choices_Processing is new @@ -998,11 +997,9 @@ package body Sem_Ch5 is if Is_Entity_Name (Exp) then Ent := Entity (Exp); - if Ekind (Ent) = E_Variable - or else - Ekind (Ent) = E_In_Out_Parameter - or else - Ekind (Ent) = E_Out_Parameter + if Ekind_In (Ent, E_Variable, + E_In_Out_Parameter, + E_Out_Parameter) then if List_Length (Choices) = 1 and then Nkind (First (Choices)) in N_Subexpr @@ -1198,7 +1195,7 @@ package body Sem_Ch5 is else Error_Msg_N ("cannot exit from program unit or accept statement", N); - exit; + return; end if; end loop; @@ -1209,6 +1206,11 @@ package body Sem_Ch5 is Check_Unset_Reference (Cond); end if; + -- Chain exit statement to associated loop entity + + Set_Next_Exit_Statement (N, First_Exit_Statement (Scope_Id)); + Set_First_Exit_Statement (Scope_Id, N); + -- Since the exit may take us out of a loop, any previous assignment -- statement is not useless, so clear last assignment indications. It -- is OK to keep other current values, since if the exit statement @@ -1472,8 +1474,8 @@ package body Sem_Ch5 is R_Copy : constant Node_Id := New_Copy_Tree (R); Lo : constant Node_Id := Low_Bound (R); Hi : constant Node_Id := High_Bound (R); - New_Lo_Bound : Node_Id := Empty; - New_Hi_Bound : Node_Id := Empty; + New_Lo_Bound : Node_Id; + New_Hi_Bound : Node_Id; Typ : Entity_Id; Save_Analysis : Boolean; @@ -1517,9 +1519,7 @@ package body Sem_Ch5 is Analyze_And_Resolve (Original_Bound, Typ); - Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); + Id := Make_Temporary (Loc, 'S', Original_Bound); -- Normally, the best approach is simply to generate a constant -- declaration that captures the bound. However, there is a nasty @@ -1571,15 +1571,6 @@ package body Sem_Ch5 is Name => New_Occurrence_Of (Id, Loc), Expression => Relocate_Node (Original_Bound)); - -- If the relocated node is a function call then check if some - -- SCIL node references it and needs readjustment. - - if Generate_SCIL - and then Nkind (Original_Bound) = N_Function_Call - then - Adjust_SCIL_Node (Original_Bound, Expression (Assign)); - end if; - Insert_Before (Parent (N), Assign); Analyze (Assign); @@ -1718,13 +1709,10 @@ package body Sem_Ch5 is then declare Loc : constant Source_Ptr := Sloc (N); - Arr : constant Entity_Id := - Etype (Entity (Prefix (DS))); + Arr : constant Entity_Id := Etype (Entity (Prefix (DS))); Indx : constant Entity_Id := Base_Type (Etype (First_Index (Arr))); - Subt : constant Entity_Id := - Make_Defining_Identifier - (Loc, New_Internal_Name ('S')); + Subt : constant Entity_Id := Make_Temporary (Loc, 'S'); Decl : Node_Id; begin @@ -2060,8 +2048,12 @@ package body Sem_Ch5 is End_Scope; Kill_Current_Values; - -- Check for infinite loop. We skip this check for generated code, since - -- it justs waste time and makes debugging the routine called harder. + -- Check for infinite loop. Skip check for generated code, since it + -- justs waste time and makes debugging the routine called harder. + + -- Note that we have to wait till the body of the loop is fully analyzed + -- before making this call, since Check_Infinite_Loop_Warning relies on + -- being able to use semantic visibility information to find references. if Comes_From_Source (N) then Check_Infinite_Loop_Warning (N); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index d1bbf53adf6..cbdaf68180f 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -98,7 +98,7 @@ package body Sem_Ch6 is ----------------------- procedure Analyze_Return_Statement (N : Node_Id); - -- Common processing for simple_ and extended_return_statements + -- Common processing for simple and extended return statements procedure Analyze_Function_Return (N : Node_Id); -- Subsidiary to Analyze_Return_Statement. Called when the return statement @@ -106,11 +106,12 @@ package body Sem_Ch6 is procedure Analyze_Return_Type (N : Node_Id); -- Subsidiary to Process_Formals: analyze subtype mark in function - -- specification, in a context where the formals are visible and hide + -- specification in a context where the formals are visible and hide -- outer homographs. procedure Analyze_Subprogram_Body_Helper (N : Node_Id); - -- Does all the real work of Analyze_Subprogram_Body + -- Does all the real work of Analyze_Subprogram_Body. This is split out so + -- that we can use RETURN but not skip the debug output at the end. procedure Analyze_Generic_Subprogram_Body (N : Node_Id; Gen_Id : Entity_Id); -- Analyze a generic subprogram body. N is the body to be analyzed, and @@ -514,10 +515,10 @@ package body Sem_Ch6 is ------------------------------------- procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id) is - Return_Obj : constant Node_Id := Defining_Identifier (Obj_Decl); - R_Stm_Type : constant Entity_Id := Etype (Return_Obj); - -- Subtype given in the extended return statement; - -- this must match R_Type. + Return_Obj : constant Node_Id := Defining_Identifier (Obj_Decl); + + R_Stm_Type : constant Entity_Id := Etype (Return_Obj); + -- Subtype given in the extended return statement (must match R_Type) Subtype_Ind : constant Node_Id := Object_Definition (Original_Node (Obj_Decl)); @@ -542,7 +543,7 @@ package body Sem_Ch6 is -- True if type of the return object is an anonymous access type begin - -- First, avoid cascade errors: + -- First, avoid cascaded errors if Error_Posted (Obj_Decl) or else Error_Posted (Subtype_Ind) then return; @@ -773,6 +774,11 @@ package body Sem_Ch6 is & "null-excluding return?", Reason => CE_Null_Not_Allowed); end if; + + -- Apply checks suggested by AI05-0144 (dangerous order dependence) + -- (Disabled for now) + + -- Check_Order_Dependence; end if; end Analyze_Function_Return; @@ -978,6 +984,7 @@ package body Sem_Ch6 is if Style_Check then Style.Check_Identifier (Body_Id, Gen_Id); end if; + End_Generic; end Analyze_Generic_Subprogram_Body; @@ -1037,6 +1044,7 @@ package body Sem_Ch6 is procedure Analyze_Call_And_Resolve; -- Do Analyze and Resolve calls for procedure call + -- At end, check illegal order dependence. ------------------------------ -- Analyze_Call_And_Resolve -- @@ -1047,6 +1055,11 @@ package body Sem_Ch6 is if Nkind (N) = N_Procedure_Call_Statement then Analyze_Call (N); Resolve (N, Standard_Void_Type); + + -- Apply checks suggested by AI05-0144 (Disabled for now) + + -- Check_Order_Dependence; + else Analyze (N); end if; @@ -1074,9 +1087,13 @@ package body Sem_Ch6 is return; end if; - -- If error analyzing prefix, then set Any_Type as result and return + -- If there is an error analyzing the name (which may have been + -- rewritten if the original call was in prefix notation) then error + -- has been emitted already, mark node and return. - if Etype (P) = Any_Type then + if Error_Posted (N) + or else Etype (Name (N)) = Any_Type + then Set_Etype (N, Any_Type); return; end if; @@ -1424,7 +1441,6 @@ package body Sem_Ch6 is Prev_Id : constant Entity_Id := Current_Entity_In_Scope (Body_Id); Conformant : Boolean; HSS : Node_Id; - Missing_Ret : Boolean; P_Ent : Entity_Id; Prot_Typ : Entity_Id := Empty; Spec_Id : Entity_Id; @@ -1466,6 +1482,10 @@ package body Sem_Ch6 is -- If pragma does not appear after the body, check whether there is -- an inline pragma before any local declarations. + procedure Check_Missing_Return; + -- Checks for a function with a no return statements, and also performs + -- the warning checks implemented by Check_Returns. + function Disambiguate_Spec return Entity_Id; -- When a primitive is declared between the private view and the full -- view of a concurrent type which implements an interface, a special @@ -1658,6 +1678,46 @@ package body Sem_Ch6 is end if; end Check_Inline_Pragma; + -------------------------- + -- Check_Missing_Return -- + -------------------------- + + procedure Check_Missing_Return is + Id : Entity_Id; + Missing_Ret : Boolean; + + begin + if Nkind (Body_Spec) = N_Function_Specification then + if Present (Spec_Id) then + Id := Spec_Id; + else + Id := Body_Id; + end if; + + if Return_Present (Id) then + Check_Returns (HSS, 'F', Missing_Ret); + + if Missing_Ret then + Set_Has_Missing_Return (Id); + end if; + + elsif (Is_Generic_Subprogram (Id) + or else not Is_Machine_Code_Subprogram (Id)) + and then not Body_Deleted + then + Error_Msg_N ("missing RETURN statement in function body", N); + end if; + + -- If procedure with No_Return, check returns + + elsif Nkind (Body_Spec) = N_Procedure_Specification + and then Present (Spec_Id) + and then No_Return (Spec_Id) + then + Check_Returns (HSS, 'P', Missing_Ret, Spec_Id); + end if; + end Check_Missing_Return; + ----------------------- -- Disambiguate_Spec -- ----------------------- @@ -1846,9 +1906,10 @@ package body Sem_Ch6 is elsif not Is_Primitive (Spec_Id) and then Ekind (Scope (Spec_Id)) /= E_Protected_Type then - Error_Msg_N ("overriding indicator only allowed " & - "if subprogram is primitive", - Body_Spec); + Error_Msg_N + ("overriding indicator only allowed " & + "if subprogram is primitive", + Body_Spec); end if; elsif Style_Check -- ??? incorrect use of Style_Check! @@ -1881,6 +1942,12 @@ package body Sem_Ch6 is Set_Is_Child_Unit (Body_Id, Is_Child_Unit (Spec_Id)); Analyze_Generic_Subprogram_Body (N, Spec_Id); + + if Nkind (N) = N_Subprogram_Body then + HSS := Handled_Statement_Sequence (N); + Check_Missing_Return; + end if; + return; else @@ -2026,10 +2093,13 @@ package body Sem_Ch6 is end if; end if; - -- Mark presence of postcondition proc in current scope + -- Mark presence of postcondition procedure in current scope and mark + -- the procedure itself as needing debug info. The latter is important + -- when analyzing decision coverage (for example, for MC/DC coverage). if Chars (Body_Id) = Name_uPostconditions then Set_Has_Postconditions (Current_Scope); + Set_Debug_Info_Needed (Body_Id); end if; -- Place subprogram on scope stack, and make formals visible. If there @@ -2079,6 +2149,15 @@ package body Sem_Ch6 is then Conformant := True; + -- Conversely, the spec may have been generated for specless body + -- with an inline pragma. + + elsif Comes_From_Source (N) + and then not Comes_From_Source (Spec_Id) + and then Has_Pragma_Inline (Spec_Id) + then + Conformant := True; + else Check_Conformance (Body_Id, Spec_Id, @@ -2407,41 +2486,7 @@ package body Sem_Ch6 is end if; end if; - -- If function, check return statements - - if Nkind (Body_Spec) = N_Function_Specification then - declare - Id : Entity_Id; - - begin - if Present (Spec_Id) then - Id := Spec_Id; - else - Id := Body_Id; - end if; - - if Return_Present (Id) then - Check_Returns (HSS, 'F', Missing_Ret); - - if Missing_Ret then - Set_Has_Missing_Return (Id); - end if; - - elsif not Is_Machine_Code_Subprogram (Id) - and then not Body_Deleted - then - Error_Msg_N ("missing RETURN statement in function body", N); - end if; - end; - - -- If procedure with No_Return, check returns - - elsif Nkind (Body_Spec) = N_Procedure_Specification - and then Present (Spec_Id) - and then No_Return (Spec_Id) - then - Check_Returns (HSS, 'P', Missing_Ret, Spec_Id); - end if; + Check_Missing_Return; -- Now we are going to check for variables that are never modified in -- the body of the procedure. But first we deal with a special case @@ -2618,8 +2663,7 @@ package body Sem_Ch6 is end loop; if Is_Protected_Type (Current_Scope) then - Error_Msg_N - ("protected operation cannot be a null procedure", N); + Error_Msg_N ("protected operation cannot be a null procedure", N); end if; end if; @@ -3087,6 +3131,15 @@ package body Sem_Ch6 is and then Has_Excluded_Statement (Statements (S)) then return True; + + elsif Nkind (S) = N_Extended_Return_Statement then + if Has_Excluded_Statement + (Statements (Handled_Statement_Sequence (S))) + or else Present + (Exception_Handlers (Handled_Statement_Sequence (S))) + then + return True; + end if; end if; Next (S); @@ -3109,6 +3162,7 @@ package body Sem_Ch6 is or else Is_Child_Unit (S) then return False; + elsif Ekind (S) = E_Package and then Has_Forward_Instantiation (S) then @@ -3153,12 +3207,33 @@ package body Sem_Ch6 is return Abandon; end if; + -- A return statement within an extended return is a noop + -- after inlining. + + elsif No (Expression (N)) + and then Nkind (Parent (Parent (N))) = + N_Extended_Return_Statement + then + return OK; + else -- Expression has wrong form return Abandon; end if; + -- We can only inline a build-in-place function if + -- it has a single extended return. + + elsif Nkind (N) = N_Extended_Return_Statement then + if No (Return_Statement) then + Return_Statement := N; + return OK; + + else + return Abandon; + end if; + else return OK; end if; @@ -3169,11 +3244,18 @@ package body Sem_Ch6 is -- Start of processing for Has_Single_Return begin - return Check_All_Returns (N) = OK - and then Present (Declarations (N)) - and then Present (First (Declarations (N))) - and then Chars (Expression (Return_Statement)) = - Chars (Defining_Identifier (First (Declarations (N)))); + if Check_All_Returns (N) /= OK then + return False; + + elsif Nkind (Return_Statement) = N_Extended_Return_Statement then + return True; + + else + return Present (Declarations (N)) + and then Present (First (Declarations (N))) + and then Chars (Expression (Return_Statement)) = + Chars (Defining_Identifier (First (Declarations (N)))); + end if; end Has_Single_Return; -------------------- @@ -3462,21 +3544,21 @@ package body Sem_Ch6 is when Mode_Conformant => if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then - Error_Msg_N -- CODEFIX??? + Error_Msg_N ("not mode conformant with operation inherited#!", Enode); else - Error_Msg_N -- CODEFIX??? + Error_Msg_N ("not mode conformant with declaration#!", Enode); end if; when Subtype_Conformant => if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then - Error_Msg_N -- CODEFIX??? + Error_Msg_N ("not subtype conformant with operation inherited#!", Enode); else - Error_Msg_N -- CODEFIX??? + Error_Msg_N ("not subtype conformant with declaration#!", Enode); end if; @@ -3960,22 +4042,25 @@ package body Sem_Ch6 is if not Is_Overriding_Operation (Op) then Error_Msg_N ("\\primitive % defined #", Typ); else - Error_Msg_N ("\\overriding operation % with " & - "convention % defined #", Typ); + Error_Msg_N + ("\\overriding operation % with " & + "convention % defined #", Typ); end if; else pragma Assert (Present (Alias (Op))); Error_Msg_Sloc := Sloc (Alias (Op)); - Error_Msg_N ("\\inherited operation % with " & - "convention % defined #", Typ); + Error_Msg_N + ("\\inherited operation % with " & + "convention % defined #", Typ); end if; Error_Msg_Name_1 := Chars (Op); Error_Msg_Name_2 := Get_Convention_Name (Convention (Iface_Prim)); Error_Msg_Sloc := Sloc (Iface_Prim); - Error_Msg_N ("\\overridden operation % with " & - "convention % defined #", Typ); + Error_Msg_N + ("\\overridden operation % with " & + "convention % defined #", Typ); -- Avoid cascading errors @@ -4393,7 +4478,8 @@ package body Sem_Ch6 is then Error_Msg_Node_2 := Alias (Overridden_Subp); Error_Msg_Sloc := Sloc (Error_Msg_Node_2); - Error_Msg_NE ("& does not match corresponding formal of&#", + Error_Msg_NE + ("& does not match corresponding formal of&#", Form1, Form1); exit; end if; @@ -4404,8 +4490,24 @@ package body Sem_Ch6 is end; end if; + -- If there is an overridden subprogram, then check that there is not + -- a "not overriding" indicator, and mark the subprogram as overriding. + -- This is not done if the overridden subprogram is marked as hidden, + -- which can occur for the case of inherited controlled operations + -- (see Derive_Subprogram), unless the inherited subprogram's parent + -- subprogram is not itself hidden. (Note: This condition could probably + -- be simplified, leaving out the testing for the specific controlled + -- cases, but it seems safer and clearer this way, and echoes similar + -- special-case tests of this kind in other places.) + if Present (Overridden_Subp) - and then not Is_Hidden (Overridden_Subp) + and then (not Is_Hidden (Overridden_Subp) + or else + ((Chars (Overridden_Subp) = Name_Initialize + or else Chars (Overridden_Subp) = Name_Adjust + or else Chars (Overridden_Subp) = Name_Finalize) + and then Present (Alias (Overridden_Subp)) + and then not Is_Hidden (Alias (Overridden_Subp)))) then if Must_Not_Override (Spec) then Error_Msg_Sloc := Sloc (Overridden_Subp); @@ -4477,7 +4579,7 @@ package body Sem_Ch6 is elsif Must_Override (Spec) then if Is_Overriding_Operation (Subp) then - Set_Is_Overriding_Operation (Subp); + null; elsif not Can_Override then Error_Msg_NE ("subprogram & is not overriding", Spec, Subp); @@ -5329,6 +5431,14 @@ package body Sem_Ch6 is -- and also returned as the result. These formals are always of mode IN. -- The new formal has the type Typ, is declared in Scope, and its name -- is given by a concatenation of the name of Assoc_Entity and Suffix. + -- The following suffixes are currently used. They should not be changed + -- without coordinating with CodePeer, which makes use of these to + -- provide better messages. + + -- O denotes the Constrained bit. + -- L denotes the accessibility level. + -- BIP_xxx denotes an extra formal for a build-in-place function. See + -- the full list in exp_ch6.BIP_Formal_Kind. ---------------------- -- Add_Extra_Formal -- @@ -5455,7 +5565,7 @@ package body Sem_Ch6 is and then not Is_Indefinite_Subtype (Formal_Type) then Set_Extra_Constrained - (Formal, Add_Extra_Formal (Formal, Standard_Boolean, E, "F")); + (Formal, Add_Extra_Formal (Formal, Standard_Boolean, E, "O")); end if; end if; @@ -5488,7 +5598,7 @@ package body Sem_Ch6 is or else Present (Extra_Accessibility (P_Formal))) then Set_Extra_Accessibility - (Formal, Add_Extra_Formal (Formal, Standard_Natural, E, "F")); + (Formal, Add_Extra_Formal (Formal, Standard_Natural, E, "L")); end if; -- This label is required when skipping extra formal generation for @@ -6001,8 +6111,9 @@ package body Sem_Ch6 is when N_Aggregate => return FCL (Expressions (E1), Expressions (E2)) - and then FCL (Component_Associations (E1), - Component_Associations (E2)); + and then + FCL (Component_Associations (E1), + Component_Associations (E2)); when N_Allocator => if Nkind (Expression (E1)) = N_Qualified_Expression @@ -6072,6 +6183,38 @@ package body Sem_Ch6 is and then FCE (Right_Opnd (E1), Right_Opnd (E2)); + when N_Case_Expression => + declare + Alt1 : Node_Id; + Alt2 : Node_Id; + + begin + if not FCE (Expression (E1), Expression (E2)) then + return False; + + else + Alt1 := First (Alternatives (E1)); + Alt2 := First (Alternatives (E2)); + loop + if Present (Alt1) /= Present (Alt2) then + return False; + elsif No (Alt1) then + return True; + end if; + + if not FCE (Expression (Alt1), Expression (Alt2)) + or else not FCL (Discrete_Choices (Alt1), + Discrete_Choices (Alt2)) + then + return False; + end if; + + Next (Alt1); + Next (Alt2); + end loop; + end if; + end; + when N_Character_Literal => return Char_Literal_Value (E1) = Char_Literal_Value (E2); @@ -6079,7 +6222,8 @@ package body Sem_Ch6 is when N_Component_Association => return FCL (Choices (E1), Choices (E2)) - and then FCE (Expression (E1), Expression (E2)); + and then + FCE (Expression (E1), Expression (E2)); when N_Conditional_Expression => return @@ -6100,13 +6244,15 @@ package body Sem_Ch6 is when N_Function_Call => return FCE (Name (E1), Name (E2)) - and then FCL (Parameter_Associations (E1), - Parameter_Associations (E2)); + and then + FCL (Parameter_Associations (E1), + Parameter_Associations (E2)); when N_Indexed_Component => return FCE (Prefix (E1), Prefix (E2)) - and then FCL (Expressions (E1), Expressions (E2)); + and then + FCL (Expressions (E1), Expressions (E2)); when N_Integer_Literal => return (Intval (E1) = Intval (E2)); @@ -6130,12 +6276,14 @@ package body Sem_Ch6 is when N_Qualified_Expression => return FCE (Subtype_Mark (E1), Subtype_Mark (E2)) - and then FCE (Expression (E1), Expression (E2)); + and then + FCE (Expression (E1), Expression (E2)); when N_Range => return FCE (Low_Bound (E1), Low_Bound (E2)) - and then FCE (High_Bound (E1), High_Bound (E2)); + and then + FCE (High_Bound (E1), High_Bound (E2)); when N_Real_Literal => return (Realval (E1) = Realval (E2)); @@ -6143,12 +6291,14 @@ package body Sem_Ch6 is when N_Selected_Component => return FCE (Prefix (E1), Prefix (E2)) - and then FCE (Selector_Name (E1), Selector_Name (E2)); + and then + FCE (Selector_Name (E1), Selector_Name (E2)); when N_Slice => return FCE (Prefix (E1), Prefix (E2)) - and then FCE (Discrete_Range (E1), Discrete_Range (E2)); + and then + FCE (Discrete_Range (E1), Discrete_Range (E2)); when N_String_Literal => declare @@ -6177,17 +6327,20 @@ package body Sem_Ch6 is when N_Type_Conversion => return FCE (Subtype_Mark (E1), Subtype_Mark (E2)) - and then FCE (Expression (E1), Expression (E2)); + and then + FCE (Expression (E1), Expression (E2)); when N_Unary_Op => return Entity (E1) = Entity (E2) - and then FCE (Right_Opnd (E1), Right_Opnd (E2)); + and then + FCE (Right_Opnd (E1), Right_Opnd (E2)); when N_Unchecked_Type_Conversion => return FCE (Subtype_Mark (E1), Subtype_Mark (E2)) - and then FCE (Expression (E1), Expression (E2)); + and then + FCE (Expression (E1), Expression (E2)); -- All other node types cannot appear in this context. Strictly -- we should raise a fatal internal error. Instead we just ignore @@ -6343,8 +6496,8 @@ package body Sem_Ch6 is or else Etype (Prim) = Etype (Iface_Prim) or else not Has_Controlling_Result (Prim) then - return Type_Conformant (Prim, Iface_Prim, - Skip_Controlling_Formals => True); + return Type_Conformant + (Iface_Prim, Prim, Skip_Controlling_Formals => True); -- Case of a function returning an interface, or an access to one. -- Check that the return types correspond. @@ -6481,7 +6634,6 @@ package body Sem_Ch6 is -- instance of) a generic type. Formal := First_Formal (Prev_E); - while Present (Formal) loop F_Typ := Base_Type (Etype (Formal)); @@ -6792,8 +6944,9 @@ package body Sem_Ch6 is and then (not Is_Overriding or else not Is_Abstract_Subprogram (E)) then - Error_Msg_N ("abstract subprograms must be visible " - & "(RM 3.9.3(10))!", S); + Error_Msg_N + ("abstract subprograms must be visible " + & "(RM 3.9.3(10))!", S); elsif Ekind (S) = E_Function and then Is_Tagged_Type (T) @@ -7409,9 +7562,11 @@ package body Sem_Ch6 is -- E exists and is overloadable else - -- Ada 2005 (AI-251): Derivation of abstract interface primitives - -- need no check against the homonym chain. They are directly added - -- to the list of primitive operations of Derived_Type. + -- Ada 2005 (AI-251): Derivation of abstract interface primitives. + -- They are directly added to the list of primitive operations of + -- Derived_Type, unless this is a rederivation in the private part + -- of an operation that was already derived in the visible part of + -- the current package. if Ada_Version >= Ada_05 and then Present (Derived_Type) @@ -7419,7 +7574,16 @@ package body Sem_Ch6 is and then Present (Find_Dispatching_Type (Alias (S))) and then Is_Interface (Find_Dispatching_Type (Alias (S))) then - goto Add_New_Entity; + if Type_Conformant (E, S) + and then Is_Package_Or_Generic_Package (Current_Scope) + and then In_Private_Part (Current_Scope) + and then Parent (E) /= Parent (S) + and then Alias (E) = Alias (S) + then + Check_Operation_From_Private_View (S, E); + else + goto Add_New_Entity; + end if; end if; Check_Synchronized_Overriding (S, Overridden_Subp); diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 27505f215a9..b797791c24f 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -261,8 +261,7 @@ package body Sem_Ch7 is Error_Msg_N ("optional package body (not allowed in Ada 95)?", N); else - Error_Msg_N - ("spec of this package does not allow a body", N); + Error_Msg_N ("spec of this package does not allow a body", N); end if; end if; end if; @@ -1954,6 +1953,7 @@ package body Sem_Ch7 is Set_Is_Volatile (Priv, Is_Volatile (Full)); Set_Treat_As_Volatile (Priv, Treat_As_Volatile (Full)); Set_Is_Ada_2005_Only (Priv, Is_Ada_2005_Only (Full)); + Set_Has_Pragma_Unmodified (Priv, Has_Pragma_Unmodified (Full)); Set_Has_Pragma_Unreferenced (Priv, Has_Pragma_Unreferenced (Full)); Set_Has_Pragma_Unreferenced_Objects (Priv, Has_Pragma_Unreferenced_Objects @@ -2032,6 +2032,11 @@ package body Sem_Ch7 is end if; Set_Has_Discriminants (Priv, Has_Discriminants (Full)); + + if Has_Discriminants (Full) then + Set_Discriminant_Constraint (Priv, + Discriminant_Constraint (Full)); + end if; end if; end Preserve_Full_Attributes; @@ -2068,7 +2073,7 @@ package body Sem_Ch7 is -- but the formals are private and remain so. if Ekind (Id) = E_Function - and then Is_Operator_Symbol_Name (Chars (Id)) + and then Is_Operator_Symbol_Name (Chars (Id)) and then not Is_Hidden (Id) and then not Error_Posted (Id) then diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index a25d1d6ab54..370e2d68975 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -398,15 +398,20 @@ package body Sem_Ch8 is -- must be added to the list of actuals in any subsequent call. function Applicable_Use (Pack_Name : Node_Id) return Boolean; - -- Common code to Use_One_Package and Set_Use, to determine whether - -- use clause must be processed. Pack_Name is an entity name that - -- references the package in question. + -- Common code to Use_One_Package and Set_Use, to determine whether use + -- clause must be processed. Pack_Name is an entity name that references + -- the package in question. procedure Attribute_Renaming (N : Node_Id); -- Analyze renaming of attribute as subprogram. The renaming declaration N -- is rewritten as a subprogram body that returns the attribute reference -- applied to the formals of the function. + procedure Set_Entity_Or_Discriminal (N : Node_Id; E : Entity_Id); + -- Set Entity, with style check if need be. For a discriminant reference, + -- replace by the corresponding discriminal, i.e. the parameter of the + -- initialization procedure that corresponds to the discriminant. + procedure Check_Frozen_Renaming (N : Node_Id; Subp : Entity_Id); -- A renaming_as_body may occur after the entity of the original decla- -- ration has been frozen. In that case, the body of the new entity must @@ -893,7 +898,7 @@ package body Sem_Ch8 is Error_Msg_NE ("\?function & will be called only once", Nam, Entity (Name (Nam))); - Error_Msg_N + Error_Msg_N -- CODEFIX ("\?suggest using an initialized constant object instead", Nam); end if; @@ -910,9 +915,7 @@ package body Sem_Ch8 is then declare Loc : constant Source_Ptr := Sloc (N); - Subt : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); + Subt : constant Entity_Id := Make_Temporary (Loc, 'T'); begin Remove_Side_Effects (Nam); Insert_Action (N, @@ -1315,7 +1318,8 @@ package body Sem_Ch8 is begin if not Is_Overloaded (P) then if Ekind (Etype (Nam)) /= E_Subprogram_Type - or else not Type_Conformant (Etype (Nam), New_S) then + or else not Type_Conformant (Etype (Nam), New_S) + then Error_Msg_N ("designated type does not match specification", P); else Resolve (P); @@ -1330,8 +1334,8 @@ package body Sem_Ch8 is while Present (It.Nam) loop if Ekind (It.Nam) = E_Subprogram_Type - and then Type_Conformant (It.Nam, New_S) then - + and then Type_Conformant (It.Nam, New_S) + then if Typ /= Any_Id then Error_Msg_N ("ambiguous renaming", P); return; @@ -2149,9 +2153,7 @@ package body Sem_Ch8 is -- Guard against previous errors, and omit renamings of predefined -- operators. - elsif Ekind (Old_S) /= E_Function - and then Ekind (Old_S) /= E_Procedure - then + elsif not Ekind_In (Old_S, E_Function, E_Procedure) then null; elsif Requires_Overriding (Old_S) @@ -2584,8 +2586,7 @@ package body Sem_Ch8 is ("a generic package is not allowed in a use clause", Pack_Name); else - Error_Msg_N -- CODEFIX??? - ("& is not a usable package", Pack_Name); + Error_Msg_N ("& is not a usable package", Pack_Name); end if; else @@ -2706,7 +2707,7 @@ package body Sem_Ch8 is if Warn_On_Redundant_Constructs and then Pack = Current_Scope then - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("& is already use-visible within itself?", Pack_Name, Pack); end if; @@ -2838,19 +2839,17 @@ package body Sem_Ch8 is if Aname = Name_AST_Entry then declare - Ent : Entity_Id; + Ent : constant Entity_Id := Make_Temporary (Loc, 'R', Nam); Decl : Node_Id; begin - Ent := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); - Decl := Make_Object_Declaration (Loc, Defining_Identifier => Ent, - Object_Definition => + Object_Definition => New_Occurrence_Of (RTE (RE_AST_Handler), Loc), - Expression => Nam, - Constant_Present => True); + Expression => Nam, + Constant_Present => True); Set_Assignment_OK (Decl, True); Insert_Action (N, Decl); @@ -3042,6 +3041,56 @@ package body Sem_Ch8 is end if; end Check_Frozen_Renaming; + ------------------------------- + -- Set_Entity_Or_Discriminal -- + ------------------------------- + + procedure Set_Entity_Or_Discriminal (N : Node_Id; E : Entity_Id) is + P : Node_Id; + + begin + -- If the entity is not a discriminant, or else expansion is disabled, + -- simply set the entity. + + if not In_Spec_Expression + or else Ekind (E) /= E_Discriminant + or else Inside_A_Generic + then + Set_Entity_With_Style_Check (N, E); + + -- The replacement of a discriminant by the corresponding discriminal + -- is not done for a task discriminant that appears in a default + -- expression of an entry parameter. See Expand_Discriminant in exp_ch2 + -- for details on their handling. + + elsif Is_Concurrent_Type (Scope (E)) then + + P := Parent (N); + while Present (P) + and then not Nkind_In (P, N_Parameter_Specification, + N_Component_Declaration) + loop + P := Parent (P); + end loop; + + if Present (P) + and then Nkind (P) = N_Parameter_Specification + then + null; + + else + Set_Entity (N, Discriminal (E)); + end if; + + -- Otherwise, this is a discriminant in a context in which + -- it is a reference to the corresponding parameter of the + -- init proc for the enclosing type. + + else + Set_Entity (N, Discriminal (E)); + end if; + end Set_Entity_Or_Discriminal; + ----------------------------------- -- Check_In_Previous_With_Clause -- ----------------------------------- @@ -3076,8 +3125,7 @@ package body Sem_Ch8 is end loop; if Is_Child_Unit (Entity (Original_Node (Par))) then - Error_Msg_NE - ("& is not directly visible", Par, Entity (Par)); + Error_Msg_NE ("& is not directly visible", Par, Entity (Par)); else return; end if; @@ -3426,33 +3474,47 @@ package body Sem_Ch8 is ------------------ procedure End_Use_Type (N : Node_Id) is + Elmt : Elmt_Id; Id : Entity_Id; Op_List : Elist_Id; - Elmt : Elmt_Id; + Op : Entity_Id; T : Entity_Id; + function May_Be_Used_Primitive_Of (T : Entity_Id) return Boolean; + -- An operator may be primitive in several types, if they are declared + -- in the same scope as the operator. To determine the use-visiblity of + -- the operator in such cases we must examine all types in the profile. + + ------------------------------ + -- May_Be_Used_Primitive_Of -- + ------------------------------ + + function May_Be_Used_Primitive_Of (T : Entity_Id) return Boolean is + begin + return Scope (Op) = Scope (T) + and then (In_Use (T) or else Is_Potentially_Use_Visible (T)); + end May_Be_Used_Primitive_Of; + + -- Start of processing for End_Use_Type + begin Id := First (Subtype_Marks (N)); while Present (Id) loop - -- A call to rtsfind may occur while analyzing a use_type clause, + -- A call to Rtsfind may occur while analyzing a use_type clause, -- in which case the type marks are not resolved yet, and there is -- nothing to remove. - if not Is_Entity_Name (Id) - or else No (Entity (Id)) - then + if not Is_Entity_Name (Id) or else No (Entity (Id)) then goto Continue; end if; T := Entity (Id); - if T = Any_Type - or else From_With_Type (T) - then + if T = Any_Type or else From_With_Type (T) then null; - -- Note that the use_Type clause may mention a subtype of the type + -- Note that the use_type clause may mention a subtype of the type -- whose primitive operations have been made visible. Here as -- elsewhere, it is the base type that matters for visibility. @@ -3468,8 +3530,30 @@ package body Sem_Ch8 is Elmt := First_Elmt (Op_List); while Present (Elmt) loop - if Nkind (Node (Elmt)) = N_Defining_Operator_Symbol then - Set_Is_Potentially_Use_Visible (Node (Elmt), False); + Op := Node (Elmt); + + if Nkind (Op) = N_Defining_Operator_Symbol then + declare + T_First : constant Entity_Id := + Base_Type (Etype (First_Formal (Op))); + T_Res : constant Entity_Id := Base_Type (Etype (Op)); + T_Next : Entity_Id; + + begin + if Present (Next_Formal (First_Formal (Op))) then + T_Next := + Base_Type (Etype (Next_Formal (First_Formal (Op)))); + else + T_Next := T_First; + end if; + + if not May_Be_Used_Primitive_Of (T_First) + and then not May_Be_Used_Primitive_Of (T_Next) + and then not May_Be_Used_Primitive_Of (T_Res) + then + Set_Is_Potentially_Use_Visible (Op, False); + end if; + end; end if; Next_Elmt (Elmt); @@ -3805,9 +3889,20 @@ package body Sem_Ch8 is Nkind (Parent (Parent (N))) = N_Use_Package_Clause then Error_Msg_Qual_Level := 99; - Error_Msg_NE ("\\missing `WITH &;`", N, Ent); + Error_Msg_NE -- CODEFIX + ("\\missing `WITH &;`", N, Ent); Error_Msg_Qual_Level := 0; end if; + + if Ekind (Ent) = E_Discriminant + and then Present (Corresponding_Discriminant (Ent)) + and then Scope (Corresponding_Discriminant (Ent)) = + Etype (Scope (Ent)) + then + Error_Msg_N + ("inherited discriminant not allowed here" & + " (RM 3.8 (12), 3.8.1 (6))!", N); + end if; end if; -- Set entity and its containing package as referenced. We @@ -3873,7 +3968,7 @@ package body Sem_Ch8 is if Chars (Lit) /= Chars (N) and then Is_Bad_Spelling_Of (Chars (N), Chars (Lit)) then Error_Msg_Node_2 := Lit; - Error_Msg_N + Error_Msg_N -- CODEFIX ("& is undefined, assume misspelling of &", N); Rewrite (N, New_Occurrence_Of (Lit, Sloc (N))); return; @@ -3937,7 +4032,7 @@ package body Sem_Ch8 is -- this is a very common error for beginners to make). if Chars (N) = Name_Put or else Chars (N) = Name_Put_Line then - Error_Msg_N + Error_Msg_N -- CODEFIX ("\\possible missing `WITH Ada.Text_'I'O; " & "USE Ada.Text_'I'O`!", N); @@ -3950,7 +4045,8 @@ package body Sem_Ch8 is and then Is_Known_Unit (Parent (N)) then Error_Msg_Node_2 := Selector_Name (Parent (N)); - Error_Msg_N ("\\missing `WITH &.&;`", Prefix (Parent (N))); + Error_Msg_N -- CODEFIX + ("\\missing `WITH &.&;`", Prefix (Parent (N))); end if; -- Now check for possible misspellings @@ -4336,8 +4432,18 @@ package body Sem_Ch8 is return; end if; - Set_Entity (N, E); - -- Why no Style_Check here??? + -- Set the entity. Note that the reason we call Set_Entity for the + -- overloadable case, as opposed to Set_Entity_With_Style_Check is + -- that in the overloaded case, the initial call can set the wrong + -- homonym. The call that sets the right homonym is in Sem_Res and + -- that call does use Set_Entity_With_Style_Check, so we don't miss + -- a style check. + + if Is_Overloadable (E) then + Set_Entity (N, E); + else + Set_Entity_With_Style_Check (N, E); + end if; if Is_Type (E) then Set_Etype (N, E); @@ -4447,58 +4553,7 @@ package body Sem_Ch8 is Check_Nested_Access (E); end if; - -- Set Entity, with style check if need be. For a discriminant - -- reference, replace by the corresponding discriminal, i.e. the - -- parameter of the initialization procedure that corresponds to - -- the discriminant. If this replacement is being performed, there - -- is no style check to perform. - - -- This replacement must not be done if we are currently - -- processing a generic spec or body, because the discriminal - -- has not been not generated in this case. - - -- The replacement is also skipped if we are in special - -- spec-expression mode. Why is this skipped in this case ??? - - if not In_Spec_Expression - or else Ekind (E) /= E_Discriminant - or else Inside_A_Generic - then - Set_Entity_With_Style_Check (N, E); - - -- The replacement is not done either for a task discriminant that - -- appears in a default expression of an entry parameter. See - -- Expand_Discriminant in exp_ch2 for details on their handling. - - elsif Is_Concurrent_Type (Scope (E)) then - declare - P : Node_Id; - - begin - P := Parent (N); - while Present (P) - and then not Nkind_In (P, N_Parameter_Specification, - N_Component_Declaration) - loop - P := Parent (P); - end loop; - - if Present (P) - and then Nkind (P) = N_Parameter_Specification - then - null; - else - Set_Entity (N, Discriminal (E)); - end if; - end; - - -- Otherwise, this is a discriminant in a context in which - -- it is a reference to the corresponding parameter of the - -- init proc for the enclosing type. - - else - Set_Entity (N, Discriminal (E)); - end if; + Set_Entity_Or_Discriminal (N, E); end if; end; end Find_Direct_Name; @@ -4688,7 +4743,8 @@ package body Sem_Ch8 is else Error_Msg_Qual_Level := 99; - Error_Msg_NE ("missing `WITH &;`", Selector, Candidate); + Error_Msg_NE -- CODEFIX + ("missing `WITH &;`", Selector, Candidate); Error_Msg_Qual_Level := 0; end if; @@ -4719,9 +4775,9 @@ package body Sem_Ch8 is exit when S = Standard_Standard; - if Ekind (S) = E_Function - or else Ekind (S) = E_Package - or else Ekind (S) = E_Procedure + if Ekind_In (S, E_Function, + E_Package, + E_Procedure) then P := Generic_Parent (Specification (Unit_Declaration_Node (S))); @@ -4745,7 +4801,8 @@ package body Sem_Ch8 is if Is_Known_Unit (N) then if not Error_Posted (N) then Error_Msg_Node_2 := Selector; - Error_Msg_N ("missing `WITH &.&;`", Prefix (N)); + Error_Msg_N -- CODEFIX + ("missing `WITH &.&;`", Prefix (N)); end if; -- If this is a selection from a dummy package, then suppress @@ -4785,11 +4842,17 @@ package body Sem_Ch8 is ("\use fully qualified name starting with" & " Standard to make& visible", N, H); Error_Msg_Qual_Level := 0; - exit; + goto Done; end if; Next_Entity (Id); end loop; + + -- If not found, standard error message. + + Error_Msg_NE ("& not declared in&", N, Selector); + + <> null; end; else @@ -4820,7 +4883,8 @@ package body Sem_Ch8 is (Generic_Parent (Parent (Entity (Prefix (N))))) then Error_Msg_Node_2 := Selector; - Error_Msg_N ("\missing `WITH &.&;`", Prefix (N)); + Error_Msg_N -- CODEFIX + ("\missing `WITH &.&;`", Prefix (N)); end if; end if; end if; @@ -4885,7 +4949,7 @@ package body Sem_Ch8 is if Has_Homonym (Id) then Set_Entity (N, Id); else - Set_Entity_With_Style_Check (N, Id); + Set_Entity_Or_Discriminal (N, Id); Generate_Reference (Id, N); end if; @@ -5112,11 +5176,11 @@ package body Sem_Ch8 is function Report_Overload return Entity_Id is begin if Is_Actual then - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("ambiguous actual subprogram&, " & "possible interpretations:", N, Nam); else - Error_Msg_N + Error_Msg_N -- CODEFIX ("ambiguous subprogram, " & "possible interpretations:", N); end if; @@ -5582,7 +5646,19 @@ package body Sem_Ch8 is -- It is legal to denote the class type of an incomplete -- type. The full type will have to be tagged, of course. -- In Ada 2005 this usage is declared obsolescent, so we - -- warn accordingly. + -- warn accordingly. This usage is only legal if the type + -- is completed in the current scope, and not for a limited + -- view of a type. + + if not Is_Tagged_Type (T) + and then Ada_Version >= Ada_05 + then + if From_With_Type (T) then + Error_Msg_N + ("prefix of Class attribute must be tagged", N); + Set_Etype (N, Any_Type); + Set_Entity (N, Any_Type); + return; -- ??? This test is temporarily disabled (always False) -- because it causes an unwanted warning on GNAT sources @@ -5590,14 +5666,13 @@ package body Sem_Ch8 is -- Feature). Once this issue is cleared in the sources, it -- can be enabled. - if not Is_Tagged_Type (T) - and then Ada_Version >= Ada_05 - and then Warn_On_Obsolescent_Feature - and then False - then - Error_Msg_N - ("applying 'Class to an untagged incomplete type" - & " is an obsolescent feature (RM J.11)", N); + elsif Warn_On_Obsolescent_Feature + and then False + then + Error_Msg_N + ("applying 'Class to an untagged incomplete type" + & " is an obsolescent feature (RM J.11)", N); + end if; end if; Set_Is_Tagged_Type (T); @@ -5685,7 +5760,7 @@ package body Sem_Ch8 is and then Base_Type (Typ) = Typ and then Warn_On_Redundant_Constructs then - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("?redundant attribute, & is its own base type", N, Typ); end if; @@ -5968,12 +6043,45 @@ package body Sem_Ch8 is Change_Selected_Component_To_Expanded_Name (N); end if; - Add_One_Interp (N, Predef_Op, T); + -- If the context is an unanalyzed function call, determine whether + -- a binary or unary interpretation is required. - -- For operators with unary and binary interpretations, add both + if Nkind (Parent (N)) = N_Indexed_Component then + declare + Is_Binary_Call : constant Boolean := + Present + (Next (First (Expressions (Parent (N))))); + Is_Binary_Op : constant Boolean := + First_Entity + (Predef_Op) /= Last_Entity (Predef_Op); + Predef_Op2 : constant Entity_Id := Homonym (Predef_Op); - if Present (Homonym (Predef_Op)) then - Add_One_Interp (N, Homonym (Predef_Op), T); + begin + if Is_Binary_Call then + if Is_Binary_Op then + Add_One_Interp (N, Predef_Op, T); + else + Add_One_Interp (N, Predef_Op2, T); + end if; + + else + if not Is_Binary_Op then + Add_One_Interp (N, Predef_Op, T); + else + Add_One_Interp (N, Predef_Op2, T); + end if; + end if; + end; + + else + Add_One_Interp (N, Predef_Op, T); + + -- For operators with unary and binary interpretations, if + -- context is not a call, add both + + if Present (Homonym (Predef_Op)) then + Add_One_Interp (N, Homonym (Predef_Op), T); + end if; end if; -- The node is a reference to a predefined operator, and @@ -6170,9 +6278,7 @@ package body Sem_Ch8 is Next_Formal (Old_F); end loop; - if Ekind (Old_S) = E_Function - or else Ekind (Old_S) = E_Enumeration_Literal - then + if Ekind_In (Old_S, E_Function, E_Enumeration_Literal) then Set_Etype (New_S, Etype (Old_S)); end if; end if; @@ -6488,7 +6594,7 @@ package body Sem_Ch8 is if Present (Redundant) then Error_Msg_Sloc := Sloc (Prev_Use); - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("& is already use-visible through previous use clause #?", Redundant, Pack_Name); end if; @@ -7162,11 +7268,11 @@ package body Sem_Ch8 is -- we compare the scope depth of its scope with that of the -- current instance. However, a generic actual of a subprogram -- instance is declared in the wrapper package but will not be - -- hidden by a use-visible entity. Similarly, a generic actual - -- will not be hidden by an entity declared in another generic - -- actual, which can only have been use-visible in the generic. - -- Is this condition complete, and can the following complex - -- test be simplified ??? + -- hidden by a use-visible entity. similarly, an entity that is + -- declared in an enclosing instance will not be hidden by an + -- an entity declared in a generic actual, which can only have + -- been use-visible in the generic and will not have hidden the + -- entity in the generic parent. -- If Id is called Standard, the predefined package with the -- same name is in the homonym chain. It has to be ignored @@ -7181,8 +7287,8 @@ package body Sem_Ch8 is and then (Scope (Prev) /= Standard_Standard or else Sloc (Prev) > Standard_Location) then - if Ekind (Prev) = E_Package - and then Present (Associated_Formal_Package (Prev)) + if In_Open_Scopes (Scope (Prev)) + and then Is_Generic_Instance (Scope (Prev)) and then Present (Associated_Formal_Package (P)) then null; @@ -7466,14 +7572,14 @@ package body Sem_Ch8 is if Unit1 = Unit2 then Error_Msg_Sloc := Sloc (Current_Use_Clause (T)); - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("& is already use-visible through previous " & "use_type_clause #?", Clause1, T); return; elsif Nkind (Unit1) = N_Subunit then Error_Msg_Sloc := Sloc (Current_Use_Clause (T)); - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("& is already use-visible through previous " & "use_type_clause #?", Clause1, T); return; @@ -7483,7 +7589,7 @@ package body Sem_Ch8 is and then Nkind (Unit1) /= N_Subunit then Error_Msg_Sloc := Sloc (Clause1); - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("& is already use-visible through previous " & "use_type_clause #?", Current_Use_Clause (T), T); return; @@ -7534,7 +7640,7 @@ package body Sem_Ch8 is end; end if; - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("& is already use-visible through previous " & "use_type_clause #?", Err_No, Id); @@ -7543,7 +7649,7 @@ package body Sem_Ch8 is -- level. In this case we don't have location information. else - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("& is already use-visible through previous " & "use type clause?", Id, T); end if; @@ -7553,7 +7659,7 @@ package body Sem_Ch8 is -- where we do not have the location information available. else - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("& is already use-visible through previous " & "use type clause?", Id, T); end if; @@ -7562,7 +7668,7 @@ package body Sem_Ch8 is elsif In_Use (Scope (T)) then Error_Msg_Sloc := Sloc (Current_Use_Clause (Scope (T))); - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("& is already use-visible through package use clause #?", Id, T); @@ -7570,7 +7676,7 @@ package body Sem_Ch8 is else Error_Msg_Node_2 := Scope (T); - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("& is already use-visible inside package &?", Id, T); end if; end if; diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 9a242d5eedd..21f80dfd713 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -30,7 +30,6 @@ with Errout; use Errout; with Exp_Ch9; use Exp_Ch9; with Elists; use Elists; with Freeze; use Freeze; -with Itypes; use Itypes; with Lib.Xref; use Lib.Xref; with Namet; use Namet; with Nlists; use Nlists; @@ -167,73 +166,6 @@ package body Sem_Ch9 is Kind : Entity_Kind; Task_Nam : Entity_Id; - ----------------------- - -- Actual_Index_Type -- - ----------------------- - - function Actual_Index_Type (E : Entity_Id) return Entity_Id; - -- If the bounds of an entry family depend on task discriminants, create - -- a new index type where a discriminant is replaced by the local - -- variable that renames it in the task body. - - ----------------------- - -- Actual_Index_Type -- - ----------------------- - - function Actual_Index_Type (E : Entity_Id) return Entity_Id is - Typ : constant Entity_Id := Entry_Index_Type (E); - Lo : constant Node_Id := Type_Low_Bound (Typ); - Hi : constant Node_Id := Type_High_Bound (Typ); - New_T : Entity_Id; - - function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id; - -- If bound is discriminant reference, replace with corresponding - -- local variable of the same name. - - ----------------------------- - -- Actual_Discriminant_Ref -- - ----------------------------- - - function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is - Typ : constant Entity_Id := Etype (Bound); - Ref : Node_Id; - begin - if not Is_Entity_Name (Bound) - or else Ekind (Entity (Bound)) /= E_Discriminant - then - return Bound; - else - Ref := Make_Identifier (Sloc (N), Chars (Entity (Bound))); - Analyze (Ref); - Resolve (Ref, Typ); - return Ref; - end if; - end Actual_Discriminant_Ref; - - -- Start of processing for Actual_Index_Type - - begin - if not Has_Discriminants (Task_Nam) - or else (not Is_Entity_Name (Lo) - and then not Is_Entity_Name (Hi)) - then - return Entry_Index_Type (E); - else - New_T := Create_Itype (Ekind (Typ), N); - Set_Etype (New_T, Base_Type (Typ)); - Set_Size_Info (New_T, Typ); - Set_RM_Size (New_T, RM_Size (Typ)); - Set_Scalar_Range (New_T, - Make_Range (Sloc (N), - Low_Bound => Actual_Discriminant_Ref (Lo), - High_Bound => Actual_Discriminant_Ref (Hi))); - - return New_T; - end if; - end Actual_Index_Type; - - -- Start of processing for Analyze_Accept_Statement - begin Tasking_Used := True; @@ -370,7 +302,7 @@ package body Sem_Ch9 is Error_Msg_N ("missing entry index in accept for entry family", N); else Analyze_And_Resolve (Index, Entry_Index_Type (E)); - Apply_Range_Check (Index, Actual_Index_Type (E)); + Apply_Range_Check (Index, Entry_Index_Type (E)); end if; elsif Present (Index) then @@ -991,9 +923,7 @@ package body Sem_Ch9 is procedure Analyze_Entry_Index_Specification (N : Node_Id) is Iden : constant Node_Id := Defining_Identifier (N); Def : constant Node_Id := Discrete_Subtype_Definition (N); - Loop_Id : constant Entity_Id := - Make_Defining_Identifier (Sloc (N), - Chars => New_Internal_Name ('L')); + Loop_Id : constant Entity_Id := Make_Temporary (Sloc (N), 'L'); begin Tasking_Used := True; @@ -1174,9 +1104,7 @@ package body Sem_Ch9 is E := First_Entity (Current_Scope); while Present (E) loop - if Ekind (E) = E_Function - or else Ekind (E) = E_Procedure - then + if Ekind_In (E, E_Function, E_Procedure) then Set_Convention (E, Convention_Protected); elsif Is_Task_Type (Etype (E)) @@ -1248,16 +1176,6 @@ package body Sem_Ch9 is Set_Is_Constrained (T, not Has_Discriminants (T)); - -- Perform minimal expansion of protected type while inside a generic. - -- The corresponding record is needed for various semantic checks. - - if Ada_Version >= Ada_05 - and then Inside_A_Generic - then - Insert_After_And_Analyze (N, - Build_Corresponding_Record (N, T, Sloc (T))); - end if; - Analyze (Protected_Definition (N)); -- Protected types with entries are controlled (because of the @@ -1343,9 +1261,7 @@ package body Sem_Ch9 is Enclosing := Scope_Stack.Table (J).Entity; exit when Is_Entry (Enclosing); - if Ekind (Enclosing) /= E_Block - and then Ekind (Enclosing) /= E_Loop - then + if not Ekind_In (Enclosing, E_Block, E_Loop) then Error_Msg_N ("requeue must appear within accept or entry body", N); return; end if; @@ -1576,10 +1492,7 @@ package body Sem_Ch9 is -- perform an unconditional goto so that any further -- references will not occur anyway. - if Ekind (Ent) = E_Out_Parameter - or else - Ekind (Ent) = E_In_Out_Parameter - then + if Ekind_In (Ent, E_Out_Parameter, E_In_Out_Parameter) then Set_Never_Set_In_Source (Ent, False); Set_Is_True_Constant (Ent, False); end if; @@ -2053,15 +1966,6 @@ package body Sem_Ch9 is Set_Is_Constrained (T, not Has_Discriminants (T)); - -- Perform minimal expansion of the task type while inside a generic - -- context. The corresponding record is needed for various semantic - -- checks. - - if Inside_A_Generic then - Insert_After_And_Analyze (N, - Build_Corresponding_Record (N, T, Sloc (T))); - end if; - if Present (Task_Definition (N)) then Analyze_Task_Definition (Task_Definition (N)); end if; @@ -2433,15 +2337,17 @@ package body Sem_Ch9 is Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces); if Present (Iface) then - Error_Msg_NE ("interface & not implemented by full type " & - "(RM-2005 7.3 (7.3/2))", Priv_T, Iface); + Error_Msg_NE + ("interface & not implemented by full type " & + "(RM-2005 7.3 (7.3/2))", Priv_T, Iface); end if; Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces); if Present (Iface) then - Error_Msg_NE ("interface & not implemented by partial " & - "view (RM-2005 7.3 (7.3/2))", T, Iface); + Error_Msg_NE + ("interface & not implemented by partial " & + "view (RM-2005 7.3 (7.3/2))", T, Iface); end if; end if; end if; diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 9c9da627ee0..a21337bb600 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -175,10 +175,7 @@ package body Sem_Disp is Next_Formal (Formal); end loop; - if Ekind (Subp) = E_Function - or else - Ekind (Subp) = E_Generic_Function - then + if Ekind_In (Subp, E_Function, E_Generic_Function) then Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp); if Present (Ctrl_Type) then @@ -643,8 +640,8 @@ package body Sem_Disp is end if; if Present (Func) and then Is_Abstract_Subprogram (Func) then - Error_Msg_N ( - "call to abstract function must be dispatching", N); + Error_Msg_N + ("call to abstract function must be dispatching", N); end if; end if; @@ -673,25 +670,22 @@ package body Sem_Disp is Body_Is_Last_Primitive : Boolean := False; begin - if Ekind (Subp) /= E_Procedure and then Ekind (Subp) /= E_Function then + if not Ekind_In (Subp, E_Procedure, E_Function) then return; end if; Set_Is_Dispatching_Operation (Subp, False); Tagged_Type := Find_Dispatching_Type (Subp); - -- Ada 2005 (AI-345) + -- Ada 2005 (AI-345): Use the corresponding record (if available). + -- Required because primitives of concurrent types are be attached + -- to the corresponding record (not to the concurrent type). - if Ada_Version = Ada_05 + if Ada_Version >= Ada_05 and then Present (Tagged_Type) and then Is_Concurrent_Type (Tagged_Type) + and then Present (Corresponding_Record_Type (Tagged_Type)) then - -- Protect the frontend against previously detected errors - - if No (Corresponding_Record_Type (Tagged_Type)) then - return; - end if; - Tagged_Type := Corresponding_Record_Type (Tagged_Type); end if; @@ -749,7 +743,7 @@ package body Sem_Disp is and then not In_Instance then Error_Msg_N ("?declaration of& is too late!", Subp); - Error_Msg_NE + Error_Msg_NE -- CODEFIX?? ("\spec should appear immediately after declaration of &!", Subp, Typ); exit; @@ -790,7 +784,7 @@ package body Sem_Disp is and then not Comes_From_Source (Subp) and then not Has_Dispatching_Parent then - -- Complete decoration if internally built subprograms that override + -- Complete decoration of internally built subprograms that override -- a dispatching primitive. These entities correspond with the -- following cases: @@ -1071,6 +1065,18 @@ package body Sem_Disp is end if; end if; + -- If the tagged type is a concurrent type then we must be compiling + -- with no code generation (we are either compiling a generic unit or + -- compiling under -gnatc mode) because we have previously tested that + -- no serious errors has been reported. In this case we do not add the + -- primitive to the list of primitives of Tagged_Type but we leave the + -- primitive decorated as a dispatching operation to be able to analyze + -- and report errors associated with the Object.Operation notation. + + elsif Is_Concurrent_Type (Tagged_Type) then + pragma Assert (not Expander_Active); + null; + -- If no old subprogram, then we add this as a dispatching operation, -- but we avoid doing this if an error was posted, to prevent annoying -- cascaded errors. @@ -1499,7 +1505,7 @@ package body Sem_Disp is -- For subprograms internally generated by derivations of tagged types -- use the alias subprogram as a reference to locate the dispatching - -- type of Subp + -- type of Subp. elsif not Comes_From_Source (Subp) and then Present (Alias (Subp)) @@ -1703,7 +1709,28 @@ package body Sem_Disp is return; end if; - Replace_Elmt (Elmt, New_Op); + -- The location of entities that come from source in the list of + -- primitives of the tagged type must follow their order of occurrence + -- in the sources to fulfill the C++ ABI. If the overriden entity is a + -- primitive of an interface that is not an ancestor of this tagged + -- type (that is, it is an entity added to the list of primitives by + -- Derive_Interface_Progenitors), then we must append the new entity + -- at the end of the list of primitives. + + if Present (Alias (Prev_Op)) + and then Is_Interface (Find_Dispatching_Type (Alias (Prev_Op))) + and then not Is_Ancestor (Find_Dispatching_Type (Alias (Prev_Op)), + Tagged_Type) + then + Remove_Elmt (Primitive_Operations (Tagged_Type), Elmt); + Append_Elmt (New_Op, Primitive_Operations (Tagged_Type)); + + -- The new primitive replaces the overriden entity. Required to ensure + -- that overriding primitive is assigned the same dispatch table slot. + + else + Replace_Elmt (Elmt, New_Op); + end if; if Ada_Version >= Ada_05 and then Has_Interfaces (Tagged_Type) diff --git a/gcc/ada/sem_disp.ads b/gcc/ada/sem_disp.ads index c0195ecd4fd..3877826ca29 100644 --- a/gcc/ada/sem_disp.ads +++ b/gcc/ada/sem_disp.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -46,7 +46,12 @@ package Sem_Disp is -- if it has a parameter of this type and is defined at a proper place for -- primitive operations (new primitives are only defined in package spec, -- overridden operation can be defined in any scope). If Old_Subp is not - -- Empty we are in the overriding case. + -- Empty we are in the overriding case. If the tagged type associated with + -- Subp is a concurrent type (case that occurs when the type is declared in + -- a generic because the analysis of generics disables generation of the + -- corresponding record) then this routine does does not add "Subp" to the + -- list of primitive operations but leaves Subp decorated as dispatching + -- operation to enable checks associated with the Object.Operation notation procedure Check_Operation_From_Incomplete_Type (Subp : Entity_Id; diff --git a/gcc/ada/sem_dist.adb b/gcc/ada/sem_dist.adb index 111a9d2d0d6..64b85758a10 100644 --- a/gcc/ada/sem_dist.adb +++ b/gcc/ada/sem_dist.adb @@ -451,9 +451,7 @@ package body Sem_Dist is -- True iff this RAS has an access formal parameter (see -- Exp_Dist.Add_RAS_Dereference_TSS for details). - Subpkg : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('S')); + Subpkg : constant Entity_Id := Make_Temporary (Loc, 'S'); Subpkg_Decl : Node_Id; Subpkg_Body : Node_Id; Vis_Decls : constant List_Id := New_List; @@ -464,16 +462,14 @@ package body Sem_Dist is New_External_Name (Chars (User_Type), 'R')); Full_Obj_Type : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars (Obj_Type)); + Make_Defining_Identifier (Loc, Chars (Obj_Type)); RACW_Type : constant Entity_Id := Make_Defining_Identifier (Loc, New_External_Name (Chars (User_Type), 'P')); Fat_Type : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars (User_Type)); + Make_Defining_Identifier (Loc, Chars (User_Type)); Fat_Type_Decl : Node_Id; diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 1e278a6bb58..74aac9e5e0e 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -599,9 +599,7 @@ package body Sem_Elab is -- No checks needed for pure or preelaborated compilation units - if Is_Pure (E_Scope) - or else Is_Preelaborated (E_Scope) - then + if Is_Pure (E_Scope) or else Is_Preelaborated (E_Scope) then return; end if; @@ -1891,6 +1889,11 @@ package body Sem_Elab is elsif In_Task_Activation then return; + + -- Nothing to do if call is within a generic unit + + elsif Inside_A_Generic then + return; end if; -- Delay this call if we are still delaying calls @@ -2427,7 +2430,8 @@ package body Sem_Elab is and then not Elaboration_Checks_Suppressed (Task_Scope) then Error_Msg_Node_2 := Task_Scope; - Error_Msg_NE ("activation of an instance of task type&" & + Error_Msg_NE + ("activation of an instance of task type&" & " requires pragma Elaborate_All on &?", N, Ent); end if; @@ -3008,10 +3012,7 @@ package body Sem_Elab is -- Check for case of body entity -- Why is the check for E_Void needed??? - if Ekind (E) = E_Void - or else Ekind (E) = E_Subprogram_Body - or else Ekind (E) = E_Package_Body - then + if Ekind_In (E, E_Void, E_Subprogram_Body, E_Package_Body) then Decl := E; loop @@ -3042,17 +3043,17 @@ package body Sem_Elab is if No (Corresponding_Body (N)) then declare - Loc : constant Source_Ptr := Sloc (N); - B : Node_Id; - Formals : constant List_Id := - Copy_Parameter_List (Ent); - Nam : constant Entity_Id := - Make_Defining_Identifier (Loc, Chars (Ent)); - Spec : Node_Id; - Stats : constant List_Id := - New_List - (Make_Raise_Program_Error (Loc, - Reason => PE_Access_Before_Elaboration)); + Loc : constant Source_Ptr := Sloc (N); + B : Node_Id; + Formals : constant List_Id := Copy_Parameter_List (Ent); + Nam : constant Entity_Id := + Make_Defining_Identifier (Loc, Chars (Ent)); + Spec : Node_Id; + Stats : constant List_Id := + New_List + (Make_Raise_Program_Error (Loc, + Reason => PE_Access_Before_Elaboration)); + begin if Ekind (Ent) = E_Function then Spec := diff --git a/gcc/ada/sem_elim.adb b/gcc/ada/sem_elim.adb index e4c99fc01b6..c160c8e419a 100644 --- a/gcc/ada/sem_elim.adb +++ b/gcc/ada/sem_elim.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,7 +29,9 @@ with Errout; use Errout; with Lib; use Lib; with Namet; use Namet; with Nlists; use Nlists; +with Opt; use Opt; with Sem; use Sem; +with Sem_Aux; use Sem_Aux; with Sem_Prag; use Sem_Prag; with Sem_Util; use Sem_Util; with Sinput; use Sinput; @@ -234,6 +236,7 @@ package body Sem_Elim is Elmt : Access_Elim_Data; Scop : Entity_Id; Form : Entity_Id; + Up : Nat; begin if No_Elimination then @@ -286,21 +289,49 @@ package body Sem_Elim is goto Continue; end if; - -- Find enclosing unit + -- Find enclosing unit, and verify that its name and those of its + -- parents match. Scop := Cunit_Entity (Current_Sem_Unit); -- Now see if compilation unit matches - for J in reverse Elmt.Unit_Name'Range loop + Up := Elmt.Unit_Name'Last; + + -- If we are within a subunit, the name in the pragma has been + -- parsed as a child unit, but the current compilation unit is in + -- fact the parent in which the subunit is embedded. We must skip + -- the first name which is that of the subunit to match the pragma + -- specification. Body may be that of a package or subprogram. + + declare + Par : Node_Id; + + begin + Par := Parent (E); + while Present (Par) loop + if Nkind (Par) = N_Subunit then + if Chars (Defining_Entity (Proper_Body (Par))) = + Elmt.Unit_Name (Up) + then + Up := Up - 1; + exit; + + else + goto Continue; + end if; + end if; + + Par := Parent (Par); + end loop; + end; + + for J in reverse Elmt.Unit_Name'First .. Up loop if Elmt.Unit_Name (J) /= Chars (Scop) then goto Continue; end if; Scop := Scope (Scop); - while Ekind (Scop) = E_Block loop - Scop := Scope (Scop); - end loop; if Scop /= Standard_Standard and then J = 1 then goto Continue; @@ -311,8 +342,59 @@ package body Sem_Elim is goto Continue; end if; - -- Check for case of given entity is a library level subprogram - -- and we have the single parameter Eliminate case, a match! + if Present (Elmt.Entity_Node) + and then Elmt.Entity_Scope /= null + then + -- Check that names of enclosing scopes match. Skip blocks and + -- wrapper package of subprogram instances, which do not appear + -- in the pragma. + + Scop := Scope (E); + + for J in reverse Elmt.Entity_Scope'Range loop + while Ekind (Scop) = E_Block + or else + (Ekind (Scop) = E_Package + and then Is_Wrapper_Package (Scop)) + loop + Scop := Scope (Scop); + end loop; + + if Elmt.Entity_Scope (J) /= Chars (Scop) then + if Ekind (Scop) /= E_Protected_Type + or else Comes_From_Source (Scop) + then + goto Continue; + + -- For simple protected declarations, retrieve the source + -- name of the object, which appeared in the Eliminate + -- pragma. + + else + declare + Decl : constant Node_Id := + Original_Node (Parent (Scop)); + + begin + if Elmt.Entity_Scope (J) /= + Chars (Defining_Identifier (Decl)) + then + if J > 0 then + null; + end if; + goto Continue; + end if; + end; + end if; + + end if; + + Scop := Scope (Scop); + end loop; + end if; + + -- If given entity is a library level subprogram and pragma had a + -- single parameter, a match! if Is_Compilation_Unit (E) and then Is_Subprogram (E) @@ -332,9 +414,8 @@ package body Sem_Elim is -- Check for case of subprogram - elsif Ekind (E) = E_Function - or else Ekind (E) = E_Procedure - then + elsif Ekind_In (E, E_Function, E_Procedure) then + -- If Source_Location present, then see if it matches if Elmt.Source_Location /= No_Name then @@ -642,7 +723,20 @@ package body Sem_Elim is Enclosing_Subp := Enclosing_Subprogram (Enclosing_Subp); end loop; - Eliminate_Error_Msg (N, Ultimate_Subp); + -- Emit error, unless we are within an instance body and the expander + -- is disabled, indicating an instance within an enclosing generic. + -- In an instance, the ultimate alias is an internal entity, so place + -- the message on the original subprogram. + + if In_Instance_Body and then not Expander_Active then + null; + + elsif Comes_From_Source (Ultimate_Subp) then + Eliminate_Error_Msg (N, Ultimate_Subp); + + else + Eliminate_Error_Msg (N, S); + end if; end if; end Check_For_Eliminated_Subprogram; @@ -673,7 +767,9 @@ package body Sem_Elim is -- Otherwise should not fall through, entry should be in table else - raise Program_Error; + Error_Msg_NE + ("subprogram& is called but its alias is eliminated", N, E); + -- raise Program_Error; end if; end Eliminate_Error_Msg; diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index c9054f387a8..84bb34a66f2 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,6 +31,7 @@ with Elists; use Elists; with Errout; use Errout; with Eval_Fat; use Eval_Fat; with Exp_Util; use Exp_Util; +with Freeze; use Freeze; with Lib; use Lib; with Namet; use Namet; with Nmake; use Nmake; @@ -126,6 +127,10 @@ package body Sem_Eval is -- This is the actual cache, with entries consisting of node/value pairs, -- and the impossible value Node_High_Bound used for unset entries. + type Range_Membership is (In_Range, Out_Of_Range, Unknown); + -- Range membership may either be statically known to be in range or out + -- of range, or not statically known. Used for Test_In_Range below. + ----------------------- -- Local Subprograms -- ----------------------- @@ -176,6 +181,15 @@ package body Sem_Eval is -- used for producing the result of the static evaluation of the -- logical operators + function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id; + -- Check whether an arithmetic operation with universal operands which + -- is a rewritten function call with an explicit scope indication is + -- ambiguous: P."+" (1, 2) will be ambiguous if there is more than one + -- visible numeric type declared in P and the context does not impose a + -- type on the result (e.g. in the expression of a type conversion). + -- If ambiguous, emit an error and return Empty, else return the result + -- type of the operator. + procedure Test_Expression_Is_Foldable (N : Node_Id; Op1 : Node_Id; @@ -210,6 +224,18 @@ package body Sem_Eval is -- Same processing, except applies to an expression N with two operands -- Op1 and Op2. + function Test_In_Range + (N : Node_Id; + Typ : Entity_Id; + Assume_Valid : Boolean; + Fixed_Int : Boolean; + Int_Real : Boolean) return Range_Membership; + -- Common processing for Is_In_Range and Is_Out_Of_Range: + -- Returns In_Range or Out_Of_Range if it can be guaranteed at compile time + -- that expression N is known to be in or out of range of the subtype Typ. + -- If not compile time known, Unknown is returned. + -- See documentation of Is_In_Range for complete description of parameters. + procedure To_Bits (U : Uint; B : out Bits); -- Converts a Uint value to a bit string of length B'Length @@ -1430,6 +1456,7 @@ package body Sem_Eval is Right : constant Node_Id := Right_Opnd (N); Ltype : constant Entity_Id := Etype (Left); Rtype : constant Entity_Id := Etype (Right); + Otype : Entity_Id := Empty; Stat : Boolean; Fold : Boolean; @@ -1442,6 +1469,13 @@ package body Sem_Eval is return; end if; + if Is_Universal_Numeric_Type (Etype (Left)) + and then + Is_Universal_Numeric_Type (Etype (Right)) + then + Otype := Find_Universal_Operator_Type (N); + end if; + -- Fold for cases where both operands are of integer type if Is_Integer_Type (Ltype) and then Is_Integer_Type (Rtype) then @@ -1548,9 +1582,9 @@ package body Sem_Eval is Fold_Uint (N, Result, Stat); end; - -- Cases where at least one operand is a real. We handle the cases - -- of both reals, or mixed/real integer cases (the latter happen - -- only for divide and multiply, and the result is always real). + -- Cases where at least one operand is a real. We handle the cases of + -- both reals, or mixed/real integer cases (the latter happen only for + -- divide and multiply, and the result is always real). elsif Is_Real_Type (Ltype) or else Is_Real_Type (Rtype) then declare @@ -1593,6 +1627,14 @@ package body Sem_Eval is Fold_Ureal (N, Result, Stat); end; end if; + + -- If the operator was resolved to a specific type, make sure that type + -- is frozen even if the expression is folded into a literal (which has + -- a universal type). + + if Present (Otype) then + Freeze_Before (N, Otype); + end if; end Eval_Arithmetic_Op; ---------------------------- @@ -1632,10 +1674,7 @@ package body Sem_Eval is and then Present (Alias (Entity (Name (N)))) and then Is_Enumeration_Type (Base_Type (Typ)) then - Lit := Alias (Entity (Name (N))); - while Present (Alias (Lit)) loop - Lit := Alias (Lit); - end loop; + Lit := Ultimate_Alias (Entity (Name (N))); if Ekind (Lit) = E_Enumeration_Literal then if Base_Type (Etype (Lit)) /= Base_Type (Typ) then @@ -1650,6 +1689,27 @@ package body Sem_Eval is end if; end Eval_Call; + -------------------------- + -- Eval_Case_Expression -- + -------------------------- + + -- Right now we do not attempt folding of any case expressions, and the + -- language does not require it, so the only required processing is to + -- do the check for all expressions appearing in the case expression. + + procedure Eval_Case_Expression (N : Node_Id) is + Alt : Node_Id; + + begin + Check_Non_Static_Context (Expression (N)); + + Alt := First (Alternatives (N)); + while Present (Alt) loop + Check_Non_Static_Context (Expression (Alt)); + Next (Alt); + end loop; + end Eval_Case_Expression; + ------------------------ -- Eval_Concatenation -- ------------------------ @@ -1767,18 +1827,79 @@ package body Sem_Eval is -- Eval_Conditional_Expression -- --------------------------------- - -- This GNAT internal construct can never be statically folded, so the - -- only required processing is to do the check for non-static context - -- for the two expression operands. + -- We can fold to a static expression if the condition and both constituent + -- expressions are static. Otherwise, the only required processing is to do + -- the check for non-static context for the then and else expressions. procedure Eval_Conditional_Expression (N : Node_Id) is - Condition : constant Node_Id := First (Expressions (N)); - Then_Expr : constant Node_Id := Next (Condition); - Else_Expr : constant Node_Id := Next (Then_Expr); + Condition : constant Node_Id := First (Expressions (N)); + Then_Expr : constant Node_Id := Next (Condition); + Else_Expr : constant Node_Id := Next (Then_Expr); + Result : Node_Id; + Non_Result : Node_Id; + + Rstat : constant Boolean := + Is_Static_Expression (Condition) + and then + Is_Static_Expression (Then_Expr) + and then + Is_Static_Expression (Else_Expr); begin - Check_Non_Static_Context (Then_Expr); - Check_Non_Static_Context (Else_Expr); + -- If any operand is Any_Type, just propagate to result and do not try + -- to fold, this prevents cascaded errors. + + if Etype (Condition) = Any_Type or else + Etype (Then_Expr) = Any_Type or else + Etype (Else_Expr) = Any_Type + then + Set_Etype (N, Any_Type); + Set_Is_Static_Expression (N, False); + return; + + -- Static case where we can fold. Note that we don't try to fold cases + -- where the condition is known at compile time, but the result is + -- non-static. This avoids possible cases of infinite recursion where + -- the expander puts in a redundant test and we remove it. Instead we + -- deal with these cases in the expander. + + elsif Rstat then + + -- Select result operand + + if Is_True (Expr_Value (Condition)) then + Result := Then_Expr; + Non_Result := Else_Expr; + else + Result := Else_Expr; + Non_Result := Then_Expr; + end if; + + -- Note that it does not matter if the non-result operand raises a + -- Constraint_Error, but if the result raises constraint error then + -- we replace the node with a raise constraint error. This will + -- properly propagate Raises_Constraint_Error since this flag is + -- set in Result. + + if Raises_Constraint_Error (Result) then + Rewrite_In_Raise_CE (N, Result); + Check_Non_Static_Context (Non_Result); + + -- Otherwise the result operand replaces the original node + + else + Rewrite (N, Relocate_Node (Result)); + end if; + + -- Case of condition not known at compile time + + else + Check_Non_Static_Context (Condition); + Check_Non_Static_Context (Then_Expr); + Check_Non_Static_Context (Else_Expr); + end if; + + Set_Is_Static_Expression (N, Rstat); end Eval_Conditional_Expression; ---------------------- @@ -2069,7 +2190,11 @@ package body Sem_Eval is Right_Int : constant Uint := Expr_Value (Right); begin - if Is_Modular_Integer_Type (Etype (N)) then + -- VMS includes bitwise operations on signed types + + if Is_Modular_Integer_Type (Etype (N)) + or else Is_VMS_Operator (Entity (N)) + then declare Left_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1); Right_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1); @@ -2144,9 +2269,7 @@ package body Sem_Eval is -- Ignore if error in either operand, except to make sure that Any_Type -- is properly propagated to avoid junk cascaded errors. - if Etype (Left) = Any_Type - or else Etype (Right) = Any_Type - then + if Etype (Left) = Any_Type or else Etype (Right) = Any_Type then Set_Etype (N, Any_Type); return; end if; @@ -2219,7 +2342,8 @@ package body Sem_Eval is declare Typlen : constant Uint := String_Type_Len (Etype (Right)); Strlen : constant Uint := - UI_From_Int (String_Length (Strval (Get_String_Val (Left)))); + UI_From_Int + (String_Length (Strval (Get_String_Val (Left)))); begin Result := (Typlen = Strlen); end; @@ -2252,6 +2376,7 @@ package body Sem_Eval is end if; Fold_Uint (N, Test (Result), True); + Warn_On_Known_Condition (N); end Eval_Membership_Op; @@ -2311,8 +2436,8 @@ package body Sem_Eval is Result : Uint; begin - -- Exponentiation of an integer raises the exception - -- Constraint_Error for a negative exponent (RM 4.5.6) + -- Exponentiation of an integer raises Constraint_Error for a + -- negative exponent (RM 4.5.6). if Right_Int < 0 then Apply_Compile_Time_Constraint_Error @@ -2427,9 +2552,9 @@ package body Sem_Eval is begin -- Can only fold if target is string or scalar and subtype is static. - -- Also, do not fold if our parent is an allocator (this is because - -- the qualified expression is really part of the syntactic structure - -- of an allocator, and we do not want to end up with something that + -- Also, do not fold if our parent is an allocator (this is because the + -- qualified expression is really part of the syntactic structure of an + -- allocator, and we do not want to end up with something that -- corresponds to "new 1" where the 1 is the result of folding a -- qualified expression). @@ -2529,14 +2654,15 @@ package body Sem_Eval is -- Eval_Relational_Op -- ------------------------ - -- Relational operations are static functions, so the result is static - -- if both operands are static (RM 4.9(7), 4.9(20)), except that for - -- strings, the result is never static, even if the operands are. + -- Relational operations are static functions, so the result is static if + -- both operands are static (RM 4.9(7), 4.9(20)), except that for strings, + -- the result is never static, even if the operands are. procedure Eval_Relational_Op (N : Node_Id) is Left : constant Node_Id := Left_Opnd (N); Right : constant Node_Id := Right_Opnd (N); Typ : constant Entity_Id := Etype (Left); + Otype : Entity_Id := Empty; Result : Boolean; Stat : Boolean; Fold : Boolean; @@ -2615,7 +2741,7 @@ package body Sem_Eval is -- entity name, and the two X's are the same and K1 and K2 are -- known at compile time, in this case, the length can also be -- computed at compile time, even though the bounds are not - -- known. A common case of this is e.g. (X'First..X'First+5). + -- known. A common case of this is e.g. (X'First .. X'First+5). Extract_Length : declare procedure Decompose_Expr @@ -2645,17 +2771,37 @@ package body Sem_Eval is if Nkind (Expr) = N_Op_Add and then Compile_Time_Known_Value (Right_Opnd (Expr)) then - Exp := Left_Opnd (Expr); + Exp := Left_Opnd (Expr); Cons := Expr_Value (Right_Opnd (Expr)); elsif Nkind (Expr) = N_Op_Subtract and then Compile_Time_Known_Value (Right_Opnd (Expr)) then - Exp := Left_Opnd (Expr); + Exp := Left_Opnd (Expr); Cons := -Expr_Value (Right_Opnd (Expr)); + -- If the bound is a constant created to remove side + -- effects, recover original expression to see if it has + -- one of the recognizable forms. + + elsif Nkind (Expr) = N_Identifier + and then not Comes_From_Source (Entity (Expr)) + and then Ekind (Entity (Expr)) = E_Constant + and then + Nkind (Parent (Entity (Expr))) = N_Object_Declaration + then + Exp := Expression (Parent (Entity (Expr))); + Decompose_Expr (Exp, Ent, Kind, Cons); + + -- If original expression includes an entity, create a + -- reference to it for use below. + + if Present (Ent) then + Exp := New_Occurrence_Of (Ent, Sloc (Ent)); + end if; + else - Exp := Expr; + Exp := Expr; Cons := Uint_0; end if; @@ -2664,8 +2810,10 @@ package body Sem_Eval is if Nkind (Exp) = N_Attribute_Reference then if Attribute_Name (Exp) = Name_First then Kind := 'F'; + elsif Attribute_Name (Exp) = Name_Last then Kind := 'L'; + else Ent := Empty; return; @@ -2746,6 +2894,17 @@ package body Sem_Eval is Set_Is_Static_Expression (N, False); end if; + -- For operators on universal numeric types called as functions with + -- an explicit scope, determine appropriate specific numeric type, and + -- diagnose possible ambiguity. + + if Is_Universal_Numeric_Type (Etype (Left)) + and then + Is_Universal_Numeric_Type (Etype (Right)) + then + Otype := Find_Universal_Operator_Type (N); + end if; + -- For static real type expressions, we cannot use Compile_Time_Compare -- since it worries about run-time results which are not exact. @@ -2845,6 +3004,13 @@ package body Sem_Eval is Fold_Uint (N, Test (Result), Stat); end if; + -- For the case of a folded relational operator on a specific numeric + -- type, freeze operand type now. + + if Present (Otype) then + Freeze_Before (N, Otype); + end if; + Warn_On_Known_Condition (N); end Eval_Relational_Op; @@ -2852,9 +3018,9 @@ package body Sem_Eval is -- Eval_Shift -- ---------------- - -- Shift operations are intrinsic operations that can never be static, - -- so the only processing required is to perform the required check for - -- a non static context for the two operands. + -- Shift operations are intrinsic operations that can never be static, so + -- the only processing required is to perform the required check for a non + -- static context for the two operands. -- Actually we could do some compile time evaluation here some time ??? @@ -2868,24 +3034,24 @@ package body Sem_Eval is -- Eval_Short_Circuit -- ------------------------ - -- A short circuit operation is potentially static if both operands - -- are potentially static (RM 4.9 (13)) + -- A short circuit operation is potentially static if both operands are + -- potentially static (RM 4.9 (13)). procedure Eval_Short_Circuit (N : Node_Id) is Kind : constant Node_Kind := Nkind (N); Left : constant Node_Id := Left_Opnd (N); Right : constant Node_Id := Right_Opnd (N); Left_Int : Uint; - Rstat : constant Boolean := - Is_Static_Expression (Left) - and then Is_Static_Expression (Right); + + Rstat : constant Boolean := + Is_Static_Expression (Left) + and then + Is_Static_Expression (Right); begin -- Short circuit operations are never static in Ada 83 - if Ada_Version = Ada_83 - and then Comes_From_Source (N) - then + if Ada_Version = Ada_83 and then Comes_From_Source (N) then Check_Non_Static_Context (Left); Check_Non_Static_Context (Right); return; @@ -2896,8 +3062,8 @@ package body Sem_Eval is -- are a special case, they can still be foldable, even if the right -- operand raises constraint error. - -- If either operand is Any_Type, just propagate to result and - -- do not try to fold, this prevents cascaded errors. + -- If either operand is Any_Type, just propagate to result and do not + -- try to fold, this prevents cascaded errors. if Etype (Left) = Any_Type or else Etype (Right) = Any_Type then Set_Etype (N, Any_Type); @@ -2942,7 +3108,7 @@ package body Sem_Eval is if (Kind = N_And_Then and then Is_False (Left_Int)) or else - (Kind = N_Or_Else and then Is_True (Left_Int)) + (Kind = N_Or_Else and then Is_True (Left_Int)) then Fold_Uint (N, Left_Int, Rstat); return; @@ -2970,8 +3136,8 @@ package body Sem_Eval is -- Eval_Slice -- ---------------- - -- Slices can never be static, so the only processing required is to - -- check for non-static context if an explicit range is given. + -- Slices can never be static, so the only processing required is to check + -- for non-static context if an explicit range is given. procedure Eval_Slice (N : Node_Id) is Drange : constant Node_Id := Discrete_Range (N); @@ -2981,7 +3147,7 @@ package body Sem_Eval is Check_Non_Static_Context (High_Bound (Drange)); end if; - -- A slice of the form A (subtype), when the subtype is the index of + -- A slice of the form A (subtype), when the subtype is the index of -- the type of A, is redundant, the slice can be replaced with A, and -- this is worth a warning. @@ -3002,7 +3168,7 @@ package body Sem_Eval is Error_Msg_N ("redundant slice denotes whole array?", N); end if; - -- The following might be a useful optimization ???? + -- The following might be a useful optimization???? -- Rewrite (N, New_Occurrence_Of (E, Sloc (N))); end if; @@ -3024,7 +3190,7 @@ package body Sem_Eval is begin -- Nothing to do if error type (handles cases like default expressions - -- or generics where we have not yet fully resolved the type) + -- or generics where we have not yet fully resolved the type). if Bas = Any_Type or else Bas = Any_String then return; @@ -3042,7 +3208,7 @@ package body Sem_Eval is end if; -- Here if Etype of string literal is normal Etype (not yet possible, - -- but may be possible in future!) + -- but may be possible in future). elsif not Is_OK_Static_Expression (Type_Low_Bound (Etype (First_Index (Typ)))) @@ -3058,12 +3224,12 @@ package body Sem_Eval is return; end if; - -- Test for illegal Ada 95 cases. A string literal is illegal in - -- Ada 95 if its bounds are outside the index base type and this - -- index type is static. This can happen in only two ways. Either - -- the string literal is too long, or it is null, and the lower - -- bound is type'First. In either case it is the upper bound that - -- is out of range of the index type. + -- Test for illegal Ada 95 cases. A string literal is illegal in Ada 95 + -- if its bounds are outside the index base type and this index type is + -- static. This can happen in only two ways. Either the string literal + -- is too long, or it is null, and the lower bound is type'First. In + -- either case it is the upper bound that is out of range of the index + -- type. if Ada_Version >= Ada_95 then if Root_Type (Bas) = Standard_String @@ -3109,7 +3275,7 @@ package body Sem_Eval is -- A type conversion is potentially static if its subtype mark is for a -- static scalar subtype, and its operand expression is potentially static - -- (RM 4.9 (10)) + -- (RM 4.9(10)). procedure Eval_Type_Conversion (N : Node_Id) is Operand : constant Node_Id := Expression (N); @@ -3120,9 +3286,9 @@ package body Sem_Eval is Fold : Boolean; function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean; - -- Returns true if type T is an integer type, or if it is a - -- fixed-point type to be treated as an integer (i.e. the flag - -- Conversion_OK is set on the conversion node). + -- Returns true if type T is an integer type, or if it is a fixed-point + -- type to be treated as an integer (i.e. the flag Conversion_OK is set + -- on the conversion node). function To_Be_Treated_As_Real (T : Entity_Id) return Boolean; -- Returns true if type T is a floating-point type, or if it is a @@ -3256,10 +3422,11 @@ package body Sem_Eval is ------------------- -- Predefined unary operators are static functions (RM 4.9(20)) and thus - -- are potentially static if the operand is potentially static (RM 4.9(7)) + -- are potentially static if the operand is potentially static (RM 4.9(7)). procedure Eval_Unary_Op (N : Node_Id) is Right : constant Node_Id := Right_Opnd (N); + Otype : Entity_Id := Empty; Stat : Boolean; Fold : Boolean; @@ -3272,6 +3439,13 @@ package body Sem_Eval is return; end if; + if Etype (Right) = Universal_Integer + or else + Etype (Right) = Universal_Real + then + Otype := Find_Universal_Operator_Type (N); + end if; + -- Fold for integer case if Is_Integer_Type (Etype (N)) then @@ -3327,6 +3501,14 @@ package body Sem_Eval is Fold_Ureal (N, Result, Stat); end; end if; + + -- If the operator was resolved to a specific type, make sure that type + -- is frozen even if the expression is folded into a literal (which has + -- a universal type). + + if Present (Otype) then + Freeze_Before (N, Otype); + end if; end Eval_Unary_Op; ------------------------------- @@ -3353,8 +3535,8 @@ package body Sem_Eval is if Is_Entity_Name (N) then Ent := Entity (N); - -- An enumeration literal that was either in the source or - -- created as a result of static evaluation. + -- An enumeration literal that was either in the source or created + -- as a result of static evaluation. if Ekind (Ent) = E_Enumeration_Literal then return Enumeration_Rep (Ent); @@ -3366,8 +3548,8 @@ package body Sem_Eval is return Expr_Rep_Value (Constant_Value (Ent)); end if; - -- An integer literal that was either in the source or created - -- as a result of static evaluation. + -- An integer literal that was either in the source or created as a + -- result of static evaluation. elsif Kind = N_Integer_Literal then return Intval (N); @@ -3394,11 +3576,11 @@ package body Sem_Eval is pragma Assert (Kind = N_Character_Literal); Ent := Entity (N); - -- Since Character literals of type Standard.Character don't - -- have any defining character literals built for them, they - -- do not have their Entity set, so just use their Char - -- code. Otherwise for user-defined character literals use - -- their Pos value as usual which is the same as the Rep value. + -- Since Character literals of type Standard.Character don't have any + -- defining character literals built for them, they do not have their + -- Entity set, so just use their Char code. Otherwise for user- + -- defined character literals use their Pos value as usual which is + -- the same as the Rep value. if No (Ent) then return Char_Literal_Value (N); @@ -3432,8 +3614,8 @@ package body Sem_Eval is if Is_Entity_Name (N) then Ent := Entity (N); - -- An enumeration literal that was either in the source or - -- created as a result of static evaluation. + -- An enumeration literal that was either in the source or created as + -- a result of static evaluation. if Ekind (Ent) = E_Enumeration_Literal then Val := Enumeration_Pos (Ent); @@ -3445,8 +3627,8 @@ package body Sem_Eval is Val := Expr_Value (Constant_Value (Ent)); end if; - -- An integer literal that was either in the source or created - -- as a result of static evaluation. + -- An integer literal that was either in the source or created as a + -- result of static evaluation. elsif Kind = N_Integer_Literal then Val := Intval (N); @@ -3558,8 +3740,8 @@ package body Sem_Eval is return Ureal_0; end if; - -- If we fall through, we have a node that cannot be interpreted - -- as a compile time constant. That is definitely an error. + -- If we fall through, we have a node that cannot be interpreted as a + -- compile time constant. That is definitely an error. raise Program_Error; end Expr_Value_R; @@ -3578,6 +3760,144 @@ package body Sem_Eval is end if; end Expr_Value_S; + ---------------------------------- + -- Find_Universal_Operator_Type -- + ---------------------------------- + + function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id is + PN : constant Node_Id := Parent (N); + Call : constant Node_Id := Original_Node (N); + Is_Int : constant Boolean := Is_Integer_Type (Etype (N)); + + Is_Fix : constant Boolean := + Nkind (N) in N_Binary_Op + and then Nkind (Right_Opnd (N)) /= Nkind (Left_Opnd (N)); + -- A mixed-mode operation in this context indicates the presence of + -- fixed-point type in the designated package. + + Is_Relational : constant Boolean := Etype (N) = Standard_Boolean; + -- Case where N is a relational (or membership) operator (else it is an + -- arithmetic one). + + In_Membership : constant Boolean := + Nkind (PN) in N_Membership_Test + and then + Nkind (Right_Opnd (PN)) = N_Range + and then + Is_Universal_Numeric_Type (Etype (Left_Opnd (PN))) + and then + Is_Universal_Numeric_Type + (Etype (Low_Bound (Right_Opnd (PN)))) + and then + Is_Universal_Numeric_Type + (Etype (High_Bound (Right_Opnd (PN)))); + -- Case where N is part of a membership test with a universal range + + E : Entity_Id; + Pack : Entity_Id; + Typ1 : Entity_Id := Empty; + Priv_E : Entity_Id; + + function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean; + -- Check whether one operand is a mixed-mode operation that requires the + -- presence of a fixed-point type. Given that all operands are universal + -- and have been constant-folded, retrieve the original function call. + + --------------------------- + -- Is_Mixed_Mode_Operand -- + --------------------------- + + function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean is + Onod : constant Node_Id := Original_Node (Op); + begin + return Nkind (Onod) = N_Function_Call + and then Present (Next_Actual (First_Actual (Onod))) + and then Etype (First_Actual (Onod)) /= + Etype (Next_Actual (First_Actual (Onod))); + end Is_Mixed_Mode_Operand; + + -- Start of processing for Find_Universal_Operator_Type + + begin + if Nkind (Call) /= N_Function_Call + or else Nkind (Name (Call)) /= N_Expanded_Name + then + return Empty; + + -- There are several cases where the context does not imply the type of + -- the operands: + -- - the universal expression appears in a type conversion; + -- - the expression is a relational operator applied to universal + -- operands; + -- - the expression is a membership test with a universal operand + -- and a range with universal bounds. + + elsif Nkind (Parent (N)) = N_Type_Conversion + or else Is_Relational + or else In_Membership + then + Pack := Entity (Prefix (Name (Call))); + + -- If the prefix is a package declared elsewhere, iterate over its + -- visible entities, otherwise iterate over all declarations in the + -- designated scope. + + if Ekind (Pack) = E_Package + and then not In_Open_Scopes (Pack) + then + Priv_E := First_Private_Entity (Pack); + else + Priv_E := Empty; + end if; + + Typ1 := Empty; + E := First_Entity (Pack); + while Present (E) and then E /= Priv_E loop + if Is_Numeric_Type (E) + and then Nkind (Parent (E)) /= N_Subtype_Declaration + and then Comes_From_Source (E) + and then Is_Integer_Type (E) = Is_Int + and then + (Nkind (N) in N_Unary_Op + or else Is_Relational + or else Is_Fixed_Point_Type (E) = Is_Fix) + then + if No (Typ1) then + Typ1 := E; + + -- Before emitting an error, check for the presence of a + -- mixed-mode operation that specifies a fixed point type. + + elsif Is_Relational + and then + (Is_Mixed_Mode_Operand (Left_Opnd (N)) + or else Is_Mixed_Mode_Operand (Right_Opnd (N))) + and then Is_Fixed_Point_Type (E) /= Is_Fixed_Point_Type (Typ1) + + then + if Is_Fixed_Point_Type (E) then + Typ1 := E; + end if; + + else + -- More than one type of the proper class declared in P + + Error_Msg_N ("ambiguous operation", N); + Error_Msg_Sloc := Sloc (Typ1); + Error_Msg_N ("\possible interpretation (inherited)#", N); + Error_Msg_Sloc := Sloc (E); + Error_Msg_N ("\possible interpretation (inherited)#", N); + return Empty; + end if; + end if; + + Next_Entity (E); + end loop; + end if; + + return Typ1; + end Find_Universal_Operator_Type; + -------------------------- -- Flag_Non_Static_Expr -- -------------------------- @@ -3623,8 +3943,8 @@ package body Sem_Eval is Ent : Entity_Id; begin - -- If we are folding a named number, retain the entity in the - -- literal, for ASIS use. + -- If we are folding a named number, retain the entity in the literal, + -- for ASIS use. if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Named_Integer @@ -3677,8 +3997,8 @@ package body Sem_Eval is Ent : Entity_Id; begin - -- If we are folding a named number, retain the entity in the - -- literal, for ASIS use. + -- If we are folding a named number, retain the entity in the literal, + -- for ASIS use. if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Named_Real @@ -3872,78 +4192,9 @@ package body Sem_Eval is Fixed_Int : Boolean := False; Int_Real : Boolean := False) return Boolean is - Val : Uint; - Valr : Ureal; - - pragma Warnings (Off, Assume_Valid); - -- For now Assume_Valid is unreferenced since the current implementation - -- always returns False if N is not a compile time known value, but we - -- keep the parameter to allow for future enhancements in which we try - -- to get the information in the variable case as well. - begin - -- Universal types have no range limits, so always in range - - if Typ = Universal_Integer or else Typ = Universal_Real then - return True; - - -- Never in range if not scalar type. Don't know if this can - -- actually happen, but our spec allows it, so we must check! - - elsif not Is_Scalar_Type (Typ) then - return False; - - -- Never in range unless we have a compile time known value - - elsif not Compile_Time_Known_Value (N) then - return False; - - -- General processing with a known compile time value - - else - declare - Lo : Node_Id; - Hi : Node_Id; - LB_Known : Boolean; - UB_Known : Boolean; - - begin - Lo := Type_Low_Bound (Typ); - Hi := Type_High_Bound (Typ); - - LB_Known := Compile_Time_Known_Value (Lo); - UB_Known := Compile_Time_Known_Value (Hi); - - -- Fixed point types should be considered as such only in - -- flag Fixed_Int is set to False. - - if Is_Floating_Point_Type (Typ) - or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int) - or else Int_Real - then - Valr := Expr_Value_R (N); - - if LB_Known and then Valr >= Expr_Value_R (Lo) - and then UB_Known and then Valr <= Expr_Value_R (Hi) - then - return True; - else - return False; - end if; - - else - Val := Expr_Value (N); - - if LB_Known and then Val >= Expr_Value (Lo) - and then UB_Known and then Val <= Expr_Value (Hi) - then - return True; - else - return False; - end if; - end if; - end; - end if; + return Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real) + = In_Range; end Is_In_Range; ------------------- @@ -3998,8 +4249,8 @@ package body Sem_Eval is -- Is_OK_Static_Subtype -- -------------------------- - -- Determines if Typ is a static subtype as defined in (RM 4.9(26)) - -- where neither bound raises constraint error when evaluated. + -- Determines if Typ is a static subtype as defined in (RM 4.9(26)) where + -- neither bound raises constraint error when evaluated. function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean is Base_T : constant Entity_Id := Base_Type (Typ); @@ -4041,8 +4292,8 @@ package body Sem_Eval is return True; else - -- Scalar_Range (Typ) might be an N_Subtype_Indication, so - -- use Get_Type_Low,High_Bound. + -- Scalar_Range (Typ) might be an N_Subtype_Indication, so use + -- Get_Type_{Low,High}_Bound. return Is_OK_Static_Subtype (Anc_Subt) and then Is_OK_Static_Expression (Type_Low_Bound (Typ)) @@ -4067,90 +4318,9 @@ package body Sem_Eval is Fixed_Int : Boolean := False; Int_Real : Boolean := False) return Boolean is - Val : Uint; - Valr : Ureal; - - pragma Warnings (Off, Assume_Valid); - -- For now Assume_Valid is unreferenced since the current implementation - -- always returns False if N is not a compile time known value, but we - -- keep the parameter to allow for future enhancements in which we try - -- to get the information in the variable case as well. - begin - -- Universal types have no range limits, so always in range - - if Typ = Universal_Integer or else Typ = Universal_Real then - return False; - - -- Never out of range if not scalar type. Don't know if this can - -- actually happen, but our spec allows it, so we must check! - - elsif not Is_Scalar_Type (Typ) then - return False; - - -- Never out of range if this is a generic type, since the bounds - -- of generic types are junk. Note that if we only checked for - -- static expressions (instead of compile time known values) below, - -- we would not need this check, because values of a generic type - -- can never be static, but they can be known at compile time. - - elsif Is_Generic_Type (Typ) then - return False; - - -- Never out of range unless we have a compile time known value - - elsif not Compile_Time_Known_Value (N) then - return False; - - else - declare - Lo : Node_Id; - Hi : Node_Id; - LB_Known : Boolean; - UB_Known : Boolean; - - begin - Lo := Type_Low_Bound (Typ); - Hi := Type_High_Bound (Typ); - - LB_Known := Compile_Time_Known_Value (Lo); - UB_Known := Compile_Time_Known_Value (Hi); - - -- Real types (note that fixed-point types are not treated - -- as being of a real type if the flag Fixed_Int is set, - -- since in that case they are regarded as integer types). - - if Is_Floating_Point_Type (Typ) - or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int) - or else Int_Real - then - Valr := Expr_Value_R (N); - - if LB_Known and then Valr < Expr_Value_R (Lo) then - return True; - - elsif UB_Known and then Expr_Value_R (Hi) < Valr then - return True; - - else - return False; - end if; - - else - Val := Expr_Value (N); - - if LB_Known and then Val < Expr_Value (Lo) then - return True; - - elsif UB_Known and then Expr_Value (Hi) < Val then - return True; - - else - return False; - end if; - end if; - end; - end if; + return Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real) + = Out_Of_Range; end Is_Out_Of_Range; --------------------- @@ -4275,10 +4445,9 @@ package body Sem_Eval is begin -- If we have the static expression case, then this is an illegality -- in Ada 95 mode, except that in an instance, we never generate an - -- error (if the error is legitimate, it was already diagnosed in - -- the template). The expression to compute the length of a packed - -- array is attached to the array type itself, and deserves a separate - -- message. + -- error (if the error is legitimate, it was already diagnosed in the + -- template). The expression to compute the length of a packed array is + -- attached to the array type itself, and deserves a separate message. if Is_Static_Expression (N) and then not In_Instance @@ -4300,8 +4469,8 @@ package body Sem_Eval is (N, "value not in range of}", CE_Range_Check_Failed); end if; - -- Here we generate a warning for the Ada 83 case, or when we are - -- in an instance, or when we have a non-static expression case. + -- Here we generate a warning for the Ada 83 case, or when we are in an + -- instance, or when we have a non-static expression case. else Apply_Compile_Time_Constraint_Error @@ -4317,22 +4486,22 @@ package body Sem_Eval is Typ : constant Entity_Id := Etype (N); begin - -- If we want to raise CE in the condition of a raise_CE node - -- we may as well get rid of the condition + -- If we want to raise CE in the condition of a N_Raise_CE node + -- we may as well get rid of the condition. if Present (Parent (N)) and then Nkind (Parent (N)) = N_Raise_Constraint_Error then Set_Condition (Parent (N), Empty); - -- If the expression raising CE is a N_Raise_CE node, we can use - -- that one. We just preserve the type of the context + -- If the expression raising CE is a N_Raise_CE node, we can use that + -- one. We just preserve the type of the context. elsif Nkind (Exp) = N_Raise_Constraint_Error then Rewrite (N, Exp); Set_Etype (N, Typ); - -- We have to build an explicit raise_ce node + -- Else build an explcit N_Raise_CE else Rewrite (N, @@ -4470,15 +4639,15 @@ package body Sem_Eval is -- subtype, i.e. both types must be constrained or unconstrained. -- To understand the requirement for this test, see RM 4.9.1(1). - -- As is made clear in RM 3.5.4(11), type Integer, for example - -- is a constrained subtype with constraint bounds matching the - -- bounds of its corresponding unconstrained base type. In this - -- situation, Integer and Integer'Base do not statically match, - -- even though they have the same bounds. + -- As is made clear in RM 3.5.4(11), type Integer, for example is + -- a constrained subtype with constraint bounds matching the bounds + -- of its corresponding unconstrained base type. In this situation, + -- Integer and Integer'Base do not statically match, even though + -- they have the same bounds. - -- We only apply this test to types in Standard and types that - -- appear in user programs. That way, we do not have to be - -- too careful about setting Is_Constrained right for itypes. + -- We only apply this test to types in Standard and types that appear + -- in user programs. That way, we do not have to be too careful about + -- setting Is_Constrained right for Itypes. if Is_Numeric_Type (T1) and then (Is_Constrained (T1) /= Is_Constrained (T2)) @@ -4489,9 +4658,9 @@ package body Sem_Eval is then return False; - -- A generic scalar type does not statically match its base - -- type (AI-311). In this case we make sure that the formals, - -- which are first subtypes of their bases, are constrained. + -- A generic scalar type does not statically match its base type + -- (AI-311). In this case we make sure that the formals, which are + -- first subtypes of their bases, are constrained. elsif Is_Generic_Type (T1) and then Is_Generic_Type (T2) @@ -4500,8 +4669,8 @@ package body Sem_Eval is return False; end if; - -- If there was an error in either range, then just assume - -- the types statically match to avoid further junk errors + -- If there was an error in either range, then just assume the types + -- statically match to avoid further junk errors. if Error_Posted (Scalar_Range (T1)) or else @@ -4532,8 +4701,8 @@ package body Sem_Eval is then return False; - -- If either type has constraint error bounds, then say - -- that they match to avoid junk cascaded errors here. + -- If either type has constraint error bounds, then say that + -- they match to avoid junk cascaded errors here. elsif not Is_OK_Static_Subtype (T1) or else not Is_OK_Static_Subtype (T2) @@ -4643,11 +4812,11 @@ package body Sem_Eval is return True; - -- A definite type does not match an indefinite or classwide type + -- A definite type does not match an indefinite or classwide type. -- However, a generic type with unknown discriminants may be -- instantiated with a type with no discriminants, and conformance - -- checking on an inherited operation may compare the actual with - -- the subtype that renames it in the instance. + -- checking on an inherited operation may compare the actual with the + -- subtype that renames it in the instance. elsif Has_Unknown_Discriminants (T1) /= Has_Unknown_Discriminants (T2) @@ -4659,16 +4828,15 @@ package body Sem_Eval is elsif Is_Array_Type (T1) then - -- If either subtype is unconstrained then both must be, - -- and if both are unconstrained then no further checking - -- is needed. + -- If either subtype is unconstrained then both must be, and if both + -- are unconstrained then no further checking is neede. if not Is_Constrained (T1) or else not Is_Constrained (T2) then return not (Is_Constrained (T1) or else Is_Constrained (T2)); end if; - -- Both subtypes are constrained, so check that the index - -- subtypes statically match. + -- Both subtypes are constrained, so check that the index subtypes + -- statically match. declare Index1 : Node_Id := First_Index (T1); @@ -4693,8 +4861,8 @@ package body Sem_Eval is if Can_Never_Be_Null (T1) /= Can_Never_Be_Null (T2) then return False; - elsif Ekind (T1) = E_Access_Subprogram_Type - or else Ekind (T1) = E_Anonymous_Access_Subprogram_Type + elsif Ekind_In (T1, E_Access_Subprogram_Type, + E_Anonymous_Access_Subprogram_Type) then return Subtype_Conformant @@ -4819,8 +4987,8 @@ package body Sem_Eval is Set_Etype (N, Any_Type); return; - -- If left operand raises constraint error, then replace node N with - -- the raise constraint error node, and we are obviously not foldable. + -- If left operand raises constraint error, then replace node N with the + -- Raise_Constraint_Error node, and we are obviously not foldable. -- Is_Static_Expression is set from the two operands in the normal way, -- and we check the right operand if it is in a non-static context. @@ -4833,9 +5001,9 @@ package body Sem_Eval is Set_Is_Static_Expression (N, Rstat); return; - -- Similar processing for the case of the right operand. Note that - -- we don't use this routine for the short-circuit case, so we do - -- not have to worry about that special case here. + -- Similar processing for the case of the right operand. Note that we + -- don't use this routine for the short-circuit case, so we do not have + -- to worry about that special case here. elsif Raises_Constraint_Error (Op2) then if not Rstat then @@ -4855,7 +5023,7 @@ package body Sem_Eval is return; -- If result is not static, then check non-static contexts on operands - -- since one of them may be static and the other one may not be static + -- since one of them may be static and the other one may not be static. elsif not Rstat then Check_Non_Static_Context (Op1); @@ -4864,8 +5032,8 @@ package body Sem_Eval is and then Compile_Time_Known_Value (Op2); return; - -- Else result is static and foldable. Both operands are static, - -- and neither raises constraint error, so we can definitely fold. + -- Else result is static and foldable. Both operands are static, and + -- neither raises constraint error, so we can definitely fold. else Set_Is_Static_Expression (N); @@ -4875,6 +5043,125 @@ package body Sem_Eval is end if; end Test_Expression_Is_Foldable; + ------------------- + -- Test_In_Range -- + ------------------- + + function Test_In_Range + (N : Node_Id; + Typ : Entity_Id; + Assume_Valid : Boolean; + Fixed_Int : Boolean; + Int_Real : Boolean) return Range_Membership + is + Val : Uint; + Valr : Ureal; + + pragma Warnings (Off, Assume_Valid); + -- For now Assume_Valid is unreferenced since the current implementation + -- always returns Unknown if N is not a compile time known value, but we + -- keep the parameter to allow for future enhancements in which we try + -- to get the information in the variable case as well. + + begin + -- Universal types have no range limits, so always in range + + if Typ = Universal_Integer or else Typ = Universal_Real then + return In_Range; + + -- Never known if not scalar type. Don't know if this can actually + -- happen, but our spec allows it, so we must check! + + elsif not Is_Scalar_Type (Typ) then + return Unknown; + + -- Never known if this is a generic type, since the bounds of generic + -- types are junk. Note that if we only checked for static expressions + -- (instead of compile time known values) below, we would not need this + -- check, because values of a generic type can never be static, but they + -- can be known at compile time. + + elsif Is_Generic_Type (Typ) then + return Unknown; + + -- Never known unless we have a compile time known value + + elsif not Compile_Time_Known_Value (N) then + return Unknown; + + -- General processing with a known compile time value + + else + declare + Lo : Node_Id; + Hi : Node_Id; + + LB_Known : Boolean; + HB_Known : Boolean; + + begin + Lo := Type_Low_Bound (Typ); + Hi := Type_High_Bound (Typ); + + LB_Known := Compile_Time_Known_Value (Lo); + HB_Known := Compile_Time_Known_Value (Hi); + + -- Fixed point types should be considered as such only if flag + -- Fixed_Int is set to False. + + if Is_Floating_Point_Type (Typ) + or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int) + or else Int_Real + then + Valr := Expr_Value_R (N); + + if LB_Known and HB_Known then + if Valr >= Expr_Value_R (Lo) + and then + Valr <= Expr_Value_R (Hi) + then + return In_Range; + else + return Out_Of_Range; + end if; + + elsif (LB_Known and then Valr < Expr_Value_R (Lo)) + or else + (HB_Known and then Valr > Expr_Value_R (Hi)) + then + return Out_Of_Range; + + else + return Unknown; + end if; + + else + Val := Expr_Value (N); + + if LB_Known and HB_Known then + if Val >= Expr_Value (Lo) + and then + Val <= Expr_Value (Hi) + then + return In_Range; + else + return Out_Of_Range; + end if; + + elsif (LB_Known and then Val < Expr_Value (Lo)) + or else + (HB_Known and then Val > Expr_Value (Hi)) + then + return Out_Of_Range; + + else + return Unknown; + end if; + end if; + end; + end if; + end Test_In_Range; + -------------- -- To_Bits -- -------------- @@ -4896,8 +5183,8 @@ package body Sem_Eval is E : Entity_Id; procedure Why_Not_Static_List (L : List_Id); - -- A version that can be called on a list of expressions. Finds - -- all non-static violations in any element of the list. + -- A version that can be called on a list of expressions. Finds all + -- non-static violations in any element of the list. ------------------------- -- Why_Not_Static_List -- @@ -4919,8 +5206,8 @@ package body Sem_Eval is -- Start of processing for Why_Not_Static begin - -- If in ACATS mode (debug flag 2), then suppress all these - -- messages, this avoids massive updates to the ACATS base line. + -- If in ACATS mode (debug flag 2), then suppress all these messages, + -- this avoids massive updates to the ACATS base line. if Debug_Flag_2 then return; @@ -5044,8 +5331,8 @@ package body Sem_Eval is return; - -- Special case generic types, since again this is a common - -- source of confusion. + -- Special case generic types, since again this is a common source + -- of confusion. elsif Is_Generic_Actual_Type (E) or else diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads index 565ce675873..078ac375c35 100644 --- a/gcc/ada/sem_eval.ads +++ b/gcc/ada/sem_eval.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -282,6 +282,7 @@ package Sem_Eval is procedure Eval_Allocator (N : Node_Id); procedure Eval_Arithmetic_Op (N : Node_Id); procedure Eval_Call (N : Node_Id); + procedure Eval_Case_Expression (N : Node_Id); procedure Eval_Character_Literal (N : Node_Id); procedure Eval_Concatenation (N : Node_Id); procedure Eval_Conditional_Expression (N : Node_Id); diff --git a/gcc/ada/sem_intr.adb b/gcc/ada/sem_intr.adb index 42136b13ee8..20a1614fb06 100644 --- a/gcc/ada/sem_intr.adb +++ b/gcc/ada/sem_intr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -53,8 +53,8 @@ package body Sem_Intr is -- returns type String. procedure Check_Intrinsic_Operator (E : Entity_Id; N : Node_Id); - -- Check that operator is one of the binary arithmetic operators, and - -- that the types involved have the same size. + -- Check that operator is one of the binary arithmetic operators, and that + -- the types involved both have underlying integer types. procedure Check_Shift (E : Entity_Id; N : Node_Id); -- Check intrinsic shift subprogram, the two arguments are the same @@ -73,9 +73,7 @@ package body Sem_Intr is procedure Check_Exception_Function (E : Entity_Id; N : Node_Id) is begin - if Ekind (E) /= E_Function - and then Ekind (E) /= E_Generic_Function - then + if not Ekind_In (E, E_Function, E_Generic_Function) then Errint ("intrinsic exception subprogram must be a function", E, N); @@ -200,11 +198,24 @@ package body Sem_Intr is T2 := Etype (Next_Formal (First_Formal (E))); end if; - if Root_Type (T1) /= Root_Type (T2) - or else Root_Type (T1) /= Root_Type (Ret) + if Root_Type (T1) = Root_Type (T2) + or else Root_Type (T1) = Root_Type (Ret) + then + -- Same types, predefined operator will apply + + null; + + elsif Is_Integer_Type (Underlying_Type (T1)) + and then Is_Integer_Type (Underlying_Type (T2)) + and then Is_Integer_Type (Underlying_Type (Ret)) then + -- Expansion will introduce conversions if sizes are not equal + + null; + + else Errint - ("types of intrinsic operator must have the same size", E, N); + ("types of intrinsic operator operands do not match", E, N); end if; -- Comparison operators @@ -274,7 +285,7 @@ package body Sem_Intr is return; end if; - if not Is_Numeric_Type (T1) then + if not Is_Numeric_Type (Underlying_Type (T1)) then Errint ("intrinsic operator can only apply to numeric types", E, N); end if; end Check_Intrinsic_Operator; @@ -374,9 +385,7 @@ package body Sem_Intr is Ptyp2 : Node_Id; begin - if Ekind (E) /= E_Function - and then Ekind (E) /= E_Generic_Function - then + if not Ekind_In (E, E_Function, E_Generic_Function) then Errint ("intrinsic shift subprogram must be a function", E, N); return; end if; diff --git a/gcc/ada/sem_mech.adb b/gcc/ada/sem_mech.adb index 5f18176b8c2..1954b3deb74 100644 --- a/gcc/ada/sem_mech.adb +++ b/gcc/ada/sem_mech.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -92,8 +92,7 @@ package body Sem_Mech is return; elsif Chars (Mech_Name) = Name_Copy then - Error_Msg_N - ("bad mechanism name, Value assumed", Mech_Name); + Error_Msg_N ("bad mechanism name, Value assumed", Mech_Name); Set_Mechanism (Ent, By_Copy); else diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 29b4cdf7db6..e5afd0cebb8 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -46,6 +46,7 @@ with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; with Output; use Output; +with Par_SCO; use Par_SCO; with Restrict; use Restrict; with Rident; use Rident; with Rtsfind; use Rtsfind; @@ -376,10 +377,6 @@ package body Sem_Prag is -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If -- Typ is left Empty, then any static expression is allowed. - procedure Check_Arg_Is_String_Literal (Arg : Node_Id); - -- Check the specified argument Arg to make sure that it is a string - -- literal. If not give error and raise Pragma_Exit - procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id); -- Check the specified argument Arg to make sure that it is a valid task -- dispatching policy name. If not give error and raise Pragma_Exit. @@ -1014,19 +1011,6 @@ package body Sem_Prag is end if; end Check_Arg_Is_Static_Expression; - --------------------------------- - -- Check_Arg_Is_String_Literal -- - --------------------------------- - - procedure Check_Arg_Is_String_Literal (Arg : Node_Id) is - Argx : constant Node_Id := Get_Pragma_Arg (Arg); - begin - if Nkind (Argx) /= N_String_Literal then - Error_Pragma_Arg - ("argument for pragma% must be string literal", Argx); - end if; - end Check_Arg_Is_String_Literal; - ------------------------------------------ -- Check_Arg_Is_Task_Dispatching_Policy -- ------------------------------------------ @@ -1154,14 +1138,6 @@ package body Sem_Prag is String_Val : constant String_Id := Strval (Nam); begin - -- We allow duplicated export names in CIL, as they are always - -- enclosed in a namespace that differentiates them, and overloaded - -- entities are supported by the VM. - - if VM_Target = CLI_Target then - return; - end if; - -- We are only interested in the export case, and in the case of -- generics, it is the instance, not the template, that is the -- problem (the template will generate a warning in any case). @@ -1418,9 +1394,12 @@ package body Sem_Prag is Pragma_Misplaced; end if; - -- Record whether pragma is enabled + -- Record if pragma is enabled - Set_Pragma_Enabled (N, Check_Enabled (Pname)); + if Check_Enabled (Pname) then + Set_Pragma_Enabled (N); + Set_SCO_Pragma_Enabled (Loc); + end if; -- If we are within an inlined body, the legality of the pragma -- has been checked already. @@ -1867,7 +1846,8 @@ package body Sem_Prag is Proc := Entity (Name); if Ekind (Proc) /= E_Procedure - or else Present (First_Formal (Proc)) then + or else Present (First_Formal (Proc)) + then Error_Pragma_Arg ("argument of pragma% must be parameterless procedure", Arg); end if; @@ -2366,12 +2346,176 @@ package body Sem_Prag is Cname : Name_Id; Comp_Unit : Unit_Number_Type; + procedure Diagnose_Multiple_Pragmas (S : Entity_Id); + -- Called if we have more than one Export/Import/Convention pragma. + -- This is generally illegal, but we have a special case of allowing + -- Import and Interface to coexist if they specify the convention in + -- a consistent manner. We are allowed to do this, since Interface is + -- an implementation defined pragma, and we choose to do it since we + -- know Rational allows this combination. S is the entity id of the + -- subprogram in question. This procedure also sets the special flag + -- Import_Interface_Present in both pragmas in the case where we do + -- have matching Import and Interface pragmas. + procedure Set_Convention_From_Pragma (E : Entity_Id); -- Set convention in entity E, and also flag that the entity has a -- convention pragma. If entity is for a private or incomplete type, -- also set convention and flag on underlying type. This procedure -- also deals with the special case of C_Pass_By_Copy convention. + ------------------------------- + -- Diagnose_Multiple_Pragmas -- + ------------------------------- + + procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is + Pdec : constant Node_Id := Declaration_Node (S); + Decl : Node_Id; + Err : Boolean; + + function Same_Convention (Decl : Node_Id) return Boolean; + -- Decl is a pragma node. This function returns True if this + -- pragma has a first argument that is an identifier with a + -- Chars field corresponding to the Convention_Id C. + + function Same_Name (Decl : Node_Id) return Boolean; + -- Decl is a pragma node. This function returns True if this + -- pragma has a second argument that is an identifier with a + -- Chars field that matches the Chars of the current subprogram. + + --------------------- + -- Same_Convention -- + --------------------- + + function Same_Convention (Decl : Node_Id) return Boolean is + Arg1 : constant Node_Id := + First (Pragma_Argument_Associations (Decl)); + + begin + if Present (Arg1) then + declare + Arg : constant Node_Id := Get_Pragma_Arg (Arg1); + begin + if Nkind (Arg) = N_Identifier + and then Is_Convention_Name (Chars (Arg)) + and then Get_Convention_Id (Chars (Arg)) = C + then + return True; + end if; + end; + end if; + + return False; + end Same_Convention; + + --------------- + -- Same_Name -- + --------------- + + function Same_Name (Decl : Node_Id) return Boolean is + Arg1 : constant Node_Id := + First (Pragma_Argument_Associations (Decl)); + Arg2 : Node_Id; + + begin + if No (Arg1) then + return False; + end if; + + Arg2 := Next (Arg1); + + if No (Arg2) then + return False; + end if; + + declare + Arg : constant Node_Id := Get_Pragma_Arg (Arg2); + begin + if Nkind (Arg) = N_Identifier + and then Chars (Arg) = Chars (S) + then + return True; + end if; + end; + + return False; + end Same_Name; + + -- Start of processing for Diagnose_Multiple_Pragmas + + begin + Err := True; + + -- Definitely give message if we have Convention/Export here + + if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then + null; + + -- If we have an Import or Export, scan back from pragma to + -- find any previous pragma applying to the same procedure. + -- The scan will be terminated by the start of the list, or + -- hitting the subprogram declaration. This won't allow one + -- pragma to appear in the public part and one in the private + -- part, but that seems very unlikely in practice. + + else + Decl := Prev (N); + while Present (Decl) and then Decl /= Pdec loop + + -- Look for pragma with same name as us + + if Nkind (Decl) = N_Pragma + and then Same_Name (Decl) + then + -- Give error if same as our pragma or Export/Convention + + if Pragma_Name (Decl) = Name_Export + or else + Pragma_Name (Decl) = Name_Convention + or else + Pragma_Name (Decl) = Pragma_Name (N) + then + exit; + + -- Case of Import/Interface or the other way round + + elsif Pragma_Name (Decl) = Name_Interface + or else + Pragma_Name (Decl) = Name_Import + then + -- Here we know that we have Import and Interface. It + -- doesn't matter which way round they are. See if + -- they specify the same convention. If so, all OK, + -- and set special flags to stop other messages + + if Same_Convention (Decl) then + Set_Import_Interface_Present (N); + Set_Import_Interface_Present (Decl); + Err := False; + + -- If different conventions, special message + + else + Error_Msg_Sloc := Sloc (Decl); + Error_Pragma_Arg + ("convention differs from that given#", Arg1); + return; + end if; + end if; + end if; + + Next (Decl); + end loop; + end if; + + -- Give message if needed if we fall through those tests + + if Err then + Error_Pragma_Arg + ("at most one Convention/Export/Import pragma is allowed", + Arg2); + end if; + end Diagnose_Multiple_Pragmas; + -------------------------------- -- Set_Convention_From_Pragma -- -------------------------------- @@ -2537,10 +2681,7 @@ package body Sem_Prag is -- Check that we are not applying this to a named constant - if Ekind (E) = E_Named_Integer - or else - Ekind (E) = E_Named_Real - then + if Ekind_In (E, E_Named_Integer, E_Named_Real) then Error_Msg_Name_1 := Pname; Error_Msg_N ("cannot apply pragma% to named constant!", @@ -2568,8 +2709,7 @@ package body Sem_Prag is end if; if Has_Convention_Pragma (E) then - Error_Pragma_Arg - ("at most one Convention/Export/Import pragma is allowed", Arg2); + Diagnose_Multiple_Pragmas (E); elsif Convention (E) = Convention_Protected or else Ekind (Scope (E)) = E_Protected_Type @@ -2597,7 +2737,7 @@ package body Sem_Prag is and then Ekind (E) /= E_Variable and then not (Is_Access_Type (E) - and then Ekind (Designated_Type (E)) = E_Subprogram_Type) + and then Ekind (Designated_Type (E)) = E_Subprogram_Type) then Error_Pragma_Arg ("second argument of pragma% must be subprogram (type)", @@ -2610,7 +2750,6 @@ package body Sem_Prag is Set_Convention_From_Pragma (E); if Is_Type (E) then - Check_First_Subtype (Arg2); Set_Convention_From_Pragma (Base_Type (E)); @@ -2778,9 +2917,7 @@ package body Sem_Prag is Process_Extended_Import_Export_Internal_Arg (Arg_Internal); Def_Id := Entity (Arg_Internal); - if Ekind (Def_Id) /= E_Constant - and then Ekind (Def_Id) /= E_Variable - then + if not Ekind_In (Def_Id, E_Constant, E_Variable) then Error_Pragma_Arg ("pragma% must designate an object", Arg_Internal); end if; @@ -3132,7 +3269,7 @@ package body Sem_Prag is Prag_Id = Pragma_Import_Valued_Procedure then if not Is_Imported (Ent) then - Error_Pragma -- CODEFIX??? + Error_Pragma ("pragma Import or Interface must precede pragma%"); end if; @@ -3390,10 +3527,8 @@ package body Sem_Prag is Kill_Size_Check_Code (Def_Id); Note_Possible_Modification (Expression (Arg2), Sure => False); - if Ekind (Def_Id) = E_Variable - or else - Ekind (Def_Id) = E_Constant - then + if Ekind_In (Def_Id, E_Variable, E_Constant) then + -- We do not permit Import to apply to a renaming declaration if Present (Renamed_Object (Def_Id)) then @@ -3821,9 +3956,7 @@ package body Sem_Prag is -- entity (if declared in the same unit) is inlined. if Is_Subprogram (Subp) then - while Present (Alias (Inner_Subp)) loop - Inner_Subp := Alias (Inner_Subp); - end loop; + Inner_Subp := Ultimate_Alias (Inner_Subp); if In_Same_Source_Unit (Subp, Inner_Subp) then Set_Inline_Flags (Inner_Subp); @@ -4140,7 +4273,14 @@ package body Sem_Prag is Set_Encoded_Interface_Name (Get_Base_Subprogram (Subprogram_Def), Link_Nam); - Check_Duplicated_Export_Name (Link_Nam); + + -- We allow duplicated export names in CIL, as they are always + -- enclosed in a namespace that differentiates them, and overloaded + -- entities are supported by the VM. + + if Convention (Subprogram_Def) /= Convention_CIL then + Check_Duplicated_Export_Name (Link_Nam); + end if; end Process_Interface_Name; ----------------------------------------- @@ -4594,8 +4734,7 @@ package body Sem_Prag is end if; if Warn_On_Export_Import and then Is_Type (E) then - Error_Msg_NE - ("exporting a type has no effect?", Arg, E); + Error_Msg_NE ("exporting a type has no effect?", Arg, E); end if; if Warn_On_Export_Import and Inside_A_Generic then @@ -4695,8 +4834,19 @@ package body Sem_Prag is -- Error message if already imported or exported if Is_Exported (E) or else Is_Imported (E) then + + -- Error if being set Exported twice + if Is_Exported (E) then Error_Msg_NE ("entity& was previously exported", N, E); + + -- OK if Import/Interface case + + elsif Import_Interface_Present (N) then + goto OK; + + -- Error if being set Imported twice + else Error_Msg_NE ("entity& was previously imported", N, E); end if; @@ -4725,6 +4875,8 @@ package body Sem_Prag is Set_Is_Statically_Allocated (E); end if; end if; + + <> null; end Set_Imported; ------------------------- @@ -5105,8 +5257,9 @@ package body Sem_Prag is -- said this was a configuration pragma, but we did not check and -- are hesitant to add the check now. - -- However, we really cannot tolerate mixing Ada 2005 with Ada 83 - -- or Ada 95, so we must check if we are in Ada 2005 mode. + -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012 + -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005 + -- or Ada 2012 mode. if Ada_Version >= Ada_05 then Check_Valid_Configuration_Pragma; @@ -5195,6 +5348,33 @@ package body Sem_Prag is end if; end; + --------------------- + -- Ada_12/Ada_2012 -- + --------------------- + + -- pragma Ada_12; + -- pragma Ada_2012; + + -- Note: these pragma also have some specific processing in Par.Prag + -- because we want to set the Ada 2012 version mode during parsing. + + when Pragma_Ada_12 | Pragma_Ada_2012 => + GNAT_Pragma; + Check_Arg_Count (0); + + -- For Ada_2012 we unconditionally enforce the documented + -- configuration pragma placement, since we do not want to + -- tolerate mixed modes in a unit involving Ada 2012. That would + -- cause real difficulties for those cases where there are + -- incompatibilities between Ada 95 and Ada 2005/Ada 2012. + + Check_Valid_Configuration_Pragma; + + -- Now set Ada 2012 mode + + Ada_Version := Ada_12; + Ada_Version_Explicit := Ada_12; + ---------------------- -- All_Calls_Remote -- ---------------------- @@ -5246,6 +5426,8 @@ package body Sem_Prag is GNAT_Pragma; Check_At_Least_N_Arguments (1); Check_Arg_Is_Identifier (Arg1); + Check_No_Identifiers; + Store_Note (N); declare Arg : Node_Id; @@ -5788,8 +5970,17 @@ package body Sem_Prag is end if; Check_Arg_Is_Identifier (Arg1); + + -- Indicate if pragma is enabled. The Original_Node reference here + -- is to deal with pragma Assert rewritten as a Check pragma. + Check_On := Check_Enabled (Chars (Get_Pragma_Arg (Arg1))); - Set_Pragma_Enabled (N, Check_On); + + if Check_On then + Set_Pragma_Enabled (N); + Set_Pragma_Enabled (Original_Node (N)); + Set_SCO_Pragma_Enabled (Loc); + end if; -- If expansion is active and the check is not enabled then we -- rewrite the Check as: @@ -7288,8 +7479,11 @@ package body Sem_Prag is if Chars (Expression (Arg1)) = Name_On then Extensions_Allowed := True; + Ada_Version := Ada_Version_Type'Last; + else Extensions_Allowed := False; + Ada_Version := Ada_Version_Explicit; end if; -------------- @@ -7575,6 +7769,7 @@ package body Sem_Prag is Check_Arg_Count (1); Check_No_Identifiers; Check_Arg_Is_Static_Expression (Arg1, Standard_String); + Store_Note (N); -- For pragma Ident, preserve DEC compatibility by requiring the -- pragma to appear in a declarative part or package spec. @@ -9134,9 +9329,7 @@ package body Sem_Prag is while Present (E) and then Scope (E) = Current_Scope loop - if Ekind (E) = E_Procedure - or else Ekind (E) = E_Generic_Procedure - then + if Ekind_In (E, E_Procedure, E_Generic_Procedure) then Set_No_Return (E); -- Set flag on any alias as well @@ -9918,7 +10111,7 @@ package body Sem_Prag is -- This is one of the few cases where we need to test the value of -- Ada_Version_Explicit rather than Ada_Version (which is always - -- set to Ada_05 in a predefined unit), we need to know the + -- set to Ada_12 in a predefined unit), we need to know the -- explicit version set to know if this pragma is active. if Ada_Version_Explicit >= Ada_05 then @@ -10294,9 +10487,7 @@ package body Sem_Prag is Def_Id := Entity (Internal); - if Ekind (Def_Id) /= E_Constant - and then Ekind (Def_Id) /= E_Variable - then + if not Ekind_In (Def_Id, E_Constant, E_Variable) then Error_Pragma_Arg ("pragma% must designate an object", Internal); end if; @@ -10420,7 +10611,7 @@ package body Sem_Prag is -- This is one of the few cases where we need to test the value of -- Ada_Version_Explicit rather than Ada_Version (which is always - -- set to Ada_05 in a predefined unit), we need to know the + -- set to Ada_12 in a predefined unit), we need to know the -- explicit version set to know if this pragma is active. if Ada_Version_Explicit >= Ada_05 then @@ -10462,9 +10653,9 @@ package body Sem_Prag is loop Def_Id := Get_Base_Subprogram (E); - if Ekind (Def_Id) /= E_Function - and then Ekind (Def_Id) /= E_Generic_Function - and then Ekind (Def_Id) /= E_Operator + if not Ekind_In (Def_Id, E_Function, + E_Generic_Function, + E_Operator) then Error_Pragma_Arg ("pragma% requires a function name", Arg1); @@ -10484,8 +10675,9 @@ package body Sem_Prag is if not Effective and then Warn_On_Redundant_Constructs then - Error_Msg_NE ("pragma Pure_Function on& is redundant?", - N, Entity (E_Id)); + Error_Msg_NE + ("pragma Pure_Function on& is redundant?", + N, Entity (E_Id)); end if; end if; end Pure_Function; @@ -10658,10 +10850,8 @@ package body Sem_Prag is Set_Ravenscar_Profile (N); if Warn_On_Obsolescent_Feature then - Error_Msg_N - ("pragma Ravenscar is an obsolescent feature?", N); - Error_Msg_N - ("|use pragma Profile (Ravenscar) instead", N); + Error_Msg_N ("pragma Ravenscar is an obsolescent feature?", N); + Error_Msg_N ("|use pragma Profile (Ravenscar) instead", N); end if; ------------------------- @@ -10680,8 +10870,7 @@ package body Sem_Prag is if Warn_On_Obsolescent_Feature then Error_Msg_N ("pragma Restricted_Run_Time is an obsolescent feature?", N); - Error_Msg_N - ("|use pragma Profile (Restricted) instead", N); + Error_Msg_N ("|use pragma Profile (Restricted) instead", N); end if; ------------------ @@ -11164,7 +11353,11 @@ package body Sem_Prag is elsif Nkind (A) = N_Identifier then if Chars (A) = Name_All_Checks then - Set_Default_Style_Check_Options; + if GNAT_Mode then + Set_GNAT_Style_Check_Options; + else + Set_Default_Style_Check_Options; + end if; elsif Chars (A) = Name_On then Style_Check := True; @@ -11186,7 +11379,8 @@ package body Sem_Prag is GNAT_Pragma; Check_Arg_Count (1); Check_Optional_Identifier (Arg1, Name_Subtitle); - Check_Arg_Is_String_Literal (Arg1); + Check_Arg_Is_Static_Expression (Arg1, Standard_String); + Store_Note (N); -------------- -- Suppress -- @@ -11564,10 +11758,11 @@ package body Sem_Prag is begin GNAT_Pragma; Gather_Associations (Names, Args); + Store_Note (N); for J in 1 .. 2 loop if Present (Args (J)) then - Check_Arg_Is_String_Literal (Args (J)); + Check_Arg_Is_Static_Expression (Args (J), Standard_String); end if; end loop; end Title; @@ -12089,7 +12284,7 @@ package body Sem_Prag is elsif not Is_Static_String_Expression (Arg1) then Error_Pragma_Arg ("argument of pragma% must be On/Off or " & - "static string expression", Arg2); + "static string expression", Arg1); -- One argument string expression case @@ -12309,6 +12504,11 @@ package body Sem_Prag is raise Program_Error; end case; + -- AI05-0144: detect dangerous order dependence. Disabled for now, + -- until AI is formally approved. + + -- Check_Order_Dependence; + exception when Pragma_Exit => null; end Analyze_Pragma; @@ -12483,6 +12683,8 @@ package body Sem_Prag is Pragma_Ada_95 => -1, Pragma_Ada_05 => -1, Pragma_Ada_2005 => -1, + Pragma_Ada_12 => -1, + Pragma_Ada_2012 => -1, Pragma_All_Calls_Remote => -1, Pragma_Annotate => -1, Pragma_Assert => -1, diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 96a295cd218..92ae30f4e55 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -130,10 +130,14 @@ package body Sem_Res is -- declaration, and not an (anonymous) allocator type. function Is_Predefined_Op (Nam : Entity_Id) return Boolean; - -- Utility to check whether the name in the call is a predefined - -- operator, in which case the call is made into an operator node. - -- An instance of an intrinsic conversion operation may be given - -- an operator name, but is not treated like an operator. + -- Utility to check whether the entity for an operator is a predefined + -- operator, in which case the expression is left as an operator in the + -- tree (else it is rewritten into a call). An instance of an intrinsic + -- conversion operation may be given an operator name, but is not treated + -- like an operator. Note that an operator that is an imported back-end + -- builtin has convention Intrinsic, but is expected to be rewritten into + -- a call, so such an operator is not treated as predefined by this + -- predicate. procedure Replace_Actual_Discriminants (N : Node_Id; Default : Node_Id); -- If a default expression in entry call N depends on the discriminants @@ -160,12 +164,14 @@ package body Sem_Res is procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id); procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id); procedure Resolve_Call (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Case_Expression (N : Node_Id; Typ : Entity_Id); procedure Resolve_Character_Literal (N : Node_Id; Typ : Entity_Id); procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id); procedure Resolve_Conditional_Expression (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Entity_Name (N : Node_Id; Typ : Entity_Id); procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id); procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id); - procedure Resolve_Entity_Name (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Expression_With_Actions (N : Node_Id; Typ : Entity_Id); procedure Resolve_Indexed_Component (N : Node_Id; Typ : Entity_Id); procedure Resolve_Integer_Literal (N : Node_Id; Typ : Entity_Id); procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id); @@ -211,9 +217,13 @@ package body Sem_Res is procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id); -- A call to a user-defined intrinsic operator is rewritten as a call -- to the corresponding predefined operator, with suitable conversions. + -- Note that this applies only for intrinsic operators that denote + -- predefined operators, not operators that are intrinsic imports of + -- back-end builtins. procedure Resolve_Intrinsic_Unary_Operator (N : Node_Id; Typ : Entity_Id); - -- Ditto, for unary operators (only arithmetic ones) + -- Ditto, for unary operators (arithmetic ones and "not" on signed + -- integer types for VMS). procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id); -- If an operator node resolves to a call to a user-defined operator, @@ -276,16 +286,13 @@ package body Sem_Res is -- First the ones in Standard - Error_Msg_N - ("\\possible interpretation: Character!", C); - Error_Msg_N - ("\\possible interpretation: Wide_Character!", C); + Error_Msg_N ("\\possible interpretation: Character!", C); + Error_Msg_N ("\\possible interpretation: Wide_Character!", C); -- Include Wide_Wide_Character in Ada 2005 mode if Ada_Version >= Ada_05 then - Error_Msg_N - ("\\possible interpretation: Wide_Wide_Character!", C); + Error_Msg_N ("\\possible interpretation: Wide_Wide_Character!", C); end if; -- Now any other types that match @@ -632,9 +639,10 @@ package body Sem_Res is procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id) is begin if Is_Invisible_Operator (N, T) then - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("operator for} is not directly visible!", N, First_Subtype (T)); - Error_Msg_N ("use clause would make operation legal!", N); + Error_Msg_N -- CODEFIX + ("use clause would make operation legal!", N); end if; end Check_For_Visible_Operator; @@ -898,10 +906,12 @@ package body Sem_Res is Expr := Original_Node (Expression (Parent (Comp))); -- Return True if the expression is a call to a function - -- (including an attribute function such as Image) with - -- a result that requires a transient scope. + -- (including an attribute function such as Image, or a + -- user-defined operator) with a result that requires a + -- transient scope. if (Nkind (Expr) = N_Function_Call + or else Nkind (Expr) in N_Op or else (Nkind (Expr) = N_Attribute_Reference and then Present (Expressions (Expr)))) and then Requires_Transient_Scope (Etype (Expr)) @@ -1034,7 +1044,7 @@ package body Sem_Res is if (Is_Entity_Name (N) and then Is_Overloadable (Entity (N)) and then (Ekind (Entity (N)) /= E_Enumeration_Literal - or else Is_Overloaded (N))) + or else Is_Overloaded (N))) -- Rewrite as call if it is an explicit dereference of an expression of -- a subprogram access type, and the subprogram type is not that of a @@ -1050,11 +1060,10 @@ package body Sem_Res is or else (Nkind (N) = N_Selected_Component and then (Ekind (Entity (Selector_Name (N))) = E_Function - or else - ((Ekind (Entity (Selector_Name (N))) = E_Entry - or else - Ekind (Entity (Selector_Name (N))) = E_Procedure) - and then Is_Overloaded (Selector_Name (N))))) + or else + (Ekind_In (Entity (Selector_Name (N)), E_Entry, + E_Procedure) + and then Is_Overloaded (Selector_Name (N))))) -- If one of the above three conditions is met, rewrite as call. -- Apply the rewriting only once. @@ -1102,11 +1111,21 @@ package body Sem_Res is function Is_Predefined_Op (Nam : Entity_Id) return Boolean is begin - return Is_Intrinsic_Subprogram (Nam) - and then not Is_Generic_Instance (Nam) + -- Predefined operators are intrinsic subprograms + + if not Is_Intrinsic_Subprogram (Nam) then + return False; + end if; + + -- A call to a back-end builtin is never a predefined operator + + if Is_Imported (Nam) and then Present (Interface_Name (Nam)) then + return False; + end if; + + return not Is_Generic_Instance (Nam) and then Chars (Nam) in Any_Operator_Name - and then (No (Alias (Nam)) - or else Is_Predefined_Op (Alias (Nam))); + and then (No (Alias (Nam)) or else Is_Predefined_Op (Alias (Nam))); end Is_Predefined_Op; ----------------------------- @@ -1133,7 +1152,7 @@ package body Sem_Res is function Operand_Type_In_Scope (S : Entity_Id) return Boolean; -- If the operand is not universal, and the operator is given by a - -- expanded name, verify that the operand has an interpretation with + -- expanded name, verify that the operand has an interpretation with -- a type defined in the given scope of the operator. function Type_In_P (Test : Kind_Test) return Entity_Id; @@ -1274,16 +1293,15 @@ package body Sem_Res is -- you courtesy of b33302a. The type itself must be frozen, so we must -- find the type of the proper class in the given scope. - -- A final wrinkle is the multiplication operator for fixed point - -- types, which is defined in Standard only, and not in the scope of - -- the fixed_point type itself. + -- A final wrinkle is the multiplication operator for fixed point types, + -- which is defined in Standard only, and not in the scope of the + -- fixed_point type itself. if Nkind (Name (N)) = N_Expanded_Name then Pack := Entity (Prefix (Name (N))); - -- If the entity being called is defined in the given package, - -- it is a renaming of a predefined operator, and known to be - -- legal. + -- If the entity being called is defined in the given package, it is + -- a renaming of a predefined operator, and known to be legal. if Scope (Entity (Name (N))) = Pack and then Pack /= Standard_Standard @@ -1297,8 +1315,7 @@ package body Sem_Res is elsif In_Instance then null; - elsif (Op_Name = Name_Op_Multiply - or else Op_Name = Name_Op_Divide) + elsif (Op_Name = Name_Op_Multiply or else Op_Name = Name_Op_Divide) and then Is_Fixed_Point_Type (Etype (Left_Opnd (Op_Node))) and then Is_Fixed_Point_Type (Etype (Right_Opnd (Op_Node))) then @@ -1306,8 +1323,8 @@ package body Sem_Res is Error := True; end if; - -- Ada 2005, AI-420: Predefined equality on Universal_Access - -- is available. + -- Ada 2005, AI-420: Predefined equality on Universal_Access is + -- available. elsif Ada_Version >= Ada_05 and then (Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne) @@ -1338,7 +1355,7 @@ package body Sem_Res is if Pack /= Standard_Standard then if Opnd_Type = Universal_Integer then - Orig_Type := Type_In_P (Is_Integer_Type'Access); + Orig_Type := Type_In_P (Is_Integer_Type'Access); elsif Opnd_Type = Universal_Real then Orig_Type := Type_In_P (Is_Real_Type'Access); @@ -1347,7 +1364,7 @@ package body Sem_Res is Orig_Type := Type_In_P (Is_String_Type'Access); elsif Opnd_Type = Any_Access then - Orig_Type := Type_In_P (Is_Definite_Access_Type'Access); + Orig_Type := Type_In_P (Is_Definite_Access_Type'Access); elsif Opnd_Type = Any_Composite then Orig_Type := Type_In_P (Is_Composite_Type'Access); @@ -1407,6 +1424,41 @@ package body Sem_Res is ("& not declared in&", N, Selector_Name (Name (N))); Set_Etype (N, Any_Type); return; + + -- Detect a mismatch between the context type and the result type + -- in the named package, which is otherwise not detected if the + -- operands are universal. Check is only needed if source entity is + -- an operator, not a function that renames an operator. + + elsif Nkind (Parent (N)) /= N_Type_Conversion + and then Ekind (Entity (Name (N))) = E_Operator + and then Is_Numeric_Type (Typ) + and then not Is_Universal_Numeric_Type (Typ) + and then Scope (Base_Type (Typ)) /= Pack + and then not In_Instance + then + if Is_Fixed_Point_Type (Typ) + and then (Op_Name = Name_Op_Multiply + or else + Op_Name = Name_Op_Divide) + then + -- Already checked above + + null; + + -- Operator may be defined in an extension of System + + elsif Present (System_Aux_Id) + and then Scope (Opnd_Type) = System_Aux_Id + then + null; + + else + -- Could we use Wrong_Type here??? (this would require setting + -- Etype (N) to the actual type found where Typ was expected). + + Error_Msg_NE ("expect }", N, Typ); + end if; end if; end if; @@ -1468,14 +1520,6 @@ package body Sem_Res is else Resolve (N, Typ); end if; - - -- For predefined operators on literals, the operation freezes - -- their type. - - if Present (Orig_Type) then - Set_Etype (Act1, Orig_Type); - Freeze_Expression (Act1); - end if; end Make_Call_Into_Operator; ------------------- @@ -1669,6 +1713,10 @@ package body Sem_Res is -- Try and fix up a literal so that it matches its expected type. New -- literals are manufactured if necessary to avoid cascaded errors. + procedure Report_Ambiguous_Argument; + -- Additional diagnostics when an ambiguous call has an ambiguous + -- argument (typically a controlling actual). + procedure Resolution_Failed; -- Called when attempt at resolving current expression fails @@ -1733,6 +1781,39 @@ package body Sem_Res is end if; end Patch_Up_Value; + ------------------------------- + -- Report_Ambiguous_Argument -- + ------------------------------- + + procedure Report_Ambiguous_Argument is + Arg : constant Node_Id := First (Parameter_Associations (N)); + I : Interp_Index; + It : Interp; + + begin + if Nkind (Arg) = N_Function_Call + and then Is_Entity_Name (Name (Arg)) + and then Is_Overloaded (Name (Arg)) + then + Error_Msg_NE ("ambiguous call to&", Arg, Name (Arg)); + + -- Could use comments on what is going on here ??? + + Get_First_Interp (Name (Arg), I, It); + while Present (It.Nam) loop + Error_Msg_Sloc := Sloc (It.Nam); + + if Nkind (Parent (It.Nam)) = N_Full_Type_Declaration then + Error_Msg_N ("interpretation (inherited) #!", Arg); + else + Error_Msg_N ("interpretation #!", Arg); + end if; + + Get_Next_Interp (I, It); + end loop; + end if; + end Report_Ambiguous_Argument; + ----------------------- -- Resolution_Failed -- ----------------------- @@ -1805,6 +1886,7 @@ package body Sem_Res is -- Check that Typ is a remote access-to-subprogram type if Is_Remote_Access_To_Subprogram_Type (Typ) then + -- Prefix (N) must statically denote a remote subprogram -- declared in a package specification. @@ -2037,6 +2119,13 @@ package body Sem_Res is Error_Msg_N -- CODEFIX ("\\possible interpretation#!", N); end if; + + if Nkind_In + (N, N_Procedure_Call_Statement, N_Function_Call) + and then Present (Parameter_Associations (N)) + then + Report_Ambiguous_Argument; + end if; end if; Error_Msg_Sloc := Sloc (It.Nam); @@ -2077,7 +2166,7 @@ package body Sem_Res is -- If this is an indirect call, use the subprogram_type -- in the message, to have a meaningful location. - -- Indicate as well if this is an inherited operation, + -- Also indicate if this is an inherited operation, -- created by a type declaration. elsif Nkind (N) = N_Function_Call @@ -2134,6 +2223,9 @@ package body Sem_Res is Set_Entity (N, Seen); Generate_Reference (Seen, N); + elsif Nkind (N) = N_Case_Expression then + Set_Etype (N, Expr_Type); + elsif Nkind (N) = N_Character_Literal then Set_Etype (N, Expr_Type); @@ -2158,7 +2250,7 @@ package body Sem_Res is null; -- For procedure or function calls, set the type of the name, - -- and also the entity pointer for the prefix + -- and also the entity pointer for the prefix. elsif Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call) and then (Is_Entity_Name (Name (N)) @@ -2194,9 +2286,9 @@ package body Sem_Res is end if; -- At this stage Found indicates whether or not an acceptable - -- interpretation exists. If not, then we have an error, except - -- that if the context is Any_Type as a result of some other error, - -- then we suppress the error report. + -- interpretation exists. If not, then we have an error, except that if + -- the context is Any_Type as a result of some other error, then we + -- suppress the error report. if not Found then if Typ /= Any_Type then @@ -2489,6 +2581,9 @@ package body Sem_Res is when N_Attribute_Reference => Resolve_Attribute (N, Ctx_Type); + when N_Case_Expression + => Resolve_Case_Expression (N, Ctx_Type); + when N_Character_Literal => Resolve_Character_Literal (N, Ctx_Type); @@ -2498,12 +2593,15 @@ package body Sem_Res is when N_Expanded_Name => Resolve_Entity_Name (N, Ctx_Type); - when N_Extension_Aggregate - => Resolve_Extension_Aggregate (N, Ctx_Type); - when N_Explicit_Dereference => Resolve_Explicit_Dereference (N, Ctx_Type); + when N_Expression_With_Actions + => Resolve_Expression_With_Actions (N, Ctx_Type); + + when N_Extension_Aggregate + => Resolve_Extension_Aggregate (N, Ctx_Type); + when N_Function_Call => Resolve_Call (N, Ctx_Type); @@ -2584,7 +2682,6 @@ package body Sem_Res is when N_Unchecked_Type_Conversion => Resolve_Unchecked_Type_Conversion (N, Ctx_Type); - end case; -- If the subexpression was replaced by a non-subexpression, then @@ -3379,6 +3476,13 @@ package body Sem_Res is A_Typ := Etype (A); F_Typ := Etype (F); + -- Save actual for subsequent check on order dependence, + -- and indicate whether actual is modifiable. For AI05-0144 + + -- Save_Actual (A, + -- Ekind (F) /= E_In_Parameter or else Is_Access_Type (F_Typ)); + -- Why is this code commented out ??? + -- For mode IN, if actual is an entity, and the type of the formal -- has warnings suppressed, then we reset Never_Set_In_Source for -- the calling entity. The reason for this is to catch cases like @@ -3490,9 +3594,7 @@ package body Sem_Res is -- might not be done in the In Out case since Gigi does not do -- any analysis. More thought required about this ??? - if Ekind (F) = E_In_Parameter - or else Ekind (F) = E_In_Out_Parameter - then + if Ekind_In (F, E_In_Parameter, E_In_Out_Parameter) then if Is_Scalar_Type (Etype (A)) then Apply_Scalar_Range_Check (A, F_Typ); @@ -3538,9 +3640,7 @@ package body Sem_Res is end if; end if; - if Ekind (F) = E_Out_Parameter - or else Ekind (F) = E_In_Out_Parameter - then + if Ekind_In (F, E_Out_Parameter, E_In_Out_Parameter) then if Nkind (A) = N_Type_Conversion then if Is_Scalar_Type (A_Typ) then Apply_Scalar_Range_Check @@ -4568,7 +4668,7 @@ package body Sem_Res is -- If the context is Universal_Fixed and the operands are also -- universal fixed, this is an error, unless there is only one - -- applicable fixed_point type (usually duration). + -- applicable fixed_point type (usually Duration). if B_Typ = Universal_Fixed and then Etype (L) = Universal_Fixed then T := Unique_Fixed_Point_Type (N); @@ -4719,6 +4819,28 @@ package body Sem_Res is Scop : Entity_Id; Rtype : Entity_Id; + function Same_Or_Aliased_Subprograms + (S : Entity_Id; + E : Entity_Id) return Boolean; + -- Returns True if the subprogram entity S is the same as E or else + -- S is an alias of E. + + --------------------------------- + -- Same_Or_Aliased_Subprograms -- + --------------------------------- + + function Same_Or_Aliased_Subprograms + (S : Entity_Id; + E : Entity_Id) return Boolean + is + Subp_Alias : constant Entity_Id := Alias (S); + begin + return S = E + or else (Present (Subp_Alias) and then Subp_Alias = E); + end Same_Or_Aliased_Subprograms; + + -- Start of processing for Resolve_Call + begin -- The context imposes a unique interpretation with type Typ on a -- procedure or function call. Find the entity of the subprogram that @@ -5004,10 +5126,15 @@ package body Sem_Res is Expressions => Parameter_Associations (N)); end if; + -- Preserve the parenthesis count of the node + + Set_Paren_Count (Index_Node, Paren_Count (N)); + -- Since we are correcting a node classification error made -- by the parser, we call Replace rather than Rewrite. Replace (N, Index_Node); + Set_Etype (Prefix (N), Ret_Type); Set_Etype (N, Typ); Resolve_Indexed_Component (N, Typ); @@ -5051,7 +5178,7 @@ package body Sem_Res is -- Issue warning for possible infinite recursion in the absence -- of the No_Recursion restriction. - if Nam = Scop + if Same_Or_Aliased_Subprograms (Nam, Scop) and then not Restriction_Active (No_Recursion) and then Check_Infinite_Recursion (N) then @@ -5068,7 +5195,7 @@ package body Sem_Res is else Scope_Loop : while Scop /= Standard_Standard loop - if Nam = Scop then + if Same_Or_Aliased_Subprograms (Nam, Scop) then -- Although in general case, recursion is not statically -- checkable, the case of calling an immediately containing @@ -5316,9 +5443,7 @@ package body Sem_Res is F := First_Formal (Nam); A := First_Actual (N); while Present (F) and then Present (A) loop - if (Ekind (F) = E_Out_Parameter - or else - Ekind (F) = E_In_Out_Parameter) + if Ekind_In (F, E_Out_Parameter, E_In_Out_Parameter) and then Warn_On_Modified_As_Out_Parameter (F) and then Is_Entity_Name (A) and then Present (Entity (A)) @@ -5380,9 +5505,14 @@ package body Sem_Res is Check_Potentially_Blocking_Operation (N); end if; - -- Issue an error for a call to an eliminated subprogram + -- Issue an error for a call to an eliminated subprogram. We skip this + -- in a spec expression, e.g. a call in a default parameter value, since + -- we are not really doing a call at this time. That's important because + -- the spec expression may itself belong to an eliminated subprogram. - Check_For_Eliminated_Subprogram (Subp, Nam); + if not In_Spec_Expression then + Check_For_Eliminated_Subprogram (Subp, Nam); + end if; -- All done, evaluate call and deal with elaboration issues @@ -5391,6 +5521,24 @@ package body Sem_Res is Warn_On_Overlapping_Actuals (Nam, N); end Resolve_Call; + ----------------------------- + -- Resolve_Case_Expression -- + ----------------------------- + + procedure Resolve_Case_Expression (N : Node_Id; Typ : Entity_Id) is + Alt : Node_Id; + + begin + Alt := First (Alternatives (N)); + while Present (Alt) loop + Resolve (Expression (Alt), Typ); + Next (Alt); + end loop; + + Set_Etype (N, Typ); + Eval_Case_Expression (N); + end Resolve_Case_Expression; + ------------------------------- -- Resolve_Character_Literal -- ------------------------------- @@ -5689,6 +5837,14 @@ package body Sem_Res is Set_Etype (N, Typ); Eval_Named_Real (N); + -- For enumeration literals, we need to make sure that a proper style + -- check is done, since such literals are overloaded, and thus we did + -- not do a style check during the first phase of analysis. + + elsif Ekind (E) = E_Enumeration_Literal then + Set_Entity_With_Style_Check (N, E); + Eval_Entity_Name (N); + -- Allow use of subtype only if it is a concurrent type where we are -- currently inside the body. This will eventually be expanded into a -- call to Self (for tasks) or _object (for protected objects). Any @@ -5743,7 +5899,6 @@ package body Sem_Res is and then not In_Spec_Expression and then not Is_Imported (E) then - if No_Initialization (Parent (E)) or else (Present (Full_View (E)) and then No_Initialization (Parent (Full_View (E)))) @@ -5794,7 +5949,7 @@ package body Sem_Res is -- to the discriminant of the same name in the target task. If the -- entry name is the target of a requeue statement and the entry is -- in the current protected object, the bound to be used is the - -- discriminal of the object (see apply_range_checks for details of + -- discriminal of the object (see Apply_Range_Checks for details of -- the transformation). ----------------------------- @@ -5817,7 +5972,14 @@ package body Sem_Res is and then In_Open_Scopes (Tsk) and then Nkind (Parent (Entry_Name)) = N_Requeue_Statement then - return New_Occurrence_Of (Discriminal (Entity (Bound)), Loc); + -- Note: here Bound denotes a discriminant of the corresponding + -- record type tskV, whose discriminal is a formal of the + -- init-proc tskVIP. What we want is the body discriminal, + -- which is associated to the discriminant of the original + -- concurrent type tsk. + + return New_Occurrence_Of + (Find_Body_Discriminal (Entity (Bound)), Loc); else Ref := @@ -6097,9 +6259,7 @@ package body Sem_Res is Resolve_Actuals (N, Nam); Generate_Reference (Nam, Entry_Name); - if Ekind (Nam) = E_Entry - or else Ekind (Nam) = E_Entry_Family - then + if Ekind_In (Nam, E_Entry, E_Entry_Family) then Check_Potentially_Blocking_Operation (N); end if; @@ -6253,8 +6413,7 @@ package body Sem_Res is return; elsif T = Any_Access - or else Ekind (T) = E_Allocator_Type - or else Ekind (T) = E_Access_Attribute_Type + or else Ekind_In (T, E_Allocator_Type, E_Access_Attribute_Type) then T := Find_Unique_Access_Type; @@ -6282,7 +6441,8 @@ package body Sem_Res is and then Entity (R) = Standard_True and then Comes_From_Source (R) then - Error_Msg_N ("?comparison with True is redundant!", R); + Error_Msg_N -- CODEFIX + ("?comparison with True is redundant!", R); end if; Check_Unset_Reference (L); @@ -6321,8 +6481,8 @@ package body Sem_Res is if Expander_Active and then - (Ekind (T) = E_Anonymous_Access_Type - or else Ekind (T) = E_Anonymous_Access_Subprogram_Type + (Ekind_In (T, E_Anonymous_Access_Type, + E_Anonymous_Access_Subprogram_Type) or else Is_Private_Type (T)) then if Etype (L) /= T then @@ -6434,6 +6594,15 @@ package body Sem_Res is end Resolve_Explicit_Dereference; + ------------------------------------- + -- Resolve_Expression_With_Actions -- + ------------------------------------- + + procedure Resolve_Expression_With_Actions (N : Node_Id; Typ : Entity_Id) is + begin + Set_Etype (N, Typ); + end Resolve_Expression_With_Actions; + ------------------------------- -- Resolve_Indexed_Component -- ------------------------------- @@ -6556,6 +6725,24 @@ package body Sem_Res is Warn_On_Suspicious_Index (Name, First (Expressions (N))); Eval_Indexed_Component (N); end if; + + -- If the array type is atomic, and is packed, and we are in a left side + -- context, then this is worth a warning, since we have a situation + -- where the access to the component may cause extra read/writes of + -- the atomic array object, which could be considered unexpected. + + if Nkind (N) = N_Indexed_Component + and then (Is_Atomic (Array_Type) + or else (Is_Entity_Name (Prefix (N)) + and then Is_Atomic (Entity (Prefix (N))))) + and then Is_Bit_Packed_Array (Array_Type) + and then Is_LHS (N) + then + Error_Msg_N ("?assignment to component of packed atomic array", + Prefix (N)); + Error_Msg_N ("?\may cause unexpected accesses to atomic object", + Prefix (N)); + end if; end Resolve_Indexed_Component; ----------------------------- @@ -6573,12 +6760,20 @@ package body Sem_Res is -------------------------------- procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id) is - Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ)); - Op : Entity_Id; - Arg1 : Node_Id; - Arg2 : Node_Id; + Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ)); + Op : Entity_Id; + Orig_Op : constant Entity_Id := Entity (N); + Arg1 : Node_Id; + Arg2 : Node_Id; begin + -- We must preserve the original entity in a generic setting, so that + -- the legality of the operation can be verified in an instance. + + if not Expander_Active then + return; + end if; + Op := Entity (N); while Scope (Op) /= Standard_Standard loop Op := Homonym (Op); @@ -6601,8 +6796,13 @@ package body Sem_Res is Arg2 := Unchecked_Convert_To (Btyp, Right_Opnd (N)); end if; - Save_Interps (Left_Opnd (N), Expression (Arg1)); - Save_Interps (Right_Opnd (N), Expression (Arg2)); + if Nkind (Arg1) = N_Type_Conversion then + Save_Interps (Left_Opnd (N), Expression (Arg1)); + end if; + + if Nkind (Arg2) = N_Type_Conversion then + Save_Interps (Right_Opnd (N), Expression (Arg2)); + end if; Set_Left_Opnd (N, Arg1); Set_Right_Opnd (N, Arg2); @@ -6615,19 +6815,31 @@ package body Sem_Res is or else Typ /= Etype (Right_Opnd (N)) then -- Add explicit conversion where needed, and save interpretations in - -- case operands are overloaded. + -- case operands are overloaded. If the context is a VMS operation, + -- assert that the conversion is legal (the operands have the proper + -- types to select the VMS intrinsic). Note that in rare cases the + -- VMS operators may be visible, but the default System is being used + -- and Address is a private type. Arg1 := Convert_To (Typ, Left_Opnd (N)); Arg2 := Convert_To (Typ, Right_Opnd (N)); if Nkind (Arg1) = N_Type_Conversion then Save_Interps (Left_Opnd (N), Expression (Arg1)); + + if Is_VMS_Operator (Orig_Op) then + Set_Conversion_OK (Arg1); + end if; else Save_Interps (Left_Opnd (N), Arg1); end if; if Nkind (Arg2) = N_Type_Conversion then Save_Interps (Right_Opnd (N), Expression (Arg2)); + + if Is_VMS_Operator (Orig_Op) then + Set_Conversion_OK (Arg2); + end if; else Save_Interps (Right_Opnd (N), Arg2); end if; @@ -6699,13 +6911,18 @@ package body Sem_Res is B_Typ := Base_Type (Typ); end if; + -- OK if this is a VMS-specific intrinsic operation + + if Is_VMS_Operator (Entity (N)) then + null; + -- The following test is required because the operands of the operation -- may be literals, in which case the resulting type appears to be -- compatible with a signed integer type, when in fact it is compatible -- only with modular types. If the context itself is universal, the -- operation is illegal. - if not Valid_Boolean_Arg (Typ) then + elsif not Valid_Boolean_Arg (Typ) then Error_Msg_N ("invalid context for logical operation", N); Set_Etype (N, Any_Type); return; @@ -6822,6 +7039,18 @@ package body Sem_Res is T := Intersect_Types (L, R); end if; + -- If mixed-mode operations are present and operands are all literal, + -- the only interpretation involves Duration, which is probably not + -- the intention of the programmer. + + if T = Any_Fixed then + T := Unique_Fixed_Point_Type (N); + + if T = Any_Type then + return; + end if; + end if; + Resolve (L, T); Check_Unset_Reference (L); @@ -7249,9 +7478,12 @@ package body Sem_Res is B_Typ := Base_Type (Typ); end if; + if Is_VMS_Operator (Entity (N)) then + null; + -- Straightforward case of incorrect arguments - if not Valid_Boolean_Arg (Typ) then + elsif not Valid_Boolean_Arg (Typ) then Error_Msg_N ("invalid operand type for operator&", N); Set_Etype (N, Any_Type); return; @@ -7628,7 +7860,6 @@ package body Sem_Res is Comp := Next_Entity (Comp); end loop; - end if; Get_Next_Interp (I, It); @@ -7666,9 +7897,7 @@ package body Sem_Res is end if; if Has_Discriminants (T) - and then (Ekind (Entity (S)) = E_Component - or else - Ekind (Entity (S)) = E_Discriminant) + and then Ekind_In (Entity (S), E_Component, E_Discriminant) and then Present (Original_Record_Component (Entity (S))) and then Ekind (Original_Record_Component (Entity (S))) = E_Component and then Present (Discriminant_Checking_Func @@ -7697,6 +7926,23 @@ package body Sem_Res is -- Note: No Eval processing is required, because the prefix is of a -- record type, or protected type, and neither can possibly be static. + -- If the array type is atomic, and is packed, and we are in a left side + -- context, then this is worth a warning, since we have a situation + -- where the access to the component may cause extra read/writes of + -- the atomic array object, which could be considered unexpected. + + if Nkind (N) = N_Selected_Component + and then (Is_Atomic (T) + or else (Is_Entity_Name (Prefix (N)) + and then Is_Atomic (Entity (Prefix (N))))) + and then Is_Packed (T) + and then Is_LHS (N) + then + Error_Msg_N ("?assignment to component of packed atomic record", + Prefix (N)); + Error_Msg_N ("?\may cause unexpected accesses to atomic object", + Prefix (N)); + end if; end Resolve_Selected_Component; ------------------- @@ -7733,8 +7979,11 @@ package body Sem_Res is R : constant Node_Id := Right_Opnd (N); begin + -- Why are the calls to Check_Order_Dependence commented out ??? Resolve (L, B_Typ); + -- Check_Order_Dependence; -- For AI05-0144 Resolve (R, B_Typ); + -- Check_Order_Dependence; -- For AI05-0144 -- Check for issuing warning for always False assert/check, this happens -- when assertions are turned off, in which case the pragma Assert/Check @@ -7772,15 +8021,15 @@ package body Sem_Res is then null; else - -- Issue warning. Note that we don't want to make this - -- an unconditional warning, because if the assert is - -- within deleted code we do not want the warning. But - -- we do not want the deletion of the IF/AND-THEN to - -- take this message with it. We achieve this by making - -- sure that the expanded code points to the Sloc of - -- the expression, not the original pragma. - - Error_Msg_N ("?assertion would fail at run-time", Orig); + -- Issue warning. We do not want the deletion of the + -- IF/AND-THEN to take this message with it. We achieve + -- this by making sure that the expanded code points to + -- the Sloc of the expression, not the original pragma. + + Error_Msg_N + ("?assertion would fail at run-time!", + Expression + (First (Pragma_Argument_Associations (Orig)))); end if; end; @@ -7803,7 +8052,10 @@ package body Sem_Res is then null; else - Error_Msg_N ("?check would fail at run-time", Orig); + Error_Msg_N + ("?check would fail at run-time!", + Expression + (Last (Pragma_Argument_Associations (Orig)))); end if; end; end if; @@ -7905,6 +8157,7 @@ package body Sem_Res is end if; elsif Is_Entity_Name (Name) + or else Nkind (Name) = N_Explicit_Dereference or else (Nkind (Name) = N_Function_Call and then not Is_Constrained (Etype (Name))) then @@ -8398,7 +8651,7 @@ package body Sem_Res is (Etype (Entity (Orig_N)) = Orig_T or else (Ekind (Entity (Orig_N)) = E_Loop_Parameter - and then Covers (Orig_T, Etype (Entity (Orig_N))))) + and then Covers (Orig_T, Etype (Entity (Orig_N))))) then -- One more check, do not give warning if the analyzed conversion -- has an expression with non-static bounds, and the bounds of the @@ -8436,11 +8689,11 @@ package body Sem_Res is begin if Is_Access_Type (Opnd) then - Opnd := Directly_Designated_Type (Opnd); + Opnd := Designated_Type (Opnd); end if; if Is_Access_Type (Target_Typ) then - Target := Directly_Designated_Type (Target); + Target := Designated_Type (Target); end if; if Opnd = Target then @@ -8454,7 +8707,8 @@ package body Sem_Res is if From_With_Type (Opnd) then Error_Msg_Qual_Level := 99; - Error_Msg_NE ("missing WITH clause on package &", N, + Error_Msg_NE -- CODEFIX + ("missing WITH clause on package &", N, Cunit_Entity (Get_Source_Unit (Base_Type (Opnd)))); Error_Msg_N ("type conversions require visibility of the full view", @@ -8466,7 +8720,8 @@ package body Sem_Res is and then Present (Non_Limited_View (Etype (Target)))) then Error_Msg_Qual_Level := 99; - Error_Msg_NE ("missing WITH clause on package &", N, + Error_Msg_NE -- CODEFIX + ("missing WITH clause on package &", N, Cunit_Entity (Get_Source_Unit (Base_Type (Target)))); Error_Msg_N ("type conversions require visibility of the full view", @@ -8482,9 +8737,7 @@ package body Sem_Res is -- Handle subtypes - if Ekind (Opnd) = E_Protected_Subtype - or else Ekind (Opnd) = E_Task_Subtype - then + if Ekind_In (Opnd, E_Protected_Subtype, E_Task_Subtype) then Opnd := Etype (Opnd); end if; @@ -8560,7 +8813,7 @@ package body Sem_Res is Determine_Range (Right_Opnd (N), OK, Lo, Hi); if OK and then Hi >= Lo and then Lo >= 0 then - Error_Msg_N + Error_Msg_N -- CODEFIX ("?abs applied to known non-negative value has no effect", N); end if; end if; @@ -8784,9 +9037,7 @@ package body Sem_Res is -- Exclude user-defined intrinsic operations of the same name, which are -- treated separately and rewritten as calls. - if Ekind (Op) /= E_Function - or else Chars (N) /= Nam - then + if Ekind (Op) /= E_Function or else Chars (N) /= Nam then Op_Node := New_Node (Operator_Kind (Nam, Is_Binary), Sloc (N)); Set_Chars (Op_Node, Nam); Set_Etype (Op_Node, Etype (N)); @@ -8825,9 +9076,8 @@ package body Sem_Res is end case; end if; - elsif Ekind (Op) = E_Function - and then Is_Intrinsic_Subprogram (Op) - then + elsif Ekind (Op) = E_Function and then Is_Intrinsic_Subprogram (Op) then + -- Operator renames a user-defined operator of the same name. Use -- the original operator in the node, which is the one that Gigi -- knows about. @@ -8877,7 +9127,17 @@ package body Sem_Res is Index_Subtype := Create_Itype (Subtype_Kind (Ekind (Index_Type)), N); - Set_Scalar_Range (Index_Subtype, Drange); + -- Take a new copy of Drange (where bounds have been rewritten to + -- reference side-effect-vree names). Using a separate tree ensures + -- that further expansion (e.g while rewriting a slice assignment + -- into a FOR loop) does not attempt to remove side effects on the + -- bounds again (which would cause the bounds in the index subtype + -- definition to refer to temporaries before they are defined) (the + -- reason is that some names are considered side effect free here + -- for the subtype, but not in the context of a loop iteration + -- scheme). + + Set_Scalar_Range (Index_Subtype, New_Copy_Tree (Drange)); Set_Etype (Index_Subtype, Index_Type); Set_Size_Info (Index_Subtype, Index_Type); Set_RM_Size (Index_Subtype, RM_Size (Index_Type)); @@ -8900,18 +9160,22 @@ package body Sem_Res is Set_Etype (N, Slice_Subtype); - -- In the packed case, this must be immediately frozen - - -- Couldn't we always freeze here??? and if we did, then the above - -- call to Check_Compile_Time_Size could be eliminated, which would - -- be nice, because then that routine could be made private to Freeze. - - -- Why the test for In_Spec_Expression here ??? + -- For packed slice subtypes, freeze immediately (except in the + -- case of being in a "spec expression" where we never freeze + -- when we first see the expression). if Is_Packed (Slice_Subtype) and not In_Spec_Expression then Freeze_Itype (Slice_Subtype, N); - end if; + -- For all other cases insert an itype reference in the slice's actions + -- so that the itype is frozen at the proper place in the tree (i.e. at + -- the point where actions for the slice are analyzed). Note that this + -- is different from freezing the itype immediately, which might be + -- premature (e.g. if the slice is within a transient scope). + + else + Ensure_Defined (Typ => Slice_Subtype, N => N); + end if; end Set_Slice_Subtype; -------------------------------- @@ -9253,9 +9517,8 @@ package body Sem_Res is -- out-of-scope references. elsif - (Ekind (Target_Comp_Base) = E_Anonymous_Access_Type - or else - Ekind (Target_Comp_Base) = E_Anonymous_Access_Subprogram_Type) + Ekind_In (Target_Comp_Base, E_Anonymous_Access_Type, + E_Anonymous_Access_Subprogram_Type) and then Ekind (Opnd_Comp_Base) = Ekind (Target_Comp_Base) and then Subtypes_Statically_Match (Target_Comp_Type, Opnd_Comp_Type) @@ -9384,6 +9647,7 @@ package body Sem_Res is It : Interp; It1 : Interp; N1 : Entity_Id; + T1 : Entity_Id; begin -- Remove procedure calls, which syntactically cannot appear in @@ -9440,16 +9704,30 @@ package body Sem_Res is if Present (It.Typ) then N1 := It1.Nam; + T1 := It1.Typ; It1 := Disambiguate (Operand, I1, I, Any_Type); if It1 = No_Interp then Error_Msg_N ("ambiguous operand in conversion", Operand); - Error_Msg_Sloc := Sloc (It.Nam); + -- If the interpretation involves a standard operator, use + -- the location of the type, which may be user-defined. + + if Sloc (It.Nam) = Standard_Location then + Error_Msg_Sloc := Sloc (It.Typ); + else + Error_Msg_Sloc := Sloc (It.Nam); + end if; + Error_Msg_N -- CODEFIX ("\\possible interpretation#!", Operand); - Error_Msg_Sloc := Sloc (N1); + if Sloc (N1) = Standard_Location then + Error_Msg_Sloc := Sloc (T1); + else + Error_Msg_Sloc := Sloc (N1); + end if; + Error_Msg_N -- CODEFIX ("\\possible interpretation#!", Operand); @@ -9511,9 +9789,8 @@ package body Sem_Res is -- Ada 2005 (AI-251): Anonymous access types where target references an -- interface type. - elsif (Ekind (Target_Type) = E_General_Access_Type - or else - Ekind (Target_Type) = E_Anonymous_Access_Type) + elsif Ekind_In (Target_Type, E_General_Access_Type, + E_Anonymous_Access_Type) and then Is_Interface (Directly_Designated_Type (Target_Type)) then -- Check the static accessibility rule of 4.6(17). Note that the @@ -9582,8 +9859,8 @@ package body Sem_Res is if Is_Entity_Name (Operand) and then not Is_Local_Anonymous_Access (Opnd_Type) - and then (Ekind (Entity (Operand)) = E_In_Parameter - or else Ekind (Entity (Operand)) = E_Constant) + and then + Ekind_In (Entity (Operand), E_In_Parameter, E_Constant) and then Present (Discriminal_Link (Entity (Operand))) then Error_Msg_N @@ -9598,15 +9875,14 @@ package body Sem_Res is -- General and anonymous access types - elsif (Ekind (Target_Type) = E_General_Access_Type - or else Ekind (Target_Type) = E_Anonymous_Access_Type) + elsif Ekind_In (Target_Type, E_General_Access_Type, + E_Anonymous_Access_Type) and then Conversion_Check (Is_Access_Type (Opnd_Type) - and then Ekind (Opnd_Type) /= - E_Access_Subprogram_Type - and then Ekind (Opnd_Type) /= - E_Access_Protected_Subprogram_Type, + and then not + Ekind_In (Opnd_Type, E_Access_Subprogram_Type, + E_Access_Protected_Subprogram_Type), "must be an access-to-object type") then if Is_Access_Constant (Opnd_Type) @@ -9656,7 +9932,6 @@ package body Sem_Res is elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type and then not Is_Local_Anonymous_Access (Opnd_Type) then - -- When the operand is a selected access discriminant the check -- needs to be made against the level of the object denoted by -- the prefix of the selected name (Object_Access_Level handles @@ -9693,8 +9968,8 @@ package body Sem_Res is -- access type. if Is_Entity_Name (Operand) - and then (Ekind (Entity (Operand)) = E_In_Parameter - or else Ekind (Entity (Operand)) = E_Constant) + and then + Ekind_In (Entity (Operand), E_In_Parameter, E_Constant) and then Present (Discriminal_Link (Entity (Operand))) then Error_Msg_N @@ -9914,7 +10189,8 @@ package body Sem_Res is and then Is_Access_Type (Opnd_Type) then Error_Msg_N ("target type must be general access type!", N); - Error_Msg_NE ("add ALL to }!", N, Target_Type); + Error_Msg_NE -- CODEFIX + ("add ALL to }!", N, Target_Type); return False; else diff --git a/gcc/ada/sem_scil.adb b/gcc/ada/sem_scil.adb index 5adf803fc70..3ab7511663e 100644 --- a/gcc/ada/sem_scil.adb +++ b/gcc/ada/sem_scil.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -23,649 +23,170 @@ -- -- ------------------------------------------------------------------------------ -with Einfo; use Einfo; -with Namet; use Namet; -with Nlists; use Nlists; -with Opt; use Opt; -with Rtsfind; use Rtsfind; -with Sem; use Sem; -with Sem_Aux; use Sem_Aux; -with Sem_Util; use Sem_Util; -with Sinfo; use Sinfo; -with Snames; use Snames; -with Stand; use Stand; +with Einfo; use Einfo; +with Nlists; use Nlists; +with Rtsfind; use Rtsfind; +with Sem_Aux; use Sem_Aux; +with Sinfo; use Sinfo; +with Stand; use Stand; +with SCIL_LL; use SCIL_LL; package body Sem_SCIL is - ---------------------- - -- Adjust_SCIL_Node -- - ---------------------- - - procedure Adjust_SCIL_Node (Old_Node : Node_Id; New_Node : Node_Id) is - SCIL_Node : Node_Id; - - begin - pragma Assert (Generate_SCIL); - - -- Check cases in which no action is required. Currently the only SCIL - -- nodes that may require adjustment are those of dispatching calls - -- internally generated by the frontend. - - if Comes_From_Source (Old_Node) - or else not - Nkind_In (New_Node, N_Function_Call, N_Procedure_Call_Statement) - then - return; - - -- Conditional expression associated with equality operator. Old_Node - -- may be part of the expansion of the predefined equality operator of - -- a tagged type and hence we need to check if it has a SCIL dispatching - -- node that needs adjustment. - - elsif Nkind (Old_Node) = N_Conditional_Expression - and then (Nkind (Original_Node (Old_Node)) = N_Op_Eq - or else - (Nkind (Original_Node (Old_Node)) = N_Function_Call - and then Chars (Name (Original_Node (Old_Node))) = - Name_Op_Eq)) - then - null; - - -- Type conversions may involve dispatching calls to functions whose - -- associated SCIL dispatching node needs adjustment. - - elsif Nkind_In (Old_Node, N_Type_Conversion, - N_Unchecked_Type_Conversion) - then - null; - - -- Relocated subprogram call - - elsif Nkind (Old_Node) = Nkind (New_Node) - and then Original_Node (Old_Node) = Original_Node (New_Node) - then - null; - - else - return; - end if; - - -- Search for the SCIL node and update it (if found) - - SCIL_Node := Find_SCIL_Node (Old_Node); - - if Present (SCIL_Node) then - Set_SCIL_Related_Node (SCIL_Node, New_Node); - end if; - end Adjust_SCIL_Node; - --------------------- -- Check_SCIL_Node -- --------------------- function Check_SCIL_Node (N : Node_Id) return Traverse_Result is - Ctrl_Tag : Node_Id; - Ctrl_Typ : Entity_Id; + SCIL_Node : constant Node_Id := Get_SCIL_Node (N); + Ctrl_Tag : Node_Id; + Ctrl_Typ : Entity_Id; begin - if Nkind (N) = N_SCIL_Membership_Test then - - -- Check contents of the boolean expression associated with the - -- membership test. - - pragma Assert (Nkind (SCIL_Related_Node (N)) = N_Identifier - and then Etype (SCIL_Related_Node (N)) = Standard_Boolean); - - -- Check the entity identifier of the associated tagged type (that - -- is, in testing for membership in T'Class, the entity id of the - -- specific type T). - - -- Note: When the SCIL node is generated the private and full-view - -- of the tagged types may have been swapped and hence the node - -- referenced by attribute SCIL_Entity may be the private view. - -- Therefore, in order to uniformily locate the full-view we use - -- attribute Underlying_Type. + -- For nodes that do not have SCIL node continue traversing the tree - pragma Assert (Is_Tagged_Type (Underlying_Type (SCIL_Entity (N)))); - - -- Interface types are unsupported - - pragma Assert (not Is_Interface (Underlying_Type (SCIL_Entity (N)))); - - -- Check the decoration of the expression that denotes the tag value - -- being tested - - Ctrl_Tag := SCIL_Tag_Value (N); + if No (SCIL_Node) then + return OK; + end if; - case Nkind (Ctrl_Tag) is + case Nkind (SCIL_Node) is + when N_SCIL_Dispatch_Table_Tag_Init => + pragma Assert (Nkind (N) = N_Object_Declaration); + null; - -- For class-wide membership tests the SCIL tag value is the tag - -- of the tested object (i.e. Obj.Tag). + when N_SCIL_Dispatching_Call => + Ctrl_Tag := SCIL_Controlling_Tag (SCIL_Node); - when N_Selected_Component => - pragma Assert (Etype (Ctrl_Tag) = RTE (RE_Tag)); - null; + -- Parent of SCIL dispatching call nodes MUST be a subprogram call - when others => + if not Nkind_In (N, N_Function_Call, + N_Procedure_Call_Statement) + then pragma Assert (False); - null; - - end case; - - return Skip; + raise Program_Error; - elsif Nkind (N) = N_SCIL_Dispatching_Call then - Ctrl_Tag := SCIL_Controlling_Tag (N); + -- In simple cases the controlling tag is the tag of the + -- controlling argument (i.e. Obj.Tag). - -- SCIL_Related_Node of SCIL dispatching call nodes MUST reference - -- subprogram calls. + elsif Nkind (Ctrl_Tag) = N_Selected_Component then + Ctrl_Typ := Etype (Ctrl_Tag); - if not Nkind_In (SCIL_Related_Node (N), N_Function_Call, - N_Procedure_Call_Statement) - then - pragma Assert (False); - raise Program_Error; + -- Interface types are unsupported - -- In simple cases the controlling tag is the tag of the controlling - -- argument (i.e. Obj.Tag). + if Is_Interface (Ctrl_Typ) + or else (RTE_Available (RE_Interface_Tag) + and then Ctrl_Typ = RTE (RE_Interface_Tag)) + then + null; - elsif Nkind (Ctrl_Tag) = N_Selected_Component then - Ctrl_Typ := Etype (Ctrl_Tag); + else + pragma Assert (Ctrl_Typ = RTE (RE_Tag)); + null; + end if; - -- Interface types are unsupported + -- When the controlling tag of a dispatching call is an identifier + -- the SCIL_Controlling_Tag attribute references the corresponding + -- object or parameter declaration. Interface types are still + -- unsupported. - if Is_Interface (Ctrl_Typ) - or else (RTE_Available (RE_Interface_Tag) - and then Ctrl_Typ = RTE (RE_Interface_Tag)) + elsif Nkind_In (Ctrl_Tag, N_Object_Declaration, + N_Parameter_Specification) then - null; + Ctrl_Typ := Etype (Defining_Identifier (Ctrl_Tag)); + + -- Interface types are unsupported. + + if Is_Interface (Ctrl_Typ) + or else (RTE_Available (RE_Interface_Tag) + and then Ctrl_Typ = RTE (RE_Interface_Tag)) + or else (Is_Access_Type (Ctrl_Typ) + and then + Is_Interface + (Available_View + (Base_Type (Designated_Type (Ctrl_Typ))))) + then + null; - else - pragma Assert (Ctrl_Typ = RTE (RE_Tag)); - null; - end if; + else + pragma Assert + (Ctrl_Typ = RTE (RE_Tag) + or else + (Is_Access_Type (Ctrl_Typ) + and then Available_View + (Base_Type (Designated_Type (Ctrl_Typ))) + = RTE (RE_Tag))); + null; + end if; - -- When the controlling tag of a dispatching call is an identifier - -- the SCIL_Controlling_Tag attribute references the corresponding - -- object or parameter declaration. Interface types are still - -- unsupported. - - elsif Nkind_In (Ctrl_Tag, N_Object_Declaration, - N_Parameter_Specification) - then - Ctrl_Typ := Etype (Defining_Identifier (Ctrl_Tag)); - - -- Interface types are unsupported. - - if Is_Interface (Ctrl_Typ) - or else (RTE_Available (RE_Interface_Tag) - and then Ctrl_Typ = RTE (RE_Interface_Tag)) - or else (Is_Access_Type (Ctrl_Typ) - and then - Is_Interface - (Available_View - (Base_Type (Designated_Type (Ctrl_Typ))))) - then - null; + -- Interface types are unsupported - else - pragma Assert - (Ctrl_Typ = RTE (RE_Tag) - or else - (Is_Access_Type (Ctrl_Typ) - and then Available_View - (Base_Type (Designated_Type (Ctrl_Typ))) = - RTE (RE_Tag))); + elsif Is_Interface (Etype (Ctrl_Tag)) then null; - end if; - - -- Interface types are unsupported - - elsif Is_Interface (Etype (Ctrl_Tag)) then - null; - else - pragma Assert (False); - raise Program_Error; - end if; - - return Skip; - - -- Node is not N_SCIL_Dispatching_Call - - else - return OK; - end if; - end Check_SCIL_Node; - - -------------------- - -- Find_SCIL_Node -- - -------------------- - - function Find_SCIL_Node (Node : Node_Id) return Node_Id is - Found_Node : Node_Id; - -- This variable stores the last node found by the nested subprogram - -- Find_SCIL_Node. - - function Find_SCIL_Node (L : List_Id) return Boolean; - -- Searches in list L for a SCIL node associated with a dispatching call - -- whose SCIL_Related_Node is Node. If found returns true and stores the - -- SCIL node in Found_Node; otherwise returns False and sets Found_Node - -- to Empty. - - -------------------- - -- Find_SCIL_Node -- - -------------------- - - function Find_SCIL_Node (L : List_Id) return Boolean is - N : Node_Id; - - begin - N := First (L); - while Present (N) loop - if Nkind (N) in N_SCIL_Node - and then SCIL_Related_Node (N) = Node - then - Found_Node := N; - return True; + else + pragma Assert (False); + raise Program_Error; end if; - Next (N); - end loop; + return Skip; - Found_Node := Empty; - return False; - end Find_SCIL_Node; + when N_SCIL_Membership_Test => - -- Local variables + -- Check contents of the boolean expression associated with the + -- membership test. - P : Node_Id; + pragma Assert (Nkind_In (N, N_Identifier, + N_And_Then, + N_Or_Else, + N_Expression_With_Actions) + and then Etype (N) = Standard_Boolean); - -- Start of processing for Find_SCIL_Node + -- Check the entity identifier of the associated tagged type (that + -- is, in testing for membership in T'Class, the entity id of the + -- specific type T). - begin - pragma Assert (Generate_SCIL); - - -- Search for the SCIL node in list associated with a transient scope - - if Scope_Is_Transient then - declare - SE : Scope_Stack_Entry - renames Scope_Stack.Table (Scope_Stack.Last); - begin - if SE.Is_Transient - and then Present (SE.Actions_To_Be_Wrapped_Before) - and then Find_SCIL_Node (SE.Actions_To_Be_Wrapped_Before) - then - return Found_Node; - end if; - end; - end if; - - -- Otherwise climb up the tree searching for the SCIL node analyzing - -- all the lists in which Insert_Actions may have inserted it - - P := Node; - while Present (P) loop - case Nkind (P) is + -- Note: When the SCIL node is generated the private and full-view + -- of the tagged types may have been swapped and hence the node + -- referenced by attribute SCIL_Entity may be the private view. + -- Therefore, in order to uniformily locate the full-view we use + -- attribute Underlying_Type. - -- Actions associated with AND THEN or OR ELSE + pragma Assert + (Is_Tagged_Type (Underlying_Type (SCIL_Entity (SCIL_Node)))); - when N_Short_Circuit => - if Present (Actions (P)) - and then Find_SCIL_Node (Actions (P)) - then - return Found_Node; - end if; - - -- Actions of conditional expressions - - when N_Conditional_Expression => - if (Present (Then_Actions (P)) - and then Find_SCIL_Node (Actions (P))) - or else - (Present (Else_Actions (P)) - and then Find_SCIL_Node (Else_Actions (P))) - then - return Found_Node; - end if; - - -- Actions in handled sequence of statements + -- Interface types are unsupported - when - N_Handled_Sequence_Of_Statements => - if Find_SCIL_Node (Statements (P)) then - return Found_Node; - end if; + pragma Assert + (not Is_Interface (Underlying_Type (SCIL_Entity (SCIL_Node)))); - -- Conditions of while expression or elsif. + -- Check the decoration of the expression that denotes the tag + -- value being tested - when N_Iteration_Scheme | - N_Elsif_Part - => - if Present (Condition_Actions (P)) - and then Find_SCIL_Node (Condition_Actions (P)) - then - return Found_Node; - end if; + Ctrl_Tag := SCIL_Tag_Value (SCIL_Node); - -- Statements, declarations, pragmas, representation clauses - - when - -- Statements - - N_Procedure_Call_Statement | - N_Statement_Other_Than_Procedure_Call | - - -- Pragmas - - N_Pragma | - - -- Representation_Clause - - N_At_Clause | - N_Attribute_Definition_Clause | - N_Enumeration_Representation_Clause | - N_Record_Representation_Clause | - - -- Declarations - - N_Abstract_Subprogram_Declaration | - N_Entry_Body | - N_Exception_Declaration | - N_Exception_Renaming_Declaration | - N_Formal_Abstract_Subprogram_Declaration | - N_Formal_Concrete_Subprogram_Declaration | - N_Formal_Object_Declaration | - N_Formal_Type_Declaration | - N_Full_Type_Declaration | - N_Function_Instantiation | - N_Generic_Function_Renaming_Declaration | - N_Generic_Package_Declaration | - N_Generic_Package_Renaming_Declaration | - N_Generic_Procedure_Renaming_Declaration | - N_Generic_Subprogram_Declaration | - N_Implicit_Label_Declaration | - N_Incomplete_Type_Declaration | - N_Number_Declaration | - N_Object_Declaration | - N_Object_Renaming_Declaration | - N_Package_Body | - N_Package_Body_Stub | - N_Package_Declaration | - N_Package_Instantiation | - N_Package_Renaming_Declaration | - N_Private_Extension_Declaration | - N_Private_Type_Declaration | - N_Procedure_Instantiation | - N_Protected_Body | - N_Protected_Body_Stub | - N_Protected_Type_Declaration | - N_Single_Task_Declaration | - N_Subprogram_Body | - N_Subprogram_Body_Stub | - N_Subprogram_Declaration | - N_Subprogram_Renaming_Declaration | - N_Subtype_Declaration | - N_Task_Body | - N_Task_Body_Stub | - N_Task_Type_Declaration | - - -- Freeze entity behaves like a declaration or statement - - N_Freeze_Entity - => - -- Do not search here if the item is not a list member - - if not Is_List_Member (P) then - null; + case Nkind (Ctrl_Tag) is - -- Do not search if parent of P is an N_Component_Association - -- node (i.e. we are in the context of an N_Aggregate or - -- N_Extension_Aggregate node). In this case the node should - -- have been added before the entire aggregate. + -- For class-wide membership tests the SCIL tag value is the + -- tag of the tested object (i.e. Obj.Tag). - elsif Nkind (Parent (P)) = N_Component_Association then + when N_Selected_Component => + pragma Assert (Etype (Ctrl_Tag) = RTE (RE_Tag)); null; - -- Do not search if the parent of P is either an N_Variant - -- node or an N_Record_Definition node. In this case the node - -- should have been added before the entire record. - - elsif Nkind (Parent (P)) = N_Variant - or else Nkind (Parent (P)) = N_Record_Definition - then + when others => + pragma Assert (False); null; + end case; - -- Otherwise search it in the list containing this node - - elsif Find_SCIL_Node (List_Containing (P)) then - return Found_Node; - end if; - - -- A special case, N_Raise_xxx_Error can act either as a statement - -- or a subexpression. We diferentiate them by looking at the - -- Etype. It is set to Standard_Void_Type in the statement case. - - when - N_Raise_xxx_Error => - if Etype (P) = Standard_Void_Type then - if Is_List_Member (P) - and then Find_SCIL_Node (List_Containing (P)) - then - return Found_Node; - end if; - - -- In the subexpression case, keep climbing - - else - null; - end if; - - -- If a component association appears within a loop created for - -- an array aggregate, check if the SCIL node was added to the - -- the list of nodes attached to the association. - - when - N_Component_Association => - if Nkind (Parent (P)) = N_Aggregate - and then Present (Loop_Actions (P)) - and then Find_SCIL_Node (Loop_Actions (P)) - then - return Found_Node; - end if; - - -- Another special case, an attribute denoting a procedure call - - when - N_Attribute_Reference => - if Is_Procedure_Attribute_Name (Attribute_Name (P)) - and then Find_SCIL_Node (List_Containing (P)) - then - return Found_Node; - - -- In the subexpression case, keep climbing - - else - null; - end if; - - -- SCIL nodes do not have subtrees and hence they can never be - -- found climbing tree - - when - N_SCIL_Dispatch_Table_Object_Init | - N_SCIL_Dispatch_Table_Tag_Init | - N_SCIL_Dispatching_Call | - N_SCIL_Membership_Test | - N_SCIL_Tag_Init - => - pragma Assert (False); - raise Program_Error; - - -- For all other node types, keep climbing tree - - when - N_Abortable_Part | - N_Accept_Alternative | - N_Access_Definition | - N_Access_Function_Definition | - N_Access_Procedure_Definition | - N_Access_To_Object_Definition | - N_Aggregate | - N_Allocator | - N_Case_Statement_Alternative | - N_Character_Literal | - N_Compilation_Unit | - N_Compilation_Unit_Aux | - N_Component_Clause | - N_Component_Declaration | - N_Component_Definition | - N_Component_List | - N_Constrained_Array_Definition | - N_Decimal_Fixed_Point_Definition | - N_Defining_Character_Literal | - N_Defining_Identifier | - N_Defining_Operator_Symbol | - N_Defining_Program_Unit_Name | - N_Delay_Alternative | - N_Delta_Constraint | - N_Derived_Type_Definition | - N_Designator | - N_Digits_Constraint | - N_Discriminant_Association | - N_Discriminant_Specification | - N_Empty | - N_Entry_Body_Formal_Part | - N_Entry_Call_Alternative | - N_Entry_Declaration | - N_Entry_Index_Specification | - N_Enumeration_Type_Definition | - N_Error | - N_Exception_Handler | - N_Expanded_Name | - N_Explicit_Dereference | - N_Extension_Aggregate | - N_Floating_Point_Definition | - N_Formal_Decimal_Fixed_Point_Definition | - N_Formal_Derived_Type_Definition | - N_Formal_Discrete_Type_Definition | - N_Formal_Floating_Point_Definition | - N_Formal_Modular_Type_Definition | - N_Formal_Ordinary_Fixed_Point_Definition | - N_Formal_Package_Declaration | - N_Formal_Private_Type_Definition | - N_Formal_Signed_Integer_Type_Definition | - N_Function_Call | - N_Function_Specification | - N_Generic_Association | - N_Identifier | - N_In | - N_Index_Or_Discriminant_Constraint | - N_Indexed_Component | - N_Integer_Literal | - N_Itype_Reference | - N_Label | - N_Loop_Parameter_Specification | - N_Mod_Clause | - N_Modular_Type_Definition | - N_Not_In | - N_Null | - N_Op_Abs | - N_Op_Add | - N_Op_And | - N_Op_Concat | - N_Op_Divide | - N_Op_Eq | - N_Op_Expon | - N_Op_Ge | - N_Op_Gt | - N_Op_Le | - N_Op_Lt | - N_Op_Minus | - N_Op_Mod | - N_Op_Multiply | - N_Op_Ne | - N_Op_Not | - N_Op_Or | - N_Op_Plus | - N_Op_Rem | - N_Op_Rotate_Left | - N_Op_Rotate_Right | - N_Op_Shift_Left | - N_Op_Shift_Right | - N_Op_Shift_Right_Arithmetic | - N_Op_Subtract | - N_Op_Xor | - N_Operator_Symbol | - N_Ordinary_Fixed_Point_Definition | - N_Others_Choice | - N_Package_Specification | - N_Parameter_Association | - N_Parameter_Specification | - N_Pop_Constraint_Error_Label | - N_Pop_Program_Error_Label | - N_Pop_Storage_Error_Label | - N_Pragma_Argument_Association | - N_Procedure_Specification | - N_Protected_Definition | - N_Push_Constraint_Error_Label | - N_Push_Program_Error_Label | - N_Push_Storage_Error_Label | - N_Qualified_Expression | - N_Range | - N_Range_Constraint | - N_Real_Literal | - N_Real_Range_Specification | - N_Record_Definition | - N_Reference | - N_Selected_Component | - N_Signed_Integer_Type_Definition | - N_Single_Protected_Declaration | - N_Slice | - N_String_Literal | - N_Subprogram_Info | - N_Subtype_Indication | - N_Subunit | - N_Task_Definition | - N_Terminate_Alternative | - N_Triggering_Alternative | - N_Type_Conversion | - N_Unchecked_Expression | - N_Unchecked_Type_Conversion | - N_Unconstrained_Array_Definition | - N_Unused_At_End | - N_Unused_At_Start | - N_Use_Package_Clause | - N_Use_Type_Clause | - N_Variant | - N_Variant_Part | - N_Validate_Unchecked_Conversion | - N_With_Clause - => - null; - - end case; - - -- If we fall through above tests, keep climbing tree - - if Nkind (Parent (P)) = N_Subunit then - - -- This is the proper body corresponding to a stub. Insertion done - -- at the point of the stub, which is in the declarative part of - -- the parent unit. + return Skip; - P := Corresponding_Stub (Parent (P)); - - else - P := Parent (P); - end if; - end loop; - - -- SCIL node not found + when others => + pragma Assert (False); + raise Program_Error; + end case; - return Empty; - end Find_SCIL_Node; + return Skip; + end Check_SCIL_Node; ------------------------- -- First_Non_SCIL_Node -- diff --git a/gcc/ada/sem_scil.ads b/gcc/ada/sem_scil.ads index f257e636295..1a6e45caacb 100644 --- a/gcc/ada/sem_scil.ads +++ b/gcc/ada/sem_scil.ads @@ -4,9 +4,9 @@ -- -- -- S E M _ S C I L -- -- -- --- B o d y -- +-- S p e c -- -- -- --- Copyright (C) 2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -33,10 +33,6 @@ package Sem_SCIL is -- Here would be a good place to document what SCIL is all about ??? - procedure Adjust_SCIL_Node (Old_Node : Node_Id; New_Node : Node_Id); - -- Searches for a SCIL dispatching node associated with Old_Node. If found - -- then update its SCIL_Related_Node field to reference New_Node. - function Check_SCIL_Node (N : Node_Id) return Traverse_Result; -- Process a single node during the tree traversal. Done to verify that -- SCIL nodes decoration fulfill the requirements of the SCIL backend. @@ -44,10 +40,6 @@ package Sem_SCIL is procedure Check_SCIL_Nodes is new Traverse_Proc (Check_SCIL_Node); -- The traversal procedure itself - function Find_SCIL_Node (Node : Node_Id) return Node_Id; - -- Searches for a SCIL dispatching node associated with Node. If not found - -- then return Empty. - function First_Non_SCIL_Node (L : List_Id) return Node_Id; -- Returns the first non-SCIL node of list L diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index d35326e1a50..b1962861556 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -362,7 +362,6 @@ package body Sem_Type is -- performed, given that the operator was visible in the generic. if Ekind (E) = E_Operator then - if Present (Opnd_Type) then Vis_Type := Opnd_Type; else @@ -803,8 +802,8 @@ package body Sem_Type is then return True; - -- The context may be class wide, and a class-wide type is - -- compatible with any member of the class. + -- The context may be class wide, and a class-wide type is compatible + -- with any member of the class. elsif Is_Class_Wide_Type (T1) and then Is_Ancestor (Root_Type (T1), T2) @@ -997,9 +996,7 @@ package body Sem_Type is -- imposed by context. elsif Ekind (T2) = E_Access_Attribute_Type - and then (Ekind (BT1) = E_General_Access_Type - or else - Ekind (BT1) = E_Access_Type) + and then Ekind_In (BT1, E_General_Access_Type, E_Access_Type) and then Covers (Designated_Type (T1), Designated_Type (T2)) then -- If the target type is a RACW type while the source is an access @@ -1677,9 +1674,8 @@ package body Sem_Type is elsif Nkind (Parent (N)) = N_Object_Renaming_Declaration and then Present (Access_Definition (Parent (N))) then - if Ekind (It1.Typ) = E_Anonymous_Access_Type - or else - Ekind (It1.Typ) = E_Anonymous_Access_Subprogram_Type + if Ekind_In (It1.Typ, E_Anonymous_Access_Type, + E_Anonymous_Access_Subprogram_Type) then if Ekind (It2.Typ) = Ekind (It1.Typ) then @@ -1691,9 +1687,8 @@ package body Sem_Type is return It1; end if; - elsif Ekind (It2.Typ) = E_Anonymous_Access_Type - or else - Ekind (It2.Typ) = E_Anonymous_Access_Subprogram_Type + elsif Ekind_In (It2.Typ, E_Anonymous_Access_Type, + E_Anonymous_Access_Subprogram_Type) then return It2; @@ -1880,8 +1875,8 @@ package body Sem_Type is if Ekind (Etype (Opnd)) = E_Anonymous_Access_Type and then - List_Containing (Parent (Designated_Type (Etype (Opnd)))) - = List_Containing (Unit_Declaration_Node (User_Subp)) + List_Containing (Parent (Designated_Type (Etype (Opnd)))) + = List_Containing (Unit_Declaration_Node (User_Subp)) then if It2.Nam = Predef_Subp then return It1; @@ -2559,9 +2554,9 @@ package body Sem_Type is BT1 := Base_Type (T1); BT2 := Base_Type (T2); - -- Handle underlying view of records with unknown discriminants - -- using the original entity that motivated the construction of - -- this underlying record view (see Build_Derived_Private_Type). + -- Handle underlying view of records with unknown discriminants using + -- the original entity that motivated the construction of this + -- underlying record view (see Build_Derived_Private_Type). if Is_Underlying_Record_View (BT1) then BT1 := Underlying_Record_View (BT1); @@ -2574,12 +2569,20 @@ package body Sem_Type is if BT1 = BT2 then return True; + -- The predicate must look past privacy + elsif Is_Private_Type (T1) and then Present (Full_View (T1)) and then BT2 = Base_Type (Full_View (T1)) then return True; + elsif Is_Private_Type (T2) + and then Present (Full_View (T2)) + and then BT1 = Base_Type (Full_View (T2)) + then + return True; + else Par := Etype (BT2); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index e56066b7d4d..e846845ca70 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -50,19 +50,20 @@ with Sem_Ch8; use Sem_Ch8; with Sem_Disp; use Sem_Disp; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; -with Sem_SCIL; use Sem_SCIL; with Sem_Type; use Sem_Type; with Sinfo; use Sinfo; with Sinput; use Sinput; with Stand; use Stand; with Style; with Stringt; use Stringt; +with Table; with Targparm; use Targparm; with Tbuild; use Tbuild; with Ttypes; use Ttypes; with Uname; use Uname; with GNAT.HTable; use GNAT.HTable; + package body Sem_Util is ---------------------------------------- @@ -94,6 +95,30 @@ package body Sem_Util is subtype NCT_Header_Num is Int range 0 .. 511; -- Defines range of headers in hash tables (512 headers) + ---------------------------------- + -- Order Dependence (AI05-0144) -- + ---------------------------------- + + -- Each actual in a call is entered into the table below. A flag indicates + -- whether the corresponding formal is OUT or IN OUT. Each top-level call + -- (procedure call, condition, assignment) examines all the actuals for a + -- possible order dependence. The table is reset after each such check. + + type Actual_Name is record + Act : Node_Id; + Is_Writable : Boolean; + -- Comments needed??? + + end record; + + package Actuals_In_Call is new Table.Table ( + Table_Component_Type => Actual_Name, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Actuals"); + ----------------------- -- Local Subprograms -- ----------------------- @@ -398,9 +423,7 @@ package body Sem_Util is end loop; end if; - Subt := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); + Subt := Make_Temporary (Loc, 'S', Related_Node => N); Set_Is_Internal (Subt); Decl := @@ -543,8 +566,8 @@ package body Sem_Util is and then Is_Constrained (Root_Type (T))) and then not Has_Unknown_Discriminants (T) then - -- If the type of the dereference is already constrained, it - -- is an actual subtype. + -- If the type of the dereference is already constrained, it is an + -- actual subtype. if Is_Array_Type (Etype (N)) and then Is_Constrained (Etype (N)) @@ -624,9 +647,7 @@ package body Sem_Util is return Empty; end if; - Subt := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); + Subt := Make_Temporary (Loc, 'S'); Set_Is_Internal (Subt); Decl := @@ -666,10 +687,7 @@ package body Sem_Util is end if; declare - Act : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); - + Act : constant Entity_Id := Make_Temporary (Loc, 'S'); Constraints : constant List_Id := New_List; Decl : Node_Id; @@ -1151,6 +1169,53 @@ package body Sem_Util is end if; end Check_Nested_Access; + ---------------------------- + -- Check_Order_Dependence -- + ---------------------------- + + procedure Check_Order_Dependence is + Act1 : Node_Id; + Act2 : Node_Id; + + begin + -- This could use comments ??? + + for J in 0 .. Actuals_In_Call.Last loop + if Actuals_In_Call.Table (J).Is_Writable then + Act1 := Actuals_In_Call.Table (J).Act; + + if Nkind (Act1) = N_Attribute_Reference then + Act1 := Prefix (Act1); + end if; + + for K in 0 .. Actuals_In_Call.Last loop + if K /= J then + Act2 := Actuals_In_Call.Table (K).Act; + + if Nkind (Act2) = N_Attribute_Reference then + Act2 := Prefix (Act2); + end if; + + if Actuals_In_Call.Table (K).Is_Writable + and then K < J + then + -- Already checked + + null; + + elsif Denotes_Same_Object (Act1, Act2) + and then False + then + Error_Msg_N ("?,mighty suspicious!!!", Act1); + end if; + end if; + end loop; + end if; + end loop; + + Actuals_In_Call.Set_Last (0); + end Check_Order_Dependence; + ------------------------------------------ -- Check_Potentially_Blocking_Operation -- ------------------------------------------ @@ -1677,18 +1742,40 @@ package body Sem_Util is and then (not Formal_Derived or else Present (Alias (Id))) then - Append_Elmt (Id, Op_List); + -- In the special case of an equality operator aliased to + -- an overriding dispatching equality belonging to the same + -- type, we don't include it in the list of primitives. + -- This avoids inheriting multiple equality operators when + -- deriving from untagged private types whose full type is + -- tagged, which can otherwise cause ambiguities. Note that + -- this should only happen for this kind of untagged parent + -- type, since normally dispatching operations are inherited + -- using the type's Primitive_Operations list. + + if Chars (Id) = Name_Op_Eq + and then Is_Dispatching_Operation (Id) + and then Present (Alias (Id)) + and then Is_Overriding_Operation (Alias (Id)) + and then Base_Type (Etype (First_Entity (Id))) = + Base_Type (Etype (First_Entity (Alias (Id)))) + then + null; + + -- Include the subprogram in the list of primitives + + else + Append_Elmt (Id, Op_List); + end if; end if; end if; Next_Entity (Id); - -- For a type declared in System, some of its operations - -- may appear in the target-specific extension to System. + -- For a type declared in System, some of its operations may + -- appear in the target-specific extension to System. if No (Id) - and then Chars (B_Scope) = Name_System - and then Scope (B_Scope) = Standard_Standard + and then B_Scope = RTU_Entity (System) and then Present_System_Aux then B_Scope := System_Aux_Id; @@ -2080,9 +2167,7 @@ package body Sem_Util is -- so we can continue semantic analysis elsif Nam = Error then - Err := - Make_Defining_Identifier (Sloc (N), - Chars => New_Internal_Name ('T')); + Err := Make_Temporary (Sloc (N), 'T'); Set_Defining_Unit_Name (N, Err); return Err; @@ -2238,7 +2323,9 @@ package body Sem_Util is begin if Is_Entity_Name (A1) then - if Nkind_In (A2, N_Selected_Component, N_Indexed_Component) then + if Nkind_In (A2, N_Selected_Component, N_Indexed_Component) + and then not Is_Access_Type (Etype (A1)) + then return Denotes_Same_Object (A1, Prefix (A2)) or else Denotes_Same_Prefix (A1, Prefix (A2)); else @@ -2558,7 +2645,12 @@ package body Sem_Util is elsif Ekind (Dynamic_Scope) = E_Task_Type then return Get_Task_Body_Procedure (Dynamic_Scope); - elsif Convention (Dynamic_Scope) = Convention_Protected then + -- No body is generated if the protected operation is eliminated + + elsif Convention (Dynamic_Scope) = Convention_Protected + and then not Is_Eliminated (Dynamic_Scope) + and then Present (Protected_Body_Subprogram (Dynamic_Scope)) + then return Protected_Body_Subprogram (Dynamic_Scope); else @@ -2817,9 +2909,7 @@ package body Sem_Util is -- Avoid cascaded messages with duplicate components in -- derived types. - if Ekind (E) = E_Component - or else Ekind (E) = E_Discriminant - then + if Ekind_In (E, E_Component, E_Discriminant) then return; end if; end if; @@ -2854,9 +2944,7 @@ package body Sem_Util is -- midst of inheriting components in a derived record definition. -- Preserve their Ekind and Etype. - if Ekind (Def_Id) = E_Discriminant - or else Ekind (Def_Id) = E_Component - then + if Ekind_In (Def_Id, E_Discriminant, E_Component) then null; -- If a type is already set, leave it alone (happens whey a type @@ -2876,8 +2964,7 @@ package body Sem_Util is -- Inherited discriminants and components in derived record types are -- immediately visible. Itypes are not. - if Ekind (Def_Id) = E_Discriminant - or else Ekind (Def_Id) = E_Component + if Ekind_In (Def_Id, E_Discriminant, E_Component) or else (No (Corresponding_Remote_Type (Def_Id)) and then not Is_Itype (Def_Id)) then @@ -3048,6 +3135,38 @@ package body Sem_Util is Call := Empty; end Find_Actual; + --------------------------- + -- Find_Body_Discriminal -- + --------------------------- + + function Find_Body_Discriminal + (Spec_Discriminant : Entity_Id) return Entity_Id + is + pragma Assert (Is_Concurrent_Record_Type (Scope (Spec_Discriminant))); + + Tsk : constant Entity_Id := + Corresponding_Concurrent_Type (Scope (Spec_Discriminant)); + Disc : Entity_Id; + + begin + -- Find discriminant of original concurrent type, and use its current + -- discriminal, which is the renaming within the task/protected body. + + Disc := First_Discriminant (Tsk); + while Present (Disc) loop + if Chars (Disc) = Chars (Spec_Discriminant) then + return Discriminal (Disc); + end if; + + Next_Discriminant (Disc); + end loop; + + -- That loop should always succeed in finding a matching entry and + -- returning. Fatal error if not. + + raise Program_Error; + end Find_Body_Discriminal; + ------------------------------------- -- Find_Corresponding_Discriminant -- ------------------------------------- @@ -4452,15 +4571,13 @@ package body Sem_Util is (T : Entity_Id; Use_Full_View : Boolean := True) return Boolean is - Typ : Entity_Id; + Typ : Entity_Id := Base_Type (T); begin -- Handle concurrent types - if Is_Concurrent_Type (T) then - Typ := Corresponding_Record_Type (T); - else - Typ := T; + if Is_Concurrent_Type (Typ) then + Typ := Corresponding_Record_Type (Typ); end if; if not Present (Typ) @@ -4848,10 +4965,8 @@ package body Sem_Util is -- We are interested only in components and discriminants - if Ekind (Ent) = E_Component - or else - Ekind (Ent) = E_Discriminant - then + if Ekind_In (Ent, E_Component, E_Discriminant) then + -- Get default expression if any. If there is no declaration -- node, it means we have an internal entity. The parent and -- tag fields are examples of such entities. For these cases, @@ -5406,15 +5521,6 @@ package body Sem_Util is begin Save_Interps (N, New_Prefix); - -- Check if the node relocation requires readjustment of some SCIL - -- dispatching node. - - if Generate_SCIL - and then Nkind (N) = N_Function_Call - then - Adjust_SCIL_Node (N, New_Prefix); - end if; - Rewrite (N, Make_Explicit_Dereference (Sloc (N), Prefix => New_Prefix)); Set_Etype (N, Designated_Type (Etype (New_Prefix))); @@ -5700,7 +5806,14 @@ package body Sem_Util is -- Start of processing for Is_Atomic_Object begin - if Is_Atomic (Etype (N)) + -- Predicate is not relevant to subprograms + + if Is_Entity_Name (N) + and then Is_Overloadable (Entity (N)) + then + return False; + + elsif Is_Atomic (Etype (N)) or else (Is_Entity_Name (N) and then Is_Atomic (Entity (N))) then return True; @@ -5797,6 +5910,54 @@ package body Sem_Util is and then Is_Imported (Entity (Name (N))); end Is_CPP_Constructor_Call; + ----------------- + -- Is_Delegate -- + ----------------- + + function Is_Delegate (T : Entity_Id) return Boolean is + Desig_Type : Entity_Id; + + begin + if VM_Target /= CLI_Target then + return False; + end if; + + -- Access-to-subprograms are delegates in CIL + + if Ekind (T) = E_Access_Subprogram_Type then + return True; + end if; + + if Ekind (T) not in Access_Kind then + + -- A delegate is a managed pointer. If no designated type is defined + -- it means that it's not a delegate. + + return False; + end if; + + Desig_Type := Etype (Directly_Designated_Type (T)); + + if not Is_Tagged_Type (Desig_Type) then + return False; + end if; + + -- Test if the type is inherited from [mscorlib]System.Delegate + + while Etype (Desig_Type) /= Desig_Type loop + if Chars (Scope (Desig_Type)) /= No_Name + and then Is_Imported (Scope (Desig_Type)) + and then Get_Name_String (Chars (Scope (Desig_Type))) = "delegate" + then + return True; + end if; + + Desig_Type := Etype (Desig_Type); + end loop; + + return False; + end Is_Delegate; + ---------------------------------------------- -- Is_Dependent_Component_Of_Mutable_Object -- ---------------------------------------------- @@ -6376,10 +6537,7 @@ package body Sem_Util is Ent : constant Entity_Id := Entity (Expr); Sub : constant Entity_Id := Enclosing_Subprogram (Ent); begin - if Ekind (Ent) /= E_Variable - and then - Ekind (Ent) /= E_In_Out_Parameter - then + if not Ekind_In (Ent, E_Variable, E_In_Out_Parameter) then return False; else return Present (Sub) and then Sub = Current_Subprogram; @@ -7033,6 +7191,15 @@ package body Sem_Util is return (U /= 0); end Is_True; + ------------------------------- + -- Is_Universal_Numeric_Type -- + ------------------------------- + + function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean is + begin + return T = Universal_Integer or else T = Universal_Real; + end Is_Universal_Numeric_Type; + ------------------- -- Is_Value_Type -- ------------------- @@ -7045,53 +7212,25 @@ package body Sem_Util is and then Get_Name_String (Chars (T)) = "valuetype"; end Is_Value_Type; - ----------------- - -- Is_Delegate -- - ----------------- - - function Is_Delegate (T : Entity_Id) return Boolean is - Desig_Type : Entity_Id; + --------------------- + -- Is_VMS_Operator -- + --------------------- + function Is_VMS_Operator (Op : Entity_Id) return Boolean is begin - if VM_Target /= CLI_Target then - return False; - end if; - - -- Access-to-subprograms are delegates in CIL - - if Ekind (T) = E_Access_Subprogram_Type then - return True; - end if; - - if Ekind (T) not in Access_Kind then - - -- A delegate is a managed pointer. If no designated type is defined - -- it means that it's not a delegate. - - return False; - end if; - - Desig_Type := Etype (Directly_Designated_Type (T)); - - if not Is_Tagged_Type (Desig_Type) then - return False; - end if; - - -- Test if the type is inherited from [mscorlib]System.Delegate - - while Etype (Desig_Type) /= Desig_Type loop - if Chars (Scope (Desig_Type)) /= No_Name - and then Is_Imported (Scope (Desig_Type)) - and then Get_Name_String (Chars (Scope (Desig_Type))) = "delegate" - then - return True; - end if; - - Desig_Type := Etype (Desig_Type); - end loop; + -- The VMS operators are declared in a child of System that is loaded + -- through pragma Extend_System. In some rare cases a program is run + -- with this extension but without indicating that the target is VMS. - return False; - end Is_Delegate; + return Ekind (Op) = E_Function + and then Is_Intrinsic_Subprogram (Op) + and then + ((Present_System_Aux + and then Scope (Op) = System_Aux_Id) + or else + (True_VMS_Target + and then Scope (Scope (Op)) = RTU_Entity (System))); + end Is_VMS_Operator; ----------------- -- Is_Variable -- @@ -7107,14 +7246,14 @@ package body Sem_Util is -- expansion. function In_Protected_Function (E : Entity_Id) return Boolean; - -- Within a protected function, the private components of the - -- enclosing protected type are constants. A function nested within - -- a (protected) procedure is not itself protected. + -- Within a protected function, the private components of the enclosing + -- protected type are constants. A function nested within a (protected) + -- procedure is not itself protected. function Is_Variable_Prefix (P : Node_Id) return Boolean; - -- Prefixes can involve implicit dereferences, in which case we - -- must test for the case of a reference of a constant access - -- type, which can never be a variable. + -- Prefixes can involve implicit dereferences, in which case we must + -- test for the case of a reference of a constant access type, which can + -- can never be a variable. --------------------------- -- In_Protected_Function -- @@ -7130,9 +7269,7 @@ package body Sem_Util is else S := Current_Scope; while Present (S) and then S /= Prot loop - if Ekind (S) = E_Function - and then Scope (S) = Prot - then + if Ekind (S) = E_Function and then Scope (S) = Prot then return True; end if; @@ -7177,16 +7314,16 @@ package body Sem_Util is if Nkind (N) in N_Subexpr and then Assignment_OK (N) then return True; - -- Normally we go to the original node, but there is one exception - -- where we use the rewritten node, namely when it is an explicit - -- dereference. The generated code may rewrite a prefix which is an - -- access type with an explicit dereference. The dereference is a - -- variable, even though the original node may not be (since it could - -- be a constant of the access type). + -- Normally we go to the original node, but there is one exception where + -- we use the rewritten node, namely when it is an explicit dereference. + -- The generated code may rewrite a prefix which is an access type with + -- an explicit dereference. The dereference is a variable, even though + -- the original node may not be (since it could be a constant of the + -- access type). - -- In Ada 2005 we have a further case to consider: the prefix may be - -- a function call given in prefix notation. The original node appears - -- to be a selected component, but we need to examine the call. + -- In Ada 2005 we have a further case to consider: the prefix may be a + -- function call given in prefix notation. The original node appears to + -- be a selected component, but we need to examine the call. elsif Nkind (N) = N_Explicit_Dereference and then Nkind (Orig_Node) /= N_Explicit_Dereference @@ -7805,6 +7942,17 @@ package body Sem_Util is if Nkind (N) = N_Allocator then if Is_Dynamic then Set_Is_Dynamic_Coextension (N); + + -- If the allocator expression is potentially dynamic, it may + -- be expanded out of order and require dynamic allocation + -- anyway, so we treat the coextension itself as dynamic. + -- Potential optimization ??? + + elsif Nkind (Expression (N)) = N_Qualified_Expression + and then Nkind (Expression (Expression (N))) = N_Op_Concat + then + Set_Is_Dynamic_Coextension (N); + else Set_Is_Static_Coextension (N); end if; @@ -8647,9 +8795,7 @@ package body Sem_Util is -- If a record subtype is simply copied, the entity list will be -- shared. Thus cloned_Subtype must be set to indicate the sharing. - if Ekind (Old_Itype) = E_Record_Subtype - or else Ekind (Old_Itype) = E_Class_Wide_Subtype - then + if Ekind_In (Old_Itype, E_Record_Subtype, E_Class_Wide_Subtype) then Set_Cloned_Subtype (New_Itype, Old_Itype); end if; @@ -8852,8 +8998,7 @@ package body Sem_Util is Sloc_Value : Source_Ptr; Id_Char : Character) return Entity_Id is - N : constant Entity_Id := - Make_Defining_Identifier (Sloc_Value, New_Internal_Name (Id_Char)); + N : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char); begin Set_Ekind (N, Kind); @@ -9468,15 +9613,112 @@ package body Sem_Util is then return Object_Access_Level (Expression (Obj)); - -- Function results are objects, so we get either the access level of - -- the function or, in the case of an indirect call, the level of the - -- access-to-subprogram type. - elsif Nkind (Obj) = N_Function_Call then - if Is_Entity_Name (Name (Obj)) then - return Subprogram_Access_Level (Entity (Name (Obj))); + + -- Function results are objects, so we get either the access level of + -- the function or, in the case of an indirect call, the level of the + -- access-to-subprogram type. (This code is used for Ada 95, but it + -- looks wrong, because it seems that we should be checking the level + -- of the call itself, even for Ada 95. However, using the Ada 2005 + -- version of the code causes regressions in several tests that are + -- compiled with -gnat95. ???) + + if Ada_Version < Ada_05 then + if Is_Entity_Name (Name (Obj)) then + return Subprogram_Access_Level (Entity (Name (Obj))); + else + return Type_Access_Level (Etype (Prefix (Name (Obj)))); + end if; + + -- For Ada 2005, the level of the result object of a function call is + -- defined to be the level of the call's innermost enclosing master. + -- We determine that by querying the depth of the innermost enclosing + -- dynamic scope. + else - return Type_Access_Level (Etype (Prefix (Name (Obj)))); + Return_Master_Scope_Depth_Of_Call : declare + + function Innermost_Master_Scope_Depth + (N : Node_Id) return Uint; + -- Returns the scope depth of the given node's innermost + -- enclosing dynamic scope (effectively the accessibility + -- level of the innermost enclosing master). + + ---------------------------------- + -- Innermost_Master_Scope_Depth -- + ---------------------------------- + + function Innermost_Master_Scope_Depth + (N : Node_Id) return Uint + is + Node_Par : Node_Id := Parent (N); + + begin + -- Locate the nearest enclosing node (by traversing Parents) + -- that Defining_Entity can be applied to, and return the + -- depth of that entity's nearest enclosing dynamic scope. + + while Present (Node_Par) loop + case Nkind (Node_Par) is + when N_Component_Declaration | + N_Entry_Declaration | + N_Formal_Object_Declaration | + N_Formal_Type_Declaration | + N_Full_Type_Declaration | + N_Incomplete_Type_Declaration | + N_Loop_Parameter_Specification | + N_Object_Declaration | + N_Protected_Type_Declaration | + N_Private_Extension_Declaration | + N_Private_Type_Declaration | + N_Subtype_Declaration | + N_Function_Specification | + N_Procedure_Specification | + N_Task_Type_Declaration | + N_Body_Stub | + N_Generic_Instantiation | + N_Proper_Body | + N_Implicit_Label_Declaration | + N_Package_Declaration | + N_Single_Task_Declaration | + N_Subprogram_Declaration | + N_Generic_Declaration | + N_Renaming_Declaration | + N_Block_Statement | + N_Formal_Subprogram_Declaration | + N_Abstract_Subprogram_Declaration | + N_Entry_Body | + N_Exception_Declaration | + N_Formal_Package_Declaration | + N_Number_Declaration | + N_Package_Specification | + N_Parameter_Specification | + N_Single_Protected_Declaration | + N_Subunit => + + return Scope_Depth + (Nearest_Dynamic_Scope + (Defining_Entity (Node_Par))); + + when others => + null; + end case; + + Node_Par := Parent (Node_Par); + end loop; + + pragma Assert (False); + + -- Should never reach the following return + + return Scope_Depth (Current_Scope) + 1; + end Innermost_Master_Scope_Depth; + + -- Start of processing for Return_Master_Scope_Depth_Of_Call + + begin + return Innermost_Master_Scope_Depth (Obj); + end Return_Master_Scope_Depth_Of_Call; end if; -- For convenience we handle qualified expressions, even though @@ -10140,12 +10382,7 @@ package body Sem_Util is while R_Scope /= Standard_Standard loop exit when R_Scope = E_Scope; - if Ekind (R_Scope) /= E_Package - and then - Ekind (R_Scope) /= E_Block - and then - Ekind (R_Scope) /= E_Loop - then + if not Ekind_In (R_Scope, E_Package, E_Block, E_Loop) then return False; else R_Scope := Scope (R_Scope); @@ -10341,6 +10578,32 @@ package body Sem_Util is end if; end Same_Value; + ----------------- + -- Save_Actual -- + ----------------- + + procedure Save_Actual (N : Node_Id; Writable : Boolean := False) is + begin + if Is_Entity_Name (N) + or else + Nkind_In (N, N_Indexed_Component, N_Selected_Component, N_Slice) + or else + (Nkind (N) = N_Attribute_Reference + and then Attribute_Name (N) = Name_Access) + + then + -- We are only interested in IN OUT parameters of inner calls + + if not Writable + or else Nkind (Parent (N)) = N_Function_Call + or else Nkind (Parent (N)) in N_Op + then + Actuals_In_Call.Increment_Last; + Actuals_In_Call.Table (Actuals_In_Call.Last) := (N, Writable); + end if; + end if; + end Save_Actual; + ------------------------ -- Scope_Is_Transient -- ------------------------ @@ -10489,6 +10752,9 @@ package body Sem_Util is end loop; end; + -- For a class wide subtype, we also need debug information + -- for the equivalent type. + if Ekind (T) = E_Class_Wide_Subtype then Set_Debug_Info_Needed_If_Not_Set (Equivalent_Type (T)); end if; @@ -10964,22 +11230,6 @@ package body Sem_Util is return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)); end Type_Access_Level; - -------------------- - -- Ultimate_Alias -- - -------------------- - -- To do: add occurrences calling this new subprogram - - function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is - E : Entity_Id := Prim; - - begin - while Present (Alias (E)) loop - E := Alias (E); - end loop; - - return E; - end Ultimate_Alias; - -------------------------- -- Unit_Declaration_Node -- -------------------------- @@ -11218,8 +11468,10 @@ package body Sem_Util is and then Covers (Designated_Type (Expec_Type), Designated_Type (Found_Type)) then - Error_Msg_N ("result must be general access type!", Expr); - Error_Msg_NE ("add ALL to }!", Expr, Expec_Type); + Error_Msg_N -- CODEFIX + ("result must be general access type!", Expr); + Error_Msg_NE -- CODEFIX + ("add ALL to }!", Expr, Expec_Type); -- Another special check, if the expected type is an integer type, -- but the expression is of type System.Address, and the parent is @@ -11266,7 +11518,8 @@ package body Sem_Util is if From_With_Type (Found_Type) then Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type); Error_Msg_Qual_Level := 99; - Error_Msg_NE ("\\missing `WITH &;", Expr, Scope (Found_Type)); + Error_Msg_NE -- CODEFIX + ("\\missing `WITH &;", Expr, Scope (Found_Type)); Error_Msg_Qual_Level := 0; else Error_Msg_NE ("found}!", Expr, Found_Type); diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index ed36cf8f3d7..54878f326a1 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -132,15 +132,20 @@ package Sem_Util is -- Check wrong use of dynamically tagged expression procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id); - -- Verify that the full declaration of type T has been seen. If not, - -- place error message on node N. Used in object declarations, type - -- conversions, qualified expressions. + -- Verify that the full declaration of type T has been seen. If not, place + -- error message on node N. Used in object declarations, type conversions + -- and qualified expressions. procedure Check_Nested_Access (Ent : Entity_Id); -- Check whether Ent denotes an entity declared in an uplevel scope, which -- is accessed inside a nested procedure, and set Has_Up_Level_Access flag -- accordingly. This is currently only enabled for VM_Target /= No_VM. + procedure Check_Order_Dependence; + -- Examine the actuals in a top-level call to determine whether aliasing + -- between two actuals, one of which is writable, can make the call + -- order-dependent. + procedure Check_Potentially_Blocking_Operation (N : Node_Id); -- N is one of the statement forms that is a potentially blocking -- operation. If it appears within a protected action, emit warning. @@ -153,10 +158,10 @@ package Sem_Util is -- a possible unlocked access to data. procedure Check_VMS (Construct : Node_Id); - -- Check that this the target is OpenVMS, and if so, return with - -- no effect, otherwise post an error noting this can only be used - -- with OpenVMS ports. The argument is the construct in question - -- and is used to post the error message. + -- Check that this the target is OpenVMS, and if so, return with no effect, + -- otherwise post an error noting this can only be used with OpenVMS ports. + -- The argument is the construct in question and is used to post the error + -- message. procedure Collect_Interfaces (T : Entity_Id; @@ -187,10 +192,10 @@ package Sem_Util is -- information on the same interface type. function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id; - -- Called upon type derivation and extension. We scan the declarative - -- part in which the type appears, and collect subprograms that have - -- one subsidiary subtype of the type. These subprograms can only - -- appear after the type itself. + -- Called upon type derivation and extension. We scan the declarative part + -- in which the type appears, and collect subprograms that have one + -- subsidiary subtype of the type. These subprograms can only appear after + -- the type itself. function Compile_Time_Constraint_Error (N : Node_Id; @@ -202,12 +207,11 @@ package Sem_Util is -- generates a warning (or error) message in the same manner, but it does -- not replace any nodes. For convenience, the function always returns its -- first argument. The message is a warning if the message ends with ?, or - -- we are operating in Ada 83 mode, or if the Warn parameter is set to - -- True. + -- we are operating in Ada 83 mode, or the Warn parameter is set to True. procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id); - -- Sets the Has_Delayed_Freeze flag of New if the Delayed_Freeze flag - -- of Old is set and Old has no yet been Frozen (i.e. Is_Frozen is false); + -- Sets the Has_Delayed_Freeze flag of New if the Delayed_Freeze flag of + -- Old is set and Old has no yet been Frozen (i.e. Is_Frozen is false). function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id; -- Utility to create a parameter profile for a new subprogram spec, when @@ -216,6 +220,7 @@ package Sem_Util is -- for stubbed subprograms. function Current_Entity (N : Node_Id) return Entity_Id; + pragma Inline (Current_Entity); -- Find the currently visible definition for a given identifier, that is to -- say the first entry in the visibility chain for the Chars of N. @@ -235,21 +240,20 @@ package Sem_Util is -- from a library package which is not within any subprogram. function Defining_Entity (N : Node_Id) return Entity_Id; - -- Given a declaration N, returns the associated defining entity. If - -- the declaration has a specification, the entity is obtained from - -- the specification. If the declaration has a defining unit name, - -- then the defining entity is obtained from the defining unit name - -- ignoring any child unit prefixes. + -- Given a declaration N, returns the associated defining entity. If the + -- declaration has a specification, the entity is obtained from the + -- specification. If the declaration has a defining unit name, then the + -- defining entity is obtained from the defining unit name ignoring any + -- child unit prefixes. function Denotes_Discriminant (N : Node_Id; Check_Concurrent : Boolean := False) return Boolean; - -- Returns True if node N is an Entity_Name node for a discriminant. - -- If the flag Check_Concurrent is true, function also returns true - -- when N denotes the discriminal of the discriminant of a concurrent - -- type. This is necessary to disable some optimizations on private - -- components of protected types, and constraint checks on entry - -- families constrained by discriminants. + -- Returns True if node N is an Entity_Name node for a discriminant. If the + -- flag Check_Concurrent is true, function also returns true when N denotes + -- the discriminal of the discriminant of a concurrent type. This is needed + -- to disable some optimizations on private components of protected types, + -- and constraint checks on entry families constrained by discriminants. function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean; function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean; @@ -271,49 +275,48 @@ package Sem_Util is function Designate_Same_Unit (Name1 : Node_Id; Name2 : Node_Id) return Boolean; - -- Return true if Name1 and Name2 designate the same unit name; - -- each of these names is supposed to be a selected component name, - -- an expanded name, a defining program unit name or an identifier + -- Return true if Name1 and Name2 designate the same unit name; each of + -- these names is supposed to be a selected component name, an expanded + -- name, a defining program unit name or an identifier. function Enclosing_Generic_Body (N : Node_Id) return Node_Id; - -- Returns the Node_Id associated with the innermost enclosing - -- generic body, if any. If none, then returns Empty. + -- Returns the Node_Id associated with the innermost enclosing generic + -- body, if any. If none, then returns Empty. function Enclosing_Generic_Unit (N : Node_Id) return Node_Id; - -- Returns the Node_Id associated with the innermost enclosing - -- generic unit, if any. If none, then returns Empty. + -- Returns the Node_Id associated with the innermost enclosing generic + -- unit, if any. If none, then returns Empty. function Enclosing_Lib_Unit_Entity return Entity_Id; -- Returns the entity of enclosing N_Compilation_Unit Node which is the - -- root of the current scope (which must not be Standard_Standard, and - -- the caller is responsible for ensuring this condition). + -- root of the current scope (which must not be Standard_Standard, and the + -- caller is responsible for ensuring this condition). function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id; - -- Returns the enclosing N_Compilation_Unit Node that is the root - -- of a subtree containing N. + -- Returns the enclosing N_Compilation_Unit Node that is the root of a + -- subtree containing N. function Enclosing_Subprogram (E : Entity_Id) return Entity_Id; -- Utility function to return the Ada entity of the subprogram enclosing -- the entity E, if any. Returns Empty if no enclosing subprogram. procedure Ensure_Freeze_Node (E : Entity_Id); - -- Make sure a freeze node is allocated for entity E. If necessary, - -- build and initialize a new freeze node and set Has_Delayed_Freeze - -- true for entity E. + -- Make sure a freeze node is allocated for entity E. If necessary, build + -- and initialize a new freeze node and set Has_Delayed_Freeze True for E. procedure Enter_Name (Def_Id : Entity_Id); -- Insert new name in symbol table of current scope with check for - -- duplications (error message is issued if a conflict is found) - -- Note: Enter_Name is not used for overloadable entities, instead - -- these are entered using Sem_Ch6.Enter_Overloadable_Entity. + -- duplications (error message is issued if a conflict is found). + -- Note: Enter_Name is not used for overloadable entities, instead these + -- are entered using Sem_Ch6.Enter_Overloadable_Entity. procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id); - -- This procedure is called after issuing a message complaining - -- about an inappropriate use of limited type T. If useful, it - -- adds additional continuation lines to the message explaining - -- why type T is limited. Messages are placed at node N. + -- This procedure is called after issuing a message complaining about an + -- inappropriate use of limited type T. If useful, it adds additional + -- continuation lines to the message explaining why type T is limited. + -- Messages are placed at node N. procedure Find_Actual (N : Node_Id; @@ -329,11 +332,11 @@ package Sem_Util is function Find_Corresponding_Discriminant (Id : Node_Id; Typ : Entity_Id) return Entity_Id; - -- Because discriminants may have different names in a generic unit - -- and in an instance, they are resolved positionally when possible. - -- A reference to a discriminant carries the discriminant that it - -- denotes when analyzed. Subsequent uses of this id on a different - -- type denote the discriminant at the same position in this new type. + -- Because discriminants may have different names in a generic unit and in + -- an instance, they are resolved positionally when possible. A reference + -- to a discriminant carries the discriminant that it denotes when it is + -- analyzed. Subsequent uses of this id on a different type denotes the + -- discriminant at the same position in this new type. procedure Find_Overlaid_Entity (N : Node_Id; @@ -355,6 +358,12 @@ package Sem_Util is -- Determine the alternative chosen, so that the code of non-selected -- alternatives, and the warnings that may apply to them, are removed. + function Find_Body_Discriminal + (Spec_Discriminant : Entity_Id) return Entity_Id; + -- Given a discriminant of the record type that implements a task or + -- protected type, return the discriminal of the corresponding discriminant + -- of the actual concurrent type. + function First_Actual (Node : Node_Id) return Node_Id; -- Node is an N_Function_Call or N_Procedure_Call_Statement node. The -- result returned is the first actual parameter in declaration order @@ -364,7 +373,7 @@ package Sem_Util is -- iterating through the actuals in declaration order is to use this -- function to find the first actual, and then use Next_Actual to obtain -- the next actual in declaration order. Note that the value returned - -- is always the expression (not the N_Parameter_Association nodes + -- is always the expression (not the N_Parameter_Association nodes, -- even if named association is used). function Full_Qualified_Name (E : Entity_Id) return String_Id; @@ -409,15 +418,15 @@ package Sem_Util is function Get_Actual_Subtype (N : Node_Id) return Entity_Id; -- Given a node for an expression, obtain the actual subtype of the -- expression. In the case of a parameter where the formal is an - -- unconstrained array or discriminated type, this will be the - -- previously constructed subtype of the actual. Note that this is - -- not quite the "Actual Subtype" of the RM, since it is always - -- a constrained type, i.e. it is the subtype of the value of the - -- actual. The actual subtype is also returned in other cases where - -- it has already been constructed for an object. Otherwise the - -- expression type is returned unchanged, except for the case of an - -- unconstrained array type, where an actual subtype is created, using - -- Insert_Actions if necessary to insert any associated actions. + -- unconstrained array or discriminated type, this will be the previously + -- constructed subtype of the actual. Note that this is not quite the + -- "Actual Subtype" of the RM, since it is always a constrained type, i.e. + -- it is the subtype of the value of the actual. The actual subtype is also + -- returned in other cases where it has already been constructed for an + -- object. Otherwise the expression type is returned unchanged, except for + -- the case of an unconstrained array type, where an actual subtype is + -- created, using Insert_Actions if necessary to insert any associated + -- actions. function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id; -- This is like Get_Actual_Subtype, except that it never constructs an @@ -427,41 +436,40 @@ package Sem_Util is function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id; -- This is used to construct the string literal node representing a - -- default external name, i.e. one that is constructed from the name - -- of an entity, or (in the case of extended DEC import/export pragmas, - -- an identifier provided as the external name. Letters in the name are + -- default external name, i.e. one that is constructed from the name of an + -- entity, or (in the case of extended DEC import/export pragmas, an + -- identifier provided as the external name. Letters in the name are -- according to the setting of Opt.External_Name_Default_Casing. function Get_Generic_Entity (N : Node_Id) return Entity_Id; - -- Returns the true generic entity in an instantiation. If the name in - -- the instantiation is a renaming, the function returns the renamed - -- generic. + -- Returns the true generic entity in an instantiation. If the name in the + -- instantiation is a renaming, the function returns the renamed generic. procedure Get_Index_Bounds (N : Node_Id; L, H : out Node_Id); - -- This procedure assigns to L and H respectively the values of the - -- low and high bounds of node N, which must be a range, subtype - -- indication, or the name of a scalar subtype. The result in L, H - -- may be set to Error if there was an earlier error in the range. + -- This procedure assigns to L and H respectively the values of the low and + -- high bounds of node N, which must be a range, subtype indication, or the + -- name of a scalar subtype. The result in L, H may be set to Error if + -- there was an earlier error in the range. function Get_Enum_Lit_From_Pos (T : Entity_Id; Pos : Uint; Loc : Source_Ptr) return Entity_Id; - -- This function obtains the E_Enumeration_Literal entity for the - -- specified value from the enumeration type or subtype T. The - -- second argument is the Pos value, which is assumed to be in range. - -- The third argument supplies a source location for constructed - -- nodes returned by this function. + -- This function obtains the E_Enumeration_Literal entity for the specified + -- value from the enumeration type or subtype T. The second argument is the + -- Pos value, which is assumed to be in range. The third argument supplies + -- a source location for constructed nodes returned by this function. procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id); -- Retrieve the fully expanded name of the library unit declared by -- Decl_Node into the name buffer. function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id; + pragma Inline (Get_Name_Entity_Id); -- An entity value is associated with each name in the name table. The - -- Get_Name_Entity_Id function fetches the Entity_Id of this entity, - -- which is the innermost visible entity with the given name. See the - -- body of Sem_Ch8 for further details on handling of entity visibility. + -- Get_Name_Entity_Id function fetches the Entity_Id of this entity, which + -- is the innermost visible entity with the given name. See the body of + -- Sem_Ch8 for further details on handling of entity visibility. function Get_Pragma_Id (N : Node_Id) return Pragma_Id; pragma Inline (Get_Pragma_Id); @@ -479,22 +487,20 @@ package Sem_Util is -- with any other kind of entity. function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id; - -- Nod is either a procedure call statement, or a function call, or - -- an accept statement node. This procedure finds the Entity_Id of the - -- related subprogram or entry and returns it, or if no subprogram can - -- be found, returns Empty. + -- Nod is either a procedure call statement, or a function call, or an + -- accept statement node. This procedure finds the Entity_Id of the related + -- subprogram or entry and returns it, or if no subprogram can be found, + -- returns Empty. function Get_Subprogram_Body (E : Entity_Id) return Node_Id; - -- Given the entity for a subprogram (E_Function or E_Procedure), - -- return the corresponding N_Subprogram_Body node. If the corresponding - -- body of the declaration is missing (as for an imported subprogram) - -- return Empty. + -- Given the entity for a subprogram (E_Function or E_Procedure), return + -- the corresponding N_Subprogram_Body node. If the corresponding body + -- is missing (as for an imported subprogram), return Empty. function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id; pragma Inline (Get_Task_Body_Procedure); -- Given an entity for a task type or subtype, retrieves the - -- Task_Body_Procedure field from the corresponding task type - -- declaration. + -- Task_Body_Procedure field from the corresponding task type declaration. function Has_Access_Values (T : Entity_Id) return Boolean; -- Returns true if type or subtype T is an access type, or has a component @@ -524,18 +530,18 @@ package Sem_Util is -- -- Note: Known_Incompatible does not mean that at run time the alignment -- of Expr is known to be wrong for Obj, just that it can be determined - -- that alignments have been explicitly or implicitly specified which - -- are incompatible (whereas Unknown means that even this is not known). - -- The appropriate reaction of a caller to Known_Incompatible is to treat - -- it as Unknown, but issue a warning that there may be an alignment error. + -- that alignments have been explicitly or implicitly specified which are + -- incompatible (whereas Unknown means that even this is not known). The + -- appropriate reaction of a caller to Known_Incompatible is to treat it as + -- Unknown, but issue a warning that there may be an alignment error. function Has_Declarations (N : Node_Id) return Boolean; -- Determines if the node can have declarations function Has_Discriminant_Dependent_Constraint (Comp : Entity_Id) return Boolean; - -- Returns True if and only if Comp has a constrained subtype - -- that depends on a discriminant. + -- Returns True if and only if Comp has a constrained subtype that depends + -- on a discriminant. function Has_Infinities (E : Entity_Id) return Boolean; -- Determines if the range of the floating-point type E includes @@ -565,18 +571,18 @@ package Sem_Util is -- yet received a full declaration. function Has_Stream (T : Entity_Id) return Boolean; - -- Tests if type T is derived from Ada.Streams.Root_Stream_Type, or - -- in the case of a composite type, has a component for which this - -- predicate is True, and if so returns True. Otherwise a result of - -- False means that there is no Stream type in sight. For a private - -- type, the test is applied to the underlying type (or returns False - -- if there is no underlying type). + -- Tests if type T is derived from Ada.Streams.Root_Stream_Type, or in the + -- case of a composite type, has a component for which this predicate is + -- True, and if so returns True. Otherwise a result of False means that + -- there is no Stream type in sight. For a private type, the test is + -- applied to the underlying type (or returns False if there is no + -- underlying type). function Has_Tagged_Component (Typ : Entity_Id) return Boolean; -- Returns True if Typ is a composite type (array or record) which is -- either itself a tagged type, or has a component (recursively) which is -- a tagged type. Returns False for non-composite type, or if no tagged - -- component is present. This function is used to check if '=' has to be + -- component is present. This function is used to check if "=" has to be -- expanded into a bunch component comparisons. function Implements_Interface @@ -607,11 +613,11 @@ package Sem_Util is -- Returns True if node N belongs to a parameter specification function In_Subprogram_Or_Concurrent_Unit return Boolean; - -- Determines if the current scope is within a subprogram compilation - -- unit (inside a subprogram declaration, subprogram body, or generic - -- subprogram declaration) or within a task or protected body. The test - -- is for appearing anywhere within such a construct (that is it does not - -- need to be directly within). + -- Determines if the current scope is within a subprogram compilation unit + -- (inside a subprogram declaration, subprogram body, or generic + -- subprogram declaration) or within a task or protected body. The test is + -- for appearing anywhere within such a construct (that is it does not need + -- to be directly within). function In_Visible_Part (Scope_Id : Entity_Id) return Boolean; -- Determine whether a declaration occurs within the visible part of a @@ -643,8 +649,8 @@ package Sem_Util is -- Determines if N is an actual parameter in a subprogram call function Is_Aliased_View (Obj : Node_Id) return Boolean; - -- Determine if Obj is an aliased view, i.e. the name of an - -- object to which 'Access or 'Unchecked_Access can apply. + -- Determine if Obj is an aliased view, i.e. the name of an object to which + -- 'Access or 'Unchecked_Access can apply. function Is_Ancestor_Package (E1 : Entity_Id; @@ -652,8 +658,8 @@ package Sem_Util is -- Determine whether package E1 is an ancestor of E2 function Is_Atomic_Object (N : Node_Id) return Boolean; - -- Determines if the given node denotes an atomic object in the sense - -- of the legality checks described in RM C.6(12). + -- Determines if the given node denotes an atomic object in the sense of + -- the legality checks described in RM C.6(12). function Is_Coextension_Root (N : Node_Id) return Boolean; -- Determine whether node N is an allocator which acts as a coextension @@ -690,9 +696,10 @@ package Sem_Util is -- it is of protected, synchronized or task kind. function Is_False (U : Uint) return Boolean; - -- The argument is a Uint value which is the Boolean'Pos value of a - -- Boolean operand (i.e. is either 0 for False, or 1 for True). This - -- function simply tests if it is False (i.e. zero) + pragma Inline (Is_False); + -- The argument is a Uint value which is the Boolean'Pos value of a Boolean + -- operand (i.e. is either 0 for False, or 1 for True). This function tests + -- if it is False (i.e. zero). function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean; -- Returns True iff the number U is a model number of the fixed- @@ -712,7 +719,7 @@ package Sem_Util is -- by a derived type declarations. function Is_LHS (N : Node_Id) return Boolean; - -- Returns True iff N is used as Name in an assignment statement. + -- Returns True iff N is used as Name in an assignment statement function Is_Library_Level_Entity (E : Entity_Id) return Boolean; -- A library-level declaration is one that is accessible from Standard, @@ -728,11 +735,11 @@ package Sem_Util is -- variable and constant objects return True (compare Is_Variable). function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean; - -- Used to test if AV is an acceptable formal for an OUT or IN OUT - -- formal. Note that the Is_Variable function is not quite the right - -- test because this is a case in which conversions whose expression - -- is a variable (in the Is_Variable sense) with a non-tagged type - -- target are considered view conversions and hence variables. + -- Used to test if AV is an acceptable formal for an OUT or IN OUT formal. + -- Note that the Is_Variable function is not quite the right test because + -- this is a case in which conversions whose expression is a variable (in + -- the Is_Variable sense) with a non-tagged type target are considered view + -- conversions and hence variables. function Is_Partially_Initialized_Type (Typ : Entity_Id) return Boolean; -- Typ is a type entity. This function returns true if this type is partly @@ -776,6 +783,7 @@ package Sem_Util is -- normally such nodes represent a direct name. function Is_Statement (N : Node_Id) return Boolean; + pragma Inline (Is_Statement); -- Check if the node N is a statement node. Note that this includes -- the case of procedure call statements (unlike the direct use of -- the N_Statement_Other_Than_Procedure_Call subtype from Sinfo). @@ -785,14 +793,19 @@ package Sem_Util is -- Returns True if E is a synchronized tagged type (AARM 3.9.4 (6/2)) function Is_Transfer (N : Node_Id) return Boolean; - -- Returns True if the node N is a statement which is known to cause - -- an unconditional transfer of control at runtime, i.e. the following + -- Returns True if the node N is a statement which is known to cause an + -- unconditional transfer of control at runtime, i.e. the following -- statement definitely will not be executed. function Is_True (U : Uint) return Boolean; - -- The argument is a Uint value which is the Boolean'Pos value of a - -- Boolean operand (i.e. is either 0 for False, or 1 for True). This - -- function simply tests if it is True (i.e. non-zero) + pragma Inline (Is_True); + -- The argument is a Uint value which is the Boolean'Pos value of a Boolean + -- operand (i.e. is either 0 for False, or 1 for True). This function tests + -- if it is True (i.e. non-zero). + + function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean; + pragma Inline (Is_Universal_Numeric_Type); + -- True if T is Universal_Integer or Universal_Real function Is_Value_Type (T : Entity_Id) return Boolean; -- Returns true if type T represents a value type. This is only relevant to @@ -800,6 +813,10 @@ package Sem_Util is -- object that is accessed directly, as opposed to the other CIL objects -- that are accessed through managed pointers. + function Is_VMS_Operator (Op : Entity_Id) return Boolean; + -- Determine whether an operator is one of the intrinsics defined + -- in the DEC system extension. + function Is_Delegate (T : Entity_Id) return Boolean; -- Returns true if type T represents a delegate. A Delegate is the CIL -- object used to represent access-to-subprogram types. This is only @@ -990,7 +1007,8 @@ package Sem_Util is procedure Next_Actual (Actual_Id : in out Node_Id); pragma Inline (Next_Actual); - -- Next_Actual (N) is equivalent to N := Next_Actual (N) + -- Next_Actual (N) is equivalent to N := Next_Actual (N). Note that we + -- inline this procedural form, but not the functional form that follows. function Next_Actual (Actual_Id : Node_Id) return Node_Id; -- Find next actual parameter in declaration order. As described for @@ -1148,6 +1166,11 @@ package Sem_Util is -- are only partially ordered, so Scope_Within_Or_Same (A,B) and -- Scope_Within_Or_Same (B,A) can both be False for a given pair A,B. + procedure Save_Actual (N : Node_Id; Writable : Boolean := False); + -- Enter an actual in a call in a table global, for subsequent check of + -- possible order dependence in the presence of IN OUT parameters for + -- functions in Ada 2012 (or access parameters in older language versions). + function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean; -- Like Scope_Within_Or_Same, except that this function returns -- False in the case where Scope1 and Scope2 are the same scope. @@ -1158,6 +1181,7 @@ package Sem_Util is -- foreign convention, then we set Can_Use_Internal_Rep to False on E. procedure Set_Current_Entity (E : Entity_Id); + pragma Inline (Set_Current_Entity); -- Establish the entity E as the currently visible definition of its -- associated name (i.e. the Node_Id associated with its name) @@ -1175,6 +1199,7 @@ package Sem_Util is -- can check identifier spelling style. procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id); + pragma Inline (Set_Name_Entity_Id); -- Sets the Entity_Id value associated with the given name, which is the -- Id of the innermost visible entity with the given name. See the body -- of package Sem_Ch8 for further details on the handling of visibility. @@ -1205,6 +1230,7 @@ package Sem_Util is -- Set the flag Is_Transient of the current scope procedure Set_Size_Info (T1, T2 : Entity_Id); + pragma Inline (Set_Size_Info); -- Copies the Esize field and Has_Biased_Representation flag from sub(type) -- entity T2 to (sub)type entity T1. Also copies the Is_Unsigned_Type flag -- in the fixed-point and discrete cases, and also copies the alignment @@ -1237,10 +1263,6 @@ package Sem_Util is function Type_Access_Level (Typ : Entity_Id) return Uint; -- Return the accessibility level of Typ - function Ultimate_Alias (Prim : Entity_Id) return Entity_Id; - -- Return the last entity in the chain of aliased entities of Prim. - -- If Prim has no alias return Prim. - function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id; -- Unit_Id is the simple name of a program unit, this function returns the -- corresponding xxx_Declaration node for the entity. Also applies to the @@ -1249,31 +1271,21 @@ package Sem_Util is -- may be a child unit with any number of ancestors. function Universal_Interpretation (Opnd : Node_Id) return Entity_Id; - -- Yields universal_Integer or Universal_Real if this is a candidate + -- Yields Universal_Integer or Universal_Real if this is a candidate function Unqualify (Expr : Node_Id) return Node_Id; - -- Removes any qualifications from Expr. For example, for T1'(T2'(X)), - -- this returns X. If Expr is not a qualified expression, returns Expr. + pragma Inline (Unqualify); + -- Removes any qualifications from Expr. For example, for T1'(T2'(X)), this + -- returns X. If Expr is not a qualified expression, returns Expr. function Within_Init_Proc return Boolean; -- Determines if Current_Scope is within an init proc procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id); - -- Output error message for incorrectly typed expression. Expr is the - -- node for the incorrectly typed construct (Etype (Expr) is the type - -- found), and Expected_Type is the entity for the expected type. Note - -- that Expr does not have to be a subexpression, anything with an - -- Etype field may be used. - -private - pragma Inline (Current_Entity); - pragma Inline (Get_Name_Entity_Id); - pragma Inline (Is_False); - pragma Inline (Is_Statement); - pragma Inline (Is_True); - pragma Inline (Set_Current_Entity); - pragma Inline (Set_Name_Entity_Id); - pragma Inline (Set_Size_Info); - pragma Inline (Unqualify); + -- Output error message for incorrectly typed expression. Expr is the node + -- for the incorrectly typed construct (Etype (Expr) is the type found), + -- and Expected_Type is the entity for the expected type. Note that Expr + -- does not have to be a subexpression, anything with an Etype field may + -- be used. end Sem_Util; diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 580ba9aedc0..7f18a75e71e 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -234,10 +234,11 @@ package body Sem_Warn is -- within the body of the loop. procedure Check_Infinite_Loop_Warning (Loop_Statement : Node_Id) is - Iter : constant Node_Id := Iteration_Scheme (Loop_Statement); + Expression : Node_Id := Empty; + -- Set to WHILE or EXIT WHEN condition to be tested Ref : Node_Id := Empty; - -- Reference in iteration scheme to variable that might not be modified + -- Reference in Expression to variable that might not be modified -- in loop, indicating a possible infinite loop. Var : Entity_Id := Empty; @@ -267,9 +268,9 @@ package body Sem_Warn is function Test_Ref (N : Node_Id) return Traverse_Result; -- Test for reference to variable in question. Returns Abandon if - -- matching reference found. + -- matching reference found. Used in instantiation of No_Ref_Found. - function Find_Ref is new Traverse_Func (Test_Ref); + function No_Ref_Found is new Traverse_Func (Test_Ref); -- Function to traverse body of procedure. Returns Abandon if matching -- reference found. @@ -465,9 +466,9 @@ package body Sem_Warn is function Test_Ref (N : Node_Id) return Traverse_Result is begin - -- Waste of time to look at iteration scheme + -- Waste of time to look at the expression we are testing - if N = Iter then + if N = Expression then return Skip; -- Direct reference to variable in question @@ -537,6 +538,29 @@ package body Sem_Warn is then return Abandon; end if; + + -- If any of the arguments are of type access to subprogram, then + -- we may have funny side effects, so no warning in this case. + + declare + Actual : Node_Id; + begin + Actual := First_Actual (N); + while Present (Actual) loop + if Is_Access_Subprogram_Type (Etype (Actual)) then + return Abandon; + else + Next_Actual (Actual); + end if; + end loop; + end; + + -- Declaration of the variable in question + + elsif Nkind (N) = N_Object_Declaration + and then Defining_Identifier (N) = Var + then + return Abandon; end if; -- All OK, continue scan @@ -547,20 +571,96 @@ package body Sem_Warn is -- Start of processing for Check_Infinite_Loop_Warning begin - -- We need a while iteration with no condition actions. Condition - -- actions just make things too complicated to get the warning right. + -- Skip processing if debug flag gnatd.w is set - if No (Iter) - or else No (Condition (Iter)) - or else Present (Condition_Actions (Iter)) - or else Debug_Flag_Dot_W - then + if Debug_Flag_Dot_W then + return; + end if; + + -- Deal with Iteration scheme present + + declare + Iter : constant Node_Id := Iteration_Scheme (Loop_Statement); + + begin + if Present (Iter) then + + -- While iteration + + if Present (Condition (Iter)) then + + -- Skip processing for while iteration with conditions actions, + -- since they make it too complicated to get the warning right. + + if Present (Condition_Actions (Iter)) then + return; + end if; + + -- Capture WHILE condition + + Expression := Condition (Iter); + + -- For iteration, do not process, since loop will always terminate + + elsif Present (Loop_Parameter_Specification (Iter)) then + return; + end if; + end if; + end; + + -- Check chain of EXIT statements, we only process loops that have a + -- single exit condition (either a single EXIT WHEN statement, or a + -- WHILE loop not containing any EXIT WHEN statements). + + declare + Ident : constant Node_Id := Identifier (Loop_Statement); + Exit_Stmt : Node_Id; + + begin + -- If we don't have a proper chain set, ignore call entirely. This + -- happens because of previous errors. + + if No (Entity (Ident)) + or else Ekind (Entity (Ident)) /= E_Loop + then + return; + end if; + + -- Otherwise prepare to scan list of EXIT statements + + Exit_Stmt := First_Exit_Statement (Entity (Ident)); + while Present (Exit_Stmt) loop + + -- Check for EXIT WHEN + + if Present (Condition (Exit_Stmt)) then + + -- Quit processing if EXIT WHEN in WHILE loop, or more than + -- one EXIT WHEN statement present in the loop. + + if Present (Expression) then + return; + + -- Otherwise capture condition from EXIT WHEN statement + + else + Expression := Condition (Exit_Stmt); + end if; + end if; + + Exit_Stmt := Next_Exit_Statement (Exit_Stmt); + end loop; + end; + + -- Return if no condition to test + + if No (Expression) then return; end if; -- Initial conditions met, see if condition is of right form - Find_Var (Condition (Iter)); + Find_Var (Expression); -- Nothing to do if local variable from source not found. If it's a -- renaming, it is probably renaming something too complicated to deal @@ -608,7 +708,7 @@ package body Sem_Warn is -- We have a variable reference of the right form, now we scan the loop -- body to see if it looks like it might not be modified - if Find_Ref (Loop_Statement) = OK then + if No_Ref_Found (Loop_Statement) = OK then Error_Msg_NE ("?variable& is not modified in loop body!", Ref, Var); Error_Msg_N @@ -927,9 +1027,8 @@ package body Sem_Warn is -- we exclude protected types, too complicated to worry about. if Ekind (E1) = E_Variable - or else - ((Ekind (E1) = E_Out_Parameter - or else Ekind (E1) = E_In_Out_Parameter) + or else + (Ekind_In (E1, E_Out_Parameter, E_In_Out_Parameter) and then not Is_Protected_Type (Current_Scope)) then -- Case of an unassigned variable @@ -1245,7 +1344,7 @@ package body Sem_Warn is while Present (Comp) loop if Ekind (Comp) = E_Component and then Nkind (Parent (Comp)) = - N_Component_Declaration + N_Component_Declaration and then No (Expression (Parent (Comp))) then Error_Msg_Node_2 := Comp; @@ -1364,12 +1463,9 @@ package body Sem_Warn is -- a separate spec. and then not (Is_Formal (E1) - and then - Ekind (Scope (E1)) = E_Subprogram_Body - and then - Present (Spec_Entity (E1)) - and then - Referenced (Spec_Entity (E1))) + and then Ekind (Scope (E1)) = E_Subprogram_Body + and then Present (Spec_Entity (E1)) + and then Referenced (Spec_Entity (E1))) -- Consider private type referenced if full view is referenced. -- If there is not full view, this is a generic type on which @@ -1377,8 +1473,7 @@ package body Sem_Warn is and then not (Is_Private_Type (E1) - and then - Present (Full_View (E1)) + and then Present (Full_View (E1)) and then Referenced (Full_View (E1))) -- Don't worry about full view, only about private type @@ -1408,16 +1503,15 @@ package body Sem_Warn is -- be non-referenced, since they start up tasks! and then ((Ekind (E1) /= E_Variable - and then Ekind (E1) /= E_Constant - and then Ekind (E1) /= E_Component) - or else not Is_Task_Type (E1T)) + and then Ekind (E1) /= E_Constant + and then Ekind (E1) /= E_Component) + or else not Is_Task_Type (E1T)) -- For subunits, only place warnings on the main unit itself, -- since parent units are not completely compiled. and then (Nkind (Unit (Cunit (Main_Unit))) /= N_Subunit - or else - Get_Source_Unit (E1) = Main_Unit) + or else Get_Source_Unit (E1) = Main_Unit) -- No warning on a return object, because these are often -- created with a single expression and an implicit return. @@ -1432,9 +1526,8 @@ package body Sem_Warn is -- since they refer to problems in internal units). if GNAT_Mode - or else not - Is_Internal_File_Name - (Unit_File_Name (Get_Source_Unit (E1))) + or else not Is_Internal_File_Name + (Unit_File_Name (Get_Source_Unit (E1))) then -- We do not immediately flag the error. This is because we -- have not expanded generic bodies yet, and they may have @@ -2004,7 +2097,7 @@ package body Sem_Warn is while Present (Nam) loop if Entity (Nam) = Pack then Error_Msg_Qual_Level := 1; - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("?no entities of package& are referenced!", Nam, Pack); Error_Msg_Qual_Level := 0; @@ -2201,7 +2294,7 @@ package body Sem_Warn is -- else or a pragma elaborate with a body library task). elsif Has_Visible_Entities (Entity (Name (Item))) then - Error_Msg_N + Error_Msg_N -- CODEFIX ("?unit& is not referenced!", Name (Item)); end if; end if; @@ -2278,7 +2371,7 @@ package body Sem_Warn is if not Has_Unreferenced (Entity (Name (Item))) then - Error_Msg_N + Error_Msg_N -- CODEFIX ("?no entities of & are referenced!", Name (Item)); end if; @@ -2294,7 +2387,7 @@ package body Sem_Warn is and then not Has_Warnings_Off (Lunit) and then not Has_Unreferenced (Pack) then - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("?no entities of & are referenced!", Unit_Declaration_Node (Pack), Pack); @@ -2334,12 +2427,12 @@ package body Sem_Warn is end if; if Unreferenced_In_Spec (Item) then - Error_Msg_N + Error_Msg_N -- CODEFIX ("?unit& is not referenced in spec!", Name (Item)); elsif No_Entities_Ref_In_Spec (Item) then - Error_Msg_N + Error_Msg_N -- CODEFIX ("?no entities of & are referenced in spec!", Name (Item)); @@ -2688,8 +2781,9 @@ package body Sem_Warn is -- default mode. elsif Check_Unreferenced then - Error_Msg_N ("?formal parameter& is read but " - & "never assigned!", E1); + Error_Msg_N + ("?formal parameter& is read but " + & "never assigned!", E1); end if; end if; @@ -2783,9 +2877,7 @@ package body Sem_Warn is -- Reference to obsolescent component - elsif Ekind (E) = E_Component - or else Ekind (E) = E_Discriminant - then + elsif Ekind_In (E, E_Component, E_Discriminant) then Error_Msg_NE ("?reference to obsolescent component& declared#", N, E); @@ -3423,28 +3515,16 @@ package body Sem_Warn is and then Is_Known_Branch then declare - Start : Source_Ptr; - Dummy : Source_Ptr; - Typ : Character; Atrue : Boolean; begin - Sloc_Range (Orig, Start, Dummy); Atrue := Test_Result; - if Present (Parent (C)) - and then Nkind (Parent (C)) = N_Op_Not - then + if Present (Parent (C)) and then Nkind (Parent (C)) = N_Op_Not then Atrue := not Atrue; end if; - if Atrue then - Typ := 't'; - else - Typ := 'f'; - end if; - - Set_SCO_Condition (Start, Typ); + Set_SCO_Condition (Orig, Atrue); end; end if; @@ -3776,7 +3856,8 @@ package body Sem_Warn is procedure Warn1 is begin Error_Msg_Uint_1 := Low_Bound; - Error_Msg_FE ("?index for& may assume lower bound of^", X, Ent); + Error_Msg_FE -- CODEFIX + ("?index for& may assume lower bound of^", X, Ent); end Warn1; -- Start of processing for Test_Suspicious_Index @@ -3800,11 +3881,11 @@ package body Sem_Warn is if Nkind (Original_Node (X)) = N_Integer_Literal then if Intval (X) = Low_Bound then - Error_Msg_FE -- CODEFIX + Error_Msg_FE -- CODEFIX ("\suggested replacement: `&''First`", X, Ent); else Error_Msg_Uint_1 := Intval (X) - Low_Bound; - Error_Msg_FE -- CODEFIX + Error_Msg_FE -- CODEFIX ("\suggested replacement: `&''First + ^`", X, Ent); end if; @@ -3910,7 +3991,7 @@ package body Sem_Warn is -- Replacement subscript is now in string buffer - Error_Msg_FE -- CODEFIX + Error_Msg_FE -- CODEFIX ("\suggested replacement: `&~`", Original_Node (X), Ent); end if; @@ -4082,10 +4163,10 @@ package body Sem_Warn is if Present (Renamed_Object (E)) and then Comes_From_Source (Renamed_Object (E)) then - Error_Msg_N + Error_Msg_N -- CODEFIX ("?renamed variable & is not referenced!", E); else - Error_Msg_N + Error_Msg_N -- CODEFIX ("?variable & is not referenced!", E); end if; end if; @@ -4095,10 +4176,11 @@ package body Sem_Warn is if Present (Renamed_Object (E)) and then Comes_From_Source (Renamed_Object (E)) then - Error_Msg_N + Error_Msg_N -- CODEFIX ("?renamed constant & is not referenced!", E); else - Error_Msg_N ("?constant & is not referenced!", E); + Error_Msg_N -- CODEFIX + ("?constant & is not referenced!", E); end if; when E_In_Parameter | @@ -4123,7 +4205,7 @@ package body Sem_Warn is end if; if not Is_Trivial_Subprogram (Scope (E)) then - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("?formal parameter & is not referenced!", E, Spec_E); end if; @@ -4138,28 +4220,36 @@ package body Sem_Warn is when E_Named_Integer | E_Named_Real => - Error_Msg_N ("?named number & is not referenced!", E); + Error_Msg_N -- CODEFIX + ("?named number & is not referenced!", E); when Formal_Object_Kind => - Error_Msg_N ("?formal object & is not referenced!", E); + Error_Msg_N -- CODEFIX + ("?formal object & is not referenced!", E); when E_Enumeration_Literal => - Error_Msg_N ("?literal & is not referenced!", E); + Error_Msg_N -- CODEFIX + ("?literal & is not referenced!", E); when E_Function => - Error_Msg_N ("?function & is not referenced!", E); + Error_Msg_N -- CODEFIX + ("?function & is not referenced!", E); when E_Procedure => - Error_Msg_N ("?procedure & is not referenced!", E); + Error_Msg_N -- CODEFIX + ("?procedure & is not referenced!", E); when E_Package => - Error_Msg_N ("?package & is not referenced!", E); + Error_Msg_N -- CODEFIX + ("?package & is not referenced!", E); when E_Exception => - Error_Msg_N ("?exception & is not referenced!", E); + Error_Msg_N -- CODEFIX + ("?exception & is not referenced!", E); when E_Label => - Error_Msg_N ("?label & is not referenced!", E); + Error_Msg_N -- CODEFIX + ("?label & is not referenced!", E); when E_Generic_Procedure => Error_Msg_N -- CODEFIX @@ -4170,10 +4260,12 @@ package body Sem_Warn is ("?generic function & is never instantiated!", E); when Type_Kind => - Error_Msg_N ("?type & is not referenced!", E); + Error_Msg_N -- CODEFIX + ("?type & is not referenced!", E); when others => - Error_Msg_N ("?& is not referenced!", E); + Error_Msg_N -- CODEFIX + ("?& is not referenced!", E); end case; -- Kill warnings on the entity on which the message has been posted @@ -4270,7 +4362,7 @@ package body Sem_Warn is ("?& modified by call, but value never referenced", Last_Assignment (Ent), Ent); else - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("?useless assignment to&, value never referenced!", Last_Assignment (Ent), Ent); end if; @@ -4286,7 +4378,7 @@ package body Sem_Warn is ("?& modified by call, but value overwritten #!", Last_Assignment (Ent), Ent); else - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("?useless assignment to&, value overwritten #!", Last_Assignment (Ent), Ent); end if; diff --git a/gcc/ada/sem_warn.ads b/gcc/ada/sem_warn.ads index 365ad397d1b..e74e144fc5b 100644 --- a/gcc/ada/sem_warn.ads +++ b/gcc/ada/sem_warn.ads @@ -170,7 +170,8 @@ package Sem_Warn is procedure Check_Infinite_Loop_Warning (Loop_Statement : Node_Id); -- N is the node for a loop statement. This procedure checks if a warning - -- should be given for a possible infinite loop, and if so issues it. + -- for a possible infinite loop should be given for a suspicious WHILE or + -- EXIT WHEN condition. procedure Check_Low_Bound_Tested (Expr : Node_Id); -- Expr is the node for a comparison operation. This procedure checks if diff --git a/gcc/ada/sfn_scan.adb b/gcc/ada/sfn_scan.adb index dc6ab38d448..1d24ca227f3 100644 --- a/gcc/ada/sfn_scan.adb +++ b/gcc/ada/sfn_scan.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2000-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -37,11 +37,10 @@ package body SFN_Scan is -- Allow easy access to control character definitions EOF : constant Character := ASCII.SUB; - -- The character SUB (16#1A#) is used in DOS and other systems derived - -- from DOS (OS/2, NT etc.) to signal the end of a text file. If this - -- character appears as the last character of a file scanned by a call - -- to Scan_SFN_Pragmas, then it is ignored, otherwise it is treated as - -- an illegal character. + -- The character SUB (16#1A#) is used in DOS-derived systems, such as + -- Windows to signal the end of a text file. If this character appears as + -- the last character of a file scanned by a call to Scan_SFN_Pragmas, then + -- it is ignored, otherwise it is treated as an illegal character. type String_Ptr is access String; @@ -637,7 +636,7 @@ package body SFN_Scan is loop if At_EOF or else S (P) = LF or else S (P) = CR then - Error -- CODEFIX + Error -- CODEFIX ("missing string quote"); elsif S (P) = HT then diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 73377f1a39f..c43e0b4cbe2 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -146,7 +146,9 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_And_Then + or else NT (N).Nkind = N_Case_Expression_Alternative or else NT (N).Nkind = N_Compilation_Unit_Aux + or else NT (N).Nkind = N_Expression_With_Actions or else NT (N).Nkind = N_Freeze_Entity or else NT (N).Nkind = N_Or_Else); return List1 (N); @@ -229,6 +231,7 @@ package body Sinfo is (N : Node_Id) return List_Id is begin pragma Assert (False + or else NT (N).Nkind = N_Case_Expression or else NT (N).Nkind = N_Case_Statement or else NT (N).Nkind = N_In or else NT (N).Nkind = N_Not_In); @@ -791,6 +794,7 @@ package body Sinfo is (N : Node_Id) return List_Id is begin pragma Assert (False + or else NT (N).Nkind = N_Case_Expression_Alternative or else NT (N).Nkind = N_Case_Statement_Alternative or else NT (N).Nkind = N_Variant); return List4 (N); @@ -1169,6 +1173,8 @@ package body Sinfo is or else NT (N).Nkind = N_Assignment_Statement or else NT (N).Nkind = N_At_Clause or else NT (N).Nkind = N_Attribute_Definition_Clause + or else NT (N).Nkind = N_Case_Expression + or else NT (N).Nkind = N_Case_Expression_Alternative or else NT (N).Nkind = N_Case_Statement or else NT (N).Nkind = N_Code_Statement or else NT (N).Nkind = N_Component_Association @@ -1178,6 +1184,7 @@ package body Sinfo is or else NT (N).Nkind = N_Discriminant_Association or else NT (N).Nkind = N_Discriminant_Specification or else NT (N).Nkind = N_Exception_Declaration + or else NT (N).Nkind = N_Expression_With_Actions or else NT (N).Nkind = N_Free_Statement or else NT (N).Nkind = N_Mod_Clause or else NT (N).Nkind = N_Modular_Type_Definition @@ -1555,6 +1562,14 @@ package body Sinfo is return Flag16 (N); end Interface_Present; + function Import_Interface_Present + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + return Flag16 (N); + end Import_Interface_Present; + function In_Present (N : Node_Id) return Boolean is begin @@ -1572,6 +1587,14 @@ package body Sinfo is return Flag11 (N); end Includes_Infinities; + function Inherited_Discriminant + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_Association); + return Flag13 (N); + end Inherited_Discriminant; + function Instance_Spec (N : Node_Id) return Node_Id is begin @@ -2021,6 +2044,14 @@ package body Sinfo is return Node2 (N); end Next_Entity; + function Next_Exit_Statement + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Exit_Statement); + return Node3 (N); + end Next_Exit_Statement; + function Next_Implicit_With (N : Node_Id) return Node_Id is begin @@ -2561,26 +2592,12 @@ package body Sinfo is (N : Node_Id) return Node_Id is begin pragma Assert (False - or else NT (N).Nkind = N_SCIL_Dispatch_Table_Object_Init or else NT (N).Nkind = N_SCIL_Dispatch_Table_Tag_Init or else NT (N).Nkind = N_SCIL_Dispatching_Call - or else NT (N).Nkind = N_SCIL_Membership_Test - or else NT (N).Nkind = N_SCIL_Tag_Init); + or else NT (N).Nkind = N_SCIL_Membership_Test); return Node4 (N); end SCIL_Entity; - function SCIL_Related_Node - (N : Node_Id) return Node_Id is - begin - pragma Assert (False - or else NT (N).Nkind = N_SCIL_Dispatch_Table_Object_Init - or else NT (N).Nkind = N_SCIL_Dispatch_Table_Tag_Init - or else NT (N).Nkind = N_SCIL_Dispatching_Call - or else NT (N).Nkind = N_SCIL_Membership_Test - or else NT (N).Nkind = N_SCIL_Tag_Init); - return Node1 (N); - end SCIL_Related_Node; - function SCIL_Tag_Value (N : Node_Id) return Node_Id is begin @@ -2931,6 +2948,14 @@ package body Sinfo is return Flag13 (N); end Was_Originally_Stub; + function Withed_Body + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_With_Clause); + return Node1 (N); + end Withed_Body; + function Zero_Cost_Handling (N : Node_Id) return Boolean is begin @@ -3033,7 +3058,9 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_And_Then + or else NT (N).Nkind = N_Case_Expression_Alternative or else NT (N).Nkind = N_Compilation_Unit_Aux + or else NT (N).Nkind = N_Expression_With_Actions or else NT (N).Nkind = N_Freeze_Entity or else NT (N).Nkind = N_Or_Else); Set_List1_With_Parent (N, Val); @@ -3116,6 +3143,7 @@ package body Sinfo is (N : Node_Id; Val : List_Id) is begin pragma Assert (False + or else NT (N).Nkind = N_Case_Expression or else NT (N).Nkind = N_Case_Statement or else NT (N).Nkind = N_In or else NT (N).Nkind = N_Not_In); @@ -3678,6 +3706,7 @@ package body Sinfo is (N : Node_Id; Val : List_Id) is begin pragma Assert (False + or else NT (N).Nkind = N_Case_Expression_Alternative or else NT (N).Nkind = N_Case_Statement_Alternative or else NT (N).Nkind = N_Variant); Set_List4_With_Parent (N, Val); @@ -4047,6 +4076,8 @@ package body Sinfo is or else NT (N).Nkind = N_Assignment_Statement or else NT (N).Nkind = N_At_Clause or else NT (N).Nkind = N_Attribute_Definition_Clause + or else NT (N).Nkind = N_Case_Expression + or else NT (N).Nkind = N_Case_Expression_Alternative or else NT (N).Nkind = N_Case_Statement or else NT (N).Nkind = N_Code_Statement or else NT (N).Nkind = N_Component_Association @@ -4056,6 +4087,7 @@ package body Sinfo is or else NT (N).Nkind = N_Discriminant_Association or else NT (N).Nkind = N_Discriminant_Specification or else NT (N).Nkind = N_Exception_Declaration + or else NT (N).Nkind = N_Expression_With_Actions or else NT (N).Nkind = N_Free_Statement or else NT (N).Nkind = N_Mod_Clause or else NT (N).Nkind = N_Modular_Type_Definition @@ -4433,6 +4465,14 @@ package body Sinfo is Set_Flag16 (N, Val); end Set_Interface_Present; + procedure Set_Import_Interface_Present + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + Set_Flag16 (N, Val); + end Set_Import_Interface_Present; + procedure Set_In_Present (N : Node_Id; Val : Boolean := True) is begin @@ -4450,6 +4490,14 @@ package body Sinfo is Set_Flag11 (N, Val); end Set_Includes_Infinities; + procedure Set_Inherited_Discriminant + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_Association); + Set_Flag13 (N, Val); + end Set_Inherited_Discriminant; + procedure Set_Instance_Spec (N : Node_Id; Val : Node_Id) is begin @@ -4899,6 +4947,14 @@ package body Sinfo is Set_Node2 (N, Val); -- semantic field, no parent set end Set_Next_Entity; + procedure Set_Next_Exit_Statement + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Exit_Statement); + Set_Node3 (N, Val); -- semantic field, no parent set + end Set_Next_Exit_Statement; + procedure Set_Next_Implicit_With (N : Node_Id; Val : Node_Id) is begin @@ -5439,26 +5495,12 @@ package body Sinfo is (N : Node_Id; Val : Node_Id) is begin pragma Assert (False - or else NT (N).Nkind = N_SCIL_Dispatch_Table_Object_Init or else NT (N).Nkind = N_SCIL_Dispatch_Table_Tag_Init or else NT (N).Nkind = N_SCIL_Dispatching_Call - or else NT (N).Nkind = N_SCIL_Membership_Test - or else NT (N).Nkind = N_SCIL_Tag_Init); + or else NT (N).Nkind = N_SCIL_Membership_Test); Set_Node4 (N, Val); -- semantic field, no parent set end Set_SCIL_Entity; - procedure Set_SCIL_Related_Node - (N : Node_Id; Val : Node_Id) is - begin - pragma Assert (False - or else NT (N).Nkind = N_SCIL_Dispatch_Table_Object_Init - or else NT (N).Nkind = N_SCIL_Dispatch_Table_Tag_Init - or else NT (N).Nkind = N_SCIL_Dispatching_Call - or else NT (N).Nkind = N_SCIL_Membership_Test - or else NT (N).Nkind = N_SCIL_Tag_Init); - Set_Node1 (N, Val); -- semantic field, no parent set - end Set_SCIL_Related_Node; - procedure Set_SCIL_Tag_Value (N : Node_Id; Val : Node_Id) is begin @@ -5809,6 +5851,14 @@ package body Sinfo is Set_Flag13 (N, Val); end Set_Was_Originally_Stub; + procedure Set_Withed_Body + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_With_Clause); + Set_Node1 (N, Val); + end Set_Withed_Body; + procedure Set_Zero_Cost_Handling (N : Node_Id; Val : Boolean := True) is begin @@ -5982,7 +6032,6 @@ package body Sinfo is T = V8; end Nkind_In; - function Nkind_In (T : Node_Kind; V1 : Node_Kind; diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 8a6a157cc34..cb358c4d75b 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1172,6 +1172,11 @@ package Sinfo is -- 'Address or 'Tag attribute. ???There are other implicit with clauses -- as well. + -- Import_Interface_Present (Flag16-Sem) + -- This flag is set in an Interface or Import pragma if a matching + -- pragma of the other kind is also present. This is used to avoid + -- generating some unwanted error messages. + -- Includes_Infinities (Flag11-Sem) -- This flag is present in N_Range nodes. It is set for the range of -- unconstrained float types defined in Standard, which include not only @@ -1180,6 +1185,12 @@ package Sinfo is -- range is given by the programmer, even if that range is identical to -- the range for Float. + -- Inherited_Discriminant (Flag13-Sem) + -- This flag is present in N_Component_Association nodes. It indicates + -- that a given component association in an extension aggregate is the + -- value obtained from a constraint on an ancestor. Used to prevent + -- double expansion when the aggregate has expansion delayed. + -- Instance_Spec (Node5-Sem) -- This field is present in generic instantiation nodes, and also in -- formal package declaration nodes (formal package declarations are @@ -1395,6 +1406,12 @@ package Sinfo is -- scope are chained, and this field is used as the forward pointer for -- this list. See Einfo for further details. + -- Next_Exit_Statement (Node3-Sem) + -- Present in N_Exit_Statement nodes. The exit statements for a loop are + -- chained (in reverse order of appearence) from the First_Exit_Statement + -- field of the E_Loop entity for the loop. Next_Exit_Statement points to + -- the next entry on this chain (Empty = end of list). + -- Next_Implicit_With (Node3-Sem) -- Present in N_With_Clause. Part of a chain of with_clauses generated -- in rtsfind to indicate implicit dependencies on predefined units. Used @@ -1609,10 +1626,6 @@ package Sinfo is -- Present in SCIL nodes. Used to reference the tagged type associated -- with the SCIL node. - -- SCIL_Related_Node (Node1-Sem) - -- Present in SCIL nodes. Used to reference a tree node that requires - -- special processing in the CodePeer backend. - -- SCIL_Controlling_Tag (Node5-Sem) -- Present in N_SCIL_Dispatching_Call nodes. Used to reference the -- controlling tag of a dispatching call. @@ -1723,6 +1736,12 @@ package Sinfo is -- Original_Node here because of the case of nested instantiations where -- the substituted node can be copied. + -- Withed_Body (Node1-Sem) + -- Present in N_With_Clause nodes. Set if the unit in whose context + -- the with_clause appears instantiates a generic contained in the + -- library unit of the with_clause and as a result loads its body. + -- Used for a more precise unit traversal for CodePeer. + -- Zero_Cost_Handling (Flag5-Sem) -- This flag is set in all handled sequence of statement and exception -- handler nodes if exceptions are to be handled using the zero-cost @@ -1974,13 +1993,14 @@ package Sinfo is -- which are explicitly documented. -- N_Pragma - -- Sloc points to pragma identifier + -- Sloc points to PRAGMA -- Next_Pragma (Node1-Sem) -- Pragma_Argument_Associations (List2) (set to No_List if none) -- Debug_Statement (Node3) (set to Empty if not Debug, Assert) -- Pragma_Identifier (Node4) -- Next_Rep_Item (Node5-Sem) -- Pragma_Enabled (Flag5-Sem) + -- Import_Interface_Present (Flag16-Sem) -- Note: we should have a section on what pragmas are passed on to -- the back end to be processed. This section should note that pragma @@ -3328,6 +3348,7 @@ package Sinfo is -- Loop_Actions (List2-Sem) -- Expression (Node3) -- Box_Present (Flag15) + -- Inherited_Discriminant (Flag13) -- Note: this structure is used for both record component associations -- and array component associations, since the two cases aren't always @@ -4034,6 +4055,13 @@ package Sinfo is -- Is_Null_Loop (Flag16) -- Suppress_Loop_Warnings (Flag17) + -- Note: the parser fills in the Identifier field if there is an + -- explicit loop identifier. Otherwise the parser leaves this field + -- set to Empty, and then the semantic processing for a loop statement + -- creates an identifier, setting the Has_Created_Identifier flag to + -- True. So after semantic anlaysis, the Identifier is always set, + -- referencing an identifier whose entity has an Ekind of E_Loop. + -------------------------- -- 5.5 Iteration Scheme -- -------------------------- @@ -4122,7 +4150,8 @@ package Sinfo is -- N_Exit_Statement -- Sloc points to EXIT -- Name (Node2) (set to Empty if no loop name present) - -- Condition (Node1) (set to Empty if no when part present) + -- Condition (Node1) (set to Empty if no WHEN part present) + -- Next_Exit_Statement (Node3-Sem): Next exit on chain ------------------------- -- 5.9 Goto Statement -- @@ -5530,6 +5559,7 @@ package Sinfo is -- N_With_Clause -- Sloc points to first token of library unit name + -- Withed_Body (Node1-Sem) -- Name (Node2) -- Next_Implicit_With (Node3-Sem) -- Library_Unit (Node4-Sem) @@ -5543,7 +5573,7 @@ package Sinfo is -- Elaborate_Desirable (Flag11-Sem) -- Private_Present (Flag15) set if with_clause has private keyword -- Implicit_With (Flag16-Sem) - -- Limited_Present (Flag17) set if LIMITED is present + -- Limited_Present (Flag17) set if LIMITED is present -- Limited_View_Installed (Flag18-Sem) -- Unreferenced_In_Spec (Flag7-Sem) -- No_Entities_Ref_In_Spec (Flag8-Sem) @@ -6509,10 +6539,46 @@ package Sinfo is -- reconstructed tree printed by Sprint, and the node descriptions here -- show this syntax. - -- Note: Conditional_Expression is in this section for historical reasons. - -- We will move it to its appropriate place when it is officially approved - -- as an extension (and then we will know what the exact grammar and place - -- in the Reference Manual is!) + -- Note: Case_Expression and Conditional_Expression is in this section for + -- now, since they are extensions. We will move them to their appropriate + -- places when they are officially approved as extensions (and then we will + -- know what the exact grammar and place in the Reference Manual is!) + + --------------------- + -- Case Expression -- + --------------------- + + -- CASE_EXPRESSION ::= + -- case EXPRESSION is + -- CASE_EXPRESSION_ALTERNATIVE + -- {CASE_EXPRESSION_ALTERNATIVE} + + -- Note that the Alternatives cannot include pragmas (this constrasts + -- with the situation of case statements where pragmas are allowed). + + -- N_Case_Expression + -- Sloc points to CASE + -- Expression (Node3) + -- Alternatives (List4) + + --------------------------------- + -- Case Expression Alternative -- + --------------------------------- + + -- CASE_STATEMENT_ALTERNATIVE ::= + -- when DISCRETE_CHOICE_LIST => + -- EXPRESSION + + -- N_Case_Expression_Alternative + -- Sloc points to WHEN + -- Actions (List1) + -- Discrete_Choices (List4) + -- Expression (Node3) + + -- Note: The Actions field temporarily holds any actions associated with + -- evaluation of the Expression. During expansion of the case expression + -- these actions are wrapped into the an N_Expressions_With_Actions node + -- replacing the original expression. ---------------------------- -- Conditional Expression -- @@ -6583,6 +6649,46 @@ package Sinfo is -- Has_Private_View (Flag11-Sem) set in generic units. -- plus fields for expression + ----------------------------- + -- Expression with Actions -- + ----------------------------- + + -- This node is created by the analyzer/expander to handle some + -- expansion cases, notably short circuit forms where there are + -- actions associated with the right hand operand. + + -- The N_Expression_With_Actions node represents an expression with + -- an associated set of actions (which are executable statements and + -- declarations, as might occur in a handled statement sequence). + + -- The required semantics is that the set of actions is executed in + -- the order in which it appears just before the expression is + -- evaluated (and these actions must only be executed if the value + -- of the expression is evaluated). The node is considered to be + -- a subexpression, whose value is the value of the Expression after + -- executing all the actions. + + -- Note: if the actions contain declarations, then these declarations + -- maybe referenced with in the expression. It is thus appropriate for + -- the back end to create a scope that encompasses the construct (any + -- declarations within the actions will definitely not be referenced + -- once elaboration of the construct is completed). + + -- Sprint syntax: do + -- action; + -- action; + -- ... + -- action; + -- in expression end + + -- N_Expression_With_Actions + -- Actions (List1) + -- Expression (Node3) + -- plus fields for expression + + -- Note: the actions list is always non-null, since we would + -- never have created this node if there weren't some actions. + -------------------- -- Free Statement -- -------------------- @@ -6883,34 +6989,21 @@ package Sinfo is -- Meanwhile these nodes should be considered in experimental form, and -- should be ignored by all code generating back ends. ??? - -- N_SCIL_Dispatch_Table_Object_Init - -- Sloc references a declaration node containing a dispatch table - -- SCIL_Related_Node (Node1-Sem) - -- SCIL_Entity (Node4-Sem) - -- N_SCIL_Dispatch_Table_Tag_Init -- Sloc references a node for a tag initialization - -- SCIL_Related_Node (Node1-Sem) -- SCIL_Entity (Node4-Sem) -- N_SCIL_Dispatching_Call -- Sloc references the node of a dispatching call - -- SCIL_Related_Node (Node1-Sem) -- SCIL_Target_Prim (Node2-Sem) -- SCIL_Entity (Node4-Sem) -- SCIL_Controlling_Tag (Node5-Sem) -- N_SCIL_Membership_Test -- Sloc references the node of a membership test - -- SCIL_Related_Node (Node1-Sem) -- SCIL_Tag_Value (Node5-Sem) -- SCIL_Entity (Node4-Sem) - -- N_SCIL_Tag_Init - -- Sloc references the node of a tag component initialization - -- SCIL_Related_Node (Node1-Sem) - -- SCIL_Entity (Node4-Sem) - --------------------- -- Subprogram_Info -- --------------------- @@ -7167,6 +7260,7 @@ package Sinfo is N_Conditional_Expression, N_Explicit_Dereference, + N_Expression_With_Actions, N_Function_Call, N_Indexed_Component, N_Integer_Literal, @@ -7184,6 +7278,7 @@ package Sinfo is N_Aggregate, N_Allocator, + N_Case_Expression, N_Extension_Aggregate, N_Range, N_Real_Literal, @@ -7350,11 +7445,9 @@ package Sinfo is -- SCIL nodes - N_SCIL_Dispatch_Table_Object_Init, N_SCIL_Dispatch_Table_Tag_Init, N_SCIL_Dispatching_Call, N_SCIL_Membership_Test, - N_SCIL_Tag_Init, -- Other nodes (not part of any subtype class) @@ -7362,6 +7455,7 @@ package Sinfo is N_Abstract_Subprogram_Declaration, N_Access_Definition, N_Access_To_Object_Definition, + N_Case_Expression_Alternative, N_Case_Statement_Alternative, N_Compilation_Unit, N_Compilation_Unit_Aux, @@ -7567,8 +7661,8 @@ package Sinfo is N_Or_Else; subtype N_SCIL_Node is Node_Kind range - N_SCIL_Dispatch_Table_Object_Init .. - N_SCIL_Tag_Init; + N_SCIL_Dispatch_Table_Tag_Init .. + N_SCIL_Membership_Test; subtype N_Statement_Other_Than_Procedure_Call is Node_Kind range N_Abort_Statement .. @@ -8090,12 +8184,18 @@ package Sinfo is function Implicit_With (N : Node_Id) return Boolean; -- Flag16 + function Import_Interface_Present + (N : Node_Id) return Boolean; -- Flag16 + function In_Present (N : Node_Id) return Boolean; -- Flag15 function Includes_Infinities (N : Node_Id) return Boolean; -- Flag11 + function Inherited_Discriminant + (N : Node_Id) return Boolean; -- Flag13 + function Instance_Spec (N : Node_Id) return Node_Id; -- Node5 @@ -8240,6 +8340,9 @@ package Sinfo is function Next_Entity (N : Node_Id) return Node_Id; -- Node2 + function Next_Exit_Statement + (N : Node_Id) return Node_Id; -- Node3 + function Next_Implicit_With (N : Node_Id) return Node_Id; -- Node3 @@ -8411,9 +8514,6 @@ package Sinfo is function SCIL_Entity (N : Node_Id) return Node_Id; -- Node4 - function SCIL_Related_Node - (N : Node_Id) return Node_Id; -- Node1 - function SCIL_Tag_Value (N : Node_Id) return Node_Id; -- Node5 @@ -8522,6 +8622,9 @@ package Sinfo is function Was_Originally_Stub (N : Node_Id) return Boolean; -- Flag13 + function Withed_Body + (N : Node_Id) return Node_Id; -- Node1 + function Zero_Cost_Handling (N : Node_Id) return Boolean; -- Flag5 @@ -9008,12 +9111,18 @@ package Sinfo is procedure Set_Implicit_With (N : Node_Id; Val : Boolean := True); -- Flag16 + procedure Set_Import_Interface_Present + (N : Node_Id; Val : Boolean := True); -- Flag16 + procedure Set_In_Present (N : Node_Id; Val : Boolean := True); -- Flag15 procedure Set_Includes_Infinities (N : Node_Id; Val : Boolean := True); -- Flag11 + procedure Set_Inherited_Discriminant + (N : Node_Id; Val : Boolean := True); -- Flag13 + procedure Set_Instance_Spec (N : Node_Id; Val : Node_Id); -- Node5 @@ -9158,6 +9267,9 @@ package Sinfo is procedure Set_Next_Entity (N : Node_Id; Val : Node_Id); -- Node2 + procedure Set_Next_Exit_Statement + (N : Node_Id; Val : Node_Id); -- Node3 + procedure Set_Next_Implicit_With (N : Node_Id; Val : Node_Id); -- Node3 @@ -9329,9 +9441,6 @@ package Sinfo is procedure Set_SCIL_Entity (N : Node_Id; Val : Node_Id); -- Node4 - procedure Set_SCIL_Related_Node - (N : Node_Id; Val : Node_Id); -- Node1 - procedure Set_SCIL_Tag_Value (N : Node_Id; Val : Node_Id); -- Node5 @@ -9440,6 +9549,9 @@ package Sinfo is procedure Set_Was_Originally_Stub (N : Node_Id; Val : Boolean := True); -- Flag13 + procedure Set_Withed_Body + (N : Node_Id; Val : Node_Id); -- Node1 + procedure Set_Zero_Cost_Handling (N : Node_Id; Val : Boolean := True); -- Flag5 @@ -10161,6 +10273,20 @@ package Sinfo is 4 => False, -- unused 5 => False), -- unused + N_Case_Expression => + (1 => False, -- unused + 2 => False, -- unused + 3 => True, -- Expression (Node3) + 4 => True, -- Alternatives (List4) + 5 => False), -- unused + + N_Case_Expression_Alternative => + (1 => False, -- Actions (List1-Sem) + 2 => False, -- unused + 3 => True, -- Statements (List3) + 4 => True, -- Expression (Node4) + 5 => False), -- unused + N_Case_Statement => (1 => False, -- unused 2 => False, -- unused @@ -10938,6 +11064,13 @@ package Sinfo is 4 => False, -- Entity (Node4-Sem) 5 => False), -- Etype (Node5-Sem) + N_Expression_With_Actions => + (1 => True, -- Actions (List1) + 2 => False, -- unused + 3 => True, -- Expression (Node3) + 4 => False, -- unused + 5 => False), -- unused + N_Free_Statement => (1 => False, -- Storage_Pool (Node1-Sem) 2 => False, -- Procedure_To_Call (Node2-Sem) @@ -11068,41 +11201,27 @@ package Sinfo is -- Entries for SCIL nodes - N_SCIL_Dispatch_Table_Object_Init => - (1 => False, -- SCIL_Related_Node (Node1-Sem) - 2 => False, -- unused - 3 => False, -- unused - 4 => False, -- SCIL_Entity (Node4-Sem) - 5 => False), -- unused - N_SCIL_Dispatch_Table_Tag_Init => - (1 => False, -- SCIL_Related_Node (Node1-Sem) + (1 => False, -- unused 2 => False, -- unused 3 => False, -- unused 4 => False, -- SCIL_Entity (Node4-Sem) 5 => False), -- unused N_SCIL_Dispatching_Call => - (1 => False, -- SCIL_Related_Node (Node1-Sem) + (1 => False, -- unused 2 => False, -- SCIL_Target_Prim (Node2-Sem) 3 => False, -- unused 4 => False, -- SCIL_Entity (Node4-Sem) 5 => False), -- SCIL_Controlling_Tag (Node5-Sem) N_SCIL_Membership_Test => - (1 => False, -- SCIL_Related_Node (Node1-Sem) + (1 => False, -- unused 2 => False, -- unused 3 => False, -- unused 4 => False, -- SCIL_Entity (Node4-Sem) 5 => False), -- SCIL_Tag_Value (Node5-Sem) - N_SCIL_Tag_Init => - (1 => False, -- SCIL_Related_Node (Node1-Sem) - 2 => False, -- unused - 3 => False, -- unused - 4 => False, -- SCIL_Entity (Node4-Sem) - 5 => False), -- unused - -- Entries for Empty, Error and Unused. Even thought these have a Chars -- field for debugging purposes, they are not really syntactic fields, so -- we mark all fields as unused. @@ -11298,7 +11417,9 @@ package Sinfo is pragma Inline (Interface_List); pragma Inline (Interface_Present); pragma Inline (Includes_Infinities); + pragma Inline (Import_Interface_Present); pragma Inline (In_Present); + pragma Inline (Inherited_Discriminant); pragma Inline (Instance_Spec); pragma Inline (Intval); pragma Inline (Is_Accessibility_Actual); @@ -11347,6 +11468,7 @@ package Sinfo is pragma Inline (Name); pragma Inline (Names); pragma Inline (Next_Entity); + pragma Inline (Next_Exit_Statement); pragma Inline (Next_Implicit_With); pragma Inline (Next_Named_Actual); pragma Inline (Next_Pragma); @@ -11404,7 +11526,6 @@ package Sinfo is pragma Inline (Rounded_Result); pragma Inline (SCIL_Controlling_Tag); pragma Inline (SCIL_Entity); - pragma Inline (SCIL_Related_Node); pragma Inline (SCIL_Tag_Value); pragma Inline (SCIL_Target_Prim); pragma Inline (Scope); @@ -11441,6 +11562,7 @@ package Sinfo is pragma Inline (Variants); pragma Inline (Visible_Declarations); pragma Inline (Was_Originally_Stub); + pragma Inline (Withed_Body); pragma Inline (Zero_Cost_Handling); pragma Inline (Set_ABE_Is_Certain); @@ -11600,7 +11722,9 @@ package Sinfo is pragma Inline (Set_Includes_Infinities); pragma Inline (Set_Interface_List); pragma Inline (Set_Interface_Present); + pragma Inline (Set_Import_Interface_Present); pragma Inline (Set_In_Present); + pragma Inline (Set_Inherited_Discriminant); pragma Inline (Set_Instance_Spec); pragma Inline (Set_Intval); pragma Inline (Set_Is_Accessibility_Actual); @@ -11650,6 +11774,7 @@ package Sinfo is pragma Inline (Set_Name); pragma Inline (Set_Names); pragma Inline (Set_Next_Entity); + pragma Inline (Set_Next_Exit_Statement); pragma Inline (Set_Next_Implicit_With); pragma Inline (Set_Next_Named_Actual); pragma Inline (Set_Next_Pragma); @@ -11706,7 +11831,6 @@ package Sinfo is pragma Inline (Set_Rounded_Result); pragma Inline (Set_SCIL_Controlling_Tag); pragma Inline (Set_SCIL_Entity); - pragma Inline (Set_SCIL_Related_Node); pragma Inline (Set_SCIL_Tag_Value); pragma Inline (Set_SCIL_Target_Prim); pragma Inline (Set_Scope); @@ -11743,6 +11867,7 @@ package Sinfo is pragma Inline (Set_Variants); pragma Inline (Set_Visible_Declarations); pragma Inline (Set_Was_Originally_Stub); + pragma Inline (Set_Withed_Body); pragma Inline (Set_Zero_Cost_Handling); N_Simple_Return_Statement : constant Node_Kind := N_Return_Statement; diff --git a/gcc/ada/sinput-c.adb b/gcc/ada/sinput-c.adb index 4997346bd8e..aebdcacdd12 100644 --- a/gcc/ada/sinput-c.adb +++ b/gcc/ada/sinput-c.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -28,7 +28,10 @@ with System; use System; with Ada.Unchecked_Conversion; +pragma Warnings (Off); +-- This package is used also by gnatcoll with System.OS_Lib; use System.OS_Lib; +pragma Warnings (On); package body Sinput.C is diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 89bbe4c7e40..71700388890 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -6,7 +6,7 @@ -- -- -- T e m p l a t e -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -34,7 +34,7 @@ with Namet; use Namet; package Snames is -- This package contains definitions of standard names (i.e. entries in the --- Names table) that are used throughout the GNAT compiler). It also contains +-- Names table) that are used throughout the GNAT compiler. It also contains -- the definitions of some enumeration types whose definitions are tied to -- the order of these preset names. @@ -334,6 +334,8 @@ package Snames is Name_Ada_95 : constant Name_Id := N + $; -- GNAT Name_Ada_05 : constant Name_Id := N + $; -- GNAT Name_Ada_2005 : constant Name_Id := N + $; -- GNAT + Name_Ada_12 : constant Name_Id := N + $; -- GNAT + Name_Ada_2012 : constant Name_Id := N + $; -- GNAT Name_Assertion_Policy : constant Name_Id := N + $; -- Ada 05 Name_Assume_No_Invalid_Values : constant Name_Id := N + $; -- GNAT Name_C_Pass_By_Copy : constant Name_Id := N + $; -- GNAT @@ -1416,6 +1418,8 @@ package Snames is Pragma_Ada_95, Pragma_Ada_05, Pragma_Ada_2005, + Pragma_Ada_12, + Pragma_Ada_2012, Pragma_Assertion_Policy, Pragma_Assume_No_Invalid_Values, Pragma_C_Pass_By_Copy, @@ -1690,9 +1694,10 @@ package Snames is -- call this function with a name that is not the name of a attribute. function Get_Convention_Id (N : Name_Id) return Convention_Id; - -- Returns Id of language convention corresponding to given name. It is an - -- to call this function with a name that is not the name of a convention, - -- or one previously given in a call to Record_Convention_Identifier. + -- Returns Id of language convention corresponding to given name. It is + -- an error to call this function with a name that is not the name of a + -- convention, or one that has been previously recorded using a call to + -- Record_Convention_Identifier. function Get_Convention_Name (C : Convention_Id) return Name_Id; -- Returns the name of language convention corresponding to given diff --git a/gcc/ada/socket.c b/gcc/ada/socket.c index 76755643161..e68f4359782 100644 --- a/gcc/ada/socket.c +++ b/gcc/ada/socket.c @@ -32,6 +32,7 @@ /* This file provides a portable binding to the sockets API */ #include "gsocket.h" + #ifdef VMS /* * For VMS, gsocket.h can't include sockets-related DEC C header files @@ -42,16 +43,27 @@ # include "s-oscons.h" /* - * We also need the declaration of struct servent, which s-oscons can't - * provide, so we copy it manually here. This needs to be kept in synch + * We also need the declaration of struct hostent/servent, which s-oscons + * can't provide, so we copy it manually here. This needs to be kept in synch * with the definition of that structure in the DEC C headers, which * hopefully won't change frequently. */ +typedef char *__netdb_char_ptr __attribute__ (( mode (SI) )); +typedef __netdb_char_ptr *__netdb_char_ptr_ptr __attribute__ (( mode (SI) )); + +struct hostent { + __netdb_char_ptr h_name; + __netdb_char_ptr_ptr h_aliases; + int h_addrtype; + int h_length; + __netdb_char_ptr_ptr h_addr_list; +}; + struct servent { - char *s_name; /* official service name */ - char **s_aliases; /* alias list */ - int s_port; /* port # */ - char *s_proto; /* protocol to use */ + __netdb_char_ptr s_name; + __netdb_char_ptr_ptr s_aliases; + int s_port; + __netdb_char_ptr s_proto; }; #endif @@ -87,15 +99,19 @@ extern void __gnat_remove_socket_from_set (fd_set *, int); extern void __gnat_reset_socket_set (fd_set *); extern int __gnat_get_h_errno (void); extern int __gnat_socket_ioctl (int, int, int *); + extern char * __gnat_servent_s_name (struct servent *); -extern char ** __gnat_servent_s_aliases (struct servent *); -extern int __gnat_servent_s_port (struct servent *); +extern char * __gnat_servent_s_alias (struct servent *, int index); +extern unsigned short __gnat_servent_s_port (struct servent *); extern char * __gnat_servent_s_proto (struct servent *); -extern void __gnat_servent_set_s_name (struct servent *, char *); -extern void __gnat_servent_set_s_aliases (struct servent *, char **); -extern void __gnat_servent_set_s_port (struct servent *, int); -extern void __gnat_servent_set_s_proto (struct servent *, char *); -#if defined (__vxworks) || defined (_WIN32) + +extern char * __gnat_hostent_h_name (struct hostent *); +extern char * __gnat_hostent_h_alias (struct hostent *, int); +extern int __gnat_hostent_h_addrtype (struct hostent *); +extern int __gnat_hostent_h_length (struct hostent *); +extern char * __gnat_hostent_h_addr (struct hostent *, int); + +#ifndef HAVE_INET_PTON extern int __gnat_inet_pton (int, const char *, void *); #endif @@ -164,76 +180,28 @@ __gnat_close_signalling_fd (int sig) { #endif /* - * GetXXXbyYYY wrappers - * These functions are used by the default implementation of g-socthi, - * and also by the Windows version. + * Handling of gethostbyname, gethostbyaddr, getservbyname and getservbyport + * ========================================================================= + * + * This module exposes __gnat_getXXXbyYYY operations with the same signature + * as the reentrant variant getXXXbyYYY_r. + * + * On platforms where getXXXbyYYY is intrinsically reentrant, the provided user + * buffer argument is ignored. * - * They can be used for any platform that either provides an intrinsically - * task safe implementation of getXXXbyYYY, or a reentrant variant - * getXXXbyYYY_r. Otherwise, a task safe wrapper, including proper mutual - * exclusion if appropriate, must be implemented in the target specific - * version of g-socthi. + * When getXXXbyYYY is not reentrant but getXXXbyYYY_r exists, the latter is + * used, and the provided buffer argument must point to a valid, thread-local + * buffer (usually on the caller's stack). + * + * When getXXXbyYYY is not reentrant and no reentrant getXXXbyYYY_r variant + * is available, the non-reentrant getXXXbyYYY is called, the provided user + * buffer is ignored, and the caller is expected to take care of mutual + * exclusion. */ -#ifdef HAVE_THREAD_SAFE_GETxxxBYyyy +#ifdef HAVE_GETxxxBYyyy_R int -__gnat_safe_gethostbyname (const char *name, - struct hostent *ret, char *buf, size_t buflen, - int *h_errnop) -{ - struct hostent *rh; - rh = gethostbyname (name); - if (rh == NULL) { - *h_errnop = h_errno; - return -1; - } - *ret = *rh; - *h_errnop = 0; - return 0; -} - -int -__gnat_safe_gethostbyaddr (const char *addr, int len, int type, - struct hostent *ret, char *buf, size_t buflen, - int *h_errnop) -{ - struct hostent *rh; - rh = gethostbyaddr (addr, len, type); - if (rh == NULL) { - *h_errnop = h_errno; - return -1; - } - *ret = *rh; - *h_errnop = 0; - return 0; -} - -int -__gnat_safe_getservbyname (const char *name, const char *proto, - struct servent *ret, char *buf, size_t buflen) -{ - struct servent *rh; - rh = getservbyname (name, proto); - if (rh == NULL) - return -1; - *ret = *rh; - return 0; -} - -int -__gnat_safe_getservbyport (int port, const char *proto, - struct servent *ret, char *buf, size_t buflen) -{ - struct servent *rh; - rh = getservbyport (port, proto); - if (rh == NULL) - return -1; - *ret = *rh; - return 0; -} -#elif HAVE_GETxxxBYyyy_R -int -__gnat_safe_gethostbyname (const char *name, +__gnat_gethostbyname (const char *name, struct hostent *ret, char *buf, size_t buflen, int *h_errnop) { @@ -250,7 +218,7 @@ __gnat_safe_gethostbyname (const char *name, } int -__gnat_safe_gethostbyaddr (const char *addr, int len, int type, +__gnat_gethostbyaddr (const char *addr, int len, int type, struct hostent *ret, char *buf, size_t buflen, int *h_errnop) { @@ -267,7 +235,7 @@ __gnat_safe_gethostbyaddr (const char *addr, int len, int type, } int -__gnat_safe_getservbyname (const char *name, const char *proto, +__gnat_getservbyname (const char *name, const char *proto, struct servent *ret, char *buf, size_t buflen) { struct servent *rh; @@ -283,7 +251,7 @@ __gnat_safe_getservbyname (const char *name, const char *proto, } int -__gnat_safe_getservbyport (int port, const char *proto, +__gnat_getservbyport (int port, const char *proto, struct servent *ret, char *buf, size_t buflen) { struct servent *rh; @@ -297,6 +265,130 @@ __gnat_safe_getservbyport (int port, const char *proto, ri = (rh == NULL) ? -1 : 0; return ri; } +#elif defined (__vxworks) +static char vxw_h_name[MAXHOSTNAMELEN + 1]; +static char *vxw_h_aliases[1] = { NULL }; +static int vxw_h_addr; +static char *vxw_h_addr_list[2] = { (char*) &vxw_h_addr, NULL }; + +int +__gnat_gethostbyname (const char *name, + struct hostent *ret, char *buf, size_t buflen, + int *h_errnop) +{ + vxw_h_addr = hostGetByName (name); + if (vxw_h_addr == ERROR) { + *h_errnop = __gnat_get_h_errno (); + return -1; + } + ret->h_name = name; + ret->h_aliases = &vxw_h_aliases; + ret->h_addrtype = AF_INET; + ret->h_length = 4; + ret->h_addr_list = &vxw_h_addr_list; + return 0; +} + +int +__gnat_gethostbyaddr (const char *addr, int len, int type, + struct hostent *ret, char *buf, size_t buflen, + int *h_errnop) +{ + if (type != AF_INET) { + *h_errnop = EAFNOSUPPORT; + return -1; + } + + if (addr == NULL || len != 4) { + *h_errnop = EINVAL; + return -1; + } + + if (hostGetByAddr (*(int*)addr, &vxw_h_name) != OK) { + *h_errnop = __gnat_get_h_errno (); + return -1; + } + + vxw_h_addr = addr; + + ret->h_name = &vxw_h_name; + ret->h_aliases = &vxw_h_aliases; + ret->h_addrtype = AF_INET; + ret->h_length = 4; + ret->h_addr_list = &vxw_h_addr_list; +} + +int +__gnat_getservbyname (const char *name, const char *proto, + struct servent *ret, char *buf, size_t buflen) +{ + /* Not available under VxWorks */ + return -1; +} + +int +__gnat_getservbyport (int port, const char *proto, + struct servent *ret, char *buf, size_t buflen) +{ + /* Not available under VxWorks */ + return -1; +} +#else +int +__gnat_gethostbyname (const char *name, + struct hostent *ret, char *buf, size_t buflen, + int *h_errnop) +{ + struct hostent *rh; + rh = gethostbyname (name); + if (rh == NULL) { + *h_errnop = __gnat_get_h_errno (); + return -1; + } + *ret = *rh; + *h_errnop = 0; + return 0; +} + +int +__gnat_gethostbyaddr (const char *addr, int len, int type, + struct hostent *ret, char *buf, size_t buflen, + int *h_errnop) +{ + struct hostent *rh; + rh = gethostbyaddr (addr, len, type); + if (rh == NULL) { + *h_errnop = __gnat_get_h_errno (); + return -1; + } + *ret = *rh; + *h_errnop = 0; + return 0; +} + +int +__gnat_getservbyname (const char *name, const char *proto, + struct servent *ret, char *buf, size_t buflen) +{ + struct servent *rh; + rh = getservbyname (name, proto); + if (rh == NULL) + return -1; + *ret = *rh; + return 0; +} + +int +__gnat_getservbyport (int port, const char *proto, + struct servent *ret, char *buf, size_t buflen) +{ + struct servent *rh; + rh = getservbyport (port, proto); + if (rh == NULL) + return -1; + *ret = *rh; + return 0; +} #endif /* Find the largest socket in the socket set SET. This is needed for @@ -509,6 +601,30 @@ __gnat_inet_pton (int af, const char *src, void *dst) { } #endif +/* + * Accessor functions for struct hostent. + */ + +char * __gnat_hostent_h_name (struct hostent * h) { + return h->h_name; +} + +char * __gnat_hostent_h_alias (struct hostent * h, int index) { + return h->h_aliases[index]; +} + +int __gnat_hostent_h_addrtype (struct hostent * h) { + return h->h_addrtype; +} + +int __gnat_hostent_h_length (struct hostent * h) { + return h->h_length; +} + +char * __gnat_hostent_h_addr (struct hostent * h, int index) { + return h->h_addr_list[index]; +} + /* * Accessor functions for struct servent. * @@ -539,21 +655,19 @@ __gnat_inet_pton (int af, const char *src, void *dst) { * }; */ -/* Getters */ - char * __gnat_servent_s_name (struct servent * s) { return s->s_name; } -char ** -__gnat_servent_s_aliases (struct servent * s) +char * +__gnat_servent_s_alias (struct servent * s, int index) { - return s->s_aliases; + return s->s_aliases[index]; } -int +unsigned short __gnat_servent_s_port (struct servent * s) { return s->s_port; @@ -565,32 +679,6 @@ __gnat_servent_s_proto (struct servent * s) return s->s_proto; } -/* Setters */ - -void -__gnat_servent_set_s_name (struct servent * s, char * s_name) -{ - s->s_name = s_name; -} - -void -__gnat_servent_set_s_aliases (struct servent * s, char ** s_aliases) -{ - s->s_aliases = s_aliases; -} - -void -__gnat_servent_set_s_port (struct servent * s, int s_port) -{ - s->s_port = s_port; -} - -void -__gnat_servent_set_s_proto (struct servent * s, char * s_proto) -{ - s->s_proto = s_proto; -} - #else # warning Sockets are not supported on this platform #endif /* defined(HAVE_SOCKETS) */ diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index cc9d5a081f1..44c12f0ab2d 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -403,7 +403,8 @@ package body Sprint is procedure pg (Arg : Union_Id) is begin Dump_Generated_Only := True; - Dump_Original_Only := False; + Dump_Original_Only := False; + Dump_Freeze_Null := True; Current_Source_File := No_Source_File; if Arg in List_Range then @@ -1083,6 +1084,32 @@ package body Sprint is Write_Char (';'); + when N_Case_Expression => + declare + Alt : Node_Id; + + begin + Write_Str_With_Col_Check_Sloc ("(case "); + Sprint_Node (Expression (Node)); + Write_Str_With_Col_Check (" is"); + + Alt := First (Alternatives (Node)); + loop + Sprint_Node (Alt); + Next (Alt); + exit when No (Alt); + Write_Char (','); + end loop; + + Write_Char (')'); + end; + + when N_Case_Expression_Alternative => + Write_Str_With_Col_Check (" when "); + Sprint_Bar_List (Discrete_Choices (Node)); + Write_Str (" => "); + Sprint_Node (Expression (Node)); + when N_Case_Statement => Write_Indent_Str_Sloc ("case "); Sprint_Node (Expression (Node)); @@ -1224,14 +1251,20 @@ package body Sprint is declare Condition : constant Node_Id := First (Expressions (Node)); Then_Expr : constant Node_Id := Next (Condition); - Else_Expr : constant Node_Id := Next (Then_Expr); + begin Write_Str_With_Col_Check_Sloc ("(if "); Sprint_Node (Condition); Write_Str_With_Col_Check (" then "); - Sprint_Node (Then_Expr); - Write_Str_With_Col_Check (" else "); - Sprint_Node (Else_Expr); + + -- Defense against junk here! + + if Present (Then_Expr) then + Sprint_Node (Then_Expr); + Write_Str_With_Col_Check (" else "); + Sprint_Node (Next (Then_Expr)); + end if; + Write_Char (')'); end; @@ -1508,6 +1541,19 @@ package body Sprint is Write_Char_Sloc ('.'); Write_Str_Sloc ("all"); + when N_Expression_With_Actions => + Indent_Begin; + Write_Indent_Str_Sloc ("do "); + Indent_Begin; + Sprint_Node_List (Actions (Node)); + Indent_End; + Write_Indent; + Write_Str_With_Col_Check_Sloc ("in "); + Sprint_Node (Expression (Node)); + Write_Str_With_Col_Check (" end"); + Indent_End; + Write_Indent; + when N_Extended_Return_Statement => Write_Indent_Str_Sloc ("return "); Sprint_Node_List (Return_Object_Declarations (Node)); @@ -2643,9 +2689,6 @@ package body Sprint is -- Doc of this extended syntax belongs in sinfo.ads and/or -- sprint.ads ??? - when N_SCIL_Dispatch_Table_Object_Init => - Write_Indent_Str ("[N_SCIL_Dispatch_Table_Object_Init]"); - when N_SCIL_Dispatch_Table_Tag_Init => Write_Indent_Str ("[N_SCIL_Dispatch_Table_Tag_Init]"); @@ -2655,9 +2698,6 @@ package body Sprint is when N_SCIL_Membership_Test => Write_Indent_Str ("[N_SCIL_Membership_Test]"); - when N_SCIL_Tag_Init => - Write_Indent_Str ("[N_SCIL_Dispatch_Table_Tag_Init]"); - when N_Simple_Return_Statement => if Present (Expression (Node)) then Write_Indent_Str_Sloc ("return "); diff --git a/gcc/ada/sprint.ads b/gcc/ada/sprint.ads index 59c371acbc3..64fe81ae4c5 100644 --- a/gcc/ada/sprint.ads +++ b/gcc/ada/sprint.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -32,6 +32,7 @@ -- tree may either blow up on a debugging check, or list incorrect source. with Types; use Types; + package Sprint is ----------------------- @@ -53,8 +54,8 @@ package Sprint is -- Convert wi Rounded_Result target@(source) -- Divide wi Treat_Fixed_As_Integer x #/ y -- Divide wi Rounded_Result x @/ y + -- Expression with actions do action; .. action; in expr end -- Expression with range check {expression} - -- Operator with range check {operator} (e.g. {+}) -- Free statement free expr [storage_pool = xxx] -- Freeze entity with freeze actions freeze entityname [ actions ] -- Implicit call to run time routine $routine-name @@ -69,6 +70,7 @@ package Sprint is -- Multiple concatenation expr && expr && expr ... && expr -- Multiply wi Treat_Fixed_As_Integer x #* y -- Multiply wi Rounded_Result x @* y + -- Operator with range check {operator} (e.g. {+}) -- Others choice for cleanup when all others -- Pop exception label %pop_xxx_exception_label -- Push exception label %push_xxx_exception_label (label) diff --git a/gcc/ada/style.adb b/gcc/ada/style.adb index e700abdf8f8..0f0ab300cba 100644 --- a/gcc/ada/style.adb +++ b/gcc/ada/style.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -78,11 +78,11 @@ package body Style is begin if Style_Check_Array_Attribute_Index then if D = 1 and then Present (E1) then - Error_Msg_N + Error_Msg_N -- CODEFIX ("(style) index number not allowed for one dimensional array", E1); elsif D > 1 and then No (E1) then - Error_Msg_N + Error_Msg_N -- CODEFIX ("(style) index number required for multi-dimensional array", N); end if; @@ -161,7 +161,7 @@ package body Style is then Error_Msg_Node_1 := Def; Error_Msg_Sloc := Sloc (Def); - Error_Msg + Error_Msg -- CODEFIX ("(style) bad casing of & declared#", Sref); return; @@ -222,7 +222,7 @@ package body Style is String (Tref (Sref .. Sref + Source_Ptr (Nlen) - 1)); Set_Casing (Cas); Error_Msg_Name_1 := Name_Enter; - Error_Msg_N + Error_Msg_N -- CODEFIX ("(style) bad casing of %% declared in Standard", Ref); end if; end if; @@ -243,10 +243,10 @@ package body Style is if Style_Check_Missing_Overriding and then Comes_From_Source (N) then if Nkind (N) = N_Subprogram_Body then - Error_Msg_N + Error_Msg_N -- CODEFIX ("(style) missing OVERRIDING indicator in body of%", N); else - Error_Msg_N + Error_Msg_N -- CODEFIX ("(style) missing OVERRIDING indicator in declaration of%", N); end if; end if; @@ -259,7 +259,7 @@ package body Style is procedure Subprogram_Not_In_Alpha_Order (Name : Node_Id) is begin if Style_Check_Order_Subprograms then - Error_Msg_N + Error_Msg_N -- CODEFIX ("(style) subprogram body& not in alphabetical order", Name); end if; end Subprogram_Not_In_Alpha_Order; diff --git a/gcc/ada/styleg.adb b/gcc/ada/styleg.adb index bf72722cc88..1c22dbcf707 100644 --- a/gcc/ada/styleg.adb +++ b/gcc/ada/styleg.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -237,9 +237,11 @@ package body Styleg is -- Otherwise we have an error elsif Nkind (Orig) = N_Op_And then - Error_Msg ("(style) `AND THEN` required", Sloc (Orig)); + Error_Msg -- CODEFIX + ("(style) `AND THEN` required", Sloc (Orig)); else - Error_Msg ("(style) `OR ELSE` required", Sloc (Orig)); + Error_Msg -- CODEFIX + ("(style) `OR ELSE` required", Sloc (Orig)); end if; end; end if; @@ -434,7 +436,8 @@ package body Styleg is if Scan_Ptr > Source_First (Current_Source_File) and then Source (Scan_Ptr - 1) > ' ' then - Error_Msg_S ("(style) space required"); + Error_Msg_S -- CODEFIX + ("(style) space required"); end if; end if; @@ -447,7 +450,8 @@ package body Styleg is if Source (Scan_Ptr + 2) > ' ' and then not Is_Special_Character (Source (Scan_Ptr + 2)) then - Error_Msg ("(style) space required", Scan_Ptr + 2); + Error_Msg -- CODEFIX + ("(style) space required", Scan_Ptr + 2); end if; end if; @@ -505,7 +509,8 @@ package body Styleg is if Is_Box_Comment then Error_Space_Required (Scan_Ptr + 2); else - Error_Msg ("(style) two spaces required", Scan_Ptr + 2); + Error_Msg -- CODEFIX + ("(style) two spaces required", Scan_Ptr + 2); end if; return; @@ -558,12 +563,12 @@ package body Styleg is -- We expect one blank line, from the EOF, but no more than one if Blank_Lines = 2 then - Error_Msg + Error_Msg -- CODEFIX ("(style) blank line not allowed at end of file", Blank_Line_Location); elsif Blank_Lines >= 3 then - Error_Msg + Error_Msg -- CODEFIX ("(style) blank lines not allowed at end of file", Blank_Line_Location); end if; @@ -590,7 +595,8 @@ package body Styleg is procedure Check_HT is begin if Style_Check_Horizontal_Tabs then - Error_Msg_S ("(style) horizontal tab not allowed"); + Error_Msg_S -- CODEFIX + ("(style) horizontal tab not allowed"); end if; end Check_HT; @@ -608,7 +614,8 @@ package body Styleg is if Token_Ptr = First_Non_Blank_Location and then Start_Column rem Style_Check_Indentation /= 0 then - Error_Msg_SC ("(style) bad indentation"); + Error_Msg_SC -- CODEFIX + ("(style) bad indentation"); end if; end if; end Check_Indentation; @@ -682,9 +689,11 @@ package body Styleg is if Style_Check_Form_Feeds then if Source (Scan_Ptr) = ASCII.FF then - Error_Msg_S ("(style) form feed not allowed"); + Error_Msg_S -- CODEFIX + ("(style) form feed not allowed"); elsif Source (Scan_Ptr) = ASCII.VT then - Error_Msg_S ("(style) vertical tab not allowed"); + Error_Msg_S -- CODEFIX + ("(style) vertical tab not allowed"); end if; end if; @@ -717,7 +726,7 @@ package body Styleg is -- Issue message for blanks at end of line if option enabled if Style_Check_Blanks_At_End and then L < Len then - Error_Msg + Error_Msg -- CODEFIX ("(style) trailing spaces not permitted", S); end if; @@ -913,7 +922,7 @@ package body Styleg is else if Token = Tok_Then then - Error_Msg + Error_Msg -- CODEFIX ("(style) no statements may follow THEN on same line", S); else Error_Msg @@ -977,7 +986,8 @@ package body Styleg is procedure Check_Xtra_Parens (Loc : Source_Ptr) is begin if Style_Check_Xtra_Parens then - Error_Msg ("redundant parentheses?", Loc); + Error_Msg -- CODEFIX + ("redundant parentheses?", Loc); end if; end Check_Xtra_Parens; @@ -996,7 +1006,8 @@ package body Styleg is procedure Error_Space_Not_Allowed (S : Source_Ptr) is begin - Error_Msg ("(style) space not allowed", S); + Error_Msg -- CODEFIX + ("(style) space not allowed", S); end Error_Space_Not_Allowed; -------------------------- @@ -1005,7 +1016,8 @@ package body Styleg is procedure Error_Space_Required (S : Source_Ptr) is begin - Error_Msg ("(style) space required", S); + Error_Msg -- CODEFIX + ("(style) space required", S); end Error_Space_Required; -------------------- @@ -1037,7 +1049,8 @@ package body Styleg is begin if Style_Check_End_Labels then Error_Msg_Node_1 := Name; - Error_Msg_SP ("(style) `END &` required"); + Error_Msg_SP -- CODEFIX + ("(style) `END &` required"); end if; end No_End_Name; @@ -1052,7 +1065,8 @@ package body Styleg is begin if Style_Check_End_Labels then Error_Msg_Node_1 := Name; - Error_Msg_SP ("(style) `EXIT &` required"); + Error_Msg_SP -- CODEFIX + ("(style) `EXIT &` required"); end if; end No_Exit_Name; @@ -1067,7 +1081,7 @@ package body Styleg is procedure Non_Lower_Case_Keyword is begin if Style_Check_Keyword_Casing then - Error_Msg_SC -- CODEIX + Error_Msg_SC -- CODEFIX ("(style) reserved words must be all lower case"); end if; end Non_Lower_Case_Keyword; diff --git a/gcc/ada/switch-b.adb b/gcc/ada/switch-b.adb index e3e597bcadf..b41296b2cc9 100644 --- a/gcc/ada/switch-b.adb +++ b/gcc/ada/switch-b.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -23,9 +23,10 @@ -- -- ------------------------------------------------------------------------------ -with Debug; use Debug; -with Osint; use Osint; -with Opt; use Opt; +with Debug; use Debug; +with Osint; use Osint; +with Opt; use Opt; +with Output; use Output; with System.WCh_Con; use System.WCh_Con; @@ -40,9 +41,35 @@ package body Switch.B is Ptr : Integer := Switch_Chars'First; C : Character := ' '; + function Get_Optional_Filename return String_Ptr; + -- If current character is '=', return a newly allocated string that + -- contains the remainder of the current switch (after the '='), else + -- return null. + function Get_Stack_Size (S : Character) return Int; - -- Used for -d and -D to scan stack size including handling k/m. - -- S is set to 'd' or 'D' to indicate the switch being scanned. + -- Used for -d and -D to scan stack size including handling k/m. S is + -- set to 'd' or 'D' to indicate the switch being scanned. + + --------------------------- + -- Get_Optional_Filename -- + --------------------------- + + function Get_Optional_Filename return String_Ptr is + Result : String_Ptr; + + begin + if Ptr <= Max and then Switch_Chars (Ptr) = '=' then + if Ptr = Max then + Bad_Switch (Switch_Chars); + else + Result := new String'(Switch_Chars (Ptr + 1 .. Max)); + Ptr := Max + 1; + return Result; + end if; + end if; + + return null; + end Get_Optional_Filename; -------------------- -- Get_Stack_Size -- @@ -61,11 +88,11 @@ package body Switch.B is pragma Unsuppress (Overflow_Check); begin - -- Check for additional character 'k' (for kilobytes) or 'm' - -- (for Megabytes), but only if we have not reached the end - -- of the switch string. Note that if this appears before the - -- end of the string we will get an error when we test to make - -- sure that the string is exhausted (at the end of the case). + -- Check for additional character 'k' (for kilobytes) or 'm' (for + -- Megabytes), but only if we have not reached the end of the + -- switch string. Note that if this appears before the end of the + -- string we will get an error when we test to make sure that the + -- string is exhausted (at the end of the case). if Ptr <= Max then if Switch_Chars (Ptr) = 'k' then @@ -97,8 +124,8 @@ package body Switch.B is Ptr := Ptr + 1; end if; - -- A little check, "gnat" at the start of a switch is not allowed - -- except for the compiler + -- A little check, "gnat" at the start of a switch is not allowed except + -- for the compiler if Switch_Chars'Last >= Ptr + 3 and then Switch_Chars (Ptr .. Ptr + 3) = "gnat" @@ -124,7 +151,8 @@ package body Switch.B is when 'A' => Ptr := Ptr + 1; - Ada_Bind_File := True; + Output_ALI_List := True; + ALI_List_Filename := Get_Optional_Filename; -- Processing for b switch @@ -136,16 +164,16 @@ package body Switch.B is when 'c' => Ptr := Ptr + 1; - Check_Only := True; -- Processing for C switch when 'C' => Ptr := Ptr + 1; - Ada_Bind_File := False; + Write_Line ("warning: gnatbind switch -C is obsolescent"); + -- Processing for d switch when 'd' => @@ -243,6 +271,20 @@ package body Switch.B is Ptr := Ptr + 1; Usage_Requested := True; + -- Processing for H switch + + when 'H' => + if Ptr = Max then + Bad_Switch (Switch_Chars); + end if; + + Ptr := Ptr + 1; + Scan_Nat (Switch_Chars, Max, Ptr, Heap_Size, C); + + if Heap_Size /= 32 and then Heap_Size /= 64 then + Bad_Switch (Switch_Chars); + end if; + -- Processing for i switch when 'i' => @@ -253,7 +295,7 @@ package body Switch.B is Ptr := Ptr + 1; C := Switch_Chars (Ptr); - if C in '1' .. '5' + if C in '1' .. '5' or else C = '8' or else C = 'p' or else C = 'f' @@ -305,7 +347,6 @@ package body Switch.B is if Output_File_Name_Present then Osint.Fail ("duplicate -o switch"); - else Output_File_Name_Present := True; end if; @@ -315,6 +356,7 @@ package body Switch.B is when 'O' => Ptr := Ptr + 1; Output_Object_List := True; + Object_List_Filename := Get_Optional_Filename; -- Processing for p switch @@ -338,7 +380,6 @@ package body Switch.B is when 'R' => Ptr := Ptr + 1; - Check_Only := True; List_Closure := True; -- Processing for s switch @@ -400,7 +441,6 @@ package body Switch.B is Ptr := Ptr + 1; case Switch_Chars (Ptr) is - when 'e' => Warning_Mode := Treat_As_Error; @@ -433,8 +473,7 @@ package body Switch.B is Wide_Character_Encoding_Method_Specified := True; Upper_Half_Encoding := - Wide_Character_Encoding_Method in - WC_Upper_Half_Encoding_Method; + Wide_Character_Encoding_Method in WC_Upper_Half_Encoding_Method; Ptr := Ptr + 1; @@ -486,7 +525,7 @@ package body Switch.B is Osint.Fail ("missing path for --RTS"); else - -- valid --RTS switch + -- Valid --RTS switch Opt.No_Stdinc := True; Opt.RTS_Switch := True; @@ -508,8 +547,8 @@ package body Switch.B is Lib_Path_Name /= null then -- Set the RTS_*_Path_Name variables, so that the - -- correct directories will be set when - -- Osint.Add_Default_Search_Dirs will be called later. + -- correct directories will be set when a subsequent + -- call Osint.Add_Default_Search_Dirs is made. RTS_Src_Path_Name := Src_Path_Name; RTS_Lib_Path_Name := Lib_Path_Name; diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb index 7b194107ff6..ab213af14bb 100644 --- a/gcc/ada/switch-c.adb +++ b/gcc/ada/switch-c.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -32,8 +32,7 @@ with Validsw; use Validsw; with Sem_Warn; use Sem_Warn; with Stylesw; use Stylesw; -with System.OS_Lib; use System.OS_Lib; - +with System.Strings; with System.WCh_Con; use System.WCh_Con; package body Switch.C is @@ -41,11 +40,25 @@ package body Switch.C is RTS_Specified : String_Access := null; -- Used to detect multiple use of --RTS= flag + function Switch_Subsequently_Cancelled + (C : String; + Args : Argument_List; + Arg_Rank : Positive) return Boolean; + -- This function is called from Scan_Front_End_Switches. It determines if + -- the switch currently being scanned is followed by a switch of the form + -- "-gnat-" & C, where C is the argument. If so, then True is returned, + -- and Scan_Front_End_Switches will cancel the effect of the switch. If + -- no such switch is found, False is returned. + ----------------------------- -- Scan_Front_End_Switches -- ----------------------------- - procedure Scan_Front_End_Switches (Switch_Chars : String) is + procedure Scan_Front_End_Switches + (Switch_Chars : String; + Args : Argument_List; + Arg_Rank : Positive) + is First_Switch : Boolean := True; -- False for all but first switch @@ -519,11 +532,11 @@ package body Switch.C is System_Extend_Unit := Empty; Warning_Mode := Treat_As_Error; - -- Set Ada 2005 mode explicitly. We don't want to rely on the + -- Set Ada 2012 mode explicitly. We don't want to rely on the -- implicit setting here, since for example, we want -- Preelaborate_05 treated as Preelaborate - Ada_Version := Ada_05; + Ada_Version := Ada_12; Ada_Version_Explicit := Ada_Version; -- Set default warnings and style checks for -gnatg @@ -662,20 +675,27 @@ package body Switch.C is when 'p' => Ptr := Ptr + 1; - -- Set all specific options as well as All_Checks in the - -- Suppress_Options array, excluding Elaboration_Check, since - -- this is treated specially because we do not want -gnatp to - -- disable static elaboration processing. + -- Skip processing if cancelled by subsequent -gnat-p - for J in Suppress_Options'Range loop - if J /= Elaboration_Check then - Suppress_Options (J) := True; - end if; - end loop; + if Switch_Subsequently_Cancelled ("p", Args, Arg_Rank) then + Store_Switch := False; - Validity_Checks_On := False; - Opt.Suppress_Checks := True; - Opt.Enable_Overflow_Checks := False; + else + -- Set all specific options as well as All_Checks in the + -- Suppress_Options array, excluding Elaboration_Check, + -- since this is treated specially because we do not want + -- -gnatp to disable static elaboration processing. + + for J in Suppress_Options'Range loop + if J /= Elaboration_Check then + Suppress_Options (J) := True; + end if; + end loop; + + Validity_Checks_On := False; + Opt.Suppress_Checks := True; + Opt.Enable_Overflow_Checks := False; + end if; -- Processing for P switch @@ -883,6 +903,8 @@ package body Switch.C is when 'X' => Ptr := Ptr + 1; Extensions_Allowed := True; + Ada_Version := Ada_Version_Type'Last; + Ada_Version_Explicit := Ada_Version_Type'Last; -- Processing for y switch @@ -933,6 +955,7 @@ package body Switch.C is -- Processing for z switch when 'z' => + -- -gnatz must be the first and only switch in Switch_Chars, -- and is a two-letter switch. @@ -1027,11 +1050,68 @@ package body Switch.C is Ada_Version_Explicit := Ada_Version; end if; - -- Ignore extra switch character + -- Processing for 12 switch + + when '1' => + if Ptr = Max then + Bad_Switch ("-gnat1"); + end if; - when '/' | '-' => Ptr := Ptr + 1; + if Switch_Chars (Ptr) /= '2' then + Bad_Switch ("-gnat1" & Switch_Chars (Ptr .. Max)); + else + Ptr := Ptr + 1; + Ada_Version := Ada_12; + Ada_Version_Explicit := Ada_Version; + end if; + + -- Processing for 2005 and 2012 switches + + when '2' => + if Ptr > Max - 3 then + Bad_Switch ("-gnat" & Switch_Chars (Ptr .. Max)); + + elsif Switch_Chars (Ptr .. Ptr + 3) = "2005" then + Ada_Version := Ada_05; + + elsif Switch_Chars (Ptr .. Ptr + 3) = "2012" then + Ada_Version := Ada_12; + + else + Bad_Switch ("-gnat" & Switch_Chars (Ptr .. Ptr + 3)); + end if; + + Ada_Version_Explicit := Ada_Version; + Ptr := Ptr + 4; + + -- Switch cancellation, currently only -gnat-p is allowed. + -- All we do here is the error checking, since the actual + -- processing for switch cancellation is done by calls to + -- Switch_Subsequently_Cancelled at the appropriate point. + + when '-' => + + -- Simple ignore -gnat-p + + if Switch_Chars = "-gnat-p" then + return; + + -- Any other occurrence of minus is ignored. This is for + -- maximum compatibility with previous version which ignored + -- all occurrences of minus. + + else + Store_Switch := False; + Ptr := Ptr + 1; + end if; + + -- We ignore '/' in switches, this is historical, still needed??? + + when '/' => + Store_Switch := False; + -- Anything else is an error (illegal switch character) when others => @@ -1048,4 +1128,29 @@ package body Switch.C is end if; end Scan_Front_End_Switches; + ----------------------------------- + -- Switch_Subsequently_Cancelled -- + ----------------------------------- + + function Switch_Subsequently_Cancelled + (C : String; + Args : Argument_List; + Arg_Rank : Positive) return Boolean + is + use type System.Strings.String_Access; + + begin + -- Loop through arguments following the current one + + for Arg in Arg_Rank + 1 .. Args'Last loop + if Args (Arg).all = "-gnat-" & C then + return True; + end if; + end loop; + + -- No match found, not cancelled + + return False; + end Switch_Subsequently_Cancelled; + end Switch.C; diff --git a/gcc/ada/switch-c.ads b/gcc/ada/switch-c.ads index 09ac49ecb57..1595858a28d 100644 --- a/gcc/ada/switch-c.ads +++ b/gcc/ada/switch-c.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,15 +29,24 @@ -- switches that are recognized. In addition, package Debug documents -- the otherwise undocumented debug switches that are also recognized. +with System.OS_Lib; use System.OS_Lib; + package Switch.C is - procedure Scan_Front_End_Switches (Switch_Chars : String); + procedure Scan_Front_End_Switches + (Switch_Chars : String; + Args : Argument_List; + Arg_Rank : Positive); -- Procedures to scan out front end switches stored in the given string. -- The first character is known to be a valid switch character, and there -- are no blanks or other switch terminator characters in the string, so -- the entire string should consist of valid switch characters, except that -- an optional terminating NUL character is allowed. A bad switch causes -- a fatal error exit and control does not return. The call also sets - -- Usage_Requested to True if a ? switch is encountered. + -- Usage_Requested to True if a switch -gnath is encountered. + -- + -- Args is the full list of command line arguments. Arg_Rank is the + -- position of the switch in Args. It is used for certain switches -gnatx + -- to check if a subsequent switch -gnat-x cancels the switch -gnatx. end Switch.C; diff --git a/gcc/ada/switch-m.adb b/gcc/ada/switch-m.adb index a7a8d192626..11491d3de42 100644 --- a/gcc/ada/switch-m.adb +++ b/gcc/ada/switch-m.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -71,7 +71,7 @@ package body Switch.M is procedure Add_Switch_Component (S : String); -- Add a new String_Access component in Switches. If a string equal -- to S is already stored in the table Normalized_Switches, use it. - -- Other wise add a new component to the table. + -- Otherwise add a new component to the table. -------------------------- -- Add_Switch_Component -- @@ -215,10 +215,10 @@ package body Switch.M is -- One-letter switches - when 'a' | 'A' | 'b' | 'c' | 'D' | 'E' | 'f' | - 'F' | 'g' | 'h' | 'H' | 'k' | 'l' | 'L' | 'n' | 'N' | - 'o' | 'O' | 'p' | 'P' | 'q' | 'Q' | 'r' | 's' | 't' | - 'u' | 'U' | 'v' | 'x' | 'X' | 'Z' => + when 'a' | 'A' | 'b' | 'B' | 'c' | 'C' | 'E' | 'f' | + 'F' | 'g' | 'h' | 'H' | 'I' | 'L' | 'n' | 'N' | + 'o' | 'p' | 'P' | 'q' | 'Q' | 'r' | 's' | 'S' | + 't' | 'u' | 'U' | 'v' | 'x' | 'X' | 'Z' => Storing (First_Stored) := C; Add_Switch_Component (Storing (Storing'First .. First_Stored)); @@ -226,10 +226,14 @@ package body Switch.M is -- One-letter switches followed by a positive number - when 'm' | 'T' => + when 'D' | 'G' | 'j' | 'k' | 'm' | 'T' => Storing (First_Stored) := C; Last_Stored := First_Stored; + if Ptr <= Max and then Switch_Chars (Ptr) = '=' then + Ptr := Ptr + 1; + end if; + loop Ptr := Ptr + 1; exit when Ptr > Max @@ -268,63 +272,93 @@ package body Switch.M is when 'e' => - -- Store -gnateD, -gnatep= and -gnateG in the ALI file. - -- The other -gnate switches do not need to be stored. + -- Some of the gnate... switches are not stored Storing (First_Stored) := 'e'; Ptr := Ptr + 1; - if Ptr > Max - or else (Switch_Chars (Ptr) /= 'D' - and then Switch_Chars (Ptr) /= 'G' - and then Switch_Chars (Ptr) /= 'p') - then + if Ptr > Max then Last := 0; return; - end if; - -- Processing for -gnateD + else + case Switch_Chars (Ptr) is - if Switch_Chars (Ptr) = 'D' then - Storing (First_Stored + 1 .. - First_Stored + Max - Ptr + 1) := - Switch_Chars (Ptr .. Max); - Add_Switch_Component - (Storing (Storing'First .. - First_Stored + Max - Ptr + 1)); + when 'D' => + Storing (First_Stored + 1 .. + First_Stored + Max - Ptr + 1) := + Switch_Chars (Ptr .. Max); + Add_Switch_Component + (Storing (Storing'First .. + First_Stored + Max - Ptr + 1)); + Ptr := Max + 1; - -- Processing for -gnatep= + when 'G' => + Ptr := Ptr + 1; + Add_Switch_Component ("-gnateG"); - elsif Switch_Chars (Ptr) = 'p' then - Ptr := Ptr + 1; + when 'I' => + Ptr := Ptr + 1; - if Ptr = Max then - Last := 0; - return; - end if; + declare + First : constant Positive := Ptr - 1; + begin + if Ptr <= Max and then + Switch_Chars (Ptr) = '=' + then + Ptr := Ptr + 1; + end if; + + while Ptr <= Max and then + Switch_Chars (Ptr) in '0' .. '9' + loop + Ptr := Ptr + 1; + end loop; + + Storing (First_Stored + 1 .. + First_Stored + Ptr - First) := + Switch_Chars (First .. Ptr - 1); + Add_Switch_Component + (Storing (Storing'First .. + First_Stored + Ptr - First)); + end; + + when 'p' => + Ptr := Ptr + 1; - if Switch_Chars (Ptr) = '=' then - Ptr := Ptr + 1; - end if; + if Ptr = Max then + Last := 0; + return; + end if; - -- To normalize, always put a '=' after -gnatep. - -- Because that could lengthen the switch string, - -- declare a local variable. - - declare - To_Store : String (1 .. Max - Ptr + 9); - begin - To_Store (1 .. 8) := "-gnatep="; - To_Store (9 .. Max - Ptr + 9) := - Switch_Chars (Ptr .. Max); - Add_Switch_Component (To_Store); - end; - - elsif Switch_Chars (Ptr) = 'G' then - Add_Switch_Component ("-gnateG"); - end if; + if Switch_Chars (Ptr) = '=' then + Ptr := Ptr + 1; + end if; - return; + -- To normalize, always put a '=' after + -- -gnatep. Because that could lengthen the + -- switch string, declare a local variable. + + declare + To_Store : String (1 .. Max - Ptr + 9); + begin + To_Store (1 .. 8) := "-gnatep="; + To_Store (9 .. Max - Ptr + 9) := + Switch_Chars (Ptr .. Max); + Add_Switch_Component (To_Store); + end; + + return; + + when 'S' => + Ptr := Ptr + 1; + Add_Switch_Component ("-gnateS"); + + when others => + Last := 0; + return; + end case; + end if; when 'i' => Storing (First_Stored) := 'i'; @@ -355,6 +389,20 @@ package body Switch.M is return; end if; + -- -gnatl may be -gnatl= + + when 'l' => + Ptr := Ptr + 1; + + if Ptr > Max or else Switch_Chars (Ptr) /= '=' then + Add_Switch_Component ("-gnatl"); + + else + Add_Switch_Component + ("-gnatl" & Switch_Chars (Ptr .. Max)); + return; + end if; + -- -gnatR may be followed by '0', '1', '2' or '3', -- then by 's' @@ -390,6 +438,26 @@ package body Switch.M is Add_Switch_Component (Storing (Storing'First .. Last_Stored)); + -- -gnatWx, x = 'h'. 'u', 's', 'e', '8' or 'b' + + when 'W' => + Storing (First_Stored) := 'W'; + Ptr := Ptr + 1; + + if Ptr <= Max then + case Switch_Chars (Ptr) is + when 'h' | 'u' | 's' | 'e' | '8' | 'b' => + Storing (First_Stored + 1) := Switch_Chars (Ptr); + Add_Switch_Component + (Storing (Storing'First .. First_Stored + 1)); + Ptr := Ptr + 1; + + when others => + Last := 0; + return; + end case; + end if; + -- Multiple switches when 'V' | 'w' | 'y' => @@ -584,6 +652,9 @@ package body Switch.M is (Switch_Chars'First + Subdirs_Option'Length .. Switch_Chars'Last)); + elsif Switch_Chars = Makeutl.Unchecked_Shared_Lib_Imports then + Opt.Unchecked_Shared_Lib_Imports := True; + elsif Switch_Chars (Ptr) = '-' then Bad_Switch (Switch_Chars); @@ -839,6 +910,7 @@ package body Switch.M is when 'x' => External_Unit_Compilation_Allowed := True; + Use_Include_Path_File := True; -- Processing for z switch diff --git a/gcc/ada/switch-m.ads b/gcc/ada/switch-m.ads index 6a800234083..de7ccaf5d5d 100644 --- a/gcc/ada/switch-m.ads +++ b/gcc/ada/switch-m.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,7 +29,11 @@ -- switches that are recognized. In addition, package Debug documents -- the otherwise undocumented debug switches that are also recognized. +pragma Warnings (Off); +-- This package is used also by gnatcoll with System.OS_Lib; use System.OS_Lib; +pragma Warnings (On); + with Prj.Tree; package Switch.M is diff --git a/gcc/ada/sysdep.c b/gcc/ada/sysdep.c index 5af4299e88c..c978c036a35 100644 --- a/gcc/ada/sysdep.c +++ b/gcc/ada/sysdep.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 1992-2009, Free Software Foundation, Inc. * + * Copyright (C) 1992-2010, Free Software Foundation, Inc. * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * @@ -34,7 +34,7 @@ #ifdef __vxworks #include "ioLib.h" -#if ! defined (__VXWORKSMILS__) +#if ! defined (VTHREADS) #include "dosFsLib.h" #endif #if ! defined (__RTP__) && (! defined (VTHREADS) || defined (__VXWORKSMILS__)) @@ -158,7 +158,7 @@ extern struct tm *localtime_r(const time_t *, struct tm *); */ -#if defined(WINNT) || defined (MSDOS) || defined (__EMX__) +#if defined(WINNT) static const char *mode_read_text = "rt"; static const char *mode_write_text = "wt"; static const char *mode_append_text = "at"; @@ -345,7 +345,7 @@ __gnat_ttyname (int filedes) } #endif -#if defined (linux) || defined (sun) || defined (sgi) || defined (__EMX__) \ +#if defined (linux) || defined (sun) || defined (sgi) \ || (defined (__osf__) && ! defined (__alpha_vxworks)) || defined (WINNT) \ || defined (__MACHTEN__) || defined (__hpux__) || defined (_AIX) \ || (defined (__svr4__) && defined (i386)) || defined (__Lynx__) \ @@ -403,7 +403,7 @@ getc_immediate_common (FILE *stream, int *avail, int waiting) { -#if defined (linux) || defined (sun) || defined (sgi) || defined (__EMX__) \ +#if defined (linux) || defined (sun) || defined (sgi) \ || (defined (__osf__) && ! defined (__alpha_vxworks)) \ || defined (__CYGWIN32__) || defined (__MACHTEN__) || defined (__hpux__) \ || defined (_AIX) || (defined (__svr4__) && defined (i386)) \ @@ -424,7 +424,7 @@ getc_immediate_common (FILE *stream, /* Set RAW mode, with no echo */ termios_rec.c_lflag = termios_rec.c_lflag & ~ICANON & ~ECHO; -#if defined(linux) || defined (sun) || defined (sgi) || defined (__EMX__) \ +#if defined(linux) || defined (sun) || defined (sgi) \ || defined (__osf__) || defined (__MACHTEN__) || defined (__hpux__) \ || defined (_AIX) || (defined (__svr4__) && defined (i386)) \ || defined (__Lynx__) || defined (__FreeBSD__) || defined (__OpenBSD__) \ @@ -433,17 +433,11 @@ getc_immediate_common (FILE *stream, /* If waiting (i.e. Get_Immediate (Char)), set MIN = 1 and wait for a character forever. This doesn't seem to effect Ctrl-Z or - Ctrl-C processing except on OS/2 where Ctrl-C won't work right - unless we do a read loop. Luckily we can delay a bit between - iterations. If not waiting (i.e. Get_Immediate (Char, Available)), + Ctrl-C processing. + If not waiting (i.e. Get_Immediate (Char, Available)), don't wait for anything but timeout immediately. */ -#ifdef __EMX__ - termios_rec.c_cc[VMIN] = 0; - termios_rec.c_cc[VTIME] = waiting; -#else termios_rec.c_cc[VMIN] = waiting; termios_rec.c_cc[VTIME] = 0; -#endif #endif tcsetattr (fd, TCSANOW, &termios_rec); @@ -720,7 +714,7 @@ long __gnat_invalid_tzoff = 259273; /* Definition of __gnat_localtime_r used by a-calend.adb */ -#if defined (__EMX__) || defined (__MINGW32__) +#if defined (__MINGW32__) #ifdef CERT @@ -743,7 +737,7 @@ extern void (*Unlock_Task) (void); #endif -/* Reentrant localtime for Windows and OS/2. */ +/* Reentrant localtime for Windows. */ extern void __gnat_localtime_tzoff (const time_t *, long *); @@ -987,7 +981,7 @@ __gnat_is_file_not_found_error (int errno_val) { /* In the case of VxWorks, we also have to take into account various * filesystem-specific variants of this error. */ -#if ! defined (__VXWORKSMILS__) +#if ! defined (VTHREADS) case S_dosFsLib_FILE_NOT_FOUND: #endif #if ! defined (__RTP__) && (! defined (VTHREADS) || defined (__VXWORKSMILS__)) diff --git a/gcc/ada/system-vms-ia64.ads b/gcc/ada/system-vms-ia64.ads index 57fece94076..f5d806ddf77 100644 --- a/gcc/ada/system-vms-ia64.ads +++ b/gcc/ada/system-vms-ia64.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (OpenVMS 64bit Itanium GCC_ZCX DEC Threads Version) -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -239,7 +239,7 @@ private -- Special VMS Interfaces -- ---------------------------- - procedure Lib_Stop (I : Integer); + procedure Lib_Stop (Cond_Value : Integer); pragma Interface (C, Lib_Stop); pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value)); -- Interface to VMS condition handling. Used by RTSfind and pragma @@ -251,4 +251,7 @@ private -- Ubiquitous global symbol identifying a GNAT compiled image to VMS Debug. -- Do not remove! + pragma Ident ("GNAT"); -- Gnat_Static_Version_String + -- Default ident for all VMS images. + end System; diff --git a/gcc/ada/system-vms-zcx.ads b/gcc/ada/system-vms-zcx.ads deleted file mode 100644 index 5b4c3edb5d6..00000000000 --- a/gcc/ada/system-vms-zcx.ads +++ /dev/null @@ -1,232 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (OpenVMS GCC_ZCX DEC Threads Version) -- --- -- --- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package System is - pragma Pure; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - type Name is (SYSTEM_NAME_GNAT); - System_Name : constant Name := SYSTEM_NAME_GNAT; - - -- System-Dependent Named Numbers - - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; - - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; - Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; - - Max_Base_Digits : constant := Long_Long_Float'Digits; - Max_Digits : constant := Long_Long_Float'Digits; - - Max_Mantissa : constant := 63; - Fine_Delta : constant := 2.0 ** (-Max_Mantissa); - - Tick : constant := 0.01; - - -- Storage-related Declarations - - type Address is private; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := Low_Order_First; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - Max_Priority : constant Positive := 30; - Max_Interrupt_Priority : constant Positive := 31; - - subtype Any_Priority is Integer range 0 .. 31; - subtype Priority is Any_Priority range 0 .. 30; - subtype Interrupt_Priority is Any_Priority range 31 .. 31; - - Default_Priority : constant Priority := 15; - -private - - type Address is mod Memory_Size; - Null_Address : constant Address := 0; - - -------------------------------------- - -- System Implementation Parameters -- - -------------------------------------- - - -- These parameters provide information about the target that is used - -- by the compiler. They are in the private part of System, where they - -- can be accessed using the special circuitry in the Targparm unit - -- whose source should be consulted for more detailed descriptions - -- of the individual switch values. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - Command_Line_Args : constant Boolean := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := False; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Fractional_Fixed_Ops : constant Boolean := False; - Frontend_Layout : constant Boolean := False; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - OpenVMS : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := True; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_64_Bit_Divides : constant Boolean := True; - Support_Aggregates : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := True; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - GCC_ZCX_Support : constant Boolean := True; - - -------------------------- - -- Underlying Priorities -- - --------------------------- - - -- Important note: this section of the file must come AFTER the - -- definition of the system implementation parameters to ensure - -- that the value of these parameters is available for analysis - -- of the declarations here (using Rtsfind at compile time). - - -- The underlying priorities table provides a generalized mechanism - -- for mapping from Ada priorities to system priorities. In some - -- cases a 1-1 mapping is not the convenient or optimal choice. - - -- For DEC Threads OpenVMS, we use the full range of 31 priorities - -- in the Ada model, but map them by compression onto the more limited - -- range of priorities available in OpenVMS. - - -- To replace the default values of the Underlying_Priorities mapping, - -- copy this source file into your build directory, edit the file to - -- reflect your desired behavior, and recompile with the command: - - -- $ gcc -c -O3 -gnatpgn system.ads - - -- then recompile the run-time parts that depend on this package: - - -- $ gnatmake -a -gnatn -O3 - - -- then force rebuilding your application if you need different options: - - -- $ gnatmake -f - - type Priorities_Mapping is array (Any_Priority) of Integer; - pragma Suppress_Initialization (Priorities_Mapping); - -- Suppress initialization in case gnat.adc specifies Normalize_Scalars - - Underlying_Priorities : constant Priorities_Mapping := - - (Priority'First => 16, - - 1 => 17, - 2 => 18, - 3 => 18, - 4 => 18, - 5 => 18, - 6 => 19, - 7 => 19, - 8 => 19, - 9 => 20, - 10 => 20, - 11 => 21, - 12 => 21, - 13 => 22, - 14 => 23, - - Default_Priority => 24, - - 16 => 25, - 17 => 25, - 18 => 25, - 19 => 26, - 20 => 26, - 21 => 26, - 22 => 27, - 23 => 27, - 24 => 27, - 25 => 28, - 26 => 28, - 27 => 29, - 28 => 29, - 29 => 30, - - Priority'Last => 30, - - Interrupt_Priority => 31); - - ---------------------------- - -- Special VMS Interfaces -- - ---------------------------- - - procedure Lib_Stop (I : Integer); - pragma Interface (C, Lib_Stop); - pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value)); - -- Interface to VMS condition handling. Used by RTSfind and pragma - -- {Import,Export}_Exception. Put here because this is the only - -- VMS specific package that doesn't drag in tasking. - -end System; diff --git a/gcc/ada/system-vms.ads b/gcc/ada/system-vms.ads deleted file mode 100644 index 4b6f1eacdad..00000000000 --- a/gcc/ada/system-vms.ads +++ /dev/null @@ -1,237 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (OpenVMS DEC Threads Version) -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package System is - pragma Pure; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - type Name is (SYSTEM_NAME_GNAT); - System_Name : constant Name := SYSTEM_NAME_GNAT; - - -- System-Dependent Named Numbers - - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; - - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; - Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; - - Max_Base_Digits : constant := Long_Long_Float'Digits; - Max_Digits : constant := Long_Long_Float'Digits; - - Max_Mantissa : constant := 63; - Fine_Delta : constant := 2.0 ** (-Max_Mantissa); - - Tick : constant := 0.01; - - -- Storage-related Declarations - - type Address is private; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := Low_Order_First; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - Max_Priority : constant Positive := 30; - Max_Interrupt_Priority : constant Positive := 31; - - subtype Any_Priority is Integer range 0 .. 31; - subtype Priority is Any_Priority range 0 .. 30; - subtype Interrupt_Priority is Any_Priority range 31 .. 31; - - Default_Priority : constant Priority := 15; - -private - - type Address is mod Memory_Size; - Null_Address : constant Address := 0; - - -------------------------------------- - -- System Implementation Parameters -- - -------------------------------------- - - -- These parameters provide information about the target that is used - -- by the compiler. They are in the private part of System, where they - -- can be accessed using the special circuitry in the Targparm unit - -- whose source should be consulted for more detailed descriptions - -- of the individual switch values. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - Command_Line_Args : constant Boolean := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := False; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Fractional_Fixed_Ops : constant Boolean := False; - Frontend_Layout : constant Boolean := False; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - OpenVMS : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := True; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_64_Bit_Divides : constant Boolean := True; - Support_Aggregates : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := True; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - GCC_ZCX_Support : constant Boolean := False; - - -------------------------- - -- Underlying Priorities -- - --------------------------- - - -- Important note: this section of the file must come AFTER the - -- definition of the system implementation parameters to ensure - -- that the value of these parameters is available for analysis - -- of the declarations here (using Rtsfind at compile time). - - -- The underlying priorities table provides a generalized mechanism - -- for mapping from Ada priorities to system priorities. In some - -- cases a 1-1 mapping is not the convenient or optimal choice. - - -- For DEC Threads OpenVMS, we use the full range of 31 priorities - -- in the Ada model, but map them by compression onto the more limited - -- range of priorities available in OpenVMS. - - -- To replace the default values of the Underlying_Priorities mapping, - -- copy this source file into your build directory, edit the file to - -- reflect your desired behavior, and recompile with the command: - - -- $ gcc -c -O3 -gnatpgn system.ads - - -- then recompile the run-time parts that depend on this package: - - -- $ gnatmake -a -gnatn -O3 - - -- then force rebuilding your application if you need different options: - - -- $ gnatmake -f - - type Priorities_Mapping is array (Any_Priority) of Integer; - pragma Suppress_Initialization (Priorities_Mapping); - -- Suppress initialization in case gnat.adc specifies Normalize_Scalars - - Underlying_Priorities : constant Priorities_Mapping := - - (Priority'First => 16, - - 1 => 17, - 2 => 18, - 3 => 18, - 4 => 18, - 5 => 18, - 6 => 19, - 7 => 19, - 8 => 19, - 9 => 20, - 10 => 20, - 11 => 21, - 12 => 21, - 13 => 22, - 14 => 23, - - Default_Priority => 24, - - 16 => 25, - 17 => 25, - 18 => 25, - 19 => 26, - 20 => 26, - 21 => 26, - 22 => 27, - 23 => 27, - 24 => 27, - 25 => 28, - 26 => 28, - 27 => 29, - 28 => 29, - 29 => 30, - - Priority'Last => 30, - - Interrupt_Priority => 31); - - ---------------------------- - -- Special VMS Interfaces -- - ---------------------------- - - procedure Lib_Stop (I : Integer); - pragma Interface (C, Lib_Stop); - pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value)); - -- Interface to VMS condition handling. Used by RTSfind and pragma - -- {Import,Export}_Exception. Put here because this is the only - -- VMS specific package that doesn't drag in tasking. - - ADA_GNAT : constant Boolean := True; - pragma Export_Object (ADA_GNAT, "ADA$GNAT"); - -- Ubiquitous global symbol identifying a GNAT compiled image to VMS Debug. - -- Do not remove! - -end System; diff --git a/gcc/ada/system-vms_64.ads b/gcc/ada/system-vms_64.ads index 17b1ab81504..2934699420a 100644 --- a/gcc/ada/system-vms_64.ads +++ b/gcc/ada/system-vms_64.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (OpenVMS 64bit GCC_ZCX DEC Threads Version) -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -239,7 +239,7 @@ private -- Special VMS Interfaces -- ---------------------------- - procedure Lib_Stop (I : Integer); + procedure Lib_Stop (Cond_Value : Integer); pragma Interface (C, Lib_Stop); pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value)); -- Interface to VMS condition handling. Used by RTSfind and pragma @@ -251,4 +251,7 @@ private -- Ubiquitous global symbol identifying a GNAT compiled image to VMS Debug. -- Do not remove! + pragma Ident ("GNAT"); -- Gnat_Static_Version_String + -- Default ident for all VMS images. + end System; diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb index 3da3c611198..ed9a7138c43 100644 --- a/gcc/ada/tbuild.adb +++ b/gcc/ada/tbuild.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -442,9 +442,9 @@ package body Tbuild is function Make_Temporary (Loc : Source_Ptr; Id : Character; - Related_Node : Node_Id := Empty) return Node_Id + Related_Node : Node_Id := Empty) return Entity_Id is - Temp : constant Node_Id := + Temp : constant Entity_Id := Make_Defining_Identifier (Loc, Chars => New_Internal_Name (Id)); begin @@ -659,7 +659,7 @@ package body Tbuild is -- We don't really need these shift operators, since they never -- appear as operators in the source, but the path of least - -- resistance is to put them in (the aggregate must be complete) + -- resistance is to put them in (the aggregate must be complete). N_Op_Rotate_Left => Name_Rotate_Left, N_Op_Rotate_Right => Name_Rotate_Right, @@ -686,7 +686,6 @@ package body Tbuild is Loc : Source_Ptr) return Node_Id is Occurrence : Node_Id; - begin Occurrence := New_Node (N_Identifier, Loc); Set_Chars (Occurrence, Chars (Def_Id)); diff --git a/gcc/ada/tbuild.ads b/gcc/ada/tbuild.ads index 0b73a53d220..da41111943b 100644 --- a/gcc/ada/tbuild.ads +++ b/gcc/ada/tbuild.ads @@ -179,11 +179,20 @@ package Tbuild is function Make_Temporary (Loc : Source_Ptr; Id : Character; - Related_Node : Node_Id := Empty) return Node_Id; - -- Create a defining identifier to capture the value of an expression - -- or aggregate, and link it to the expression that it replaces, in - -- order to provide better CodePeer reports. The defining identifier - -- name is obtained by Make_Internal_Name (Id). + Related_Node : Node_Id := Empty) return Entity_Id; + -- This function should be used for all cases where a defining identifier + -- is to be built with a name to be obtained by New_Internal_Name (here Id + -- is the character passed as the argument to New_Internal_Name). Loc is + -- the location for the Sloc value of the resulting Entity. Note that this + -- can be used for all kinds of temporary defining identifiers used in + -- expansion (objects, subtypes, functions etc). + -- + -- Related_Node is used when the defining identifier is for an object that + -- captures the value of an expression (e.g. an aggregate). It should be + -- set whenever possible to point to the expression that is being captured. + -- This is provided to get better error messages, e.g. from CodePeer. + -- + -- Make_Temp_Id would probably be a better name for this function??? function Make_Unsuppress_Block (Loc : Source_Ptr; @@ -268,6 +277,9 @@ package Tbuild is -- if the identical unit is compiled with a semantically consistent set -- of sources, the numbers will be consistent. This means that it is fine -- to use these as public symbols. + -- + -- Note: Nearly all uses of this function are via calls to Make_Temporary, + -- but there are just a few cases where it is called directly. function New_Occurrence_Of (Def_Id : Entity_Id; diff --git a/gcc/ada/tempdir.ads b/gcc/ada/tempdir.ads index a73b5a417ca..7ab1b5aff86 100644 --- a/gcc/ada/tempdir.ads +++ b/gcc/ada/tempdir.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -30,7 +30,7 @@ with Namet; use Namet; -with System.OS_Lib; use System.OS_Lib; +with GNAT.OS_Lib; use GNAT.OS_Lib; package Tempdir is diff --git a/gcc/ada/tree_io.ads b/gcc/ada/tree_io.ads index c436054176a..0cb17fed26f 100644 --- a/gcc/ada/tree_io.ads +++ b/gcc/ada/tree_io.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -34,10 +34,13 @@ -- create and close routines are elsewhere (in Osint in the compiler, and in -- the tree read driver for the tree read interface). -with Types; use Types; +with Types; use Types; +with System; use System; -with System; use System; +pragma Warnings (Off); +-- This package is used also by gnatcoll with System.OS_Lib; use System.OS_Lib; +pragma Warnings (On); package Tree_IO is diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb index c2f0770f29e..087170f69fe 100644 --- a/gcc/ada/treepr.adb +++ b/gcc/ada/treepr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -38,6 +38,7 @@ with Snames; use Snames; with Sinput; use Sinput; with Stand; use Stand; with Stringt; use Stringt; +with SCIL_LL; use SCIL_LL; with Treeprs; use Treeprs; with Uintp; use Uintp; with Urealp; use Urealp; @@ -626,6 +627,14 @@ package body Treepr is Print_Eol; end if; + if Field_Present (Field28 (Ent)) then + Print_Str (Prefix); + Write_Field28_Name (Ent); + Write_Str (" = "); + Print_Field (Field28 (Ent)); + Print_Eol; + end if; + Write_Entity_Flags (Ent, Prefix); end Print_Entity_Info; @@ -1188,6 +1197,14 @@ package body Treepr is Print_Entity_Info (N, Prefix_Str_Char); end if; + -- Print the SCIL node (if available) + + if Present (Get_SCIL_Node (N)) then + Print_Str (Prefix_Str_Char); + Print_Str ("SCIL_Node = "); + Print_Node_Ref (Get_SCIL_Node (N)); + Print_Eol; + end if; end Print_Node; --------------------- diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index cc3603aafa0..5d7784dc03b 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -59,9 +59,6 @@ package Types is type Int is range -2 ** 31 .. +2 ** 31 - 1; -- Signed 32-bit integer - type Dint is range -2 ** 63 .. +2 ** 63 - 1; - -- Double length (64-bit) integer - subtype Nat is Int range 0 .. Int'Last; -- Non-negative Int values @@ -348,16 +345,16 @@ package Types is -- lie in. Such tests appear only in the lowest level packages. subtype List_Range is Union_Id - range List_Low_Bound .. List_High_Bound; + range List_Low_Bound .. List_High_Bound; subtype Node_Range is Union_Id - range Node_Low_Bound .. Node_High_Bound; + range Node_Low_Bound .. Node_High_Bound; subtype Elist_Range is Union_Id - range Elist_Low_Bound .. Elist_High_Bound; + range Elist_Low_Bound .. Elist_High_Bound; subtype Elmt_Range is Union_Id - range Elmt_Low_Bound .. Elmt_High_Bound; + range Elmt_Low_Bound .. Elmt_High_Bound; subtype Names_Range is Union_Id range Names_Low_Bound .. Names_High_Bound; @@ -369,23 +366,23 @@ package Types is range Uint_Low_Bound .. Uint_High_Bound; subtype Ureal_Range is Union_Id - range Ureal_Low_Bound .. Ureal_High_Bound; + range Ureal_Low_Bound .. Ureal_High_Bound; - ---------------------------- + ----------------------------- -- Types for Atree Package -- - ---------------------------- + ----------------------------- -- Node_Id values are used to identify nodes in the tree. They are - -- subscripts into the Node table declared in package Tree. Note that - -- the special values Empty and Error are subscripts into this table, + -- subscripts into the Nodes table declared in package Atree. Note that + -- the special values Empty and Error are subscripts into this table. -- See package Atree for further details. type Node_Id is range Node_Low_Bound .. Node_High_Bound; -- Type used to identify nodes in the tree subtype Entity_Id is Node_Id; - -- A synonym for node types, used in the entity package to refer to nodes - -- that are entities (i.e. nodes with an Nkind of N_Defining_xxx) All such + -- A synonym for node types, used in the Einfo package to refer to nodes + -- that are entities (i.e. nodes with an Nkind of N_Defining_xxx). All such -- nodes are extended nodes and these are the only extended nodes, so that -- in practice entity and extended nodes are synonymous. @@ -402,12 +399,12 @@ package Types is Empty_List_Or_Node : constant := 0; -- This constant is used in situations (e.g. initializing empty fields) - -- where the value set will be used to represent either an empty node - -- or a non-existent list, depending on the context. + -- where the value set will be used to represent either an empty node or + -- a non-existent list, depending on the context. Error : constant Node_Id := Node_Low_Bound + 1; - -- Used to indicate that there was an error in the source program. A node - -- is actually allocated at this address, so that Nkind (Error) = N_Error. + -- Used to indicate an error in the source program. A node is actually + -- allocated with this Id value, so that Nkind (Error) = N_Error. Empty_Or_Error : constant Node_Id := Error; -- Since Empty and Error are the first two Node_Id values, the test for @@ -422,11 +419,12 @@ package Types is -- Types for Nlists Package -- ------------------------------ - -- List_Id values are used to identify node lists in the tree. They are - -- subscripts into the Lists table declared in package Tree. Note that the - -- special value Error_List is a subscript in this table, but the value - -- No_List is *not* a valid subscript, and any attempt to apply list - -- operations to No_List will cause a (detected) error. + -- List_Id values are used to identify node lists stored in the tree, so + -- that each node can be on at most one such list (see package Nlists for + -- further details). Note that the special value Error_List is a subscript + -- in this table, but the value No_List is *not* a valid subscript, and any + -- attempt to apply list operations to No_List will cause a (detected) + -- error. type List_Id is range List_Low_Bound .. List_High_Bound; -- Type used to identify a node list @@ -449,24 +447,23 @@ package Types is -- Types for Elists Package -- ------------------------------ - -- Element list Id values are used to identify element lists stored in the - -- tree (see package Atree for further details). They are formed by adding - -- a bias (Element_List_Bias) to subscript values in the same array that is - -- used for node list headers. + -- Element list Id values are used to identify element lists stored outside + -- of the tree, allowing nodes to be members of more than one such list + -- (see package Elists for further details). type Elist_Id is range Elist_Low_Bound .. Elist_High_Bound; -- Type used to identify an element list (Elist header table subscript) No_Elist : constant Elist_Id := Elist_Low_Bound; - -- Used to indicate absence of an element list. Note that this is not - -- an actual Elist header, so element list operations on this value - -- are not valid. + -- Used to indicate absence of an element list. Note that this is not an + -- actual Elist header, so element list operations on this value are not + -- valid. First_Elist_Id : constant Elist_Id := No_Elist + 1; -- Subscript of first allocated Elist header - -- Element Id values are used to identify individual elements of an - -- element list (see package Elists for further details). + -- Element Id values are used to identify individual elements of an element + -- list (see package Elists for further details). type Elmt_Id is range Elmt_Low_Bound .. Elmt_High_Bound; -- Type used to identify an element list @@ -482,11 +479,12 @@ package Types is ------------------------------- -- String_Id values are used to identify entries in the strings table. They - -- are subscripts into the strings table defined in package Strings. + -- are subscripts into the Strings table defined in package Stringt. -- Note that with only a few exceptions, which are clearly documented, the -- type String_Id should be regarded as a private type. In particular it is -- never appropriate to perform arithmetic operations using this type. + -- Doesn't this also apply to all other *_Id types??? type String_Id is range Strings_Low_Bound .. Strings_High_Bound; -- Type used to identify entries in the strings table @@ -505,10 +503,10 @@ package Types is -- The type Char is used for character data internally in the compiler, but -- character codes in the source are represented by the Char_Code type. -- Each character literal in the source is interpreted as being one of the - -- 16#8000_0000 possible Wide_Wide_Character codes, and a unique Integer - -- Value is assigned, corresponding to the UTF_32 value, which also - -- corresponds to the POS value in the Wide_Wide_Character type, and also - -- corresponds to the POS value in the Wide_Character and Character types + -- 16#7FFF_FFFF# possible Wide_Wide_Character codes, and a unique Integer + -- value is assigned, corresponding to the UTF-32 value, which also + -- corresponds to the Pos value in the Wide_Wide_Character type, and also + -- corresponds to the Pos value in the Wide_Character and Character types -- for values that are in appropriate range. String literals are similarly -- interpreted as a sequence of such codes. @@ -554,7 +552,7 @@ package Types is type Unit_Number_Type is new Int; -- Unit number. The main source is unit 0, and subsidiary sources have -- non-zero numbers starting with 1. Unit numbers are used to index the - -- file table in Lib. + -- Units table in package Lib. Main_Unit : constant Unit_Number_Type := 0; -- Unit number value for main unit @@ -730,14 +728,14 @@ package Types is -- Parameter Mechanism Control -- --------------------------------- - -- Function and parameter entities have a field that records the - -- passing mechanism. See specification of Sem_Mech for full details. - -- The following subtype is used to represent values of this type: + -- Function and parameter entities have a field that records the passing + -- mechanism. See specification of Sem_Mech for full details. The following + -- subtype is used to represent values of this type: subtype Mechanism_Type is Int range -18 .. Int'Last; - -- Type used to represent a mechanism value. This is a subtype rather - -- than a type to avoid some annoying processing problems with certain - -- routines in Einfo (processing them to create the corresponding C). + -- Type used to represent a mechanism value. This is a subtype rather than + -- a type to avoid some annoying processing problems with certain routines + -- in Einfo (processing them to create the corresponding C). ------------------------------ -- Run-Time Exception Codes -- @@ -762,12 +760,12 @@ package Types is -- 1. Modify the type and subtype declarations below appropriately, -- keeping things in alphabetical order. - -- 2. Modify the corresponding definitions in types.h, including - -- the definition of last_reason_code. + -- 2. Modify the corresponding definitions in types.h, including the + -- definition of last_reason_code. - -- 3. Add a new routine in Ada.Exceptions with the appropriate call - -- and static string constant. Note that there is more than one - -- version of a-except.adb which must be modified. + -- 3. Add a new routine in Ada.Exceptions with the appropriate call and + -- static string constant. Note that there is more than one version + -- of a-except.adb which must be modified. type RT_Exception_Code is (CE_Access_Check_Failed, -- 00 diff --git a/gcc/ada/ug_words b/gcc/ada/ug_words index 5e168d2798d..efa5356dff3 100644 --- a/gcc/ada/ug_words +++ b/gcc/ada/ug_words @@ -85,6 +85,7 @@ gcc -c ^ GNAT COMPILE -gnatN ^ /INLINE=FULL -gnato ^ /CHECKS=OVERFLOW -gnatp ^ /CHECKS=SUPPRESS_ALL +-gnat-p ^ /CHECKS=UNSUPPRESS_ALL -gnatP ^ /POLLING -gnatR ^ /REPRESENTATION_INFO -gnatR0 ^ /REPRESENTATION_INFO=NONE diff --git a/gcc/ada/uintp.adb b/gcc/ada/uintp.adb index 3b72d154c10..29ffe235aad 100644 --- a/gcc/ada/uintp.adb +++ b/gcc/ada/uintp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -168,13 +168,15 @@ package body Uintp is (Left, Right : Uint; Quotient : out Uint; Remainder : out Uint; - Discard_Quotient : Boolean; - Discard_Remainder : Boolean); - -- Compute Euclidean division of Left by Right, and return Quotient and - -- signed Remainder (Left rem Right). + Discard_Quotient : Boolean := False; + Discard_Remainder : Boolean := False); + -- Compute Euclidean division of Left by Right. If Discard_Quotient is + -- False then the quotient is returned in Quotient (otherwise Quotient is + -- set to No_Uint). If Discard_Remainder is False, then the remainder is + -- returned in Remainder (otherwise Remainder is set to No_Uint). -- - -- If Discard_Quotient is True, Quotient is left unchanged. - -- If Discard_Remainder is True, Remainder is left unchanged. + -- If Discard_Quotient is True, Quotient is set to No_Uint + -- If Discard_Remainder is True, Remainder is set to No_Uint function Vector_To_Uint (In_Vec : UI_Vector; @@ -239,7 +241,7 @@ package body Uintp is function Hash_Num (F : Int) return Hnum is begin - return Standard."mod" (F, Hnum'Range_Length); + return Types."mod" (F, Hnum'Range_Length); end Hash_Num; --------------- @@ -1253,7 +1255,6 @@ package body Uintp is UI_Div_Rem (Left, Right, Quotient, Remainder, - Discard_Quotient => False, Discard_Remainder => True); return Quotient; end UI_Div; @@ -1266,14 +1267,17 @@ package body Uintp is (Left, Right : Uint; Quotient : out Uint; Remainder : out Uint; - Discard_Quotient : Boolean; - Discard_Remainder : Boolean) + Discard_Quotient : Boolean := False; + Discard_Remainder : Boolean := False) is pragma Warnings (Off, Quotient); pragma Warnings (Off, Remainder); begin pragma Assert (Right /= Uint_0); + Quotient := No_Uint; + Remainder := No_Uint; + -- Cases where both operands are represented directly if Direct (Left) and then Direct (Right) then @@ -1345,9 +1349,11 @@ package body Uintp is if not Discard_Quotient then Quotient := Uint_0; end if; + if not Discard_Remainder then Remainder := Left; end if; + return; end if; @@ -1377,6 +1383,7 @@ package body Uintp is if not Discard_Remainder then Remainder := UI_From_Int (Remainder_I); end if; + return; end; end if; @@ -1679,43 +1686,9 @@ package body Uintp is function UI_From_CC (Input : Char_Code) return Uint is begin - return UI_From_Dint (Dint (Input)); + return UI_From_Int (Int (Input)); end UI_From_CC; - ------------------ - -- UI_From_Dint -- - ------------------ - - function UI_From_Dint (Input : Dint) return Uint is - begin - - if Dint (Min_Direct) <= Input and then Input <= Dint (Max_Direct) then - return Uint (Dint (Uint_Direct_Bias) + Input); - - -- For values of larger magnitude, compute digits into a vector and call - -- Vector_To_Uint. - - else - declare - Max_For_Dint : constant := 5; - -- Base is defined so that 5 Uint digits is sufficient to hold the - -- largest possible Dint value. - - V : UI_Vector (1 .. Max_For_Dint); - - Temp_Integer : Dint := Input; - - begin - for J in reverse V'Range loop - V (J) := Int (abs (Temp_Integer rem Dint (Base))); - Temp_Integer := Temp_Integer / Dint (Base); - end loop; - - return Vector_To_Uint (V, Input < Dint'(0)); - end; - end if; - end UI_From_Dint; - ----------------- -- UI_From_Int -- ----------------- @@ -2188,11 +2161,7 @@ package body Uintp is Y := Uint_0; loop - UI_Div_Rem - (U, V, - Quotient => Q, Remainder => R, - Discard_Quotient => False, - Discard_Remainder => False); + UI_Div_Rem (U, V, Quotient => Q, Remainder => R); U := V; V := R; @@ -2229,12 +2198,15 @@ package body Uintp is function UI_Mul (Left : Uint; Right : Uint) return Uint is begin - -- Simple case of single length operands + -- Case where product fits in the range of a 32-bit integer - if Direct (Left) and then Direct (Right) then + if Int (Left) <= Int (Uint_Max_Simple_Mul) + and then + Int (Right) <= Int (Uint_Max_Simple_Mul) + then return - UI_From_Dint - (Dint (Direct_Val (Left)) * Dint (Direct_Val (Right))); + UI_From_Int + (Int (Direct_Val (Left)) * Int (Direct_Val (Right))); end if; -- Otherwise we have the general case (Algorithm M in Knuth) @@ -2557,9 +2529,7 @@ package body Uintp is pragma Warnings (Off, Quotient); begin UI_Div_Rem - (Left, Right, Quotient, Remainder, - Discard_Quotient => True, - Discard_Remainder => False); + (Left, Right, Quotient, Remainder, Discard_Quotient => True); return Remainder; end; end UI_Rem; diff --git a/gcc/ada/uintp.ads b/gcc/ada/uintp.ads index 492498d6cf2..d222c52c12f 100644 --- a/gcc/ada/uintp.ads +++ b/gcc/ada/uintp.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -233,9 +233,6 @@ package Uintp is -- given Modulo (uses Euclid's algorithm). Note: the call is considered -- to be erroneous (and the behavior is undefined) if n is not invertible. - function UI_From_Dint (Input : Dint) return Uint; - -- Converts Dint value to universal integer form - function UI_From_Int (Input : Int) return Uint; -- Converts Int value to universal integer form @@ -404,7 +401,8 @@ private -- Base is defined to allow efficient execution of the primitive operations -- (a0, b0, c0) defined in the section "The Classical Algorithms" -- (sec. 4.3.1) of Donald Knuth's "The Art of Computer Programming", - -- Vol. 2. These algorithms are used in this package. + -- Vol. 2. These algorithms are used in this package. In particular, + -- the product of two single digits in this base fits in a 32-bit integer. Base_Bits : constant := 15; -- Number of bits in base value @@ -470,6 +468,11 @@ private Uint_Minus_80 : constant Uint := Uint (Uint_Direct_Bias - 80); Uint_Minus_128 : constant Uint := Uint (Uint_Direct_Bias - 128); + Uint_Max_Simple_Mul : constant := Uint_Direct_Bias + 2 ** 15; + -- If two values are directly represented and less than or equal to this + -- value, then we know the product fits in a 32-bit integer. This allows + -- UI_Mul to efficiently compute the product in this case. + type Save_Mark is record Save_Uint : Uint; Save_Udigit : Int; diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index 1840ade33b7..2121b7f20e4 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -397,47 +397,46 @@ begin Write_Switch_Char ("wxx"); Write_Line ("Enable selected warning modes, xx = list of parameters:"); - Write_Line (" a turn on all optional info/warnings " & - "(except dhl.ot.w)"); + Write_Line (" a turn on all info/warnings marked below with +"); Write_Line (" A turn off all optional info/warnings"); - Write_Line (" .a* turn on warnings for failing assertion"); + Write_Line (" .a*+ turn on warnings for failing assertion"); Write_Line (" .A turn off warnings for failing assertion"); - Write_Line (" b turn on warnings for bad fixed value " & + Write_Line (" b+ turn on warnings for bad fixed value " & "(not multiple of small)"); Write_Line (" B* turn off warnings for bad fixed value " & "(not multiple of small)"); - Write_Line (" .b* turn on warnings for biased representation"); + Write_Line (" .b*+ turn on warnings for biased representation"); Write_Line (" .B turn off warnings for biased representation"); - Write_Line (" c turn on warnings for constant conditional"); + Write_Line (" c+ turn on warnings for constant conditional"); Write_Line (" C* turn off warnings for constant conditional"); - Write_Line (" .c turn on warnings for unrepped components"); + Write_Line (" .c+ turn on warnings for unrepped components"); Write_Line (" .C* turn off warnings for unrepped components"); Write_Line (" d turn on warnings for implicit dereference"); Write_Line (" D* turn off warnings for implicit dereference"); Write_Line (" e treat all warnings (but not info) as errors"); Write_Line (" .e turn on every optional info/warning " & "(no exceptions)"); - Write_Line (" f turn on warnings for unreferenced formal"); + Write_Line (" f+ turn on warnings for unreferenced formal"); Write_Line (" F* turn off warnings for unreferenced formal"); - Write_Line (" g* turn on warnings for unrecognized pragma"); + Write_Line (" g*+ turn on warnings for unrecognized pragma"); Write_Line (" G turn off warnings for unrecognized pragma"); Write_Line (" h turn on warnings for hiding variable"); Write_Line (" H* turn off warnings for hiding variable"); - Write_Line (" i* turn on warnings for implementation unit"); + Write_Line (" i*+ turn on warnings for implementation unit"); Write_Line (" I turn off warnings for implementation unit"); Write_Line (" .i turn on warnings for overlapping actuals"); Write_Line (" .I* turn off warnings for overlapping actuals"); - Write_Line (" j turn on warnings for obsolescent " & + Write_Line (" j+ turn on warnings for obsolescent " & "(annex J) feature"); Write_Line (" J* turn off warnings for obsolescent " & "(annex J) feature"); - Write_Line (" k turn on warnings on constant variable"); + Write_Line (" k+ turn on warnings on constant variable"); Write_Line (" K* turn off warnings on constant variable"); Write_Line (" l turn on warnings for missing " & "elaboration pragma"); Write_Line (" L* turn off warnings for missing " & "elaboration pragma"); - Write_Line (" m turn on warnings for variable assigned " & + Write_Line (" m+ turn on warnings for variable assigned " & "but not read"); Write_Line (" M* turn off warnings for variable assigned " & "but not read"); @@ -450,47 +449,48 @@ begin "but not read"); Write_Line (" .O* turn off warnings for out parameters assigned " & "but not read"); - Write_Line (" p turn on warnings for ineffective pragma " & + Write_Line (" p+ turn on warnings for ineffective pragma " & "Inline in frontend"); Write_Line (" P* turn off warnings for ineffective pragma " & "Inline in frontend"); - Write_Line (" .p turn on warnings for suspicious parameter " & + Write_Line (" .p+ turn on warnings for suspicious parameter " & "order"); Write_Line (" .P* turn off warnings for suspicious parameter " & "order"); - Write_Line (" q* turn on warnings for questionable " & + Write_Line (" q*+ turn on warnings for questionable " & "missing parenthesis"); Write_Line (" Q turn off warnings for questionable " & "missing parenthesis"); - Write_Line (" r turn on warnings for redundant construct"); + Write_Line (" r+ turn on warnings for redundant construct"); Write_Line (" R* turn off warnings for redundant construct"); - Write_Line (" .r turn on warnings for object renaming function"); + Write_Line (" .r+ turn on warnings for object renaming function"); Write_Line (" .R* turn off warnings for object renaming function"); Write_Line (" s suppress all info/warnings"); Write_Line (" t turn on warnings for tracking deleted code"); Write_Line (" T* turn off warnings for tracking deleted code"); - Write_Line (" u turn on warnings for unused entity"); + Write_Line (" u+ turn on warnings for unused entity"); Write_Line (" U* turn off warnings for unused entity"); - Write_Line (" v* turn on warnings for unassigned variable"); + Write_Line (" v*+ turn on warnings for unassigned variable"); Write_Line (" V turn off warnings for unassigned variable"); - Write_Line (" .v* turn on info messages for reverse bit order"); + Write_Line (" .v*+ turn on info messages for reverse bit order"); Write_Line (" .V turn off info messages for reverse bit order"); - Write_Line (" w* turn on warnings for wrong low bound assumption"); + Write_Line (" w*+ turn on warnings for wrong low bound assumption"); Write_Line (" W turn off warnings for wrong low bound " & "assumption"); Write_Line (" .w turn on warnings on pragma Warnings Off"); Write_Line (" .W* turn off warnings on pragma Warnings Off"); - Write_Line (" x* turn on warnings for export/import"); + Write_Line (" x*+ turn on warnings for export/import"); Write_Line (" X turn off warnings for export/import"); - Write_Line (" .x turn on warnings for non-local exception"); + Write_Line (" .x+ turn on warnings for non-local exception"); Write_Line (" .X* turn off warnings for non-local exception"); - Write_Line (" y* turn on warnings for Ada 2005 incompatibility"); + Write_Line (" y*+ turn on warnings for Ada 2005 incompatibility"); Write_Line (" Y turn off warnings for Ada 2005 incompatibility"); - Write_Line (" z* turn on warnings for suspicious " & + Write_Line (" z*+ turn on warnings for suspicious " & "unchecked conversion"); Write_Line (" Z turn off warnings for suspicious " & "unchecked conversion"); Write_Line (" * indicates default in above list"); + Write_Line (" + indicates warning flag included in -gnatwa"); -- Line for -gnatW switch @@ -595,7 +595,22 @@ begin if Ada_Version_Default = Ada_05 then Write_Line ("Ada 2005 mode (default)"); else - Write_Line ("Allow Ada 2005 extensions"); + Write_Line ("Enforce Ada 2005 restrictions"); end if; + -- Line for -gnat12 switch + + Write_Switch_Char ("12"); + + if Ada_Version_Default = Ada_12 then + Write_Line ("Ada 2012 mode (default)"); + else + Write_Line ("Allow Ada 2012 extensions"); + end if; + + -- Line for -gnat-p switch + + Write_Switch_Char ("-p"); + Write_Line ("Cancel effect of previous -gnatp switch"); + end Usage; diff --git a/gcc/ada/vms_conv.adb b/gcc/ada/vms_conv.adb index 0772a494f12..e9aba4906eb 100644 --- a/gcc/ada/vms_conv.adb +++ b/gcc/ada/vms_conv.adb @@ -2274,9 +2274,15 @@ package body VMS_Conv is New_Line; while Commands /= null loop - Put (Commands.Usage.all); - Set_Col (53); - Put_Line (Commands.Unix_String.all); + + -- No usage for GNAT SYNC + + if Commands.Command /= Sync then + Put (Commands.Usage.all); + Set_Col (53); + Put_Line (Commands.Unix_String.all); + end if; + Commands := Commands.Next; end loop; diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads index 6f4ae0f65f0..8454041abb1 100644 --- a/gcc/ada/vms_data.ads +++ b/gcc/ada/vms_data.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1996-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -196,6 +196,14 @@ package VMS_Data is -- -- Add directories to the project search path. + S_Bind_ALI : aliased constant S := "/ALI_LIST " & + "-A"; + -- /NOALI_LIST (D) + -- /ALI_LIST + -- + -- Output full names of all the ALI files in the partition. The output is + -- written to SYS$OUTPUT. + S_Bind_Bind : aliased constant S := "/BIND_FILE=" & "ADA " & "-A " & @@ -385,7 +393,7 @@ package VMS_Data is -- /NOOBJECT_LIST (D) -- /OBJECT_LIST -- - -- Output full names of all the object files that must be linker to + -- Output full names of all the object files that must be linked to -- provide the Ada component of the program. The output is written to -- SYS$OUTPUT. @@ -669,6 +677,7 @@ package VMS_Data is Bind_Switches : aliased constant Switches := (S_Bind_Add 'Access, + S_Bind_ALI 'Access, S_Bind_Bind 'Access, S_Bind_Build 'Access, S_Bind_Current 'Access, @@ -834,37 +843,6 @@ package VMS_Data is -- -- Duplicate all the output sent to Stderr into a log file. - S_Check_Sections : aliased constant S := "/SECTIONS=" & - "DEFAULT " & - "-s123 " & - "COMPILER_STYLE " & - "-s1 " & - "BY_RULES " & - "-s2 " & - "BY_FILES_BY_RULES " & - "-s3"; - -- /SECTIONS[=section-option, section-option, ...] - -- - -- Specify what sections should be included into the report file. - -- By default, all three section (diagnoses in the format corresponding - -- to compiler error and warning messages, diagnoses grouped by rules and - -- then - by files, diagnoses grouped by files and then - by rules) are - -- included in the report file. - -- - -- section-option may be one of the following: - -- - -- COMPILER_STYLE Include diagnostics in compile-style format - -- (diagnoses are grouped by files, for each file - -- they are ordered according to the references - -- into the source) - -- BY_RULES Include diagnostics grouped first by rules and - -- then by files - -- BY_FILES_BY_RULES Include diagnostics grouped first by files and - -- then by rules - -- - -- If one of these options is specified, then the report file contains - -- only sections set by these options - S_Check_Short : aliased constant S := "/SHORT " & "-s"; -- /NOSHORT (D) @@ -872,6 +850,14 @@ package VMS_Data is -- -- Generate a short form of the report file. + S_Check_Include : aliased constant S := "/INCLUDE_FILE=@" & + "--include-file=@"; + + -- /INCLUDE_FILE=filename + -- + -- Add the content of the specified text file to the generated report + -- file. + S_Check_Subdirs : aliased constant S := "/SUBDIRS=<" & "--subdirs=>"; -- /SUBDIRS=dir @@ -896,24 +882,24 @@ package VMS_Data is -- Specify the name of the output file. Check_Switches : aliased constant Switches := - (S_Check_Add 'Access, - S_Check_All 'Access, - S_Diagnosis 'Access, - S_Check_Ext 'Access, - S_Check_Files 'Access, - S_Check_Follow 'Access, - S_Check_Help 'Access, - S_Check_Locs 'Access, - S_Check_Mess 'Access, - S_Check_Project 'Access, - S_Check_Quiet 'Access, - S_Check_Time 'Access, - S_Check_Log 'Access, - S_Check_Sections 'Access, - S_Check_Short 'Access, - S_Check_Subdirs 'Access, - S_Check_Verb 'Access, - S_Check_Out 'Access); + (S_Check_Add 'Access, + S_Check_All 'Access, + S_Diagnosis 'Access, + S_Check_Ext 'Access, + S_Check_Files 'Access, + S_Check_Follow 'Access, + S_Check_Help 'Access, + S_Check_Locs 'Access, + S_Check_Mess 'Access, + S_Check_Project'Access, + S_Check_Quiet 'Access, + S_Check_Time 'Access, + S_Check_Log 'Access, + S_Check_Short 'Access, + S_Check_Include'Access, + S_Check_Subdirs'Access, + S_Check_Verb 'Access, + S_Check_Out 'Access); ---------------------------- -- Switches for GNAT CHOP -- @@ -1168,6 +1154,13 @@ package VMS_Data is -- of the directory specified in the project file. If the subdirectory -- does not exist, it is created automatically. + S_Clean_USL : aliased constant S := "/UNCHECKED_SHARED_LIB_IMPORTS " & + "--unchecked-shared-lib-imports"; + -- /NOUNCHECKED_SHARED_LIB_IMPORTS (D) + -- /UNCHECKED_SHARED_LIB_IMPORTS + -- + -- Allow shared library projects to import static library projects + S_Clean_Verbose : aliased constant S := "/VERBOSE " & "-v"; -- /NOVERBOSE (D) @@ -1193,7 +1186,8 @@ package VMS_Data is S_Clean_Recurs 'Access, S_Clean_Search 'Access, S_Clean_Subdirs'Access, - S_Clean_Verbose'Access); + S_Clean_Verbose'Access, + S_Clean_USL 'Access); ------------------------------- -- Switches for GNAT COMPILE -- @@ -1233,7 +1227,13 @@ package VMS_Data is "-gnat05"; -- /05 (D) -- - -- Allows GNAT to recognize all implemented proposed Ada 2005 + -- Allows GNAT to recognize the full range of Ada 2005 constructs. + + S_GCC_Ada_12 : aliased constant S := "/12 " & + "-gnat12"; + -- /05 (D) + -- + -- Allows GNAT to recognize all implemented proposed Ada 2012 -- extensions. See features file for list of implemented features. S_GCC_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & @@ -1276,7 +1276,9 @@ package VMS_Data is "STACK " & "-fstack-check " & "SUPPRESS_ALL " & - "-gnatp"; + "-gnatp " & + "UNSUPPRESS_ALL " & + "-gnat-p"; -- /NOCHECKS -- /CHECKS[=(keyword[,...])] -- @@ -1290,47 +1292,50 @@ package VMS_Data is -- You may specify one or more of the following keywords to the /CHECKS -- qualifier to modify this behavior: -- - -- DEFAULT The behavior described above. This is the default - -- if the /CHECKS qualifier is not present on the - -- command line. Same as /NOCHECKS. - -- - -- OVERFLOW Enables overflow checking for integer operations and - -- checks for access before elaboration on subprogram - -- calls. This causes GNAT to generate slower and larger - -- executable programs by adding code to check for both - -- overflow and division by zero (resulting in raising - -- "Constraint_Error" as required by Ada semantics). - -- Similarly, GNAT does not generate elaboration check - -- by default, and you must specify this keyword to - -- enable them. - -- - -- Note that this keyword does not affect the code - -- generated for any floating-point operations; it - -- applies only to integer operations. For floating-point, - -- GNAT has the "Machine_Overflows" attribute set to - -- "False" and the normal mode of operation is to generate - -- IEEE NaN and infinite values on overflow or invalid - -- operations (such as dividing 0.0 by 0.0). - -- - -- ELABORATION Enables dynamic checks for access-before-elaboration - -- on subprogram calls and generic instantiations. - -- - -- ASSERTIONS The pragmas "Assert" and "Debug" normally have no - -- effect and are ignored. This keyword causes "Assert" - -- and "Debug" pragmas to be activated, as well as - -- "Check", "Precondition" and "Postcondition" pragmas. - -- - -- SUPPRESS_ALL Suppress all runtime checks as though you have "pragma - -- Suppress (all_checks)" in your source. Use this switch - -- to improve the performance of the code at the expense - -- of safety in the presence of invalid data or program - -- bugs. - -- - -- DEFAULT Suppress the effect of any option OVERFLOW or - -- ASSERTIONS. - -- - -- FULL (D) Similar to OVERFLOW, but suppress the effect of any - -- option ELABORATION or SUPPRESS_ALL. + -- DEFAULT The behavior described above. This is the default + -- if the /CHECKS qualifier is not present on the + -- command line. Same as /NOCHECKS. + -- + -- OVERFLOW Enables overflow checking for integer operations and + -- checks for access before elaboration on subprogram + -- calls. This causes GNAT to generate slower and larger + -- executable programs by adding code to check for both + -- overflow and division by zero (resulting in raising + -- "Constraint_Error" as required by Ada semantics). + -- Similarly, GNAT does not generate elaboration check + -- by default, and you must specify this keyword to + -- enable them. + -- + -- Note that this keyword does not affect the code + -- generated for any floating-point operations; it + -- applies only to integer operations. For the case of + -- floating-point, GNAT has the "Machine_Overflows" + -- attribute set to "False" and the normal mode of + -- operation is to generate IEEE NaN and infinite values + -- on overflow or invalid operations (such as dividing + -- 0.0 by 0.0). + -- + -- ELABORATION Enables dynamic checks for access-before-elaboration + -- on subprogram calls and generic instantiations. + -- + -- ASSERTIONS The pragmas "Assert" and "Debug" normally have no + -- effect and are ignored. This keyword causes "Assert" + -- and "Debug" pragmas to be activated, as well as + -- "Check", "Precondition" and "Postcondition" pragmas. + -- + -- SUPPRESS_ALL Suppress all runtime checks as though you have + -- "pragma Suppress (all_checks)" in your source. Use + -- this switch to improve the performance of the code at + -- the expense of safety in the presence of invalid data + -- or program bugs. + -- + -- UNSUPPRESS_ALL Cancels effect of previous SUPPRESS_ALL. + -- + -- DEFAULT Suppress the effect of any option OVERFLOW or + -- ASSERTIONS. + -- + -- FULL (D) Similar to OVERFLOW, but suppress the effect of any + -- option ELABORATION or SUPPRESS_ALL. -- -- These keywords only control the default setting of the checks. You -- may modify them using either "Suppress" (to remove checks) or @@ -3615,6 +3620,13 @@ package VMS_Data is -- HIGH A great number of messages are output, most of them not -- being useful for the user. + S_Elim_Nodisp : aliased constant S := "/NO_DISPATCH " & + "--no-elim-dispatch"; + -- /NONO_DISPATCH (D) + -- /NO_DISPATCH + -- + -- Do not generate pragmas for dispatching operations. + S_Elim_Project : aliased constant S := "/PROJECT_FILE=<" & "-P>"; -- /PROJECT_FILE=filename @@ -3624,7 +3636,7 @@ package VMS_Data is -- gnatelim. The source directories to be searched will be communicated -- to gnatelim through logical name ADA_PRJ_INCLUDE_FILE. - S_Elim_Quiet : aliased constant S := "/QUIET " & + S_Elim_Quiet : aliased constant S := "/QUIET " & "-q"; -- /NOQUIET (D) -- /QUIET @@ -3633,6 +3645,48 @@ package VMS_Data is -- the number of program units left to be processed. This option turns -- this trace off. + S_Elim_Files : aliased constant S := "/FILES=@" & + "-files=@"; + + -- /FILES=filename + -- + -- Take as arguments the files that are listed in the specified + -- text file. + + S_Elim_Log : aliased constant S := "/LOG " & + "-l"; + -- /NOLOG (D) + -- /LOG + -- + -- Duplicate all the output sent to Stderr into a default log file. + + S_Elim_Logfile : aliased constant S := "/LOGFILE=@" & + "-l@"; + + -- /LOGFILE=logfilename + -- + -- Duplicate all the output sent to Stderr into a specified log file. + + S_Elim_Main : aliased constant S := "/MAIN=@" & + "-main=@"; + + -- /MAIN=filename + -- + -- Specify the main subprogram of the partition to analyse. + + S_Elim_Out : aliased constant S := "/OUTPUT=@" & + "-o@"; + -- /OUTPUT=filename + -- + -- Specify the name of the output file. + + S_Elim_Time : aliased constant S := "/TIME " & + "-t"; + -- /NOTIME (D) + -- /TIME + -- + -- Print out execution time + S_Elim_Search : aliased constant S := "/SEARCH=*" & "-I*"; -- /SEARCH=(directory, ...) @@ -3657,6 +3711,19 @@ package VMS_Data is -- program units left, GNAT ELIM will output the name of the current unit -- being processed. + S_Elim_Warn : aliased constant S := "/WARNINGS=" & + "NORMAL " & + "-wn " & + "QUIET " & + "-ws"; + + -- /WARNINGS[=(keyword[,...])] + -- + -- The following keywords are supported: + -- + -- NORMAL (D) Print warning all the messages. + -- QUIET Some warning messages are suppressed + Elim_Switches : aliased constant Switches := (S_Elim_Add 'Access, S_Elim_All 'Access, @@ -3665,14 +3732,22 @@ package VMS_Data is S_Elim_Config 'Access, S_Elim_Current 'Access, S_Elim_Ext 'Access, + S_Elim_Files 'Access, S_Elim_Follow 'Access, S_Elim_GNATMAKE'Access, + S_Elim_Log 'Access, + S_Elim_Logfile 'Access, + S_Elim_Main 'Access, S_Elim_Mess 'Access, + S_Elim_Nodisp 'Access, + S_Elim_Out 'Access, S_Elim_Project 'Access, S_Elim_Quiet 'Access, S_Elim_Search 'Access, S_Elim_Subdirs 'Access, - S_Elim_Verb 'Access); + S_Elim_Time 'Access, + S_Elim_Verb 'Access, + S_Elim_Warn 'Access); ---------------------------- -- Switches for GNAT FIND -- @@ -4799,6 +4874,13 @@ package VMS_Data is -- For example, -O -O2 is different than -O2 -O, but -g -O is equivalent -- to -O -g. + S_Make_USL : aliased constant S := "/UNCHECKED_SHARED_LIB_IMPORTS " & + "--unchecked-shared-lib-imports"; + -- /NOUNCHECKED_SHARED_LIB_IMPORTS (D) + -- /UNCHECKED_SHARED_LIB_IMPORTS + -- + -- Allow shared library projects to import static library projects + S_Make_Unique : aliased constant S := "/UNIQUE " & "-u"; -- /NOUNIQUE (D) @@ -4876,6 +4958,7 @@ package VMS_Data is S_Make_Stand 'Access, S_Make_Subdirs 'Access, S_Make_Switch 'Access, + S_Make_USL 'Access, S_Make_Unique 'Access, S_Make_Use_Map 'Access, S_Make_Verbose 'Access); diff --git a/gcc/ada/xr_tabls.adb b/gcc/ada/xr_tabls.adb index 95bdfa985d8..b75da1f8423 100644 --- a/gcc/ada/xr_tabls.adb +++ b/gcc/ada/xr_tabls.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -395,7 +395,7 @@ package body Xr_Tabls is begin case Ref_Type is - when 'b' | 'c' | 'm' | 'r' | 'R' | 'i' | ' ' | 'x' => + when 'b' | 'c' | 'H' | 'm' | 'o' | 'r' | 'R' | 'i' | ' ' | 'x' => null; when 'l' | 'w' => @@ -419,7 +419,12 @@ package body Xr_Tabls is (Symbol_Length => 0, Symbol => "", Key => new String'(Key), - Decl => null, + Decl => new Reference_Record' + (File => File_Ref, + Line => Line, + Column => Column, + Source_Line => null, + Next => null), Is_Parameter => True, Decl_Type => ' ', Body_Ref => null, @@ -458,7 +463,7 @@ package body Xr_Tabls is New_Ref.Next := Declaration.Body_Ref; Declaration.Body_Ref := New_Ref; - when 'r' | 'R' | 'i' | 'l' | ' ' | 'x' | 'w' => + when 'r' | 'R' | 'H' | 'i' | 'l' | 'o' | ' ' | 'x' | 'w' => New_Ref.Next := Declaration.Ref_Ref; Declaration.Ref_Ref := New_Ref; diff --git a/gcc/ada/xref_lib.adb b/gcc/ada/xref_lib.adb index f4d0fc29a36..ed213569e92 100644 --- a/gcc/ada/xref_lib.adb +++ b/gcc/ada/xref_lib.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -231,7 +231,7 @@ package body Xref_Lib is Line_Start := Index (Entity (File_Start .. Entity'Last), ":"); - -- Check if it was a disk:\directory item (for NT and OS/2) + -- Check if it was a disk:\directory item (for Windows) if File_Start = Line_Start - 1 and then Line_Start < Entity'Last @@ -508,6 +508,7 @@ package body Xref_Lib is when 'D' => return "decimal type"; when 'E' => return "enumeration type"; when 'F' => return "float type"; + when 'H' => return "abstract type"; when 'I' => return "integer type"; when 'M' => return "modular type"; when 'O' => return "fixed type"; @@ -523,7 +524,6 @@ package body Xref_Lib is when 'd' => return Param_String & "decimal object"; when 'e' => return Param_String & "enumeration object"; when 'f' => return Param_String & "float object"; - when 'h' => return "interface"; when 'i' => return Param_String & "integer object"; when 'm' => return Param_String & "modular object"; when 'o' => return Param_String & "fixed object"; @@ -535,6 +535,8 @@ package body Xref_Lib is when 'x' => return Param_String & "abstract procedure"; when 'y' => return Param_String & "abstract function"; + when 'h' => return "interface"; + when 'g' => return "macro"; when 'K' => return "package"; when 'k' => return "generic package"; when 'L' => return "statement label"; @@ -542,6 +544,7 @@ package body Xref_Lib is when 'N' => return "named number"; when 'n' => return "enumeration literal"; when 'q' => return "block label"; + when 'Q' => return "include file"; when 'U' => return "procedure"; when 'u' => return "generic procedure"; when 'V' => return "function"; @@ -557,7 +560,11 @@ package body Xref_Lib is -- have an unknown Abbrev value when others => - return "??? (" & Get_Type (Decl) & ")"; + if Is_Parameter (Decl) then + return "parameter"; + else + return "??? (" & Get_Type (Decl) & ")"; + end if; end case; end Get_Full_Type; @@ -1587,8 +1594,13 @@ package body Xref_Lib is File := Get_File_Ref (Arr (R)); F := Osint.To_Host_File_Spec (Get_Gnatchop_File (Arr (R), Full_Path_Name)); - Write_Str (F.all & ' '); - Free (F); + + if F = null then + Write_Str (" "); + else + Write_Str (F.all & ' '); + Free (F); + end if; end if; Print_Ref (Get_Line (Arr (R)), Get_Column (Arr (R))); @@ -1637,8 +1649,14 @@ package body Xref_Lib is Write_Str (" Decl: "); F := Osint.To_Host_File_Spec (Get_Gnatchop_File (Decl, Full_Path_Name)); - Print80 (F.all & ' '); - Free (F); + + if F = null then + Print80 (" "); + else + Print80 (F.all & ' '); + Free (F); + end if; + Print_Ref (Get_Line (Decl), Get_Column (Decl)); Print_List diff --git a/gcc/alias.c b/gcc/alias.c index a4083a1a13b..30717127be2 100644 --- a/gcc/alias.c +++ b/gcc/alias.c @@ -279,7 +279,8 @@ ao_ref_from_mem (ao_ref *ref, const_rtx mem) /* If this is a pointer dereference of a non-SSA_NAME punt. ??? We could replace it with a pointer to anything. */ - if (INDIRECT_REF_P (base) + if ((INDIRECT_REF_P (base) + || TREE_CODE (base) == MEM_REF) && TREE_CODE (TREE_OPERAND (base, 0)) != SSA_NAME) return false; @@ -293,10 +294,7 @@ ao_ref_from_mem (ao_ref *ref, const_rtx mem) void *namep; namep = pointer_map_contains (cfun->gimple_df->decls_to_pointers, base); if (namep) - { - ref->base_alias_set = get_alias_set (base); - ref->base = build1 (INDIRECT_REF, TREE_TYPE (base), *(tree *)namep); - } + ref->base = build_simple_mem_ref (*(tree *)namep); } ref->ref_alias_set = MEM_ALIAS_SET (mem); @@ -648,8 +646,8 @@ get_alias_set (tree t) { tree inner; - /* Remove any nops, then give the language a chance to do - something with this tree before we look at it. */ + /* Give the language a chance to do something with this tree + before we look at it. */ STRIP_NOPS (t); set = lang_hooks.get_alias_set (t); if (set != -1) @@ -659,21 +657,41 @@ get_alias_set (tree t) if (TREE_CODE (t) == TARGET_MEM_REF) t = TMR_ORIGINAL (t); - /* First see if the actual object referenced is an INDIRECT_REF from a - restrict-qualified pointer or a "void *". */ + /* Get the base object of the reference. */ inner = t; while (handled_component_p (inner)) { + /* If there is a VIEW_CONVERT_EXPR in the chain we cannot use + the type of any component references that wrap it to + determine the alias-set. */ + if (TREE_CODE (inner) == VIEW_CONVERT_EXPR) + t = TREE_OPERAND (inner, 0); inner = TREE_OPERAND (inner, 0); - STRIP_NOPS (inner); } + /* Handle pointer dereferences here, they can override the + alias-set. */ if (INDIRECT_REF_P (inner)) { set = get_deref_alias_set_1 (TREE_OPERAND (inner, 0)); if (set != -1) return set; } + else if (TREE_CODE (inner) == MEM_REF) + { + set = get_deref_alias_set_1 (TREE_OPERAND (inner, 1)); + if (set != -1) + return set; + } + + /* If the innermost reference is a MEM_REF that has a + conversion embedded treat it like a VIEW_CONVERT_EXPR above, + using the memory access type for determining the alias-set. */ + if (TREE_CODE (inner) == MEM_REF + && (TYPE_MAIN_VARIANT (TREE_TYPE (inner)) + != TYPE_MAIN_VARIANT + (TREE_TYPE (TREE_TYPE (TREE_OPERAND (inner, 1)))))) + return get_deref_alias_set (TREE_OPERAND (inner, 1)); /* Otherwise, pick up the outermost object that we could have a pointer to, processing conversions as above. */ @@ -713,7 +731,7 @@ get_alias_set (tree t) t = TYPE_CANONICAL (t); /* Canonical types shouldn't form a tree nor should the canonical type require structural equality checks. */ - gcc_assert (!TYPE_STRUCTURAL_EQUALITY_P (t) && TYPE_CANONICAL (t) == t); + gcc_checking_assert (!TYPE_STRUCTURAL_EQUALITY_P (t) && TYPE_CANONICAL (t) == t); /* If this is a type with a known alias set, return it. */ if (TYPE_ALIAS_SET_KNOWN_P (t)) @@ -823,10 +841,12 @@ record_alias_subset (alias_set_type superset, alias_set_type subset) { /* Create an entry for the SUPERSET, so that we have a place to attach the SUBSET. */ - superset_entry = GGC_NEW (struct alias_set_entry_d); + superset_entry = ggc_alloc_cleared_alias_set_entry_d (); superset_entry->alias_set = superset; superset_entry->children - = splay_tree_new_ggc (splay_tree_compare_ints); + = splay_tree_new_ggc (splay_tree_compare_ints, + ggc_alloc_splay_tree_scalar_scalar_splay_tree_s, + ggc_alloc_splay_tree_scalar_scalar_splay_tree_node_s); superset_entry->has_zero_child = 0; VEC_replace (alias_set_entry, alias_sets, superset, superset_entry); } @@ -1134,7 +1154,7 @@ record_set (rtx dest, const_rtx set, void *data ATTRIBUTE_UNUSED) regno = REGNO (dest); - gcc_assert (regno < VEC_length (rtx, reg_base_value)); + gcc_checking_assert (regno < VEC_length (rtx, reg_base_value)); /* If this spans multiple hard registers, then we must indicate that every register has an unusable value. */ @@ -2639,7 +2659,7 @@ init_alias_analysis (void) timevar_push (TV_ALIAS_ANALYSIS); reg_known_value_size = maxreg - FIRST_PSEUDO_REGISTER; - reg_known_value = GGC_CNEWVEC (rtx, reg_known_value_size); + reg_known_value = ggc_alloc_cleared_vec_rtx (reg_known_value_size); reg_known_equiv_p = XCNEWVEC (bool, reg_known_value_size); /* If we have memory allocated from the previous run, use it. */ diff --git a/gcc/alloc-pool.c b/gcc/alloc-pool.c index 6eecef53ee2..ade1753c046 100644 --- a/gcc/alloc-pool.c +++ b/gcc/alloc-pool.c @@ -137,7 +137,7 @@ create_alloc_pool (const char *name, size_t size, size_t num) struct alloc_pool_descriptor *desc; #endif - gcc_assert (name); + gcc_checking_assert (name); /* Make size large enough to store the list header. */ if (size < sizeof (alloc_pool_list)) @@ -152,7 +152,7 @@ create_alloc_pool (const char *name, size_t size, size_t num) #endif /* Um, we can't really allocate 0 elements per block. */ - gcc_assert (num); + gcc_checking_assert (num); /* Allocate memory for the pool structure. */ pool = XNEW (struct alloc_pool_def); @@ -201,7 +201,7 @@ empty_alloc_pool (alloc_pool pool) struct alloc_pool_descriptor *desc = alloc_pool_descriptor (pool->name); #endif - gcc_assert (pool); + gcc_checking_assert (pool); /* Free each block allocated to the pool. */ for (block = pool->block_list; block != NULL; block = next_block) @@ -260,7 +260,7 @@ pool_alloc (alloc_pool pool) desc->peak = desc->current; #endif - gcc_assert (pool); + gcc_checking_assert (pool); /* If there are no more free elements, make some more!. */ if (!pool->returned_free_list) @@ -328,19 +328,19 @@ pool_free (alloc_pool pool, void *ptr) struct alloc_pool_descriptor *desc = alloc_pool_descriptor (pool->name); #endif - gcc_assert (ptr); #ifdef ENABLE_CHECKING - /* Check whether the PTR was allocated from POOL. */ - gcc_assert (pool->id == ALLOCATION_OBJECT_PTR_FROM_USER_PTR (ptr)->id); + gcc_assert (ptr + /* Check if we free more than we allocated, which is Bad (TM). */ + && pool->elts_free < pool->elts_allocated + /* Check whether the PTR was allocated from POOL. */ + && pool->id == ALLOCATION_OBJECT_PTR_FROM_USER_PTR (ptr)->id); memset (ptr, 0xaf, pool->elt_size - offsetof (allocation_object, u.data)); /* Mark the element to be free. */ ALLOCATION_OBJECT_PTR_FROM_USER_PTR (ptr)->id = 0; #else - /* Check if we free more than we allocated, which is Bad (TM). */ - gcc_assert (pool->elts_free < pool->elts_allocated); #endif header = (alloc_pool_list) ptr; diff --git a/gcc/auto-inc-dec.c b/gcc/auto-inc-dec.c index 6b5c3adecbf..94dffc95eb2 100644 --- a/gcc/auto-inc-dec.c +++ b/gcc/auto-inc-dec.c @@ -1068,6 +1068,13 @@ find_inc (bool first_try) /* For the post_add to work, the result_reg of the inc must not be used in the mem insn since this will become the new index register. */ + if (count_occurrences (PATTERN (mem_insn.insn), inc_insn.reg_res, 1) == 0 + && reg_overlap_mentioned_p (inc_insn.reg_res, PATTERN (mem_insn.insn))) + { + debug_rtx (mem_insn.insn); + debug_rtx (inc_insn.reg_res); + gcc_unreachable (); + } if (count_occurrences (PATTERN (mem_insn.insn), inc_insn.reg_res, 1) != 0) { if (dump_file) diff --git a/gcc/basic-block.h b/gcc/basic-block.h index 95ad4a90505..135c0c22a07 100644 --- a/gcc/basic-block.h +++ b/gcc/basic-block.h @@ -443,8 +443,8 @@ extern int pre_and_rev_post_order_compute (int *, int *, bool); extern int dfs_enumerate_from (basic_block, int, bool (*)(const_basic_block, const void *), basic_block *, int, const void *); -extern void compute_dominance_frontiers (bitmap *); -extern bitmap compute_idf (bitmap, bitmap *); +extern void compute_dominance_frontiers (struct bitmap_head_def *); +extern bitmap compute_idf (bitmap, struct bitmap_head_def *); extern void dump_bb_info (basic_block, bool, bool, int, const char *, FILE *); extern void dump_edge_info (FILE *, edge, int); extern void brief_dump_cfg (FILE *); @@ -554,7 +554,9 @@ single_pred_p (const_basic_block bb) static inline edge single_succ_edge (const_basic_block bb) { +#ifdef ENABLE_CHECKING gcc_assert (single_succ_p (bb)); +#endif return EDGE_SUCC (bb, 0); } @@ -564,7 +566,9 @@ single_succ_edge (const_basic_block bb) static inline edge single_pred_edge (const_basic_block bb) { +#ifdef ENABLE_CHECKING gcc_assert (single_pred_p (bb)); +#endif return EDGE_PRED (bb, 0); } @@ -596,7 +600,9 @@ typedef struct { static inline VEC(edge,gc) * ei_container (edge_iterator i) { +#ifdef ENABLE_CHECKING gcc_assert (i.container); +#endif return *i.container; } @@ -647,7 +653,9 @@ ei_one_before_end_p (edge_iterator i) static inline void ei_next (edge_iterator *i) { +#ifdef ENABLE_CHECKING gcc_assert (i->index < EDGE_COUNT (ei_container (*i))); +#endif i->index++; } @@ -655,7 +663,9 @@ ei_next (edge_iterator *i) static inline void ei_prev (edge_iterator *i) { +#ifdef ENABLE_CHECKING gcc_assert (i->index > 0); +#endif i->index--; } diff --git a/gcc/bitmap.c b/gcc/bitmap.c index 8f4a56606bd..f2fd2bdb510 100644 --- a/gcc/bitmap.c +++ b/gcc/bitmap.c @@ -230,7 +230,7 @@ bitmap_element_allocate (bitmap head) /* Inner list was just a singleton. */ bitmap_ggc_free = element->prev; else - element = GGC_NEW (bitmap_element); + element = ggc_alloc_bitmap_element_def (); } #ifdef GATHER_STATISTICS @@ -375,7 +375,7 @@ bitmap_gc_alloc_stat (ALONE_MEM_STAT_DECL) { bitmap map; - map = GGC_NEW (struct bitmap_head_def); + map = ggc_alloc_bitmap_head_def (); bitmap_initialize_stat (map, NULL PASS_MEM_STAT); #ifdef GATHER_STATISTICS register_overhead (map, sizeof (bitmap_head)); @@ -499,7 +499,7 @@ bitmap_elt_insert_after (bitmap head, bitmap_element *elt, unsigned int indx) } else { - gcc_assert (head->current); + gcc_checking_assert (head->current); node->next = elt->next; if (node->next) node->next->prev = node; @@ -624,11 +624,13 @@ bitmap_clear_bit (bitmap head, int bit) BITMAP_WORD bit_val = ((BITMAP_WORD) 1) << bit_num; bool res = (ptr->bits[word_num] & bit_val) != 0; if (res) - ptr->bits[word_num] &= ~bit_val; - - /* If we cleared the entire word, free up the element. */ - if (bitmap_element_zerop (ptr)) - bitmap_element_free (head, ptr); + { + ptr->bits[word_num] &= ~bit_val; + /* If we cleared the entire word, free up the element. */ + if (!ptr->bits[word_num] + && bitmap_element_zerop (ptr)) + bitmap_element_free (head, ptr); + } return res; } @@ -780,7 +782,7 @@ bitmap_first_set_bit (const_bitmap a) BITMAP_WORD word; unsigned ix; - gcc_assert (elt); + gcc_checking_assert (elt); bit_no = elt->indx * BITMAP_ELEMENT_ALL_BITS; for (ix = 0; ix != BITMAP_ELEMENT_WORDS; ix++) { @@ -815,7 +817,7 @@ bitmap_first_set_bit (const_bitmap a) if (!(word & 0x1)) word >>= 1, bit_no += 1; - gcc_assert (word & 1); + gcc_checking_assert (word & 1); #endif return bit_no; } @@ -831,7 +833,7 @@ bitmap_last_set_bit (const_bitmap a) BITMAP_WORD word; int ix; - gcc_assert (elt); + gcc_checking_assert (elt); while (elt->next) elt = elt->next; bit_no = elt->indx * BITMAP_ELEMENT_ALL_BITS; @@ -869,7 +871,7 @@ bitmap_last_set_bit (const_bitmap a) word >>= 1, bit_no += 1; #endif - gcc_assert (word & 1); + gcc_checking_assert (word & 1); return bit_no; } @@ -908,7 +910,7 @@ bitmap_and (bitmap dst, const_bitmap a, const_bitmap b) dst_elt = bitmap_elt_insert_after (dst, dst_prev, a_elt->indx); else dst_elt->indx = a_elt->indx; - for (ix = BITMAP_ELEMENT_WORDS; ix--;) + for (ix = 0; ix < BITMAP_ELEMENT_WORDS; ix++) { BITMAP_WORD r = a_elt->bits[ix] & b_elt->bits[ix]; @@ -927,7 +929,7 @@ bitmap_and (bitmap dst, const_bitmap a, const_bitmap b) /* Ensure that dst->current is valid. */ dst->current = dst->first; bitmap_elt_clear_from (dst, dst_elt); - gcc_assert (!dst->current == !dst->first); + gcc_checking_assert (!dst->current == !dst->first); if (dst->current) dst->indx = dst->current->indx; } @@ -960,7 +962,7 @@ bitmap_and_into (bitmap a, const_bitmap b) unsigned ix; BITMAP_WORD ior = 0; - for (ix = BITMAP_ELEMENT_WORDS; ix--;) + for (ix = 0; ix < BITMAP_ELEMENT_WORDS; ix++) { BITMAP_WORD r = a_elt->bits[ix] & b_elt->bits[ix]; @@ -975,8 +977,8 @@ bitmap_and_into (bitmap a, const_bitmap b) } } bitmap_elt_clear_from (a, a_elt); - gcc_assert (!a->current == !a->first); - gcc_assert (!a->current || a->indx == a->current->indx); + gcc_checking_assert (!a->current == !a->first + && (!a->current || a->indx == a->current->indx)); } @@ -992,7 +994,7 @@ bitmap_elt_copy (bitmap dst, bitmap_element *dst_elt, bitmap_element *dst_prev, { unsigned ix; - for (ix = BITMAP_ELEMENT_WORDS; ix--;) + for (ix = 0; ix < BITMAP_ELEMENT_WORDS; ix++) if (src_elt->bits[ix] != dst_elt->bits[ix]) { dst_elt->bits[ix] = src_elt->bits[ix]; @@ -1056,7 +1058,7 @@ bitmap_and_compl (bitmap dst, const_bitmap a, const_bitmap b) if (!changed && dst_elt && dst_elt->indx == a_elt->indx) { - for (ix = BITMAP_ELEMENT_WORDS; ix--;) + for (ix = 0; ix < BITMAP_ELEMENT_WORDS; ix++) { BITMAP_WORD r = a_elt->bits[ix] & ~b_elt->bits[ix]; @@ -1082,7 +1084,7 @@ bitmap_and_compl (bitmap dst, const_bitmap a, const_bitmap b) new_element = false; } - for (ix = BITMAP_ELEMENT_WORDS; ix--;) + for (ix = 0; ix < BITMAP_ELEMENT_WORDS; ix++) { BITMAP_WORD r = a_elt->bits[ix] & ~b_elt->bits[ix]; @@ -1119,7 +1121,7 @@ bitmap_and_compl (bitmap dst, const_bitmap a, const_bitmap b) changed = true; bitmap_elt_clear_from (dst, dst_elt); } - gcc_assert (!dst->current == !dst->first); + gcc_checking_assert (!dst->current == !dst->first); if (dst->current) dst->indx = dst->current->indx; @@ -1159,7 +1161,7 @@ bitmap_and_compl_into (bitmap a, const_bitmap b) unsigned ix; BITMAP_WORD ior = 0; - for (ix = BITMAP_ELEMENT_WORDS; ix--;) + for (ix = 0; ix < BITMAP_ELEMENT_WORDS; ix++) { BITMAP_WORD cleared = a_elt->bits[ix] & b_elt->bits[ix]; BITMAP_WORD r = a_elt->bits[ix] ^ cleared; @@ -1175,8 +1177,8 @@ bitmap_and_compl_into (bitmap a, const_bitmap b) b_elt = b_elt->next; } } - gcc_assert (!a->current == !a->first); - gcc_assert (!a->current || a->indx == a->current->indx); + gcc_checking_assert (!a->current == !a->first + && (!a->current || a->indx == a->current->indx)); return changed != 0; } @@ -1207,7 +1209,7 @@ bitmap_set_range (bitmap head, unsigned int start, unsigned int count) bitmap_element_link (head, elt); } - gcc_assert (elt->indx == first_index); + gcc_checking_assert (elt->indx == first_index); elt_prev = elt->prev; for (i = first_index; i <= last_index; i++) { @@ -1453,7 +1455,7 @@ bitmap_compl_and_into (bitmap a, const_bitmap b) unsigned ix; BITMAP_WORD ior = 0; - for (ix = BITMAP_ELEMENT_WORDS; ix--;) + for (ix = 0; ix < BITMAP_ELEMENT_WORDS; ix++) { BITMAP_WORD cleared = a_elt->bits[ix] & b_elt->bits[ix]; BITMAP_WORD r = b_elt->bits[ix] ^ cleared; @@ -1470,8 +1472,8 @@ bitmap_compl_and_into (bitmap a, const_bitmap b) b_elt = b_elt->next; } } - gcc_assert (!a->current == !a->first); - gcc_assert (!a->current || a->indx == a->current->indx); + gcc_checking_assert (!a->current == !a->first + && (!a->current || a->indx == a->current->indx)); return; } @@ -1494,7 +1496,7 @@ bitmap_elt_ior (bitmap dst, bitmap_element *dst_elt, bitmap_element *dst_prev, if (!changed && dst_elt && dst_elt->indx == a_elt->indx) { - for (ix = BITMAP_ELEMENT_WORDS; ix--;) + for (ix = 0; ix < BITMAP_ELEMENT_WORDS; ix++) { BITMAP_WORD r = a_elt->bits[ix] | b_elt->bits[ix]; if (r != dst_elt->bits[ix]) @@ -1511,7 +1513,7 @@ bitmap_elt_ior (bitmap dst, bitmap_element *dst_elt, bitmap_element *dst_prev, dst_elt = bitmap_elt_insert_after (dst, dst_prev, a_elt->indx); else dst_elt->indx = a_elt->indx; - for (ix = BITMAP_ELEMENT_WORDS; ix--;) + for (ix = 0; ix < BITMAP_ELEMENT_WORDS; ix++) { BITMAP_WORD r = a_elt->bits[ix] | b_elt->bits[ix]; dst_elt->bits[ix] = r; @@ -1528,7 +1530,7 @@ bitmap_elt_ior (bitmap dst, bitmap_element *dst_elt, bitmap_element *dst_prev, else src = b_elt; - gcc_assert (src); + gcc_checking_assert (src); changed = bitmap_elt_copy (dst, dst_elt, dst_prev, src, changed); } return changed; @@ -1576,7 +1578,7 @@ bitmap_ior (bitmap dst, const_bitmap a, const_bitmap b) changed = true; bitmap_elt_clear_from (dst, dst_elt); } - gcc_assert (!dst->current == !dst->first); + gcc_checking_assert (!dst->current == !dst->first); if (dst->current) dst->indx = dst->current->indx; return changed; @@ -1615,7 +1617,7 @@ bitmap_ior_into (bitmap a, const_bitmap b) a_elt = *a_prev_pnext; } - gcc_assert (!a->current == !a->first); + gcc_checking_assert (!a->current == !a->first); if (a->current) a->indx = a->current->indx; return changed; @@ -1650,7 +1652,7 @@ bitmap_xor (bitmap dst, const_bitmap a, const_bitmap b) dst_elt = bitmap_elt_insert_after (dst, dst_prev, a_elt->indx); else dst_elt->indx = a_elt->indx; - for (ix = BITMAP_ELEMENT_WORDS; ix--;) + for (ix = 0; ix < BITMAP_ELEMENT_WORDS; ix++) { BITMAP_WORD r = a_elt->bits[ix] ^ b_elt->bits[ix]; @@ -1693,7 +1695,7 @@ bitmap_xor (bitmap dst, const_bitmap a, const_bitmap b) /* Ensure that dst->current is valid. */ dst->current = dst->first; bitmap_elt_clear_from (dst, dst_elt); - gcc_assert (!dst->current == !dst->first); + gcc_checking_assert (!dst->current == !dst->first); if (dst->current) dst->indx = dst->current->indx; } @@ -1735,7 +1737,7 @@ bitmap_xor_into (bitmap a, const_bitmap b) BITMAP_WORD ior = 0; bitmap_element *next = a_elt->next; - for (ix = BITMAP_ELEMENT_WORDS; ix--;) + for (ix = 0; ix < BITMAP_ELEMENT_WORDS; ix++) { BITMAP_WORD r = a_elt->bits[ix] ^ b_elt->bits[ix]; @@ -1750,7 +1752,7 @@ bitmap_xor_into (bitmap a, const_bitmap b) a_elt = next; } } - gcc_assert (!a->current == !a->first); + gcc_checking_assert (!a->current == !a->first); if (a->current) a->indx = a->current->indx; } @@ -1772,7 +1774,7 @@ bitmap_equal_p (const_bitmap a, const_bitmap b) { if (a_elt->indx != b_elt->indx) return false; - for (ix = BITMAP_ELEMENT_WORDS; ix--;) + for (ix = 0; ix < BITMAP_ELEMENT_WORDS; ix++) if (a_elt->bits[ix] != b_elt->bits[ix]) return false; } @@ -1797,7 +1799,7 @@ bitmap_intersect_p (const_bitmap a, const_bitmap b) b_elt = b_elt->next; else { - for (ix = BITMAP_ELEMENT_WORDS; ix--;) + for (ix = 0; ix < BITMAP_ELEMENT_WORDS; ix++) if (a_elt->bits[ix] & b_elt->bits[ix]) return true; a_elt = a_elt->next; @@ -1824,7 +1826,7 @@ bitmap_intersect_compl_p (const_bitmap a, const_bitmap b) b_elt = b_elt->next; else { - for (ix = BITMAP_ELEMENT_WORDS; ix--;) + for (ix = 0; ix < BITMAP_ELEMENT_WORDS; ix++) if (a_elt->bits[ix] & ~b_elt->bits[ix]) return true; a_elt = a_elt->next; @@ -1880,7 +1882,7 @@ bitmap_ior_and_compl (bitmap dst, const_bitmap a, const_bitmap b, const_bitmap k BITMAP_WORD ior = 0; tmp_elt.indx = b_elt->indx; - for (ix = BITMAP_ELEMENT_WORDS; ix--;) + for (ix = 0; ix < BITMAP_ELEMENT_WORDS; ix++) { BITMAP_WORD r = b_elt->bits[ix] & ~kill_elt->bits[ix]; ior |= r; @@ -1932,7 +1934,7 @@ bitmap_ior_and_compl (bitmap dst, const_bitmap a, const_bitmap b, const_bitmap k changed = true; bitmap_elt_clear_from (dst, dst_elt); } - gcc_assert (!dst->current == !dst->first); + gcc_checking_assert (!dst->current == !dst->first); if (dst->current) dst->indx = dst->current->indx; @@ -1998,7 +2000,7 @@ bitmap_ior_and_into (bitmap a, const_bitmap b, const_bitmap c) overall = 0; and_elt.indx = b_elt->indx; - for (ix = BITMAP_ELEMENT_WORDS; ix--;) + for (ix = 0; ix < BITMAP_ELEMENT_WORDS; ix++) { and_elt.bits[ix] = b_elt->bits[ix] & c_elt->bits[ix]; overall |= and_elt.bits[ix]; @@ -2028,7 +2030,7 @@ bitmap_ior_and_into (bitmap a, const_bitmap b, const_bitmap c) } done: - gcc_assert (!a->current == !a->first); + gcc_checking_assert (!a->current == !a->first); if (a->current) a->indx = a->current->indx; return changed; diff --git a/gcc/bitmap.h b/gcc/bitmap.h index bbc0e20cfef..68a46204a54 100644 --- a/gcc/bitmap.h +++ b/gcc/bitmap.h @@ -77,7 +77,7 @@ typedef struct GTY(()) bitmap_head_def { bitmap_element *current; /* Last element looked at. */ unsigned int indx; /* Index of last element looked at. */ bitmap_obstack *obstack; /* Obstack to allocate elements from. - If NULL, then use ggc_alloc. */ + If NULL, then use GGC allocation. */ #ifdef GATHER_STATISTICS struct bitmap_descriptor GTY((skip)) *desc; #endif @@ -385,6 +385,27 @@ bmp_iter_next (bitmap_iterator *bi, unsigned *bit_no) *bit_no += 1; } +/* Advance to first set bit in BI. */ + +static inline void +bmp_iter_next_bit (bitmap_iterator * bi, unsigned *bit_no) +{ +#if (GCC_VERSION >= 3004) + { + unsigned int n = __builtin_ctzl (bi->bits); + gcc_assert (sizeof (unsigned long) == sizeof (BITMAP_WORD)); + bi->bits >>= n; + *bit_no += n; + } +#else + while (!(bi->bits & 1)) + { + bi->bits >>= 1; + *bit_no += 1; + } +#endif +} + /* Advance to the next nonzero bit of a single bitmap, we will have already advanced past the just iterated bit. Return true if there is a bit to iterate. */ @@ -396,11 +417,7 @@ bmp_iter_set (bitmap_iterator *bi, unsigned *bit_no) if (bi->bits) { next_bit: - while (!(bi->bits & 1)) - { - bi->bits >>= 1; - *bit_no += 1; - } + bmp_iter_next_bit (bi, bit_no); return true; } @@ -443,11 +460,7 @@ bmp_iter_and (bitmap_iterator *bi, unsigned *bit_no) if (bi->bits) { next_bit: - while (!(bi->bits & 1)) - { - bi->bits >>= 1; - *bit_no += 1; - } + bmp_iter_next_bit (bi, bit_no); return true; } @@ -510,11 +523,7 @@ bmp_iter_and_compl (bitmap_iterator *bi, unsigned *bit_no) if (bi->bits) { next_bit: - while (!(bi->bits & 1)) - { - bi->bits >>= 1; - *bit_no += 1; - } + bmp_iter_next_bit (bi, bit_no); return true; } diff --git a/gcc/bt-load.c b/gcc/bt-load.c index 5e3d12c359a..abb033fc096 100644 --- a/gcc/bt-load.c +++ b/gcc/bt-load.c @@ -1458,7 +1458,8 @@ migrate_btr_defs (enum reg_class btr_class, int allow_callee_save) static void branch_target_load_optimize (bool after_prologue_epilogue_gen) { - enum reg_class klass = targetm.branch_target_register_class (); + enum reg_class klass + = (enum reg_class) targetm.branch_target_register_class (); if (klass != NO_REGS) { /* Initialize issue_rate. */ diff --git a/gcc/builtins.c b/gcc/builtins.c index e57449ddcae..ddbbd79dbe2 100644 --- a/gcc/builtins.c +++ b/gcc/builtins.c @@ -2521,8 +2521,6 @@ build_call_nofold_loc (location_t loc, tree fndecl, int n, ...) SET_EXPR_LOCATION (fn, loc); return fn; } -#define build_call_nofold(...) \ - build_call_nofold_loc (UNKNOWN_LOCATION, __VA_ARGS__) /* Expand a call to one of the builtin rounding functions gcc defines as an extension (lfloor and lceil). As these are gcc extensions we @@ -2640,7 +2638,7 @@ expand_builtin_int_roundingfn (tree exp, rtx target) fallback_fndecl = build_fn_decl (name, fntype); } - exp = build_call_nofold (fallback_fndecl, 1, arg); + exp = build_call_nofold_loc (EXPR_LOCATION (exp), fallback_fndecl, 1, arg); tmp = expand_normal (exp); @@ -3085,7 +3083,8 @@ expand_builtin_pow (tree exp, rtx target, rtx subtarget) && (optab_handler (sqrt_optab, mode)->insn_code != CODE_FOR_nothing)))) { - tree call_expr = build_call_nofold (fn, 1, narg0); + tree call_expr = build_call_nofold_loc (EXPR_LOCATION (exp), fn, 1, + narg0); /* Use expand_expr in case the newly built call expression was folded to a non-call. */ op = expand_expr (call_expr, subtarget, mode, EXPAND_NORMAL); @@ -3137,7 +3136,8 @@ expand_builtin_pow (tree exp, rtx target, rtx subtarget) && powi_cost (n/3) <= POWI_MAX_MULTS) || n == 1)) { - tree call_expr = build_call_nofold (fn, 1,narg0); + tree call_expr = build_call_nofold_loc (EXPR_LOCATION (exp), fn, 1, + narg0); op = expand_builtin (call_expr, NULL_RTX, subtarget, mode, 0); if (abs (n) % 3 == 2) op = expand_simple_binop (mode, MULT, op, op, op, @@ -3471,7 +3471,8 @@ expand_builtin_mempcpy_args (tree dest, tree src, tree len, if (target == const0_rtx && implicit_built_in_decls[BUILT_IN_MEMCPY]) { tree fn = implicit_built_in_decls[BUILT_IN_MEMCPY]; - tree result = build_call_nofold (fn, 3, dest, src, len); + tree result = build_call_nofold_loc (UNKNOWN_LOCATION, fn, 3, + dest, src, len); return expand_expr (result, target, mode, EXPAND_NORMAL); } else @@ -3553,7 +3554,7 @@ expand_movstr (tree dest, tree src, rtx target, int endp) rtx dest_mem; rtx src_mem; rtx insn; - const struct insn_data * data; + const struct insn_data_d * data; if (!HAVE_movstr) return NULL_RTX; @@ -3652,7 +3653,7 @@ expand_builtin_stpcpy (tree exp, rtx target, enum machine_mode mode) if (target == const0_rtx && implicit_built_in_decls[BUILT_IN_STRCPY]) { tree fn = implicit_built_in_decls[BUILT_IN_STRCPY]; - tree result = build_call_nofold (fn, 2, dst, src); + tree result = build_call_nofold_loc (loc, fn, 2, dst, src); return expand_expr (result, target, mode, EXPAND_NORMAL); } else @@ -3955,9 +3956,11 @@ expand_builtin_memset_args (tree dest, tree val, tree len, fndecl = get_callee_fndecl (orig_exp); fcode = DECL_FUNCTION_CODE (fndecl); if (fcode == BUILT_IN_MEMSET) - fn = build_call_nofold (fndecl, 3, dest, val, len); + fn = build_call_nofold_loc (EXPR_LOCATION (orig_exp), fndecl, 3, + dest, val, len); else if (fcode == BUILT_IN_BZERO) - fn = build_call_nofold (fndecl, 2, dest, len); + fn = build_call_nofold_loc (EXPR_LOCATION (orig_exp), fndecl, 2, + dest, len); else gcc_unreachable (); gcc_assert (TREE_CODE (fn) == CALL_EXPR); @@ -4230,7 +4233,7 @@ expand_builtin_strcmp (tree exp, ATTRIBUTE_UNUSED rtx target) do_libcall: #endif fndecl = get_callee_fndecl (exp); - fn = build_call_nofold (fndecl, 2, arg1, arg2); + fn = build_call_nofold_loc (EXPR_LOCATION (exp), fndecl, 2, arg1, arg2); gcc_assert (TREE_CODE (fn) == CALL_EXPR); CALL_EXPR_TAILCALL (fn) = CALL_EXPR_TAILCALL (exp); return expand_call (fn, target, target == const0_rtx); @@ -4352,7 +4355,8 @@ expand_builtin_strncmp (tree exp, ATTRIBUTE_UNUSED rtx target, /* Expand the library call ourselves using a stabilized argument list to avoid re-evaluating the function's arguments twice. */ fndecl = get_callee_fndecl (exp); - fn = build_call_nofold (fndecl, 3, arg1, arg2, len); + fn = build_call_nofold_loc (EXPR_LOCATION (exp), fndecl, 3, + arg1, arg2, len); gcc_assert (TREE_CODE (fn) == CALL_EXPR); CALL_EXPR_TAILCALL (fn) = CALL_EXPR_TAILCALL (exp); return expand_call (fn, target, target == const0_rtx); @@ -4451,7 +4455,10 @@ stabilize_va_list_loc (location_t loc, tree valist, int needs_lvalue) { tree vatype = targetm.canonical_va_list_type (TREE_TYPE (valist)); - gcc_assert (vatype != NULL_TREE); + /* The current way of determining the type of valist is completely + bogus. We should have the information on the va builtin instead. */ + if (!vatype) + vatype = targetm.fn_abi_va_list (cfun->decl); if (TREE_CODE (vatype) == ARRAY_TYPE) { @@ -4470,21 +4477,21 @@ stabilize_va_list_loc (location_t loc, tree valist, int needs_lvalue) } else { - tree pt; + tree pt = build_pointer_type (vatype); if (! needs_lvalue) { if (! TREE_SIDE_EFFECTS (valist)) return valist; - pt = build_pointer_type (vatype); valist = fold_build1_loc (loc, ADDR_EXPR, pt, valist); TREE_SIDE_EFFECTS (valist) = 1; } if (TREE_SIDE_EFFECTS (valist)) valist = save_expr (valist); - valist = build_fold_indirect_ref_loc (loc, valist); + valist = fold_build2_loc (loc, MEM_REF, + vatype, valist, build_int_cst (pt, 0)); } return valist; @@ -8342,6 +8349,7 @@ fold_builtin_memory_op (location_t loc, tree dest, tree src, { tree srctype, desttype; int src_align, dest_align; + tree off0; if (endp == 3) { @@ -8367,37 +8375,26 @@ fold_builtin_memory_op (location_t loc, tree dest, tree src, } /* If *src and *dest can't overlap, optimize into memcpy as well. */ - srcvar = build_fold_indirect_ref_loc (loc, src); - destvar = build_fold_indirect_ref_loc (loc, dest); - if (srcvar - && !TREE_THIS_VOLATILE (srcvar) - && destvar - && !TREE_THIS_VOLATILE (destvar)) + if (TREE_CODE (src) == ADDR_EXPR + && TREE_CODE (dest) == ADDR_EXPR) { tree src_base, dest_base, fn; HOST_WIDE_INT src_offset = 0, dest_offset = 0; HOST_WIDE_INT size = -1; HOST_WIDE_INT maxsize = -1; - src_base = srcvar; - if (handled_component_p (src_base)) - src_base = get_ref_base_and_extent (src_base, &src_offset, - &size, &maxsize); - dest_base = destvar; - if (handled_component_p (dest_base)) - dest_base = get_ref_base_and_extent (dest_base, &dest_offset, - &size, &maxsize); + srcvar = TREE_OPERAND (src, 0); + src_base = get_ref_base_and_extent (srcvar, &src_offset, + &size, &maxsize); + destvar = TREE_OPERAND (dest, 0); + dest_base = get_ref_base_and_extent (destvar, &dest_offset, + &size, &maxsize); if (host_integerp (len, 1)) - { - maxsize = tree_low_cst (len, 1); - if (maxsize - > INTTYPE_MAXIMUM (HOST_WIDE_INT) / BITS_PER_UNIT) - maxsize = -1; - else - maxsize *= BITS_PER_UNIT; - } + maxsize = tree_low_cst (len, 1); else maxsize = -1; + src_offset /= BITS_PER_UNIT; + dest_offset /= BITS_PER_UNIT; if (SSA_VAR_P (src_base) && SSA_VAR_P (dest_base)) { @@ -8406,13 +8403,25 @@ fold_builtin_memory_op (location_t loc, tree dest, tree src, dest_offset, maxsize)) return NULL_TREE; } - else if (TREE_CODE (src_base) == INDIRECT_REF - && TREE_CODE (dest_base) == INDIRECT_REF) + else if (TREE_CODE (src_base) == MEM_REF + && TREE_CODE (dest_base) == MEM_REF) { + double_int off; if (! operand_equal_p (TREE_OPERAND (src_base, 0), - TREE_OPERAND (dest_base, 0), 0) - || ranges_overlap_p (src_offset, maxsize, - dest_offset, maxsize)) + TREE_OPERAND (dest_base, 0), 0)) + return NULL_TREE; + off = double_int_add (mem_ref_offset (src_base), + shwi_to_double_int (src_offset)); + if (!double_int_fits_in_shwi_p (off)) + return NULL_TREE; + src_offset = off.low; + off = double_int_add (mem_ref_offset (dest_base), + shwi_to_double_int (dest_offset)); + if (!double_int_fits_in_shwi_p (off)) + return NULL_TREE; + dest_offset = off.low; + if (ranges_overlap_p (src_offset, maxsize, + dest_offset, maxsize)) return NULL_TREE; } else @@ -8468,12 +8477,12 @@ fold_builtin_memory_op (location_t loc, tree dest, tree src, dest = build1 (NOP_EXPR, build_pointer_type (desttype), dest); } if (!srctype || !desttype + || TREE_ADDRESSABLE (srctype) + || TREE_ADDRESSABLE (desttype) || !TYPE_SIZE_UNIT (srctype) || !TYPE_SIZE_UNIT (desttype) || TREE_CODE (TYPE_SIZE_UNIT (srctype)) != INTEGER_CST - || TREE_CODE (TYPE_SIZE_UNIT (desttype)) != INTEGER_CST - || TYPE_VOLATILE (srctype) - || TYPE_VOLATILE (desttype)) + || TREE_CODE (TYPE_SIZE_UNIT (desttype)) != INTEGER_CST) return NULL_TREE; src_align = get_pointer_alignment (src, BIGGEST_ALIGNMENT); @@ -8485,97 +8494,44 @@ fold_builtin_memory_op (location_t loc, tree dest, tree src, if (!ignore) dest = builtin_save_expr (dest); - srcvar = NULL_TREE; - if (tree_int_cst_equal (TYPE_SIZE_UNIT (srctype), len)) - { - srcvar = build_fold_indirect_ref_loc (loc, src); - if (TREE_THIS_VOLATILE (srcvar)) - return NULL_TREE; - else if (!tree_int_cst_equal (tree_expr_size (srcvar), len)) - srcvar = NULL_TREE; - /* With memcpy, it is possible to bypass aliasing rules, so without - this check i.e. execute/20060930-2.c would be misoptimized, - because it use conflicting alias set to hold argument for the - memcpy call. This check is probably unnecessary with - -fno-strict-aliasing. Similarly for destvar. See also - PR29286. */ - else if (!var_decl_component_p (srcvar)) - srcvar = NULL_TREE; - } - - destvar = NULL_TREE; - if (tree_int_cst_equal (TYPE_SIZE_UNIT (desttype), len)) - { - destvar = build_fold_indirect_ref_loc (loc, dest); - if (TREE_THIS_VOLATILE (destvar)) - return NULL_TREE; - else if (!tree_int_cst_equal (tree_expr_size (destvar), len)) - destvar = NULL_TREE; - else if (!var_decl_component_p (destvar)) - destvar = NULL_TREE; - } + /* Build accesses at offset zero with a ref-all character type. */ + off0 = build_int_cst (build_pointer_type_for_mode (char_type_node, + ptr_mode, true), 0); + + destvar = dest; + STRIP_NOPS (destvar); + if (TREE_CODE (destvar) == ADDR_EXPR + && var_decl_component_p (TREE_OPERAND (destvar, 0)) + && tree_int_cst_equal (TYPE_SIZE_UNIT (desttype), len)) + destvar = fold_build2 (MEM_REF, desttype, destvar, off0); + else + destvar = NULL_TREE; + + srcvar = src; + STRIP_NOPS (srcvar); + if (TREE_CODE (srcvar) == ADDR_EXPR + && var_decl_component_p (TREE_OPERAND (srcvar, 0)) + && tree_int_cst_equal (TYPE_SIZE_UNIT (srctype), len)) + srcvar = fold_build2 (MEM_REF, destvar ? desttype : srctype, + srcvar, off0); + else + srcvar = NULL_TREE; if (srcvar == NULL_TREE && destvar == NULL_TREE) return NULL_TREE; if (srcvar == NULL_TREE) { - tree srcptype; - if (TREE_ADDRESSABLE (TREE_TYPE (destvar))) - return NULL_TREE; - - srctype = build_qualified_type (desttype, 0); - if (src_align < (int) TYPE_ALIGN (srctype)) - { - if (AGGREGATE_TYPE_P (srctype) - || SLOW_UNALIGNED_ACCESS (TYPE_MODE (srctype), src_align)) - return NULL_TREE; - - srctype = build_variant_type_copy (srctype); - TYPE_ALIGN (srctype) = src_align; - TYPE_USER_ALIGN (srctype) = 1; - TYPE_PACKED (srctype) = 1; - } - srcptype = build_pointer_type_for_mode (srctype, ptr_mode, true); - src = fold_convert_loc (loc, srcptype, src); - srcvar = build_fold_indirect_ref_loc (loc, src); + STRIP_NOPS (src); + srcvar = fold_build2 (MEM_REF, desttype, src, off0); } else if (destvar == NULL_TREE) { - tree destptype; - if (TREE_ADDRESSABLE (TREE_TYPE (srcvar))) - return NULL_TREE; - - desttype = build_qualified_type (srctype, 0); - if (dest_align < (int) TYPE_ALIGN (desttype)) - { - if (AGGREGATE_TYPE_P (desttype) - || SLOW_UNALIGNED_ACCESS (TYPE_MODE (desttype), dest_align)) - return NULL_TREE; + STRIP_NOPS (dest); + destvar = fold_build2 (MEM_REF, srctype, dest, off0); + } - desttype = build_variant_type_copy (desttype); - TYPE_ALIGN (desttype) = dest_align; - TYPE_USER_ALIGN (desttype) = 1; - TYPE_PACKED (desttype) = 1; - } - destptype = build_pointer_type_for_mode (desttype, ptr_mode, true); - dest = fold_convert_loc (loc, destptype, dest); - destvar = build_fold_indirect_ref_loc (loc, dest); - } - - if (srctype == desttype - || (gimple_in_ssa_p (cfun) - && useless_type_conversion_p (desttype, srctype))) - expr = srcvar; - else if ((INTEGRAL_TYPE_P (TREE_TYPE (srcvar)) - || POINTER_TYPE_P (TREE_TYPE (srcvar))) - && (INTEGRAL_TYPE_P (TREE_TYPE (destvar)) - || POINTER_TYPE_P (TREE_TYPE (destvar)))) - expr = fold_convert_loc (loc, TREE_TYPE (destvar), srcvar); - else - expr = fold_build1_loc (loc, VIEW_CONVERT_EXPR, - TREE_TYPE (destvar), srcvar); - expr = build2 (MODIFY_EXPR, TREE_TYPE (destvar), destvar, expr); + expr = build2 (MODIFY_EXPR, TREE_TYPE (destvar), destvar, srcvar); } if (ignore) @@ -10758,6 +10714,26 @@ build_call_expr_loc (location_t loc, tree fndecl, int n, ...) return fold_builtin_call_array (loc, TREE_TYPE (fntype), fn, n, argarray); } +/* Like build_call_expr_loc (UNKNOWN_LOCATION, ...). Duplicated because + varargs macros aren't supported by all bootstrap compilers. */ + +tree +build_call_expr (tree fndecl, int n, ...) +{ + va_list ap; + tree fntype = TREE_TYPE (fndecl); + tree fn = build1 (ADDR_EXPR, build_pointer_type (fntype), fndecl); + tree *argarray = (tree *) alloca (n * sizeof (tree)); + int i; + + va_start (ap, n); + for (i = 0; i < n; i++) + argarray[i] = va_arg (ap, tree); + va_end (ap); + return fold_builtin_call_array (UNKNOWN_LOCATION, TREE_TYPE (fntype), + fn, n, argarray); +} + /* Construct a CALL_EXPR with type TYPE with FN as the function expression. N arguments are passed in the array ARGARRAY. */ @@ -11848,7 +11824,7 @@ expand_builtin_memory_chk (tree exp, rtx target, enum machine_mode mode, if (! fn) return NULL_RTX; - fn = build_call_nofold (fn, 3, dest, src, len); + fn = build_call_nofold_loc (EXPR_LOCATION (exp), fn, 3, dest, src, len); gcc_assert (TREE_CODE (fn) == CALL_EXPR); CALL_EXPR_TAILCALL (fn) = CALL_EXPR_TAILCALL (exp); return expand_expr (fn, target, mode, EXPAND_NORMAL); @@ -11896,7 +11872,8 @@ expand_builtin_memory_chk (tree exp, rtx target, enum machine_mode mode, tree fn = built_in_decls[BUILT_IN_MEMCPY_CHK]; if (!fn) return NULL_RTX; - fn = build_call_nofold (fn, 4, dest, src, len, size); + fn = build_call_nofold_loc (EXPR_LOCATION (exp), fn, 4, + dest, src, len, size); gcc_assert (TREE_CODE (fn) == CALL_EXPR); CALL_EXPR_TAILCALL (fn) = CALL_EXPR_TAILCALL (exp); return expand_expr (fn, target, mode, EXPAND_NORMAL); @@ -12043,7 +12020,7 @@ maybe_emit_free_warning (tree exp) return; arg = get_base_address (TREE_OPERAND (arg, 0)); - if (arg == NULL || INDIRECT_REF_P (arg)) + if (arg == NULL || INDIRECT_REF_P (arg) || TREE_CODE (arg) == MEM_REF) return; if (SSA_VAR_P (arg)) diff --git a/gcc/c-ada-spec.c b/gcc/c-ada-spec.c deleted file mode 100644 index 697b9633afd..00000000000 --- a/gcc/c-ada-spec.c +++ /dev/null @@ -1,3230 +0,0 @@ -/* Print GENERIC declaration (functions, variables, types) trees coming from - the C and C++ front-ends as well as macros in Ada syntax. - Copyright (C) 2010 Free Software Foundation, Inc. - Adapted from tree-pretty-print.c by Arnaud Charlet - -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 3, 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 COPYING3. If not see -. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "tm.h" -#include "tree.h" -#include "tree-pass.h" /* For TDI_ada and friends. */ -#include "output.h" -#include "c-ada-spec.h" -#include "cpplib.h" -#include "c-pragma.h" -#include "cpp-id-data.h" - -/* Local functions, macros and variables. */ -static int dump_generic_ada_node (pretty_printer *, tree, tree, - int (*)(tree, cpp_operation), int, int, bool); -static int print_ada_declaration (pretty_printer *, tree, tree, - int (*cpp_check)(tree, cpp_operation), int); -static void print_ada_struct_decl (pretty_printer *, tree, tree, - int (*cpp_check)(tree, cpp_operation), int, - bool); -static void dump_sloc (pretty_printer *buffer, tree node); -static void print_comment (pretty_printer *, const char *); -static void print_generic_ada_decl (pretty_printer *, tree, - int (*)(tree, cpp_operation), const char *); -static char *get_ada_package (const char *); -static void dump_ada_nodes (pretty_printer *, const char *, - int (*)(tree, cpp_operation)); -static void reset_ada_withs (void); -static void dump_ada_withs (FILE *); -static void dump_ads (const char *, void (*)(const char *), - int (*)(tree, cpp_operation)); -static char *to_ada_name (const char *, int *); - -#define LOCATION_COL(LOC) ((expand_location (LOC)).column) - -#define INDENT(SPACE) do { \ - int i; for (i = 0; ifun_like) - { - param_len++; - for (i = 0; i < macro->paramc; i++) - { - cpp_hashnode *param = macro->params[i]; - - *param_len += NODE_LEN (param); - - if (i + 1 < macro->paramc) - { - *param_len += 2; /* ", " */ - } - else if (macro->variadic) - { - *supported = 0; - return; - } - } - *param_len += 2; /* ")\0" */ - } - - for (j = 0; j < macro->count; j++) - { - cpp_token *token = ¯o->exp.tokens[j]; - - if (token->flags & PREV_WHITE) - (*buffer_len)++; - - if (token->flags & STRINGIFY_ARG || token->flags & PASTE_LEFT) - { - *supported = 0; - return; - } - - if (token->type == CPP_MACRO_ARG) - *buffer_len += - NODE_LEN (macro->params[token->val.macro_arg.arg_no - 1]); - else - /* Include enough extra space to handle e.g. special characters. */ - *buffer_len += (cpp_token_len (token) + 1) * 8; - } - - (*buffer_len)++; -} - -/* Dump into PP a set of MAX_ADA_MACROS MACROS (C/C++) as Ada constants when - possible. */ - -static void -print_ada_macros (pretty_printer *pp, cpp_hashnode **macros, int max_ada_macros) -{ - int j, num_macros = 0, prev_line = -1; - - for (j = 0; j < max_ada_macros; j++) - { - cpp_hashnode *node = macros [j]; - const cpp_macro *macro = node->value.macro; - unsigned i; - int supported = 1, prev_is_one = 0, buffer_len, param_len; - int is_string = 0, is_char = 0; - char *ada_name; - unsigned char *s, *params, *buffer, *buf_param, *char_one = NULL; - - macro_length (macro, &supported, &buffer_len, ¶m_len); - s = buffer = XALLOCAVEC (unsigned char, buffer_len); - params = buf_param = XALLOCAVEC (unsigned char, param_len); - - if (supported) - { - if (macro->fun_like) - { - *buf_param++ = '('; - for (i = 0; i < macro->paramc; i++) - { - cpp_hashnode *param = macro->params[i]; - - memcpy (buf_param, NODE_NAME (param), NODE_LEN (param)); - buf_param += NODE_LEN (param); - - if (i + 1 < macro->paramc) - { - *buf_param++ = ','; - *buf_param++ = ' '; - } - else if (macro->variadic) - { - supported = 0; - break; - } - } - *buf_param++ = ')'; - *buf_param = '\0'; - } - - for (i = 0; supported && i < macro->count; i++) - { - cpp_token *token = ¯o->exp.tokens[i]; - int is_one = 0; - - if (token->flags & PREV_WHITE) - *buffer++ = ' '; - - if (token->flags & STRINGIFY_ARG || token->flags & PASTE_LEFT) - { - supported = 0; - break; - } - - switch (token->type) - { - case CPP_MACRO_ARG: - { - cpp_hashnode *param = - macro->params[token->val.macro_arg.arg_no - 1]; - memcpy (buffer, NODE_NAME (param), NODE_LEN (param)); - buffer += NODE_LEN (param); - } - break; - - case CPP_EQ_EQ: *buffer++ = '='; break; - case CPP_GREATER: *buffer++ = '>'; break; - case CPP_LESS: *buffer++ = '<'; break; - case CPP_PLUS: *buffer++ = '+'; break; - case CPP_MINUS: *buffer++ = '-'; break; - case CPP_MULT: *buffer++ = '*'; break; - case CPP_DIV: *buffer++ = '/'; break; - case CPP_COMMA: *buffer++ = ','; break; - case CPP_OPEN_SQUARE: - case CPP_OPEN_PAREN: *buffer++ = '('; break; - case CPP_CLOSE_SQUARE: /* fallthrough */ - case CPP_CLOSE_PAREN: *buffer++ = ')'; break; - case CPP_DEREF: /* fallthrough */ - case CPP_SCOPE: /* fallthrough */ - case CPP_DOT: *buffer++ = '.'; break; - - case CPP_EQ: *buffer++ = ':'; *buffer++ = '='; break; - case CPP_NOT_EQ: *buffer++ = '/'; *buffer++ = '='; break; - case CPP_GREATER_EQ: *buffer++ = '>'; *buffer++ = '='; break; - case CPP_LESS_EQ: *buffer++ = '<'; *buffer++ = '='; break; - - case CPP_NOT: - *buffer++ = 'n'; *buffer++ = 'o'; *buffer++ = 't'; break; - case CPP_MOD: - *buffer++ = 'm'; *buffer++ = 'o'; *buffer++ = 'd'; break; - case CPP_AND: - *buffer++ = 'a'; *buffer++ = 'n'; *buffer++ = 'd'; break; - case CPP_OR: - *buffer++ = 'o'; *buffer++ = 'r'; break; - case CPP_XOR: - *buffer++ = 'x'; *buffer++ = 'o'; *buffer++ = 'r'; break; - case CPP_AND_AND: - strcpy ((char *) buffer, " and then "); - buffer += 10; - break; - case CPP_OR_OR: - strcpy ((char *) buffer, " or else "); - buffer += 9; - break; - - case CPP_PADDING: - *buffer++ = ' '; - is_one = prev_is_one; - break; - - case CPP_COMMENT: break; - - case CPP_WSTRING: - case CPP_STRING16: - case CPP_STRING32: - case CPP_UTF8STRING: - case CPP_WCHAR: - case CPP_CHAR16: - case CPP_CHAR32: - case CPP_NAME: - case CPP_STRING: - case CPP_NUMBER: - if (!macro->fun_like) - supported = 0; - else - buffer = cpp_spell_token (parse_in, token, buffer, false); - break; - - case CPP_CHAR: - is_char = 1; - { - unsigned chars_seen; - int ignored; - cppchar_t c; - - c = cpp_interpret_charconst (parse_in, token, - &chars_seen, &ignored); - if (c >= 32 && c <= 126) - { - *buffer++ = '\''; - *buffer++ = (char) c; - *buffer++ = '\''; - } - else - { - chars_seen = sprintf - ((char *) buffer, "Character'Val (%d)", (int) c); - buffer += chars_seen; - } - } - break; - - case CPP_LSHIFT: - if (prev_is_one) - { - /* Replace "1 << N" by "2 ** N" */ - *char_one = '2'; - *buffer++ = '*'; - *buffer++ = '*'; - break; - } - /* fallthrough */ - - case CPP_RSHIFT: - case CPP_COMPL: - case CPP_QUERY: - case CPP_EOF: - case CPP_PLUS_EQ: - case CPP_MINUS_EQ: - case CPP_MULT_EQ: - case CPP_DIV_EQ: - case CPP_MOD_EQ: - case CPP_AND_EQ: - case CPP_OR_EQ: - case CPP_XOR_EQ: - case CPP_RSHIFT_EQ: - case CPP_LSHIFT_EQ: - case CPP_PRAGMA: - case CPP_PRAGMA_EOL: - case CPP_HASH: - case CPP_PASTE: - case CPP_OPEN_BRACE: - case CPP_CLOSE_BRACE: - case CPP_SEMICOLON: - case CPP_ELLIPSIS: - case CPP_PLUS_PLUS: - case CPP_MINUS_MINUS: - case CPP_DEREF_STAR: - case CPP_DOT_STAR: - case CPP_ATSIGN: - case CPP_HEADER_NAME: - case CPP_AT_NAME: - case CPP_OTHER: - case CPP_OBJC_STRING: - default: - if (!macro->fun_like) - supported = 0; - else - buffer = cpp_spell_token (parse_in, token, buffer, false); - break; - } - - prev_is_one = is_one; - } - - if (supported) - *buffer = '\0'; - } - - if (macro->fun_like && supported) - { - char *start = (char *) s; - int is_function = 0; - - pp_string (pp, " -- arg-macro: "); - - if (*start == '(' && buffer [-1] == ')') - { - start++; - buffer [-1] = '\0'; - is_function = 1; - pp_string (pp, "function "); - } - else - { - pp_string (pp, "procedure "); - } - - pp_string (pp, (const char *) NODE_NAME (node)); - pp_space (pp); - pp_string (pp, (char *) params); - pp_newline (pp); - pp_string (pp, " -- "); - - if (is_function) - { - pp_string (pp, "return "); - pp_string (pp, start); - pp_semicolon (pp); - } - else - pp_string (pp, start); - - pp_newline (pp); - } - else if (supported) - { - expanded_location sloc = expand_location (macro->line); - - if (sloc.line != prev_line + 1) - pp_newline (pp); - - num_macros++; - prev_line = sloc.line; - - pp_string (pp, " "); - ada_name = to_ada_name ((const char *) NODE_NAME (node), NULL); - pp_string (pp, ada_name); - free (ada_name); - pp_string (pp, " : "); - - if (is_string) - pp_string (pp, "aliased constant String"); - else if (is_char) - pp_string (pp, "aliased constant Character"); - else - pp_string (pp, "constant"); - - pp_string (pp, " := "); - pp_string (pp, (char *) s); - - if (is_string) - pp_string (pp, " & ASCII.NUL"); - - pp_string (pp, "; -- "); - pp_string (pp, sloc.file); - pp_character (pp, ':'); - pp_scalar (pp, "%d", sloc.line); - pp_newline (pp); - } - else - { - pp_string (pp, " -- unsupported macro: "); - pp_string (pp, (const char *) cpp_macro_definition (parse_in, node)); - pp_newline (pp); - } - } - - if (num_macros > 0) - pp_newline (pp); -} - -static const char *source_file; -static int max_ada_macros; - -/* Callback used to count the number of relevant macros from - cpp_forall_identifiers. PFILE and V are not used. NODE is the current macro - to consider. */ - -static int -count_ada_macro (cpp_reader *pfile ATTRIBUTE_UNUSED, cpp_hashnode *node, - void *v ATTRIBUTE_UNUSED) -{ - const cpp_macro *macro = node->value.macro; - - if (node->type == NT_MACRO && !(node->flags & NODE_BUILTIN) - && macro->count - && *NODE_NAME (node) != '_' - && LOCATION_FILE (macro->line) == source_file) - max_ada_macros++; - - return 1; -} - -static int store_ada_macro_index; - -/* Callback used to store relevant macros from cpp_forall_identifiers. - PFILE is not used. NODE is the current macro to store if relevant. - MACROS is an array of cpp_hashnode* used to store NODE. */ - -static int -store_ada_macro (cpp_reader *pfile ATTRIBUTE_UNUSED, - cpp_hashnode *node, void *macros) -{ - const cpp_macro *macro = node->value.macro; - - if (node->type == NT_MACRO && !(node->flags & NODE_BUILTIN) - && macro->count - && *NODE_NAME (node) != '_' - && LOCATION_FILE (macro->line) == source_file) - ((cpp_hashnode **) macros)[store_ada_macro_index++] = node; - - return 1; -} - -/* Callback used to compare (during qsort) macros. NODE1 and NODE2 are the - two macro nodes to compare. */ - -static int -compare_macro (const void *node1, const void *node2) -{ - typedef const cpp_hashnode *const_hnode; - - const_hnode n1 = *(const const_hnode *) node1; - const_hnode n2 = *(const const_hnode *) node2; - - return n1->value.macro->line - n2->value.macro->line; -} - -/* Dump in PP all relevant macros appearing in FILE. */ - -static void -dump_ada_macros (pretty_printer *pp, const char* file) -{ - cpp_hashnode **macros; - - /* Initialize file-scope variables. */ - max_ada_macros = 0; - store_ada_macro_index = 0; - source_file = file; - - /* Count all potentially relevant macros, and then sort them by sloc. */ - cpp_forall_identifiers (parse_in, count_ada_macro, NULL); - macros = XALLOCAVEC (cpp_hashnode *, max_ada_macros); - cpp_forall_identifiers (parse_in, store_ada_macro, macros); - qsort (macros, max_ada_macros, sizeof (cpp_hashnode *), compare_macro); - - print_ada_macros (pp, macros, max_ada_macros); -} - -/* Current source file being handled. */ - -static const char *source_file_base; - -/* Compare the declaration (DECL) of struct-like types based on the sloc of - their last field (if LAST is true), so that more nested types collate before - less nested ones. - If ORIG_TYPE is true, also consider struct with a DECL_ORIGINAL_TYPE. */ - -static location_t -decl_sloc_common (const_tree decl, bool last, bool orig_type) -{ - tree type = TREE_TYPE (decl); - - if (TREE_CODE (decl) == TYPE_DECL - && (orig_type || !DECL_ORIGINAL_TYPE (decl)) - && RECORD_OR_UNION_TYPE_P (type) - && TYPE_FIELDS (type)) - { - tree f = TYPE_FIELDS (type); - - if (last) - while (TREE_CHAIN (f)) - f = TREE_CHAIN (f); - - return DECL_SOURCE_LOCATION (f); - } - else - return DECL_SOURCE_LOCATION (decl); -} - -/* Return sloc of DECL, using sloc of last field if LAST is true. */ - -location_t -decl_sloc (const_tree decl, bool last) -{ - return decl_sloc_common (decl, last, false); -} - -/* Compare two declarations (LP and RP) by their source location. */ - -static int -compare_node (const void *lp, const void *rp) -{ - const_tree lhs = *((const tree *) lp); - const_tree rhs = *((const tree *) rp); - - return decl_sloc (lhs, true) - decl_sloc (rhs, true); -} - -/* Compare two comments (LP and RP) by their source location. */ - -static int -compare_comment (const void *lp, const void *rp) -{ - const cpp_comment *lhs = (const cpp_comment *) lp; - const cpp_comment *rhs = (const cpp_comment *) rp; - - if (LOCATION_FILE (lhs->sloc) != LOCATION_FILE (rhs->sloc)) - return strcmp (LOCATION_FILE (lhs->sloc), LOCATION_FILE (rhs->sloc)); - - if (LOCATION_LINE (lhs->sloc) != LOCATION_LINE (rhs->sloc)) - return LOCATION_LINE (lhs->sloc) - LOCATION_LINE (rhs->sloc); - - if (LOCATION_COL (lhs->sloc) != LOCATION_COL (rhs->sloc)) - return LOCATION_COL (lhs->sloc) - LOCATION_COL (rhs->sloc); - - return 0; -} - -static tree *to_dump = NULL; -static int to_dump_count = 0; - -/* Collect a list of declarations from T relevant to SOURCE_FILE to be dumped - by a subsequent call to dump_ada_nodes. */ - -void -collect_ada_nodes (tree t, const char *source_file) -{ - tree n; - int i = to_dump_count; - - /* Count the likely relevant nodes. */ - for (n = t; n; n = TREE_CHAIN (n)) - if (!DECL_IS_BUILTIN (n) - && LOCATION_FILE (decl_sloc (n, false)) == source_file) - to_dump_count++; - - /* Allocate sufficient storage for all nodes. */ - to_dump = XRESIZEVEC (tree, to_dump, to_dump_count); - - /* Store the relevant nodes. */ - for (n = t; n; n = TREE_CHAIN (n)) - if (!DECL_IS_BUILTIN (n) - && LOCATION_FILE (decl_sloc (n, false)) == source_file) - to_dump [i++] = n; -} - -/* Call back for walk_tree to clear the TREE_VISITED flag of TP. */ - -static tree -unmark_visited_r (tree *tp, int *walk_subtrees ATTRIBUTE_UNUSED, - void *data ATTRIBUTE_UNUSED) -{ - if (TREE_VISITED (*tp)) - TREE_VISITED (*tp) = 0; - else - *walk_subtrees = 0; - - return NULL_TREE; -} - -/* Dump nodes into PP relevant to SOURCE_FILE, as collected by previous calls - to collect_ada_nodes. CPP_CHECK is used to perform C++ queries on nodes. */ - -static void -dump_ada_nodes (pretty_printer *pp, const char *source_file, - int (*cpp_check)(tree, cpp_operation)) -{ - int i, j; - cpp_comment_table *comments; - - /* Sort the table of declarations to dump by sloc. */ - qsort (to_dump, to_dump_count, sizeof (tree), compare_node); - - /* Fetch the table of comments. */ - comments = cpp_get_comments (parse_in); - - /* Sort the comments table by sloc. */ - qsort (comments->entries, comments->count, sizeof (cpp_comment), - compare_comment); - - /* Interleave comments and declarations in line number order. */ - i = j = 0; - do - { - /* Advance j until comment j is in this file. */ - while (j != comments->count - && LOCATION_FILE (comments->entries[j].sloc) != source_file) - j++; - - /* Advance j until comment j is not a duplicate. */ - while (j < comments->count - 1 - && !compare_comment (&comments->entries[j], - &comments->entries[j + 1])) - j++; - - /* Write decls until decl i collates after comment j. */ - while (i != to_dump_count) - { - if (j == comments->count - || LOCATION_LINE (decl_sloc (to_dump[i], false)) - < LOCATION_LINE (comments->entries[j].sloc)) - print_generic_ada_decl (pp, to_dump[i++], cpp_check, source_file); - else - break; - } - - /* Write comment j, if there is one. */ - if (j != comments->count) - print_comment (pp, comments->entries[j++].comment); - - } while (i != to_dump_count || j != comments->count); - - /* Clear the TREE_VISITED flag over each subtree we've dumped. */ - for (i = 0; i < to_dump_count; i++) - walk_tree (&to_dump[i], unmark_visited_r, NULL, NULL); - - /* Finalize the to_dump table. */ - if (to_dump) - { - free (to_dump); - to_dump = NULL; - to_dump_count = 0; - } -} - -/* Print a COMMENT to the output stream PP. */ - -static void -print_comment (pretty_printer *pp, const char *comment) -{ - int len = strlen (comment); - char *str = XALLOCAVEC (char, len + 1); - char *tok; - bool extra_newline = false; - - memcpy (str, comment, len + 1); - - /* Trim C/C++ comment indicators. */ - if (str[len - 2] == '*' && str[len - 1] == '/') - { - str[len - 2] = ' '; - str[len - 1] = '\0'; - } - str += 2; - - tok = strtok (str, "\n"); - while (tok) { - pp_string (pp, " --"); - pp_string (pp, tok); - pp_newline (pp); - tok = strtok (NULL, "\n"); - - /* Leave a blank line after multi-line comments. */ - if (tok) - extra_newline = true; - } - - if (extra_newline) - pp_newline (pp); -} - -/* Prints declaration DECL to PP in Ada syntax. The current source file being - handled is SOURCE_FILE, and CPP_CHECK is used to perform C++ queries on - nodes. */ - -static void -print_generic_ada_decl (pretty_printer *pp, tree decl, - int (*cpp_check)(tree, cpp_operation), - const char* source_file) -{ - source_file_base = source_file; - - if (print_ada_declaration (pp, decl, 0, cpp_check, INDENT_INCR)) - { - pp_newline (pp); - pp_newline (pp); - } -} - -/* Dump a newline and indent BUFFER by SPC chars. */ - -static void -newline_and_indent (pretty_printer *buffer, int spc) -{ - pp_newline (buffer); - INDENT (spc); -} - -struct with { char *s; const char *in_file; int limited; }; -static struct with *withs = NULL; -static int withs_max = 4096; -static int with_len = 0; - -/* Record a "with" clause on package S (a limited with if LIMITED_ACCESS is - true), if not already done. */ - -static void -append_withs (const char *s, int limited_access) -{ - int i; - - if (withs == NULL) - withs = XNEWVEC (struct with, withs_max); - - if (with_len == withs_max) - { - withs_max *= 2; - withs = XRESIZEVEC (struct with, withs, withs_max); - } - - for (i = 0; i < with_len; i++) - if (!strcmp (s, withs [i].s) - && source_file_base == withs [i].in_file) - { - withs [i].limited &= limited_access; - return; - } - - withs [with_len].s = xstrdup (s); - withs [with_len].in_file = source_file_base; - withs [with_len].limited = limited_access; - with_len++; -} - -/* Reset "with" clauses. */ - -static void -reset_ada_withs (void) -{ - int i; - - if (!withs) - return; - - for (i = 0; i < with_len; i++) - free (withs [i].s); - free (withs); - withs = NULL; - withs_max = 4096; - with_len = 0; -} - -/* Dump "with" clauses in F. */ - -static void -dump_ada_withs (FILE *f) -{ - int i; - - fprintf (f, "with Interfaces.C; use Interfaces.C;\n"); - - for (i = 0; i < with_len; i++) - fprintf - (f, "%swith %s;\n", withs [i].limited ? "limited " : "", withs [i].s); -} - -/* Return suitable Ada package name from FILE. */ - -static char * -get_ada_package (const char *file) -{ - const char *base; - char *res; - const char *s; - int i; - - s = strstr (file, "/include/"); - if (s) - base = s + 9; - else - base = lbasename (file); - res = XNEWVEC (char, strlen (base) + 1); - - for (i = 0; *base; base++, i++) - switch (*base) - { - case '+': - res [i] = 'p'; - break; - - case '.': - case '-': - case '_': - case '/': - case '\\': - res [i] = (i == 0 || res [i - 1] == '_') ? 'u' : '_'; - break; - - default: - res [i] = *base; - break; - } - res [i] = '\0'; - - return res; -} - -static const char *ada_reserved[] = { - "abort", "abs", "abstract", "accept", "access", "aliased", "all", "and", - "array", "at", "begin", "body", "case", "constant", "declare", "delay", - "delta", "digits", "do", "else", "elsif", "end", "entry", "exception", - "exit", "for", "function", "generic", "goto", "if", "in", "interface", "is", - "limited", "loop", "mod", "new", "not", "null", "others", "out", "of", "or", - "overriding", "package", "pragma", "private", "procedure", "protected", - "raise", "range", "record", "rem", "renames", "requeue", "return", "reverse", - "select", "separate", "subtype", "synchronized", "tagged", "task", - "terminate", "then", "type", "until", "use", "when", "while", "with", "xor", - NULL}; - -/* ??? would be nice to specify this list via a config file, so that users - can create their own dictionary of conflicts. */ -static const char *c_duplicates[] = { - /* system will cause troubles with System.Address. */ - "system", - - /* The following values have other definitions with same name/other - casing. */ - "funmap", - "rl_vi_fWord", - "rl_vi_bWord", - "rl_vi_eWord", - "rl_readline_version", - "_Vx_ushort", - "USHORT", - "XLookupKeysym", - NULL}; - -/* Return a declaration tree corresponding to TYPE. */ - -static tree -get_underlying_decl (tree type) -{ - tree decl = NULL_TREE; - - if (type == NULL_TREE) - return NULL_TREE; - - /* type is a declaration. */ - if (DECL_P (type)) - decl = type; - - /* type is a typedef. */ - if (TYPE_P (type) && TYPE_NAME (type) && DECL_P (TYPE_NAME (type))) - decl = TYPE_NAME (type); - - /* TYPE_STUB_DECL has been set for type. */ - if (TYPE_P (type) && TYPE_STUB_DECL (type) && - DECL_P (TYPE_STUB_DECL (type))) - decl = TYPE_STUB_DECL (type); - - return decl; -} - -/* Return whether TYPE has static fields. */ - -static int -has_static_fields (const_tree type) -{ - tree tmp; - - for (tmp = TYPE_FIELDS (type); tmp; tmp = TREE_CHAIN (tmp)) - { - if (DECL_NAME (tmp) && TREE_STATIC (tmp)) - return true; - } - return false; -} - -/* Return whether TYPE corresponds to an Ada tagged type (has a dispatch - table). */ - -static int -is_tagged_type (const_tree type) -{ - tree tmp; - - if (!type || !RECORD_OR_UNION_TYPE_P (type)) - return false; - - for (tmp = TYPE_METHODS (type); tmp; tmp = TREE_CHAIN (tmp)) - if (DECL_VINDEX (tmp)) - return true; - - return false; -} - -/* Generate a legal Ada name from a C NAME, returning a malloc'd string. - SPACE_FOUND, if not NULL, is used to indicate whether a space was found in - NAME. */ - -static char * -to_ada_name (const char *name, int *space_found) -{ - const char **names; - int len = strlen (name); - int j, len2 = 0; - int found = false; - char *s = XNEWVEC (char, len * 2 + 5); - char c; - - if (space_found) - *space_found = false; - - /* Add trailing "c_" if name is an Ada reserved word. */ - for (names = ada_reserved; *names; names++) - if (!strcasecmp (name, *names)) - { - s [len2++] = 'c'; - s [len2++] = '_'; - found = true; - break; - } - - if (!found) - /* Add trailing "c_" if name is an potential case sensitive duplicate. */ - for (names = c_duplicates; *names; names++) - if (!strcmp (name, *names)) - { - s [len2++] = 'c'; - s [len2++] = '_'; - found = true; - break; - } - - for (j = 0; name [j] == '_'; j++) - s [len2++] = 'u'; - - if (j > 0) - s [len2++] = '_'; - else if (*name == '.' || *name == '$') - { - s [0] = 'a'; - s [1] = 'n'; - s [2] = 'o'; - s [3] = 'n'; - len2 = 4; - j++; - } - - /* Replace unsuitable characters for Ada identifiers. */ - - for (; j < len; j++) - switch (name [j]) - { - case ' ': - if (space_found) - *space_found = true; - s [len2++] = '_'; - break; - - /* ??? missing some C++ operators. */ - case '=': - s [len2++] = '_'; - - if (name [j + 1] == '=') - { - j++; - s [len2++] = 'e'; - s [len2++] = 'q'; - } - else - { - s [len2++] = 'a'; - s [len2++] = 's'; - } - break; - - case '!': - s [len2++] = '_'; - if (name [j + 1] == '=') - { - j++; - s [len2++] = 'n'; - s [len2++] = 'e'; - } - break; - - case '~': - s [len2++] = '_'; - s [len2++] = 't'; - s [len2++] = 'i'; - break; - - case '&': - case '|': - case '^': - s [len2++] = '_'; - s [len2++] = name [j] == '&' ? 'a' : name [j] == '|' ? 'o' : 'x'; - - if (name [j + 1] == '=') - { - j++; - s [len2++] = 'e'; - } - break; - - case '+': - case '-': - case '*': - case '/': - case '(': - case '[': - if (s [len2 - 1] != '_') - s [len2++] = '_'; - - switch (name [j + 1]) { - case '\0': - j++; - switch (name [j - 1]) { - case '+': s [len2++] = 'p'; break; /* + */ - case '-': s [len2++] = 'm'; break; /* - */ - case '*': s [len2++] = 't'; break; /* * */ - case '/': s [len2++] = 'd'; break; /* / */ - } - break; - - case '=': - j++; - switch (name [j - 1]) { - case '+': s [len2++] = 'p'; break; /* += */ - case '-': s [len2++] = 'm'; break; /* -= */ - case '*': s [len2++] = 't'; break; /* *= */ - case '/': s [len2++] = 'd'; break; /* /= */ - } - s [len2++] = 'a'; - break; - - case '-': /* -- */ - j++; - s [len2++] = 'm'; - s [len2++] = 'm'; - break; - - case '+': /* ++ */ - j++; - s [len2++] = 'p'; - s [len2++] = 'p'; - break; - - case ')': /* () */ - j++; - s [len2++] = 'o'; - s [len2++] = 'p'; - break; - - case ']': /* [] */ - j++; - s [len2++] = 'o'; - s [len2++] = 'b'; - break; - } - - break; - - case '<': - case '>': - c = name [j] == '<' ? 'l' : 'g'; - s [len2++] = '_'; - - switch (name [j + 1]) { - case '\0': - s [len2++] = c; - s [len2++] = 't'; - break; - case '=': - j++; - s [len2++] = c; - s [len2++] = 'e'; - break; - case '>': - j++; - s [len2++] = 's'; - s [len2++] = 'r'; - break; - case '<': - j++; - s [len2++] = 's'; - s [len2++] = 'l'; - break; - default: - break; - } - break; - - case '_': - if (len2 && s [len2 - 1] == '_') - s [len2++] = 'u'; - /* fall through */ - - default: - s [len2++] = name [j]; - } - - if (s [len2 - 1] == '_') - s [len2++] = 'u'; - - s [len2] = '\0'; - - return s; -} - -static bool package_prefix = true; - -/* Dump in BUFFER the name of an identifier NODE of type TYPE, following Ada - syntax. LIMITED_ACCESS indicates whether NODE can be accessed via a limited - 'with' clause rather than a regular 'with' clause. */ - -static void -pp_ada_tree_identifier (pretty_printer *buffer, tree node, tree type, - int limited_access) -{ - const char *name = IDENTIFIER_POINTER (node); - int space_found = false; - char *s = to_ada_name (name, &space_found); - tree decl; - - /* If the entity is a type and comes from another file, generate "package" - prefix. */ - - decl = get_underlying_decl (type); - - if (decl) - { - expanded_location xloc = expand_location (decl_sloc (decl, false)); - - if (xloc.file && xloc.line) - { - if (xloc.file != source_file_base) - { - switch (TREE_CODE (type)) - { - case ENUMERAL_TYPE: - case INTEGER_TYPE: - case REAL_TYPE: - case FIXED_POINT_TYPE: - case BOOLEAN_TYPE: - case REFERENCE_TYPE: - case POINTER_TYPE: - case ARRAY_TYPE: - case RECORD_TYPE: - case UNION_TYPE: - case QUAL_UNION_TYPE: - case TYPE_DECL: - { - char *s1 = get_ada_package (xloc.file); - - if (package_prefix) - { - append_withs (s1, limited_access); - pp_string (buffer, s1); - pp_character (buffer, '.'); - } - free (s1); - } - break; - default: - break; - } - } - } - } - - if (space_found) - if (!strcmp (s, "short_int")) - pp_string (buffer, "short"); - else if (!strcmp (s, "short_unsigned_int")) - pp_string (buffer, "unsigned_short"); - else if (!strcmp (s, "unsigned_int")) - pp_string (buffer, "unsigned"); - else if (!strcmp (s, "long_int")) - pp_string (buffer, "long"); - else if (!strcmp (s, "long_unsigned_int")) - pp_string (buffer, "unsigned_long"); - else if (!strcmp (s, "long_long_int")) - pp_string (buffer, "Long_Long_Integer"); - else if (!strcmp (s, "long_long_unsigned_int")) - { - if (package_prefix) - { - append_withs ("Interfaces.C.Extensions", false); - pp_string (buffer, "Extensions.unsigned_long_long"); - } - else - pp_string (buffer, "unsigned_long_long"); - } - else - pp_string(buffer, s); - else - if (!strcmp (s, "bool")) - { - if (package_prefix) - { - append_withs ("Interfaces.C.Extensions", false); - pp_string (buffer, "Extensions.bool"); - } - else - pp_string (buffer, "bool"); - } - else - pp_string(buffer, s); - - free (s); -} - -/* Dump in BUFFER the assembly name of T. */ - -static void -pp_asm_name (pretty_printer *buffer, tree t) -{ - tree name = DECL_ASSEMBLER_NAME (t); - char *ada_name = XALLOCAVEC (char, IDENTIFIER_LENGTH (name) + 1), *s; - const char *ident = IDENTIFIER_POINTER (name); - - for (s = ada_name; *ident; ident++) - { - if (*ident == ' ') - break; - else if (*ident != '*') - *s++ = *ident; - } - - *s = '\0'; - pp_string (buffer, ada_name); -} - -/* Dump in BUFFER the name of a DECL node if set, following Ada syntax. - LIMITED_ACCESS indicates whether NODE can be accessed via a limited - 'with' clause rather than a regular 'with' clause. */ - -static void -dump_ada_decl_name (pretty_printer *buffer, tree decl, int limited_access) -{ - if (DECL_NAME (decl)) - pp_ada_tree_identifier (buffer, DECL_NAME (decl), decl, limited_access); - else - { - tree type_name = TYPE_NAME (TREE_TYPE (decl)); - - if (!type_name) - { - pp_string (buffer, "anon"); - if (TREE_CODE (decl) == FIELD_DECL) - pp_scalar (buffer, "%d", DECL_UID (decl)); - else - pp_scalar (buffer, "%d", TYPE_UID (TREE_TYPE (decl))); - } - else if (TREE_CODE (type_name) == IDENTIFIER_NODE) - pp_ada_tree_identifier (buffer, type_name, decl, limited_access); - } -} - -/* Dump in BUFFER a name based on both T1 and T2, followed by S. */ - -static void -dump_ada_double_name (pretty_printer *buffer, tree t1, tree t2, const char *s) -{ - if (DECL_NAME (t1)) - pp_ada_tree_identifier (buffer, DECL_NAME (t1), t1, false); - else - { - pp_string (buffer, "anon"); - pp_scalar (buffer, "%d", TYPE_UID (TREE_TYPE (t1))); - } - - pp_character (buffer, '_'); - - if (DECL_NAME (t1)) - pp_ada_tree_identifier (buffer, DECL_NAME (t2), t2, false); - else - { - pp_string (buffer, "anon"); - pp_scalar (buffer, "%d", TYPE_UID (TREE_TYPE (t2))); - } - - pp_string (buffer, s); -} - -/* Dump in BUFFER pragma Import C/CPP on a given node T. */ - -static void -dump_ada_import (pretty_printer *buffer, tree t) -{ - const char *name = IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (t)); - int is_stdcall = TREE_CODE (t) == FUNCTION_DECL && - lookup_attribute ("stdcall", TYPE_ATTRIBUTES (TREE_TYPE (t))); - - if (is_stdcall) - pp_string (buffer, "pragma Import (Stdcall, "); - else if (name [0] == '_' && name [1] == 'Z') - pp_string (buffer, "pragma Import (CPP, "); - else - pp_string (buffer, "pragma Import (C, "); - - dump_ada_decl_name (buffer, t, false); - pp_string (buffer, ", \""); - - if (is_stdcall) - pp_string (buffer, IDENTIFIER_POINTER (DECL_NAME (t))); - else - pp_asm_name (buffer, t); - - pp_string (buffer, "\");"); -} - -/* Check whether T and its type have different names, and append "the_" - otherwise in BUFFER. */ - -static void -check_name (pretty_printer *buffer, tree t) -{ - const char *s; - tree tmp = TREE_TYPE (t); - - while (TREE_CODE (tmp) == POINTER_TYPE && !TYPE_NAME (tmp)) - tmp = TREE_TYPE (tmp); - - if (TREE_CODE (tmp) != FUNCTION_TYPE) - { - if (TREE_CODE (tmp) == IDENTIFIER_NODE) - s = IDENTIFIER_POINTER (tmp); - else if (!TYPE_NAME (tmp)) - s = ""; - else if (TREE_CODE (TYPE_NAME (tmp)) == IDENTIFIER_NODE) - s = IDENTIFIER_POINTER (TYPE_NAME (tmp)); - else - s = IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME (tmp))); - - if (!strcasecmp (IDENTIFIER_POINTER (DECL_NAME (t)), s)) - pp_string (buffer, "the_"); - } -} - -/* Dump in BUFFER a function declaration FUNC with Ada syntax. - IS_METHOD indicates whether FUNC is a C++ method. - IS_CONSTRUCTOR whether FUNC is a C++ constructor. - IS_DESTRUCTOR whether FUNC is a C++ destructor. - SPC is the current indentation level. */ - -static int -dump_ada_function_declaration (pretty_printer *buffer, tree func, - int is_method, int is_constructor, - int is_destructor, int spc) -{ - tree arg; - const tree node = TREE_TYPE (func); - char buf [16]; - int num = 0, num_args = 0, have_args = true, have_ellipsis = false; - - /* Compute number of arguments. */ - arg = TYPE_ARG_TYPES (node); - - if (arg) - { - while (TREE_CHAIN (arg) && arg != error_mark_node) - { - num_args++; - arg = TREE_CHAIN (arg); - } - - if (TREE_CODE (TREE_VALUE (arg)) != VOID_TYPE) - { - num_args++; - have_ellipsis = true; - } - } - - if (is_constructor) - num_args--; - - if (is_destructor) - num_args = 1; - - if (num_args > 2) - newline_and_indent (buffer, spc + 1); - - if (num_args > 0) - { - pp_space (buffer); - pp_character (buffer, '('); - } - - if (TREE_CODE (func) == FUNCTION_DECL) - arg = DECL_ARGUMENTS (func); - else - arg = NULL_TREE; - - if (arg == NULL_TREE) - { - have_args = false; - arg = TYPE_ARG_TYPES (node); - - if (arg && TREE_CODE (TREE_VALUE (arg)) == VOID_TYPE) - arg = NULL_TREE; - } - - if (is_constructor) - arg = TREE_CHAIN (arg); - - /* Print the argument names (if available) & types. */ - - for (num = 1; num <= num_args; num++) - { - if (have_args) - { - if (DECL_NAME (arg)) - { - check_name (buffer, arg); - pp_ada_tree_identifier (buffer, DECL_NAME (arg), 0, false); - pp_string (buffer, " : "); - } - else - { - sprintf (buf, "arg%d : ", num); - pp_string (buffer, buf); - } - - dump_generic_ada_node - (buffer, TREE_TYPE (arg), node, NULL, spc, 0, true); - } - else - { - sprintf (buf, "arg%d : ", num); - pp_string (buffer, buf); - dump_generic_ada_node - (buffer, TREE_VALUE (arg), node, NULL, spc, 0, true); - } - - if (TREE_TYPE (arg) && TREE_TYPE (TREE_TYPE (arg)) - && is_tagged_type (TREE_TYPE (TREE_TYPE (arg)))) - { - if (!is_method - || (num != 1 || (!DECL_VINDEX (func) && !is_constructor))) - pp_string (buffer, "'Class"); - } - - arg = TREE_CHAIN (arg); - - if (num < num_args) - { - pp_character (buffer, ';'); - - if (num_args > 2) - newline_and_indent (buffer, spc + INDENT_INCR); - else - pp_space (buffer); - } - } - - if (have_ellipsis) - { - pp_string (buffer, " -- , ..."); - newline_and_indent (buffer, spc + INDENT_INCR); - } - - if (num_args > 0) - pp_character (buffer, ')'); - return num_args; -} - -/* Dump in BUFFER all the domains associated with an array NODE, - using Ada syntax. SPC is the current indentation level. */ - -static void -dump_ada_array_domains (pretty_printer *buffer, tree node, int spc) -{ - int first = 1; - pp_character (buffer, '('); - - for (; TREE_CODE (node) == ARRAY_TYPE; node = TREE_TYPE (node)) - { - tree domain = TYPE_DOMAIN (node); - - if (domain) - { - tree min = TYPE_MIN_VALUE (domain); - tree max = TYPE_MAX_VALUE (domain); - - if (!first) - pp_string (buffer, ", "); - first = 0; - - if (min) - dump_generic_ada_node (buffer, min, NULL_TREE, NULL, spc, 0, true); - pp_string (buffer, " .. "); - - /* If the upper bound is zero, gcc may generate a NULL_TREE - for TYPE_MAX_VALUE rather than an integer_cst. */ - if (max) - dump_generic_ada_node (buffer, max, NULL_TREE, NULL, spc, 0, true); - else - pp_string (buffer, "0"); - } - else - pp_string (buffer, "size_t"); - } - pp_character (buffer, ')'); -} - -/* Dump in BUFFER file:line:col information related to NODE. */ - -static void -dump_sloc (pretty_printer *buffer, tree node) -{ - expanded_location xloc; - - xloc.file = NULL; - - if (TREE_CODE_CLASS (TREE_CODE (node)) == tcc_declaration) - xloc = expand_location (DECL_SOURCE_LOCATION (node)); - else if (EXPR_HAS_LOCATION (node)) - xloc = expand_location (EXPR_LOCATION (node)); - - if (xloc.file) - { - pp_string (buffer, xloc.file); - pp_string (buffer, ":"); - pp_decimal_int (buffer, xloc.line); - pp_string (buffer, ":"); - pp_decimal_int (buffer, xloc.column); - } -} - -/* Return true if T designates a one dimension array of "char". */ - -static bool -is_char_array (tree t) -{ - tree tmp; - int num_dim = 0; - - /* Retrieve array's type. */ - tmp = t; - while (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE) - { - num_dim++; - tmp = TREE_TYPE (tmp); - } - - tmp = TREE_TYPE (tmp); - return num_dim == 1 && TREE_CODE (tmp) == INTEGER_TYPE - && !strcmp (IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME (tmp))), "char"); -} - -/* Dump in BUFFER an array type T in Ada syntax. Assume that the "type" - keyword and name have already been printed. SPC is the indentation - level. */ - -static void -dump_ada_array_type (pretty_printer *buffer, tree t, int spc) -{ - tree tmp; - bool char_array = is_char_array (t); - - /* Special case char arrays. */ - if (char_array) - { - pp_string (buffer, "Interfaces.C.char_array "); - } - else - pp_string (buffer, "array "); - - /* Print the dimensions. */ - dump_ada_array_domains (buffer, TREE_TYPE (t), spc); - - /* Retrieve array's type. */ - tmp = TREE_TYPE (t); - while (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE) - tmp = TREE_TYPE (tmp); - - /* Print array's type. */ - if (!char_array) - { - pp_string (buffer, " of "); - - if (TREE_CODE (TREE_TYPE (tmp)) != POINTER_TYPE) - pp_string (buffer, "aliased "); - - dump_generic_ada_node - (buffer, TREE_TYPE (tmp), TREE_TYPE (t), NULL, spc, false, true); - } -} - -/* Dump in BUFFER type names associated with a template, each prepended with - '_'. TYPES is the TREE_PURPOSE of a DECL_TEMPLATE_INSTANTIATIONS. - CPP_CHECK is used to perform C++ queries on nodes. - SPC is the indentation level. */ - -static void -dump_template_types (pretty_printer *buffer, tree types, - int (*cpp_check)(tree, cpp_operation), int spc) -{ - size_t i; - size_t len = TREE_VEC_LENGTH (types); - - for (i = 0; i < len; i++) - { - tree elem = TREE_VEC_ELT (types, i); - pp_character (buffer, '_'); - if (!dump_generic_ada_node (buffer, elem, 0, cpp_check, spc, false, true)) - { - pp_string (buffer, "unknown"); - pp_scalar (buffer, "%lu", (unsigned long) TREE_HASH (elem)); - } - } -} - -/* Dump in BUFFER the contents of all instantiations associated with a given - template T. CPP_CHECK is used to perform C++ queries on nodes. - SPC is the indentation level. */ - -static int -dump_ada_template (pretty_printer *buffer, tree t, - int (*cpp_check)(tree, cpp_operation), int spc) -{ - tree inst = DECL_VINDEX (t); - /* DECL_VINDEX is DECL_TEMPLATE_INSTANTIATIONS in this context. */ - int num_inst = 0; - - while (inst && inst != error_mark_node) - { - tree types = TREE_PURPOSE (inst); - tree instance = TREE_VALUE (inst); - - if (TREE_VEC_LENGTH (types) == 0) - break; - - if (!TYPE_METHODS (instance)) - break; - - num_inst++; - INDENT (spc); - pp_string (buffer, "package "); - package_prefix = false; - dump_generic_ada_node (buffer, instance, t, cpp_check, spc, false, true); - dump_template_types (buffer, types, cpp_check, spc); - pp_string (buffer, " is"); - spc += INDENT_INCR; - newline_and_indent (buffer, spc); - - pp_string (buffer, "type "); - dump_generic_ada_node (buffer, instance, t, cpp_check, spc, false, true); - package_prefix = true; - - if (is_tagged_type (instance)) - pp_string (buffer, " is tagged limited "); - else - pp_string (buffer, " is limited "); - - dump_generic_ada_node (buffer, instance, t, cpp_check, spc, false, false); - pp_newline (buffer); - spc -= INDENT_INCR; - newline_and_indent (buffer, spc); - - pp_string (buffer, "end;"); - newline_and_indent (buffer, spc); - pp_string (buffer, "use "); - package_prefix = false; - dump_generic_ada_node (buffer, instance, t, cpp_check, spc, false, true); - dump_template_types (buffer, types, cpp_check, spc); - package_prefix = true; - pp_semicolon (buffer); - pp_newline (buffer); - pp_newline (buffer); - - inst = TREE_CHAIN (inst); - } - - return num_inst > 0; -} - -static bool in_function = true; -static bool bitfield_used = false; - -/* Recursively dump in BUFFER Ada declarations corresponding to NODE of type - TYPE. CPP_CHECK is used to perform C++ queries on nodes. SPC is the - indentation level. LIMITED_ACCESS indicates whether NODE can be referenced - via a "limited with" clause. NAME_ONLY indicates whether we should only - dump the name of NODE, instead of its full declaration. */ - -static int -dump_generic_ada_node (pretty_printer *buffer, tree node, tree type, - int (*cpp_check)(tree, cpp_operation), int spc, - int limited_access, bool name_only) -{ - if (node == NULL_TREE) - return 0; - - switch (TREE_CODE (node)) - { - case ERROR_MARK: - pp_string (buffer, "<<< error >>>"); - return 0; - - case IDENTIFIER_NODE: - pp_ada_tree_identifier (buffer, node, type, limited_access); - break; - - case TREE_LIST: - pp_string (buffer, "--- unexpected node: TREE_LIST"); - return 0; - - case TREE_BINFO: - dump_generic_ada_node - (buffer, BINFO_TYPE (node), type, cpp_check, - spc, limited_access, name_only); - - case TREE_VEC: - pp_string (buffer, "--- unexpected node: TREE_VEC"); - return 0; - - case VOID_TYPE: - if (package_prefix) - { - append_withs ("System", false); - pp_string (buffer, "System.Address"); - } - else - pp_string (buffer, "address"); - break; - - case VECTOR_TYPE: - pp_string (buffer, ""); - break; - - case COMPLEX_TYPE: - pp_string (buffer, ""); - break; - - case ENUMERAL_TYPE: - if (name_only) - dump_generic_ada_node - (buffer, TYPE_NAME (node), node, cpp_check, spc, 0, true); - else - { - tree value; - - pp_string (buffer, "unsigned"); - - for (value = TYPE_VALUES (node); value; value = TREE_CHAIN (value)) - { - pp_semicolon (buffer); - newline_and_indent (buffer, spc); - - pp_ada_tree_identifier - (buffer, TREE_PURPOSE (value), node, false); - pp_string (buffer, " : constant "); - - dump_generic_ada_node - (buffer, DECL_NAME (type) ? type : TYPE_NAME (node), type, - cpp_check, spc, 0, true); - - pp_string (buffer, " := "); - dump_generic_ada_node - (buffer, - TREE_CODE (TREE_VALUE (value)) == INTEGER_CST ? - TREE_VALUE (value) : DECL_INITIAL (TREE_VALUE (value)), - node, - cpp_check, spc, false, true); - } - } - break; - - case INTEGER_TYPE: - case REAL_TYPE: - case FIXED_POINT_TYPE: - case BOOLEAN_TYPE: - { - enum tree_code_class tclass; - - tclass = TREE_CODE_CLASS (TREE_CODE (node)); - - if (tclass == tcc_declaration) - { - if (DECL_NAME (node)) - pp_ada_tree_identifier - (buffer, DECL_NAME (node), 0, limited_access); - else - pp_string (buffer, ""); - } - else if (tclass == tcc_type) - { - if (TYPE_NAME (node)) - { - if (TREE_CODE (TYPE_NAME (node)) == IDENTIFIER_NODE) - pp_ada_tree_identifier (buffer, TYPE_NAME (node), - node, limited_access); - else if (TREE_CODE (TYPE_NAME (node)) == TYPE_DECL - && DECL_NAME (TYPE_NAME (node))) - dump_ada_decl_name (buffer, TYPE_NAME (node), limited_access); - else - pp_string (buffer, ""); - } - else if (TREE_CODE (node) == INTEGER_TYPE) - { - append_withs ("Interfaces.C.Extensions", false); - bitfield_used = true; - - if (TYPE_PRECISION (node) == 1) - pp_string (buffer, "Extensions.Unsigned_1"); - else - { - pp_string (buffer, (TYPE_UNSIGNED (node) - ? "Extensions.Unsigned_" - : "Extensions.Signed_")); - pp_decimal_int (buffer, TYPE_PRECISION (node)); - } - } - else - pp_string (buffer, ""); - } - break; - } - - case POINTER_TYPE: - case REFERENCE_TYPE: - if (TREE_CODE (TREE_TYPE (node)) == FUNCTION_TYPE) - { - tree fnode = TREE_TYPE (node); - bool is_function; - bool prev_in_function = in_function; - - if (VOID_TYPE_P (TREE_TYPE (fnode))) - { - is_function = false; - pp_string (buffer, "access procedure"); - } - else - { - is_function = true; - pp_string (buffer, "access function"); - } - - in_function = is_function; - dump_ada_function_declaration - (buffer, node, false, false, false, spc + INDENT_INCR); - in_function = prev_in_function; - - if (is_function) - { - pp_string (buffer, " return "); - dump_generic_ada_node - (buffer, TREE_TYPE (fnode), type, cpp_check, spc, 0, true); - } - } - else - { - int is_access = false; - unsigned int quals = TYPE_QUALS (TREE_TYPE (node)); - - if (name_only && TYPE_NAME (node)) - dump_generic_ada_node - (buffer, TYPE_NAME (node), node, cpp_check, - spc, limited_access, true); - else if (VOID_TYPE_P (TREE_TYPE (node))) - { - if (!name_only) - pp_string (buffer, "new "); - if (package_prefix) - { - append_withs ("System", false); - pp_string (buffer, "System.Address"); - } - else - pp_string (buffer, "address"); - } - else - { - if (TREE_CODE (node) == POINTER_TYPE - && TREE_CODE (TREE_TYPE (node)) == INTEGER_TYPE - && !strcmp - (IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME - (TREE_TYPE (node)))), "char")) - { - if (!name_only) - pp_string (buffer, "new "); - - if (package_prefix) - { - pp_string (buffer, "Interfaces.C.Strings.chars_ptr"); - append_withs ("Interfaces.C.Strings", false); - } - else - pp_string (buffer, "chars_ptr"); - } - else - { - /* For now, handle all access-to-access or - access-to-unknown-structs as opaque system.address. */ - - tree typ = TYPE_NAME (TREE_TYPE (node)); - const_tree typ2 = !type || - DECL_P (type) ? type : TYPE_NAME (type); - const_tree underlying_type = - get_underlying_decl (TREE_TYPE (node)); - - if (TREE_CODE (TREE_TYPE (node)) == POINTER_TYPE - /* Pointer to pointer. */ - - || (RECORD_OR_UNION_TYPE_P (TREE_TYPE (node)) - && (!underlying_type - || !TYPE_FIELDS (TREE_TYPE (underlying_type)))) - /* Pointer to opaque structure. */ - - || (typ && typ2 - && DECL_P (underlying_type) - && DECL_P (typ2) - && decl_sloc (underlying_type, true) - > decl_sloc (typ2, true) - && DECL_SOURCE_FILE (underlying_type) - == DECL_SOURCE_FILE (typ2))) - { - if (package_prefix) - { - append_withs ("System", false); - if (!name_only) - pp_string (buffer, "new "); - pp_string (buffer, "System.Address"); - } - else - pp_string (buffer, "address"); - return spc; - } - - if (!package_prefix) - pp_string (buffer, "access"); - else if (AGGREGATE_TYPE_P (TREE_TYPE (node))) - { - if (!type || TREE_CODE (type) != FUNCTION_DECL) - { - pp_string (buffer, "access "); - is_access = true; - - if (quals & TYPE_QUAL_CONST) - pp_string (buffer, "constant "); - else if (!name_only) - pp_string (buffer, "all "); - } - else if (quals & TYPE_QUAL_CONST) - pp_string (buffer, "in "); - else if (in_function) - { - is_access = true; - pp_string (buffer, "access "); - } - else - { - is_access = true; - pp_string (buffer, "access "); - /* ??? should be configurable: access or in out. */ - } - } - else - { - is_access = true; - pp_string (buffer, "access "); - - if (!name_only) - pp_string (buffer, "all "); - } - - if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (node)) - && TYPE_NAME (TREE_TYPE (node))) - { - tree name = TYPE_NAME (TREE_TYPE (node)); - tree tmp; - - if (TREE_CODE (name) == TYPE_DECL - && DECL_ORIGINAL_TYPE (name) - && TYPE_STUB_DECL (DECL_ORIGINAL_TYPE (name))) - { - tmp = TYPE_NAME (TREE_TYPE (TYPE_STUB_DECL - (DECL_ORIGINAL_TYPE (name)))); - - if (tmp == NULL_TREE) - tmp = TYPE_NAME (TREE_TYPE (node)); - } - else - tmp = TYPE_NAME (TREE_TYPE (node)); - - dump_generic_ada_node - (buffer, tmp, - TREE_TYPE (node), cpp_check, spc, is_access, true); - } - else - dump_generic_ada_node - (buffer, TREE_TYPE (node), TREE_TYPE (node), - cpp_check, spc, 0, true); - } - } - } - break; - - case ARRAY_TYPE: - if (name_only) - dump_generic_ada_node - (buffer, TYPE_NAME (node), node, cpp_check, - spc, limited_access, true); - else - dump_ada_array_type (buffer, node, spc); - break; - - case RECORD_TYPE: - case UNION_TYPE: - case QUAL_UNION_TYPE: - if (name_only) - { - if (TYPE_NAME (node)) - dump_generic_ada_node - (buffer, TYPE_NAME (node), node, cpp_check, - spc, limited_access, true); - else - { - pp_string (buffer, "anon_"); - pp_scalar (buffer, "%d", TYPE_UID (node)); - } - } - else - print_ada_struct_decl - (buffer, node, type, cpp_check, spc, true); - break; - - case INTEGER_CST: - if (TREE_CODE (TREE_TYPE (node)) == POINTER_TYPE) - { - pp_wide_integer (buffer, TREE_INT_CST_LOW (node)); - pp_string (buffer, "B"); /* pseudo-unit */ - } - else if (! host_integerp (node, 0)) - { - tree val = node; - unsigned HOST_WIDE_INT low = TREE_INT_CST_LOW (val); - HOST_WIDE_INT high = TREE_INT_CST_HIGH (val); - - if (tree_int_cst_sgn (val) < 0) - { - pp_character (buffer, '-'); - high = ~high + !low; - low = -low; - } - sprintf (pp_buffer (buffer)->digit_buffer, - HOST_WIDE_INT_PRINT_DOUBLE_HEX, - (unsigned HOST_WIDE_INT) high, low); - pp_string (buffer, pp_buffer (buffer)->digit_buffer); - } - else - pp_wide_integer (buffer, TREE_INT_CST_LOW (node)); - break; - - case REAL_CST: - case FIXED_CST: - case COMPLEX_CST: - case STRING_CST: - case VECTOR_CST: - return 0; - - case FUNCTION_DECL: - case CONST_DECL: - dump_ada_decl_name (buffer, node, limited_access); - break; - - case TYPE_DECL: - if (DECL_IS_BUILTIN (node)) - { - /* Don't print the declaration of built-in types. */ - - if (name_only) - { - /* If we're in the middle of a declaration, defaults to - System.Address. */ - if (package_prefix) - { - append_withs ("System", false); - pp_string (buffer, "System.Address"); - } - else - pp_string (buffer, "address"); - } - break; - } - - if (name_only) - dump_ada_decl_name (buffer, node, limited_access); - else - { - if (is_tagged_type (TREE_TYPE (node))) - { - tree tmp = TYPE_FIELDS (TREE_TYPE (node)); - int first = 1; - - /* Look for ancestors. */ - for (; tmp; tmp = TREE_CHAIN (tmp)) - { - if (!DECL_NAME (tmp) && is_tagged_type (TREE_TYPE (tmp))) - { - if (first) - { - pp_string (buffer, "limited new "); - first = 0; - } - else - pp_string (buffer, " and "); - - dump_ada_decl_name - (buffer, TYPE_NAME (TREE_TYPE (tmp)), false); - } - } - - pp_string (buffer, first ? "tagged limited " : " with "); - } - else if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (node)) - && TYPE_METHODS (TREE_TYPE (node))) - pp_string (buffer, "limited "); - - dump_generic_ada_node - (buffer, TREE_TYPE (node), type, cpp_check, spc, false, false); - } - break; - - case VAR_DECL: - case PARM_DECL: - case FIELD_DECL: - case NAMESPACE_DECL: - dump_ada_decl_name (buffer, node, false); - break; - - default: - /* Ignore other nodes (e.g. expressions). */ - return 0; - } - - return 1; -} - -/* Dump in BUFFER NODE's methods. CPP_CHECK is used to perform C++ queries on - nodes. SPC is the indentation level. */ - -static void -print_ada_methods (pretty_printer *buffer, tree node, - int (*cpp_check)(tree, cpp_operation), int spc) -{ - tree tmp = TYPE_METHODS (node); - int res = 1; - - if (tmp) - { - pp_semicolon (buffer); - - for (; tmp; tmp = TREE_CHAIN (tmp)) - { - if (res) - { - pp_newline (buffer); - pp_newline (buffer); - } - res = print_ada_declaration (buffer, tmp, node, cpp_check, spc); - } - } -} - -/* Dump in BUFFER anonymous types nested inside T's definition. - PARENT is the parent node of T. CPP_CHECK is used to perform C++ queries on - nodes. SPC is the indentation level. */ - -static void -dump_nested_types (pretty_printer *buffer, tree t, tree parent, - int (*cpp_check)(tree, cpp_operation), int spc) -{ - tree field, outer, decl; - - /* Avoid recursing over the same tree. */ - if (TREE_VISITED (t)) - return; - - /* Find possible anonymous arrays/unions/structs recursively. */ - - outer = TREE_TYPE (t); - - if (outer == NULL_TREE) - return; - - field = TYPE_FIELDS (outer); - while (field) - { - if ((TREE_TYPE (field) != outer - || (TREE_CODE (TREE_TYPE (field)) == POINTER_TYPE - && TREE_TYPE (TREE_TYPE (field)) != outer)) - && (!TYPE_NAME (TREE_TYPE (field)) - || (TREE_CODE (field) == TYPE_DECL - && DECL_NAME (field) != DECL_NAME (t) - && TYPE_NAME (TREE_TYPE (field)) != TYPE_NAME (outer)))) - { - switch (TREE_CODE (TREE_TYPE (field))) - { - case POINTER_TYPE: - decl = TREE_TYPE (TREE_TYPE (field)); - - if (TREE_CODE (decl) == FUNCTION_TYPE) - for (decl = TREE_TYPE (decl); - decl && TREE_CODE (decl) == POINTER_TYPE; - decl = TREE_TYPE (decl)); - - decl = get_underlying_decl (decl); - - if (decl - && DECL_P (decl) - && decl_sloc (decl, true) > decl_sloc (t, true) - && DECL_SOURCE_FILE (decl) == DECL_SOURCE_FILE (t) - && !TREE_VISITED (decl) - && !DECL_IS_BUILTIN (decl) - && (!RECORD_OR_UNION_TYPE_P (TREE_TYPE (decl)) - || TYPE_FIELDS (TREE_TYPE (decl)))) - { - /* Generate forward declaration. */ - - pp_string (buffer, "type "); - dump_generic_ada_node - (buffer, decl, 0, cpp_check, spc, false, true); - pp_semicolon (buffer); - newline_and_indent (buffer, spc); - - /* Ensure we do not generate duplicate forward - declarations for this type. */ - TREE_VISITED (decl) = 1; - } - break; - - case ARRAY_TYPE: - /* Special case char arrays. */ - if (is_char_array (field)) - pp_string (buffer, "sub"); - - pp_string (buffer, "type "); - dump_ada_double_name (buffer, parent, field, "_array is "); - dump_ada_array_type (buffer, field, spc); - pp_semicolon (buffer); - newline_and_indent (buffer, spc); - break; - - case UNION_TYPE: - TREE_VISITED (t) = 1; - dump_nested_types (buffer, field, t, cpp_check, spc); - - pp_string (buffer, "type "); - - if (TYPE_NAME (TREE_TYPE (field))) - { - dump_generic_ada_node - (buffer, TYPE_NAME (TREE_TYPE (field)), 0, cpp_check, - spc, false, true); - pp_string (buffer, " (discr : unsigned := 0) is "); - print_ada_struct_decl - (buffer, TREE_TYPE (field), t, cpp_check, spc, false); - - pp_string (buffer, "pragma Convention (C_Pass_By_Copy, "); - dump_generic_ada_node - (buffer, TREE_TYPE (field), 0, cpp_check, - spc, false, true); - pp_string (buffer, ");"); - newline_and_indent (buffer, spc); - - pp_string (buffer, "pragma Unchecked_Union ("); - dump_generic_ada_node - (buffer, TREE_TYPE (field), 0, cpp_check, - spc, false, true); - pp_string (buffer, ");"); - } - else - { - dump_ada_double_name - (buffer, parent, field, - "_union (discr : unsigned := 0) is "); - print_ada_struct_decl - (buffer, TREE_TYPE (field), t, cpp_check, spc, false); - pp_string (buffer, "pragma Convention (C_Pass_By_Copy, "); - dump_ada_double_name (buffer, parent, field, "_union);"); - newline_and_indent (buffer, spc); - - pp_string (buffer, "pragma Unchecked_Union ("); - dump_ada_double_name (buffer, parent, field, "_union);"); - } - - newline_and_indent (buffer, spc); - break; - - case RECORD_TYPE: - if (TYPE_NAME (TREE_TYPE (t)) && !TREE_VISITED (t)) - { - pp_string (buffer, "type "); - dump_generic_ada_node - (buffer, t, parent, 0, spc, false, true); - pp_semicolon (buffer); - newline_and_indent (buffer, spc); - } - - TREE_VISITED (t) = 1; - dump_nested_types (buffer, field, t, cpp_check, spc); - pp_string (buffer, "type "); - - if (TYPE_NAME (TREE_TYPE (field))) - { - dump_generic_ada_node - (buffer, TREE_TYPE (field), 0, cpp_check, - spc, false, true); - pp_string (buffer, " is "); - print_ada_struct_decl - (buffer, TREE_TYPE (field), t, cpp_check, spc, false); - pp_string (buffer, "pragma Convention (C_Pass_By_Copy, "); - dump_generic_ada_node - (buffer, TREE_TYPE (field), 0, cpp_check, - spc, false, true); - pp_string (buffer, ");"); - } - else - { - dump_ada_double_name - (buffer, parent, field, "_struct is "); - print_ada_struct_decl - (buffer, TREE_TYPE (field), t, cpp_check, spc, false); - pp_string (buffer, "pragma Convention (C_Pass_By_Copy, "); - dump_ada_double_name (buffer, parent, field, "_struct);"); - } - - newline_and_indent (buffer, spc); - break; - - default: - break; - } - } - field = TREE_CHAIN (field); - } -} - -/* Dump in BUFFER destructor spec corresponding to T. */ - -static void -print_destructor (pretty_printer *buffer, tree t) -{ - const char *s = IDENTIFIER_POINTER (DECL_NAME (t)); - - if (*s == '_') - for (s += 2; *s != ' '; s++) - pp_character (buffer, *s); - else - { - pp_string (buffer, "Delete_"); - pp_ada_tree_identifier (buffer, DECL_NAME (t), t, false); - } -} - -/* Return the name of type T. */ - -static const char * -type_name (tree t) -{ - tree n = TYPE_NAME (t); - - if (TREE_CODE (n) == IDENTIFIER_NODE) - return IDENTIFIER_POINTER (n); - else - return IDENTIFIER_POINTER (DECL_NAME (n)); -} - -/* Print in BUFFER the declaration of a variable T of type TYPE in Ada syntax. - CPP_CHECK is used to perform C++ queries on nodes. SPC is the indentation - level. Return 1 if a declaration was printed, 0 otherwise. */ - -static int -print_ada_declaration (pretty_printer *buffer, tree t, tree type, - int (*cpp_check)(tree, cpp_operation), int spc) -{ - int is_var = 0, need_indent = 0; - int is_class = false; - tree name = TYPE_NAME (TREE_TYPE (t)); - tree decl_name = DECL_NAME (t); - bool dump_internal = get_dump_file_info (TDI_ada)->flags & TDF_RAW; - tree orig = NULL_TREE; - - if (cpp_check && cpp_check (t, IS_TEMPLATE)) - return dump_ada_template (buffer, t, cpp_check, spc); - - if (TREE_CODE (t) == CONST_DECL && TREE_CODE (TREE_TYPE (t)) == ENUMERAL_TYPE) - /* Skip enumeral values: will be handled as part of the type itself. */ - return 0; - - if (TREE_CODE (t) == TYPE_DECL) - { - orig = DECL_ORIGINAL_TYPE (t); - - if (orig && TYPE_STUB_DECL (orig)) - { - tree typ = TREE_TYPE (TYPE_STUB_DECL (orig)); - - if (TYPE_NAME (typ)) - { - /* If types have same representation, and same name (ignoring - casing), then ignore the second type. */ - if (type_name (typ) == type_name (TREE_TYPE (t)) - || !strcasecmp (type_name (typ), type_name (TREE_TYPE (t)))) - return 0; - - INDENT (spc); - - if (RECORD_OR_UNION_TYPE_P (typ) && !TYPE_FIELDS (typ)) - { - pp_string (buffer, "-- skipped empty struct "); - dump_generic_ada_node (buffer, t, type, 0, spc, false, true); - } - else - { - pp_string (buffer, "subtype "); - dump_generic_ada_node (buffer, t, type, 0, spc, false, true); - pp_string (buffer, " is "); - dump_generic_ada_node - (buffer, typ, type, 0, spc, false, true); - pp_semicolon (buffer); - } - return 1; - } - } - - /* Skip unnamed or anonymous structs/unions/enum types. */ - if (!orig && !decl_name && !name) - { - tree tmp; - location_t sloc; - - if (cpp_check || TREE_CODE (TREE_TYPE (t)) == ENUMERAL_TYPE) - return 0; - - if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (t))) - { - /* Search next items until finding a named type decl. */ - sloc = decl_sloc_common (t, true, true); - - for (tmp = TREE_CHAIN (t); tmp; tmp = TREE_CHAIN (tmp)) - { - if (TREE_CODE (tmp) == TYPE_DECL - && (DECL_NAME (tmp) || TYPE_NAME (TREE_TYPE (tmp)))) - { - /* If same sloc, it means we can ignore the anonymous - struct. */ - if (decl_sloc_common (tmp, true, true) == sloc) - return 0; - else - break; - } - } - if (tmp == NULL) - return 0; - } - } - - if (!orig - && TREE_CODE (TREE_TYPE (t)) == ENUMERAL_TYPE - && decl_name - && (*IDENTIFIER_POINTER (decl_name) == '.' - || *IDENTIFIER_POINTER (decl_name) == '$')) - /* Skip anonymous enum types (duplicates of real types). */ - return 0; - - INDENT (spc); - - switch (TREE_CODE (TREE_TYPE (t))) - { - case RECORD_TYPE: - case UNION_TYPE: - case QUAL_UNION_TYPE: - /* Skip empty structs (typically forward references to real - structs). */ - if (!TYPE_FIELDS (TREE_TYPE (t))) - { - pp_string (buffer, "-- skipped empty struct "); - dump_generic_ada_node (buffer, t, type, 0, spc, false, true); - return 1; - } - - if (decl_name - && (*IDENTIFIER_POINTER (decl_name) == '.' - || *IDENTIFIER_POINTER (decl_name) == '$')) - { - pp_string (buffer, "-- skipped anonymous struct "); - dump_generic_ada_node (buffer, t, type, 0, spc, false, true); - return 1; - } - - if (orig && TYPE_NAME (orig) && orig != TREE_TYPE (t)) - pp_string (buffer, "subtype "); - else - { - dump_nested_types (buffer, t, t, cpp_check, spc); - - if (TYPE_METHODS (TREE_TYPE (t)) - || has_static_fields (TREE_TYPE (t))) - { - is_class = true; - pp_string (buffer, "package Class_"); - dump_generic_ada_node - (buffer, t, type, 0, spc, false, true); - pp_string (buffer, " is"); - spc += INDENT_INCR; - newline_and_indent (buffer, spc); - } - - pp_string (buffer, "type "); - } - break; - - case ARRAY_TYPE: - case POINTER_TYPE: - case REFERENCE_TYPE: - if ((orig && TYPE_NAME (orig) && orig != TREE_TYPE (t)) - || is_char_array (t)) - pp_string (buffer, "subtype "); - else - pp_string (buffer, "type "); - break; - - case FUNCTION_TYPE: - pp_string (buffer, "-- skipped function type "); - dump_generic_ada_node (buffer, t, type, 0, spc, false, true); - return 1; - break; - - default: - pp_string (buffer, "subtype "); - } - } - else - { - if (!dump_internal - && TREE_CODE (t) == VAR_DECL - && decl_name - && *IDENTIFIER_POINTER (decl_name) == '_') - return 0; - - need_indent = 1; - } - - /* Print the type and name. */ - if (TREE_CODE (TREE_TYPE (t)) == ARRAY_TYPE) - { - if (need_indent) - INDENT (spc); - - /* Print variable's name. */ - dump_generic_ada_node (buffer, t, type, cpp_check, spc, false, true); - - if (TREE_CODE (t) == TYPE_DECL) - { - pp_string (buffer, " is "); - - if (orig && TYPE_NAME (orig) && orig != TREE_TYPE (t)) - dump_generic_ada_node - (buffer, TYPE_NAME (orig), type, - cpp_check, spc, false, true); - else - dump_ada_array_type (buffer, t, spc); - } - else - { - tree tmp = TYPE_NAME (TREE_TYPE (t)); - - if (spc == INDENT_INCR || TREE_STATIC (t)) - is_var = 1; - - pp_string (buffer, " : "); - - if (tmp) - { - if (TREE_CODE (TREE_TYPE (tmp)) != POINTER_TYPE - && TREE_CODE (tmp) != INTEGER_TYPE) - pp_string (buffer, "aliased "); - - dump_generic_ada_node (buffer, tmp, type, 0, spc, false, true); - } - else - { - pp_string (buffer, "aliased "); - - if (!type) - dump_ada_array_type (buffer, t, spc); - else - dump_ada_double_name (buffer, type, t, "_array"); - } - } - } - else if (TREE_CODE (t) == FUNCTION_DECL) - { - bool is_function = true, is_method, is_abstract_class = false; - tree decl_name = DECL_NAME (t); - int prev_in_function = in_function; - bool is_abstract = false; - bool is_constructor = false; - bool is_destructor = false; - bool is_copy_constructor = false; - - if (!decl_name) - return 0; - - if (cpp_check) - { - is_abstract = cpp_check (t, IS_ABSTRACT); - is_constructor = cpp_check (t, IS_CONSTRUCTOR); - is_destructor = cpp_check (t, IS_DESTRUCTOR); - is_copy_constructor = cpp_check (t, IS_COPY_CONSTRUCTOR); - } - - /* Skip __comp_dtor destructor which is redundant with the '~class()' - destructor. */ - if (is_destructor - && !strncmp (IDENTIFIER_POINTER (decl_name), "__comp", 6)) - return 0; - - /* Skip copy constructors: some are internal only, and those that are - not cannot be called easily from Ada anyway. */ - if (is_copy_constructor) - return 0; - - /* If this function has an entry in the dispatch table, we cannot - omit it. */ - if (!dump_internal && !DECL_VINDEX (t) - && *IDENTIFIER_POINTER (decl_name) == '_') - { - if (IDENTIFIER_POINTER (decl_name)[1] == '_') - return 0; - - INDENT (spc); - pp_string (buffer, "-- skipped func "); - pp_string (buffer, IDENTIFIER_POINTER (decl_name)); - return 1; - } - - if (need_indent) - INDENT (spc); - - if (is_constructor) - pp_string (buffer, "function New_"); - else if (VOID_TYPE_P (TREE_TYPE (TREE_TYPE (t)))) - { - is_function = false; - pp_string (buffer, "procedure "); - } - else - pp_string (buffer, "function "); - - in_function = is_function; - is_method = TREE_CODE (TREE_TYPE (t)) == METHOD_TYPE; - - if (is_destructor) - print_destructor (buffer, t); - else - dump_ada_decl_name (buffer, t, false); - - dump_ada_function_declaration - (buffer, t, is_method, is_constructor, is_destructor, spc); - in_function = prev_in_function; - - if (is_function) - { - pp_string (buffer, " return "); - - if (is_constructor) - { - dump_ada_decl_name (buffer, t, false); - } - else - { - dump_generic_ada_node - (buffer, TREE_TYPE (TREE_TYPE (t)), type, cpp_check, - spc, false, true); - } - } - - if (is_constructor && cpp_check && type - && AGGREGATE_TYPE_P (type) - && TYPE_METHODS (type)) - { - tree tmp = TYPE_METHODS (type); - - for (; tmp; tmp = TREE_CHAIN (tmp)) - if (cpp_check (tmp, IS_ABSTRACT)) - { - is_abstract_class = 1; - break; - } - } - - if (is_abstract || is_abstract_class) - pp_string (buffer, " is abstract"); - - pp_semicolon (buffer); - pp_string (buffer, " -- "); - dump_sloc (buffer, t); - - if (is_abstract) - return 1; - - newline_and_indent (buffer, spc); - - if (is_constructor) - { - pp_string (buffer, "pragma CPP_Constructor (New_"); - dump_ada_decl_name (buffer, t, false); - pp_string (buffer, ", \""); - pp_asm_name (buffer, t); - pp_string (buffer, "\");"); - } - else if (is_destructor) - { - pp_string (buffer, "pragma Import (CPP, "); - print_destructor (buffer, t); - pp_string (buffer, ", \""); - pp_asm_name (buffer, t); - pp_string (buffer, "\");"); - } - else - { - dump_ada_import (buffer, t); - } - - return 1; - } - else if (TREE_CODE (t) == TYPE_DECL && !DECL_ORIGINAL_TYPE (t)) - { - int is_interface = 0; - int is_abstract_record = 0; - - if (need_indent) - INDENT (spc); - - /* Anonymous structs/unions */ - dump_generic_ada_node - (buffer, TREE_TYPE (t), t, cpp_check, spc, false, true); - - if (TREE_CODE (TREE_TYPE (t)) == UNION_TYPE - || TREE_CODE (TREE_TYPE (t)) == QUAL_UNION_TYPE) - { - pp_string (buffer, " (discr : unsigned := 0)"); - } - - pp_string (buffer, " is "); - - /* Check whether we have an Ada interface compatible class. */ - if (cpp_check && AGGREGATE_TYPE_P (TREE_TYPE (t)) - && TYPE_METHODS (TREE_TYPE (t))) - { - int num_fields = 0; - tree tmp = TYPE_FIELDS (TREE_TYPE (t)); - - /* Check that there are no fields other than the virtual table. */ - for (; tmp; tmp = TREE_CHAIN (tmp)) - { - if (TREE_CODE (tmp) == TYPE_DECL) - continue; - num_fields++; - } - - if (num_fields == 1) - is_interface = 1; - - /* Also check that there are only virtual methods. */ - for (tmp = TYPE_METHODS (TREE_TYPE (t)); tmp; tmp = TREE_CHAIN (tmp)) - { - if (cpp_check (tmp, IS_ABSTRACT)) - is_abstract_record = 1; - else - is_interface = 0; - } - } - - if (is_interface) - { - pp_string (buffer, "limited interface; -- "); - dump_sloc (buffer, t); - newline_and_indent (buffer, spc); - pp_string (buffer, "pragma Import (CPP, "); - dump_generic_ada_node - (buffer, TYPE_NAME (TREE_TYPE (t)), type, cpp_check, - spc, false, true); - pp_character (buffer, ')'); - - print_ada_methods (buffer, TREE_TYPE (t), cpp_check, spc); - } - else - { - if (is_abstract_record) - pp_string (buffer, "abstract "); - dump_generic_ada_node (buffer, t, t, cpp_check, spc, false, false); - } - } - else - { - if (need_indent) - INDENT (spc); - - if (TREE_CODE (t) == FIELD_DECL && DECL_NAME (t)) - check_name (buffer, t); - - /* Print variable/type's name. */ - dump_generic_ada_node (buffer, t, t, cpp_check, spc, false, true); - - if (TREE_CODE (t) == TYPE_DECL) - { - tree orig = DECL_ORIGINAL_TYPE (t); - int is_subtype = orig && TYPE_NAME (orig) && orig != TREE_TYPE (t); - - if (!is_subtype - && (TREE_CODE (TREE_TYPE (t)) == UNION_TYPE - || TREE_CODE (TREE_TYPE (t)) == QUAL_UNION_TYPE)) - pp_string (buffer, " (discr : unsigned := 0)"); - - pp_string (buffer, " is "); - - dump_generic_ada_node - (buffer, orig, t, cpp_check, spc, false, is_subtype); - } - else - { - if (spc == INDENT_INCR || TREE_STATIC (t)) - is_var = 1; - - pp_string (buffer, " : "); - - /* Print type declaration. */ - - if (TREE_CODE (TREE_TYPE (t)) == UNION_TYPE - && !TYPE_NAME (TREE_TYPE (t))) - { - dump_ada_double_name (buffer, type, t, "_union"); - } - else if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (t))) - { - if (TREE_CODE (TREE_TYPE (t)) == RECORD_TYPE) - pp_string (buffer, "aliased "); - - dump_generic_ada_node - (buffer, TREE_TYPE (t), t, cpp_check, spc, false, true); - } - else - { - if (TREE_CODE (TREE_TYPE (t)) != POINTER_TYPE - && (TYPE_NAME (TREE_TYPE (t)) - || TREE_CODE (TREE_TYPE (t)) != INTEGER_TYPE)) - pp_string (buffer, "aliased "); - - dump_generic_ada_node - (buffer, TREE_TYPE (t), TREE_TYPE (t), cpp_check, - spc, false, true); - } - } - } - - if (is_class) - { - spc -= 3; - newline_and_indent (buffer, spc); - pp_string (buffer, "end;"); - newline_and_indent (buffer, spc); - pp_string (buffer, "use Class_"); - dump_generic_ada_node (buffer, t, type, 0, spc, false, true); - pp_semicolon (buffer); - pp_newline (buffer); - - /* All needed indentation/newline performed already, so return 0. */ - return 0; - } - else - { - pp_string (buffer, "; -- "); - dump_sloc (buffer, t); - } - - if (is_var) - { - newline_and_indent (buffer, spc); - dump_ada_import (buffer, t); - } - - return 1; -} - -/* Prints in BUFFER a structure NODE of type TYPE: name, fields, and methods - with Ada syntax. CPP_CHECK is used to perform C++ queries on nodes. SPC - is the indentation level. If DISPLAY_CONVENTION is true, also print the - pragma Convention for NODE. */ - -static void -print_ada_struct_decl (pretty_printer *buffer, tree node, tree type, - int (*cpp_check)(tree, cpp_operation), int spc, - bool display_convention) -{ - tree tmp; - int is_union = - TREE_CODE (node) == UNION_TYPE || TREE_CODE (node) == QUAL_UNION_TYPE; - char buf [16]; - int field_num = 0; - int field_spc = spc + INDENT_INCR; - int need_semicolon; - - bitfield_used = false; - - if (!TYPE_FIELDS (node)) - pp_string (buffer, "null record;"); - else - { - pp_string (buffer, "record"); - - /* Print the contents of the structure. */ - - if (is_union) - { - newline_and_indent (buffer, spc + INDENT_INCR); - pp_string (buffer, "case discr is"); - field_spc = spc + INDENT_INCR * 3; - } - - pp_newline (buffer); - - /* Print the non-static fields of the structure. */ - for (tmp = TYPE_FIELDS (node); tmp; tmp = TREE_CHAIN (tmp)) - { - /* Add parent field if needed. */ - if (!DECL_NAME (tmp)) - { - if (!is_tagged_type (TREE_TYPE (tmp))) - { - if (!TYPE_NAME (TREE_TYPE (tmp))) - print_ada_declaration - (buffer, tmp, type, cpp_check, field_spc); - else - { - INDENT (field_spc); - - if (field_num == 0) - pp_string (buffer, "parent : "); - else - { - sprintf (buf, "field_%d : ", field_num + 1); - pp_string (buffer, buf); - } - dump_ada_decl_name - (buffer, TYPE_NAME (TREE_TYPE (tmp)), false); - pp_semicolon (buffer); - } - pp_newline (buffer); - field_num++; - } - } - /* Avoid printing the structure recursively. */ - else if ((TREE_TYPE (tmp) != node - || (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE - && TREE_TYPE (TREE_TYPE (tmp)) != node)) - && TREE_CODE (tmp) != TYPE_DECL - && !TREE_STATIC (tmp)) - { - /* Skip internal virtual table field. */ - if (strncmp (IDENTIFIER_POINTER (DECL_NAME (tmp)), "_vptr", 5)) - { - if (is_union) - { - if (TREE_CHAIN (tmp) - && TREE_TYPE (TREE_CHAIN (tmp)) != node - && TREE_CODE (TREE_CHAIN (tmp)) != TYPE_DECL) - sprintf (buf, "when %d =>", field_num); - else - sprintf (buf, "when others =>"); - - INDENT (spc + INDENT_INCR * 2); - pp_string (buffer, buf); - pp_newline (buffer); - } - - if (print_ada_declaration (buffer, - tmp, type, cpp_check, field_spc)) - { - pp_newline (buffer); - field_num++; - } - } - } - } - - if (is_union) - { - INDENT (spc + INDENT_INCR); - pp_string (buffer, "end case;"); - pp_newline (buffer); - } - - if (field_num == 0) - { - INDENT (spc + INDENT_INCR); - pp_string (buffer, "null;"); - pp_newline (buffer); - } - - INDENT (spc); - pp_string (buffer, "end record;"); - } - - newline_and_indent (buffer, spc); - - if (!display_convention) - return; - - if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (type))) - { - if (TYPE_METHODS (TREE_TYPE (type))) - pp_string (buffer, "pragma Import (CPP, "); - else - pp_string (buffer, "pragma Convention (C_Pass_By_Copy, "); - } - else - pp_string (buffer, "pragma Convention (C, "); - - package_prefix = false; - dump_generic_ada_node - (buffer, TREE_TYPE (type), type, cpp_check, spc, false, true); - package_prefix = true; - pp_character (buffer, ')'); - - if (is_union) - { - pp_semicolon (buffer); - newline_and_indent (buffer, spc); - pp_string (buffer, "pragma Unchecked_Union ("); - - dump_generic_ada_node - (buffer, TREE_TYPE (type), type, cpp_check, spc, false, true); - pp_character (buffer, ')'); - } - - if (bitfield_used) - { - pp_semicolon (buffer); - newline_and_indent (buffer, spc); - pp_string (buffer, "pragma Pack ("); - dump_generic_ada_node - (buffer, TREE_TYPE (type), type, cpp_check, spc, false, true); - pp_character (buffer, ')'); - bitfield_used = false; - } - - print_ada_methods (buffer, node, cpp_check, spc); - - /* Print the static fields of the structure, if any. */ - need_semicolon = TYPE_METHODS (node) == NULL_TREE; - for (tmp = TYPE_FIELDS (node); tmp; tmp = TREE_CHAIN (tmp)) - { - if (DECL_NAME (tmp) && TREE_STATIC (tmp)) - { - if (need_semicolon) - { - need_semicolon = false; - pp_semicolon (buffer); - } - pp_newline (buffer); - pp_newline (buffer); - print_ada_declaration (buffer, tmp, type, cpp_check, spc); - } - } -} - -/* Dump all the declarations in SOURCE_FILE to an Ada spec. - COLLECT_ALL_REFS is a front-end callback used to collect all relevant - nodes for SOURCE_FILE. CPP_CHECK is used to perform C++ queries on - nodes. */ - -static void -dump_ads (const char *source_file, - void (*collect_all_refs)(const char *), - int (*cpp_check)(tree, cpp_operation)) -{ - char *ads_name; - char *pkg_name; - char *s; - FILE *f; - - pkg_name = get_ada_package (source_file); - - /* Construct the the .ads filename and package name. */ - ads_name = xstrdup (pkg_name); - - for (s = ads_name; *s; s++) - *s = TOLOWER (*s); - - ads_name = reconcat (ads_name, ads_name, ".ads", NULL); - - /* Write out the .ads file. */ - f = fopen (ads_name, "w"); - if (f) - { - pretty_printer pp; - - pp_construct (&pp, NULL, 0); - pp_needs_newline (&pp) = true; - pp.buffer->stream = f; - - /* Dump all relevant macros. */ - dump_ada_macros (&pp, source_file); - - /* Reset the table of withs for this file. */ - reset_ada_withs (); - - (*collect_all_refs) (source_file); - - /* Dump all references. */ - dump_ada_nodes (&pp, source_file, cpp_check); - - /* Dump withs. */ - dump_ada_withs (f); - - fprintf (f, "\npackage %s is\n\n", pkg_name); - pp_write_text_to_stream (&pp); - /* ??? need to free pp */ - fprintf (f, "end %s;\n", pkg_name); - fclose (f); - } - - free (ads_name); - free (pkg_name); -} - -static const char **source_refs = NULL; -static int source_refs_used = 0; -static int source_refs_allocd = 0; - -/* Add an entry for FILENAME to the table SOURCE_REFS. */ - -void -collect_source_ref (const char *filename) -{ - int i; - - if (!filename) - return; - - if (source_refs_allocd == 0) - { - source_refs_allocd = 1024; - source_refs = XNEWVEC (const char *, source_refs_allocd); - } - - for (i = 0; i < source_refs_used; i++) - if (filename == source_refs [i]) - return; - - if (source_refs_used == source_refs_allocd) - { - source_refs_allocd *= 2; - source_refs = XRESIZEVEC (const char *, source_refs, source_refs_allocd); - } - - source_refs [source_refs_used++] = filename; -} - -/* Main entry point: dump all Ada specs corresponding to SOURCE_REFS - using callbacks COLLECT_ALL_REFS and CPP_CHECK. - COLLECT_ALL_REFS is a front-end callback used to collect all relevant - nodes for a given source file. - CPP_CHECK is used to perform C++ queries on nodes, or NULL for the C - front-end. */ - -void -dump_ada_specs (void (*collect_all_refs)(const char *), - int (*cpp_check)(tree, cpp_operation)) -{ - int i; - - /* Iterate over the list of files to dump specs for */ - for (i = 0; i < source_refs_used; i++) - dump_ads (source_refs [i], collect_all_refs, cpp_check); - - /* Free files table. */ - free (source_refs); -} diff --git a/gcc/c-ada-spec.h b/gcc/c-ada-spec.h deleted file mode 100644 index 8aed158678c..00000000000 --- a/gcc/c-ada-spec.h +++ /dev/null @@ -1,41 +0,0 @@ -/* Interface for -fdump-ada-spec capability. - Copyright (C) 2010, 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 3, 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 COPYING3. If not see -. */ - -#ifndef C_ADA_SPEC_H -#define C_ADA_SPEC_H - -#include "pretty-print.h" - -/* In c-ada-spec.c */ - -typedef enum { - IS_ABSTRACT, - IS_CONSTRUCTOR, - IS_DESTRUCTOR, - IS_COPY_CONSTRUCTOR, - IS_TEMPLATE -} cpp_operation; - -extern location_t decl_sloc (const_tree, bool); -extern void collect_ada_nodes (tree, const char *); -extern void collect_source_ref (const char *); -extern void dump_ada_specs (void (*)(const char *), - int (*)(tree, cpp_operation)); - -#endif /* ! C_ADA_SPEC_H */ diff --git a/gcc/c-common.c b/gcc/c-common.c deleted file mode 100644 index 97d6034f28d..00000000000 --- a/gcc/c-common.c +++ /dev/null @@ -1,9465 +0,0 @@ -/* Subroutines shared by all languages that are variants of C. - Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, - 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 - 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 3, 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 COPYING3. If not see -. */ - -/* FIXME: Still need to include rtl.h here (via expr.h) in a front-end file. - Pretend this is a back-end file. */ -#undef IN_GCC_FRONTEND - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "tm.h" -#include "intl.h" -#include "tree.h" -#include "flags.h" -#include "output.h" -#include "c-pragma.h" -#include "ggc.h" -#include "c-common.h" -#include "tm_p.h" -#include "obstack.h" -#include "cpplib.h" -#include "target.h" -#include "langhooks.h" -#include "tree-inline.h" -#include "toplev.h" -#include "diagnostic.h" -#include "tree-iterator.h" -#include "hashtab.h" -#include "tree-mudflap.h" -#include "opts.h" -#include "cgraph.h" -#include "target-def.h" -#include "libfuncs.h" - -#include "expr.h" /* For vector_mode_valid_p */ - -cpp_reader *parse_in; /* Declared in c-pragma.h. */ - -/* The following symbols are subsumed in the c_global_trees array, and - listed here individually for documentation purposes. - - INTEGER_TYPE and REAL_TYPE nodes for the standard data types. - - tree short_integer_type_node; - tree long_integer_type_node; - tree long_long_integer_type_node; - tree int128_integer_type_node; - - tree short_unsigned_type_node; - tree long_unsigned_type_node; - tree long_long_unsigned_type_node; - tree int128_unsigned_type_node; - - tree truthvalue_type_node; - tree truthvalue_false_node; - tree truthvalue_true_node; - - tree ptrdiff_type_node; - - tree unsigned_char_type_node; - tree signed_char_type_node; - tree wchar_type_node; - - tree char16_type_node; - tree char32_type_node; - - tree float_type_node; - tree double_type_node; - tree long_double_type_node; - - tree complex_integer_type_node; - tree complex_float_type_node; - tree complex_double_type_node; - tree complex_long_double_type_node; - - tree dfloat32_type_node; - tree dfloat64_type_node; - tree_dfloat128_type_node; - - tree intQI_type_node; - tree intHI_type_node; - tree intSI_type_node; - tree intDI_type_node; - tree intTI_type_node; - - tree unsigned_intQI_type_node; - tree unsigned_intHI_type_node; - tree unsigned_intSI_type_node; - tree unsigned_intDI_type_node; - tree unsigned_intTI_type_node; - - tree widest_integer_literal_type_node; - tree widest_unsigned_literal_type_node; - - Nodes for types `void *' and `const void *'. - - tree ptr_type_node, const_ptr_type_node; - - Nodes for types `char *' and `const char *'. - - tree string_type_node, const_string_type_node; - - Type `char[SOMENUMBER]'. - Used when an array of char is needed and the size is irrelevant. - - tree char_array_type_node; - - Type `int[SOMENUMBER]' or something like it. - Used when an array of int needed and the size is irrelevant. - - tree int_array_type_node; - - Type `wchar_t[SOMENUMBER]' or something like it. - Used when a wide string literal is created. - - tree wchar_array_type_node; - - Type `char16_t[SOMENUMBER]' or something like it. - Used when a UTF-16 string literal is created. - - tree char16_array_type_node; - - Type `char32_t[SOMENUMBER]' or something like it. - Used when a UTF-32 string literal is created. - - tree char32_array_type_node; - - Type `int ()' -- used for implicit declaration of functions. - - tree default_function_type; - - A VOID_TYPE node, packaged in a TREE_LIST. - - tree void_list_node; - - The lazily created VAR_DECLs for __FUNCTION__, __PRETTY_FUNCTION__, - and __func__. (C doesn't generate __FUNCTION__ and__PRETTY_FUNCTION__ - VAR_DECLS, but C++ does.) - - tree function_name_decl_node; - tree pretty_function_name_decl_node; - tree c99_function_name_decl_node; - - Stack of nested function name VAR_DECLs. - - tree saved_function_name_decls; - -*/ - -tree c_global_trees[CTI_MAX]; - -/* Switches common to the C front ends. */ - -/* Nonzero if preprocessing only. */ - -int flag_preprocess_only; - -/* Nonzero means don't output line number information. */ - -char flag_no_line_commands; - -/* Nonzero causes -E output not to be done, but directives such as - #define that have side effects are still obeyed. */ - -char flag_no_output; - -/* Nonzero means dump macros in some fashion. */ - -char flag_dump_macros; - -/* Nonzero means pass #include lines through to the output. */ - -char flag_dump_includes; - -/* Nonzero means process PCH files while preprocessing. */ - -bool flag_pch_preprocess; - -/* The file name to which we should write a precompiled header, or - NULL if no header will be written in this compile. */ - -const char *pch_file; - -/* Nonzero if an ISO standard was selected. It rejects macros in the - user's namespace. */ -int flag_iso; - -/* Nonzero if -undef was given. It suppresses target built-in macros - and assertions. */ -int flag_undef; - -/* Nonzero means don't recognize the non-ANSI builtin functions. */ - -int flag_no_builtin; - -/* Nonzero means don't recognize the non-ANSI builtin functions. - -ansi sets this. */ - -int flag_no_nonansi_builtin; - -/* Nonzero means give `double' the same size as `float'. */ - -int flag_short_double; - -/* Nonzero means give `wchar_t' the same size as `short'. */ - -int flag_short_wchar; - -/* Nonzero means allow implicit conversions between vectors with - differing numbers of subparts and/or differing element types. */ -int flag_lax_vector_conversions; - -/* Nonzero means allow Microsoft extensions without warnings or errors. */ -int flag_ms_extensions; - -/* Nonzero means don't recognize the keyword `asm'. */ - -int flag_no_asm; - -/* Nonzero means to treat bitfields as signed unless they say `unsigned'. */ - -int flag_signed_bitfields = 1; - -/* Warn about #pragma directives that are not recognized. */ - -int warn_unknown_pragmas; /* Tri state variable. */ - -/* Warn about format/argument anomalies in calls to formatted I/O functions - (*printf, *scanf, strftime, strfmon, etc.). */ - -int warn_format; - -/* Warn about using __null (as NULL in C++) as sentinel. For code compiled - with GCC this doesn't matter as __null is guaranteed to have the right - size. */ - -int warn_strict_null_sentinel; - -/* Zero means that faster, ...NonNil variants of objc_msgSend... - calls will be used in ObjC; passing nil receivers to such calls - will most likely result in crashes. */ -int flag_nil_receivers = 1; - -/* Nonzero means that code generation will be altered to support - "zero-link" execution. This currently affects ObjC only, but may - affect other languages in the future. */ -int flag_zero_link = 0; - -/* Nonzero means emit an '__OBJC, __image_info' for the current translation - unit. It will inform the ObjC runtime that class definition(s) herein - contained are to replace one(s) previously loaded. */ -int flag_replace_objc_classes = 0; - -/* C/ObjC language option variables. */ - - -/* Nonzero means allow type mismatches in conditional expressions; - just make their values `void'. */ - -int flag_cond_mismatch; - -/* Nonzero means enable C89 Amendment 1 features. */ - -int flag_isoc94; - -/* Nonzero means use the ISO C99 (or C1X) dialect of C. */ - -int flag_isoc99; - -/* Nonzero means use the ISO C1X dialect of C. */ - -int flag_isoc1x; - -/* Nonzero means that we have builtin functions, and main is an int. */ - -int flag_hosted = 1; - - -/* ObjC language option variables. */ - - -/* Open and close the file for outputting class declarations, if - requested (ObjC). */ - -int flag_gen_declaration; - -/* Tells the compiler that this is a special run. Do not perform any - compiling, instead we are to test some platform dependent features - and output a C header file with appropriate definitions. */ - -int print_struct_values; - -/* Tells the compiler what is the constant string class for ObjC. */ - -const char *constant_string_class_name; - - -/* C++ language option variables. */ - - -/* Nonzero means don't recognize any extension keywords. */ - -int flag_no_gnu_keywords; - -/* Nonzero means do emit exported implementations of functions even if - they can be inlined. */ - -int flag_implement_inlines = 1; - -/* Nonzero means that implicit instantiations will be emitted if needed. */ - -int flag_implicit_templates = 1; - -/* Nonzero means that implicit instantiations of inline templates will be - emitted if needed, even if instantiations of non-inline templates - aren't. */ - -int flag_implicit_inline_templates = 1; - -/* Nonzero means generate separate instantiation control files and - juggle them at link time. */ - -int flag_use_repository; - -/* Nonzero if we want to issue diagnostics that the standard says are not - required. */ - -int flag_optional_diags = 1; - -/* Nonzero means we should attempt to elide constructors when possible. */ - -int flag_elide_constructors = 1; - -/* Nonzero means that member functions defined in class scope are - inline by default. */ - -int flag_default_inline = 1; - -/* Controls whether compiler generates 'type descriptor' that give - run-time type information. */ - -int flag_rtti = 1; - -/* Nonzero if we want to conserve space in the .o files. We do this - by putting uninitialized data and runtime initialized data into - .common instead of .data at the expense of not flagging multiple - definitions. */ - -int flag_conserve_space; - -/* Nonzero if we want to obey access control semantics. */ - -int flag_access_control = 1; - -/* Nonzero if we want to check the return value of new and avoid calling - constructors if it is a null pointer. */ - -int flag_check_new; - -/* The C++ dialect being used. C++98 is the default. */ - -enum cxx_dialect cxx_dialect = cxx98; - -/* Nonzero if we want the new ISO rules for pushing a new scope for `for' - initialization variables. - 0: Old rules, set by -fno-for-scope. - 2: New ISO rules, set by -ffor-scope. - 1: Try to implement new ISO rules, but with backup compatibility - (and warnings). This is the default, for now. */ - -int flag_new_for_scope = 1; - -/* Nonzero if we want to emit defined symbols with common-like linkage as - weak symbols where possible, in order to conform to C++ semantics. - Otherwise, emit them as local symbols. */ - -int flag_weak = 1; - -/* 0 means we want the preprocessor to not emit line directives for - the current working directory. 1 means we want it to do it. -1 - means we should decide depending on whether debugging information - is being emitted or not. */ - -int flag_working_directory = -1; - -/* Nonzero to use __cxa_atexit, rather than atexit, to register - destructors for local statics and global objects. '2' means it has been - set nonzero as a default, not by a command-line flag. */ - -int flag_use_cxa_atexit = DEFAULT_USE_CXA_ATEXIT; - -/* Nonzero to use __cxa_get_exception_ptr in C++ exception-handling - code. '2' means it has not been set explicitly on the command line. */ - -int flag_use_cxa_get_exception_ptr = 2; - -/* Nonzero means to implement standard semantics for exception - specifications, calling unexpected if an exception is thrown that - doesn't match the specification. Zero means to treat them as - assertions and optimize accordingly, but not check them. */ - -int flag_enforce_eh_specs = 1; - -/* Nonzero means to generate thread-safe code for initializing local - statics. */ - -int flag_threadsafe_statics = 1; - -/* Nonzero if we want to pretty-print template specializations as the - template signature followed by the arguments. */ - -int flag_pretty_templates = 1; - -/* Maximum template instantiation depth. This limit exists to limit the - time it takes to notice infinite template instantiations; the default - value of 1024 is likely to be in the next C++ standard. */ - -int max_tinst_depth = 1024; - - - -/* The elements of `ridpointers' are identifier nodes for the reserved - type names and storage classes. It is indexed by a RID_... value. */ -tree *ridpointers; - -tree (*make_fname_decl) (location_t, tree, int); - -/* Nonzero means don't warn about problems that occur when the code is - executed. */ -int c_inhibit_evaluation_warnings; - -/* Whether lexing has been completed, so subsequent preprocessor - errors should use the compiler's input_location. */ -bool done_lexing = false; - -/* Information about how a function name is generated. */ -struct fname_var_t -{ - tree *const decl; /* pointer to the VAR_DECL. */ - const unsigned rid; /* RID number for the identifier. */ - const int pretty; /* How pretty is it? */ -}; - -/* The three ways of getting then name of the current function. */ - -const struct fname_var_t fname_vars[] = -{ - /* C99 compliant __func__, must be first. */ - {&c99_function_name_decl_node, RID_C99_FUNCTION_NAME, 0}, - /* GCC __FUNCTION__ compliant. */ - {&function_name_decl_node, RID_FUNCTION_NAME, 0}, - /* GCC __PRETTY_FUNCTION__ compliant. */ - {&pretty_function_name_decl_node, RID_PRETTY_FUNCTION_NAME, 1}, - {NULL, 0, 0}, -}; - -static tree c_fully_fold_internal (tree expr, bool, bool *, bool *); -static tree check_case_value (tree); -static bool check_case_bounds (tree, tree, tree *, tree *); - -static tree handle_packed_attribute (tree *, tree, tree, int, bool *); -static tree handle_nocommon_attribute (tree *, tree, tree, int, bool *); -static tree handle_common_attribute (tree *, tree, tree, int, bool *); -static tree handle_noreturn_attribute (tree *, tree, tree, int, bool *); -static tree handle_hot_attribute (tree *, tree, tree, int, bool *); -static tree handle_cold_attribute (tree *, tree, tree, int, bool *); -static tree handle_noinline_attribute (tree *, tree, tree, int, bool *); -static tree handle_noclone_attribute (tree *, tree, tree, int, bool *); -static tree handle_always_inline_attribute (tree *, tree, tree, int, - bool *); -static tree handle_gnu_inline_attribute (tree *, tree, tree, int, bool *); -static tree handle_artificial_attribute (tree *, tree, tree, int, bool *); -static tree handle_flatten_attribute (tree *, tree, tree, int, bool *); -static tree handle_error_attribute (tree *, tree, tree, int, bool *); -static tree handle_used_attribute (tree *, tree, tree, int, bool *); -static tree handle_unused_attribute (tree *, tree, tree, int, bool *); -static tree handle_externally_visible_attribute (tree *, tree, tree, int, - bool *); -static tree handle_const_attribute (tree *, tree, tree, int, bool *); -static tree handle_transparent_union_attribute (tree *, tree, tree, - int, bool *); -static tree handle_constructor_attribute (tree *, tree, tree, int, bool *); -static tree handle_destructor_attribute (tree *, tree, tree, int, bool *); -static tree handle_mode_attribute (tree *, tree, tree, int, bool *); -static tree handle_section_attribute (tree *, tree, tree, int, bool *); -static tree handle_aligned_attribute (tree *, tree, tree, int, bool *); -static tree handle_weak_attribute (tree *, tree, tree, int, bool *) ; -static tree handle_alias_attribute (tree *, tree, tree, int, bool *); -static tree handle_weakref_attribute (tree *, tree, tree, int, bool *) ; -static tree handle_visibility_attribute (tree *, tree, tree, int, - bool *); -static tree handle_tls_model_attribute (tree *, tree, tree, int, - bool *); -static tree handle_no_instrument_function_attribute (tree *, tree, - tree, int, bool *); -static tree handle_malloc_attribute (tree *, tree, tree, int, bool *); -static tree handle_returns_twice_attribute (tree *, tree, tree, int, bool *); -static tree handle_no_limit_stack_attribute (tree *, tree, tree, int, - bool *); -static tree handle_pure_attribute (tree *, tree, tree, int, bool *); -static tree handle_novops_attribute (tree *, tree, tree, int, bool *); -static tree handle_deprecated_attribute (tree *, tree, tree, int, - bool *); -static tree handle_vector_size_attribute (tree *, tree, tree, int, - bool *); -static tree handle_nonnull_attribute (tree *, tree, tree, int, bool *); -static tree handle_nothrow_attribute (tree *, tree, tree, int, bool *); -static tree handle_cleanup_attribute (tree *, tree, tree, int, bool *); -static tree handle_warn_unused_result_attribute (tree *, tree, tree, int, - bool *); -static tree handle_sentinel_attribute (tree *, tree, tree, int, bool *); -static tree handle_type_generic_attribute (tree *, tree, tree, int, bool *); -static tree handle_alloc_size_attribute (tree *, tree, tree, int, bool *); -static tree handle_target_attribute (tree *, tree, tree, int, bool *); -static tree handle_optimize_attribute (tree *, tree, tree, int, bool *); -static tree handle_fnspec_attribute (tree *, tree, tree, int, bool *); - -static void check_function_nonnull (tree, int, tree *); -static void check_nonnull_arg (void *, tree, unsigned HOST_WIDE_INT); -static bool nonnull_check_p (tree, unsigned HOST_WIDE_INT); -static bool get_nonnull_operand (tree, unsigned HOST_WIDE_INT *); -static int resort_field_decl_cmp (const void *, const void *); - -/* Reserved words. The third field is a mask: keywords are disabled - if they match the mask. - - Masks for languages: - C --std=c89: D_C99 | D_CXXONLY | D_OBJC | D_CXX_OBJC - C --std=c99: D_CXXONLY | D_OBJC - ObjC is like C except that D_OBJC and D_CXX_OBJC are not set - C++ --std=c98: D_CONLY | D_CXXOX | D_OBJC - C++ --std=c0x: D_CONLY | D_OBJC - ObjC++ is like C++ except that D_OBJC is not set - - If -fno-asm is used, D_ASM is added to the mask. If - -fno-gnu-keywords is used, D_EXT is added. If -fno-asm and C in - C89 mode, D_EXT89 is added for both -fno-asm and -fno-gnu-keywords. - In C with -Wc++-compat, we warn if D_CXXWARN is set. */ - -const struct c_common_resword c_common_reswords[] = -{ - { "_Bool", RID_BOOL, D_CONLY }, - { "_Complex", RID_COMPLEX, 0 }, - { "_Imaginary", RID_IMAGINARY, D_CONLY }, - { "_Decimal32", RID_DFLOAT32, D_CONLY | D_EXT }, - { "_Decimal64", RID_DFLOAT64, D_CONLY | D_EXT }, - { "_Decimal128", RID_DFLOAT128, D_CONLY | D_EXT }, - { "_Fract", RID_FRACT, D_CONLY | D_EXT }, - { "_Accum", RID_ACCUM, D_CONLY | D_EXT }, - { "_Sat", RID_SAT, D_CONLY | D_EXT }, - { "_Static_assert", RID_STATIC_ASSERT, D_CONLY }, - { "__FUNCTION__", RID_FUNCTION_NAME, 0 }, - { "__PRETTY_FUNCTION__", RID_PRETTY_FUNCTION_NAME, 0 }, - { "__alignof", RID_ALIGNOF, 0 }, - { "__alignof__", RID_ALIGNOF, 0 }, - { "__asm", RID_ASM, 0 }, - { "__asm__", RID_ASM, 0 }, - { "__attribute", RID_ATTRIBUTE, 0 }, - { "__attribute__", RID_ATTRIBUTE, 0 }, - { "__builtin_choose_expr", RID_CHOOSE_EXPR, D_CONLY }, - { "__builtin_offsetof", RID_OFFSETOF, 0 }, - { "__builtin_types_compatible_p", RID_TYPES_COMPATIBLE_P, D_CONLY }, - { "__builtin_va_arg", RID_VA_ARG, 0 }, - { "__complex", RID_COMPLEX, 0 }, - { "__complex__", RID_COMPLEX, 0 }, - { "__const", RID_CONST, 0 }, - { "__const__", RID_CONST, 0 }, - { "__decltype", RID_DECLTYPE, D_CXXONLY }, - { "__extension__", RID_EXTENSION, 0 }, - { "__func__", RID_C99_FUNCTION_NAME, 0 }, - { "__has_nothrow_assign", RID_HAS_NOTHROW_ASSIGN, D_CXXONLY }, - { "__has_nothrow_constructor", RID_HAS_NOTHROW_CONSTRUCTOR, D_CXXONLY }, - { "__has_nothrow_copy", RID_HAS_NOTHROW_COPY, D_CXXONLY }, - { "__has_trivial_assign", RID_HAS_TRIVIAL_ASSIGN, D_CXXONLY }, - { "__has_trivial_constructor", RID_HAS_TRIVIAL_CONSTRUCTOR, D_CXXONLY }, - { "__has_trivial_copy", RID_HAS_TRIVIAL_COPY, D_CXXONLY }, - { "__has_trivial_destructor", RID_HAS_TRIVIAL_DESTRUCTOR, D_CXXONLY }, - { "__has_virtual_destructor", RID_HAS_VIRTUAL_DESTRUCTOR, D_CXXONLY }, - { "__int128", RID_INT128, 0 }, - { "__is_abstract", RID_IS_ABSTRACT, D_CXXONLY }, - { "__is_base_of", RID_IS_BASE_OF, D_CXXONLY }, - { "__is_class", RID_IS_CLASS, D_CXXONLY }, - { "__is_convertible_to", RID_IS_CONVERTIBLE_TO, D_CXXONLY }, - { "__is_empty", RID_IS_EMPTY, D_CXXONLY }, - { "__is_enum", RID_IS_ENUM, D_CXXONLY }, - { "__is_pod", RID_IS_POD, D_CXXONLY }, - { "__is_polymorphic", RID_IS_POLYMORPHIC, D_CXXONLY }, - { "__is_standard_layout", RID_IS_STD_LAYOUT, D_CXXONLY }, - { "__is_trivial", RID_IS_TRIVIAL, D_CXXONLY }, - { "__is_union", RID_IS_UNION, D_CXXONLY }, - { "__imag", RID_IMAGPART, 0 }, - { "__imag__", RID_IMAGPART, 0 }, - { "__inline", RID_INLINE, 0 }, - { "__inline__", RID_INLINE, 0 }, - { "__label__", RID_LABEL, 0 }, - { "__null", RID_NULL, 0 }, - { "__real", RID_REALPART, 0 }, - { "__real__", RID_REALPART, 0 }, - { "__restrict", RID_RESTRICT, 0 }, - { "__restrict__", RID_RESTRICT, 0 }, - { "__signed", RID_SIGNED, 0 }, - { "__signed__", RID_SIGNED, 0 }, - { "__thread", RID_THREAD, 0 }, - { "__typeof", RID_TYPEOF, 0 }, - { "__typeof__", RID_TYPEOF, 0 }, - { "__volatile", RID_VOLATILE, 0 }, - { "__volatile__", RID_VOLATILE, 0 }, - { "alignof", RID_ALIGNOF, D_CXXONLY | D_CXX0X | D_CXXWARN }, - { "asm", RID_ASM, D_ASM }, - { "auto", RID_AUTO, 0 }, - { "bool", RID_BOOL, D_CXXONLY | D_CXXWARN }, - { "break", RID_BREAK, 0 }, - { "case", RID_CASE, 0 }, - { "catch", RID_CATCH, D_CXX_OBJC | D_CXXWARN }, - { "char", RID_CHAR, 0 }, - { "char16_t", RID_CHAR16, D_CXXONLY | D_CXX0X | D_CXXWARN }, - { "char32_t", RID_CHAR32, D_CXXONLY | D_CXX0X | D_CXXWARN }, - { "class", RID_CLASS, D_CXX_OBJC | D_CXXWARN }, - { "const", RID_CONST, 0 }, - { "constexpr", RID_CONSTEXPR, D_CXXONLY | D_CXX0X | D_CXXWARN }, - { "const_cast", RID_CONSTCAST, D_CXXONLY | D_CXXWARN }, - { "continue", RID_CONTINUE, 0 }, - { "decltype", RID_DECLTYPE, D_CXXONLY | D_CXX0X | D_CXXWARN }, - { "default", RID_DEFAULT, 0 }, - { "delete", RID_DELETE, D_CXXONLY | D_CXXWARN }, - { "do", RID_DO, 0 }, - { "double", RID_DOUBLE, 0 }, - { "dynamic_cast", RID_DYNCAST, D_CXXONLY | D_CXXWARN }, - { "else", RID_ELSE, 0 }, - { "enum", RID_ENUM, 0 }, - { "explicit", RID_EXPLICIT, D_CXXONLY | D_CXXWARN }, - { "export", RID_EXPORT, D_CXXONLY | D_CXXWARN }, - { "extern", RID_EXTERN, 0 }, - { "false", RID_FALSE, D_CXXONLY | D_CXXWARN }, - { "float", RID_FLOAT, 0 }, - { "for", RID_FOR, 0 }, - { "friend", RID_FRIEND, D_CXXONLY | D_CXXWARN }, - { "goto", RID_GOTO, 0 }, - { "if", RID_IF, 0 }, - { "inline", RID_INLINE, D_EXT89 }, - { "int", RID_INT, 0 }, - { "long", RID_LONG, 0 }, - { "mutable", RID_MUTABLE, D_CXXONLY | D_CXXWARN }, - { "namespace", RID_NAMESPACE, D_CXXONLY | D_CXXWARN }, - { "new", RID_NEW, D_CXXONLY | D_CXXWARN }, - { "nullptr", RID_NULLPTR, D_CXXONLY | D_CXX0X | D_CXXWARN }, - { "operator", RID_OPERATOR, D_CXXONLY | D_CXXWARN }, - { "private", RID_PRIVATE, D_CXX_OBJC | D_CXXWARN }, - { "protected", RID_PROTECTED, D_CXX_OBJC | D_CXXWARN }, - { "public", RID_PUBLIC, D_CXX_OBJC | D_CXXWARN }, - { "register", RID_REGISTER, 0 }, - { "reinterpret_cast", RID_REINTCAST, D_CXXONLY | D_CXXWARN }, - { "restrict", RID_RESTRICT, D_CONLY | D_C99 }, - { "return", RID_RETURN, 0 }, - { "short", RID_SHORT, 0 }, - { "signed", RID_SIGNED, 0 }, - { "sizeof", RID_SIZEOF, 0 }, - { "static", RID_STATIC, 0 }, - { "static_assert", RID_STATIC_ASSERT, D_CXXONLY | D_CXX0X | D_CXXWARN }, - { "static_cast", RID_STATCAST, D_CXXONLY | D_CXXWARN }, - { "struct", RID_STRUCT, 0 }, - { "switch", RID_SWITCH, 0 }, - { "template", RID_TEMPLATE, D_CXXONLY | D_CXXWARN }, - { "this", RID_THIS, D_CXXONLY | D_CXXWARN }, - { "throw", RID_THROW, D_CXX_OBJC | D_CXXWARN }, - { "true", RID_TRUE, D_CXXONLY | D_CXXWARN }, - { "try", RID_TRY, D_CXX_OBJC | D_CXXWARN }, - { "typedef", RID_TYPEDEF, 0 }, - { "typename", RID_TYPENAME, D_CXXONLY | D_CXXWARN }, - { "typeid", RID_TYPEID, D_CXXONLY | D_CXXWARN }, - { "typeof", RID_TYPEOF, D_ASM | D_EXT }, - { "union", RID_UNION, 0 }, - { "unsigned", RID_UNSIGNED, 0 }, - { "using", RID_USING, D_CXXONLY | D_CXXWARN }, - { "virtual", RID_VIRTUAL, D_CXXONLY | D_CXXWARN }, - { "void", RID_VOID, 0 }, - { "volatile", RID_VOLATILE, 0 }, - { "wchar_t", RID_WCHAR, D_CXXONLY }, - { "while", RID_WHILE, 0 }, - /* These Objective-C keywords are recognized only immediately after - an '@'. */ - { "compatibility_alias", RID_AT_ALIAS, D_OBJC }, - { "defs", RID_AT_DEFS, D_OBJC }, - { "encode", RID_AT_ENCODE, D_OBJC }, - { "end", RID_AT_END, D_OBJC }, - { "implementation", RID_AT_IMPLEMENTATION, D_OBJC }, - { "interface", RID_AT_INTERFACE, D_OBJC }, - { "protocol", RID_AT_PROTOCOL, D_OBJC }, - { "selector", RID_AT_SELECTOR, D_OBJC }, - { "finally", RID_AT_FINALLY, D_OBJC }, - { "synchronized", RID_AT_SYNCHRONIZED, D_OBJC }, - /* These are recognized only in protocol-qualifier context - (see above) */ - { "bycopy", RID_BYCOPY, D_OBJC }, - { "byref", RID_BYREF, D_OBJC }, - { "in", RID_IN, D_OBJC }, - { "inout", RID_INOUT, D_OBJC }, - { "oneway", RID_ONEWAY, D_OBJC }, - { "out", RID_OUT, D_OBJC }, -}; - -const unsigned int num_c_common_reswords = - sizeof c_common_reswords / sizeof (struct c_common_resword); - -/* Table of machine-independent attributes common to all C-like languages. */ -const struct attribute_spec c_common_attribute_table[] = -{ - /* { name, min_len, max_len, decl_req, type_req, fn_type_req, handler } */ - { "packed", 0, 0, false, false, false, - handle_packed_attribute }, - { "nocommon", 0, 0, true, false, false, - handle_nocommon_attribute }, - { "common", 0, 0, true, false, false, - handle_common_attribute }, - /* FIXME: logically, noreturn attributes should be listed as - "false, true, true" and apply to function types. But implementing this - would require all the places in the compiler that use TREE_THIS_VOLATILE - on a decl to identify non-returning functions to be located and fixed - to check the function type instead. */ - { "noreturn", 0, 0, true, false, false, - handle_noreturn_attribute }, - { "volatile", 0, 0, true, false, false, - handle_noreturn_attribute }, - { "noinline", 0, 0, true, false, false, - handle_noinline_attribute }, - { "noclone", 0, 0, true, false, false, - handle_noclone_attribute }, - { "always_inline", 0, 0, true, false, false, - handle_always_inline_attribute }, - { "gnu_inline", 0, 0, true, false, false, - handle_gnu_inline_attribute }, - { "artificial", 0, 0, true, false, false, - handle_artificial_attribute }, - { "flatten", 0, 0, true, false, false, - handle_flatten_attribute }, - { "used", 0, 0, true, false, false, - handle_used_attribute }, - { "unused", 0, 0, false, false, false, - handle_unused_attribute }, - { "externally_visible", 0, 0, true, false, false, - handle_externally_visible_attribute }, - /* The same comments as for noreturn attributes apply to const ones. */ - { "const", 0, 0, true, false, false, - handle_const_attribute }, - { "transparent_union", 0, 0, false, false, false, - handle_transparent_union_attribute }, - { "constructor", 0, 1, true, false, false, - handle_constructor_attribute }, - { "destructor", 0, 1, true, false, false, - handle_destructor_attribute }, - { "mode", 1, 1, false, true, false, - handle_mode_attribute }, - { "section", 1, 1, true, false, false, - handle_section_attribute }, - { "aligned", 0, 1, false, false, false, - handle_aligned_attribute }, - { "weak", 0, 0, true, false, false, - handle_weak_attribute }, - { "alias", 1, 1, true, false, false, - handle_alias_attribute }, - { "weakref", 0, 1, true, false, false, - handle_weakref_attribute }, - { "no_instrument_function", 0, 0, true, false, false, - handle_no_instrument_function_attribute }, - { "malloc", 0, 0, true, false, false, - handle_malloc_attribute }, - { "returns_twice", 0, 0, true, false, false, - handle_returns_twice_attribute }, - { "no_stack_limit", 0, 0, true, false, false, - handle_no_limit_stack_attribute }, - { "pure", 0, 0, true, false, false, - handle_pure_attribute }, - /* For internal use (marking of builtins) only. The name contains space - to prevent its usage in source code. */ - { "no vops", 0, 0, true, false, false, - handle_novops_attribute }, - { "deprecated", 0, 1, false, false, false, - handle_deprecated_attribute }, - { "vector_size", 1, 1, false, true, false, - handle_vector_size_attribute }, - { "visibility", 1, 1, false, false, false, - handle_visibility_attribute }, - { "tls_model", 1, 1, true, false, false, - handle_tls_model_attribute }, - { "nonnull", 0, -1, false, true, true, - handle_nonnull_attribute }, - { "nothrow", 0, 0, true, false, false, - handle_nothrow_attribute }, - { "may_alias", 0, 0, false, true, false, NULL }, - { "cleanup", 1, 1, true, false, false, - handle_cleanup_attribute }, - { "warn_unused_result", 0, 0, false, true, true, - handle_warn_unused_result_attribute }, - { "sentinel", 0, 1, false, true, true, - handle_sentinel_attribute }, - /* For internal use (marking of builtins) only. The name contains space - to prevent its usage in source code. */ - { "type generic", 0, 0, false, true, true, - handle_type_generic_attribute }, - { "alloc_size", 1, 2, false, true, true, - handle_alloc_size_attribute }, - { "cold", 0, 0, true, false, false, - handle_cold_attribute }, - { "hot", 0, 0, true, false, false, - handle_hot_attribute }, - { "warning", 1, 1, true, false, false, - handle_error_attribute }, - { "error", 1, 1, true, false, false, - handle_error_attribute }, - { "target", 1, -1, true, false, false, - handle_target_attribute }, - { "optimize", 1, -1, true, false, false, - handle_optimize_attribute }, - /* For internal use (marking of builtins and runtime functions) only. - The name contains space to prevent its usage in source code. */ - { "fn spec", 1, 1, false, true, true, - handle_fnspec_attribute }, - { NULL, 0, 0, false, false, false, NULL } -}; - -/* Give the specifications for the format attributes, used by C and all - descendants. */ - -const struct attribute_spec c_common_format_attribute_table[] = -{ - /* { name, min_len, max_len, decl_req, type_req, fn_type_req, handler } */ - { "format", 3, 3, false, true, true, - handle_format_attribute }, - { "format_arg", 1, 1, false, true, true, - handle_format_arg_attribute }, - { NULL, 0, 0, false, false, false, NULL } -}; - -/* Return identifier for address space AS. */ - -const char * -c_addr_space_name (addr_space_t as) -{ - int rid = RID_FIRST_ADDR_SPACE + as; - gcc_assert (ridpointers [rid]); - return IDENTIFIER_POINTER (ridpointers [rid]); -} - -/* Push current bindings for the function name VAR_DECLS. */ - -void -start_fname_decls (void) -{ - unsigned ix; - tree saved = NULL_TREE; - - for (ix = 0; fname_vars[ix].decl; ix++) - { - tree decl = *fname_vars[ix].decl; - - if (decl) - { - saved = tree_cons (decl, build_int_cst (NULL_TREE, ix), saved); - *fname_vars[ix].decl = NULL_TREE; - } - } - if (saved || saved_function_name_decls) - /* Normally they'll have been NULL, so only push if we've got a - stack, or they are non-NULL. */ - saved_function_name_decls = tree_cons (saved, NULL_TREE, - saved_function_name_decls); -} - -/* Finish up the current bindings, adding them into the current function's - statement tree. This must be done _before_ finish_stmt_tree is called. - If there is no current function, we must be at file scope and no statements - are involved. Pop the previous bindings. */ - -void -finish_fname_decls (void) -{ - unsigned ix; - tree stmts = NULL_TREE; - tree stack = saved_function_name_decls; - - for (; stack && TREE_VALUE (stack); stack = TREE_CHAIN (stack)) - append_to_statement_list (TREE_VALUE (stack), &stmts); - - if (stmts) - { - tree *bodyp = &DECL_SAVED_TREE (current_function_decl); - - if (TREE_CODE (*bodyp) == BIND_EXPR) - bodyp = &BIND_EXPR_BODY (*bodyp); - - append_to_statement_list_force (*bodyp, &stmts); - *bodyp = stmts; - } - - for (ix = 0; fname_vars[ix].decl; ix++) - *fname_vars[ix].decl = NULL_TREE; - - if (stack) - { - /* We had saved values, restore them. */ - tree saved; - - for (saved = TREE_PURPOSE (stack); saved; saved = TREE_CHAIN (saved)) - { - tree decl = TREE_PURPOSE (saved); - unsigned ix = TREE_INT_CST_LOW (TREE_VALUE (saved)); - - *fname_vars[ix].decl = decl; - } - stack = TREE_CHAIN (stack); - } - saved_function_name_decls = stack; -} - -/* Return the text name of the current function, suitably prettified - by PRETTY_P. Return string must be freed by caller. */ - -const char * -fname_as_string (int pretty_p) -{ - const char *name = "top level"; - char *namep; - int vrb = 2, len; - cpp_string cstr = { 0, 0 }, strname; - - if (!pretty_p) - { - name = ""; - vrb = 0; - } - - if (current_function_decl) - name = lang_hooks.decl_printable_name (current_function_decl, vrb); - - len = strlen (name) + 3; /* Two for '"'s. One for NULL. */ - - namep = XNEWVEC (char, len); - snprintf (namep, len, "\"%s\"", name); - strname.text = (unsigned char *) namep; - strname.len = len - 1; - - if (cpp_interpret_string (parse_in, &strname, 1, &cstr, CPP_STRING)) - { - XDELETEVEC (namep); - return (const char *) cstr.text; - } - - return namep; -} - -/* Return the VAR_DECL for a const char array naming the current - function. If the VAR_DECL has not yet been created, create it - now. RID indicates how it should be formatted and IDENTIFIER_NODE - ID is its name (unfortunately C and C++ hold the RID values of - keywords in different places, so we can't derive RID from ID in - this language independent code. LOC is the location of the - function. */ - -tree -fname_decl (location_t loc, unsigned int rid, tree id) -{ - unsigned ix; - tree decl = NULL_TREE; - - for (ix = 0; fname_vars[ix].decl; ix++) - if (fname_vars[ix].rid == rid) - break; - - decl = *fname_vars[ix].decl; - if (!decl) - { - /* If a tree is built here, it would normally have the lineno of - the current statement. Later this tree will be moved to the - beginning of the function and this line number will be wrong. - To avoid this problem set the lineno to 0 here; that prevents - it from appearing in the RTL. */ - tree stmts; - location_t saved_location = input_location; - input_location = UNKNOWN_LOCATION; - - stmts = push_stmt_list (); - decl = (*make_fname_decl) (loc, id, fname_vars[ix].pretty); - stmts = pop_stmt_list (stmts); - if (!IS_EMPTY_STMT (stmts)) - saved_function_name_decls - = tree_cons (decl, stmts, saved_function_name_decls); - *fname_vars[ix].decl = decl; - input_location = saved_location; - } - if (!ix && !current_function_decl) - pedwarn (loc, 0, "%qD is not defined outside of function scope", decl); - - return decl; -} - -/* Given a STRING_CST, give it a suitable array-of-chars data type. */ - -tree -fix_string_type (tree value) -{ - int length = TREE_STRING_LENGTH (value); - int nchars; - tree e_type, i_type, a_type; - - /* Compute the number of elements, for the array type. */ - if (TREE_TYPE (value) == char_array_type_node || !TREE_TYPE (value)) - { - nchars = length; - e_type = char_type_node; - } - else if (TREE_TYPE (value) == char16_array_type_node) - { - nchars = length / (TYPE_PRECISION (char16_type_node) / BITS_PER_UNIT); - e_type = char16_type_node; - } - else if (TREE_TYPE (value) == char32_array_type_node) - { - nchars = length / (TYPE_PRECISION (char32_type_node) / BITS_PER_UNIT); - e_type = char32_type_node; - } - else - { - nchars = length / (TYPE_PRECISION (wchar_type_node) / BITS_PER_UNIT); - e_type = wchar_type_node; - } - - /* C89 2.2.4.1, C99 5.2.4.1 (Translation limits). The analogous - limit in C++98 Annex B is very large (65536) and is not normative, - so we do not diagnose it (warn_overlength_strings is forced off - in c_common_post_options). */ - if (warn_overlength_strings) - { - const int nchars_max = flag_isoc99 ? 4095 : 509; - const int relevant_std = flag_isoc99 ? 99 : 90; - if (nchars - 1 > nchars_max) - /* Translators: The %d after 'ISO C' will be 90 or 99. Do not - separate the %d from the 'C'. 'ISO' should not be - translated, but it may be moved after 'C%d' in languages - where modifiers follow nouns. */ - pedwarn (input_location, OPT_Woverlength_strings, - "string length %qd is greater than the length %qd " - "ISO C%d compilers are required to support", - nchars - 1, nchars_max, relevant_std); - } - - /* Create the array type for the string constant. The ISO C++ - standard says that a string literal has type `const char[N]' or - `const wchar_t[N]'. We use the same logic when invoked as a C - front-end with -Wwrite-strings. - ??? We should change the type of an expression depending on the - state of a warning flag. We should just be warning -- see how - this is handled in the C++ front-end for the deprecated implicit - conversion from string literals to `char*' or `wchar_t*'. - - The C++ front end relies on TYPE_MAIN_VARIANT of a cv-qualified - array type being the unqualified version of that type. - Therefore, if we are constructing an array of const char, we must - construct the matching unqualified array type first. The C front - end does not require this, but it does no harm, so we do it - unconditionally. */ - i_type = build_index_type (build_int_cst (NULL_TREE, nchars - 1)); - a_type = build_array_type (e_type, i_type); - if (c_dialect_cxx() || warn_write_strings) - a_type = c_build_qualified_type (a_type, TYPE_QUAL_CONST); - - TREE_TYPE (value) = a_type; - TREE_CONSTANT (value) = 1; - TREE_READONLY (value) = 1; - TREE_STATIC (value) = 1; - return value; -} - -/* Fully fold EXPR, an expression that was not folded (beyond integer - constant expressions and null pointer constants) when being built - up. If IN_INIT, this is in a static initializer and certain - changes are made to the folding done. Clear *MAYBE_CONST if - MAYBE_CONST is not NULL and EXPR is definitely not a constant - expression because it contains an evaluated operator (in C99) or an - operator outside of sizeof returning an integer constant (in C90) - not permitted in constant expressions, or because it contains an - evaluated arithmetic overflow. (*MAYBE_CONST should typically be - set to true by callers before calling this function.) Return the - folded expression. Function arguments have already been folded - before calling this function, as have the contents of SAVE_EXPR, - TARGET_EXPR, BIND_EXPR, VA_ARG_EXPR, OBJ_TYPE_REF and - C_MAYBE_CONST_EXPR. */ - -tree -c_fully_fold (tree expr, bool in_init, bool *maybe_const) -{ - tree ret; - tree eptype = NULL_TREE; - bool dummy = true; - bool maybe_const_itself = true; - location_t loc = EXPR_LOCATION (expr); - - /* This function is not relevant to C++ because C++ folds while - parsing, and may need changes to be correct for C++ when C++ - stops folding while parsing. */ - if (c_dialect_cxx ()) - gcc_unreachable (); - - if (!maybe_const) - maybe_const = &dummy; - if (TREE_CODE (expr) == EXCESS_PRECISION_EXPR) - { - eptype = TREE_TYPE (expr); - expr = TREE_OPERAND (expr, 0); - } - ret = c_fully_fold_internal (expr, in_init, maybe_const, - &maybe_const_itself); - if (eptype) - ret = fold_convert_loc (loc, eptype, ret); - *maybe_const &= maybe_const_itself; - return ret; -} - -/* Internal helper for c_fully_fold. EXPR and IN_INIT are as for - c_fully_fold. *MAYBE_CONST_OPERANDS is cleared because of operands - not permitted, while *MAYBE_CONST_ITSELF is cleared because of - arithmetic overflow (for C90, *MAYBE_CONST_OPERANDS is carried from - both evaluated and unevaluated subexpressions while - *MAYBE_CONST_ITSELF is carried from only evaluated - subexpressions). */ - -static tree -c_fully_fold_internal (tree expr, bool in_init, bool *maybe_const_operands, - bool *maybe_const_itself) -{ - tree ret = expr; - enum tree_code code = TREE_CODE (expr); - enum tree_code_class kind = TREE_CODE_CLASS (code); - location_t loc = EXPR_LOCATION (expr); - tree op0, op1, op2, op3; - tree orig_op0, orig_op1, orig_op2; - bool op0_const = true, op1_const = true, op2_const = true; - bool op0_const_self = true, op1_const_self = true, op2_const_self = true; - bool nowarning = TREE_NO_WARNING (expr); - int unused_p; - - /* This function is not relevant to C++ because C++ folds while - parsing, and may need changes to be correct for C++ when C++ - stops folding while parsing. */ - if (c_dialect_cxx ()) - gcc_unreachable (); - - /* Constants, declarations, statements, errors, SAVE_EXPRs and - anything else not counted as an expression cannot usefully be - folded further at this point. */ - if (!IS_EXPR_CODE_CLASS (kind) - || kind == tcc_statement - || code == SAVE_EXPR) - return expr; - - /* Operands of variable-length expressions (function calls) have - already been folded, as have __builtin_* function calls, and such - expressions cannot occur in constant expressions. */ - if (kind == tcc_vl_exp) - { - *maybe_const_operands = false; - ret = fold (expr); - goto out; - } - - if (code == C_MAYBE_CONST_EXPR) - { - tree pre = C_MAYBE_CONST_EXPR_PRE (expr); - tree inner = C_MAYBE_CONST_EXPR_EXPR (expr); - if (C_MAYBE_CONST_EXPR_NON_CONST (expr)) - *maybe_const_operands = false; - if (C_MAYBE_CONST_EXPR_INT_OPERANDS (expr)) - *maybe_const_itself = false; - if (pre && !in_init) - ret = build2 (COMPOUND_EXPR, TREE_TYPE (expr), pre, inner); - else - ret = inner; - goto out; - } - - /* Assignment, increment, decrement, function call and comma - operators, and statement expressions, cannot occur in constant - expressions if evaluated / outside of sizeof. (Function calls - were handled above, though VA_ARG_EXPR is treated like a function - call here, and statement expressions are handled through - C_MAYBE_CONST_EXPR to avoid folding inside them.) */ - switch (code) - { - case MODIFY_EXPR: - case PREDECREMENT_EXPR: - case PREINCREMENT_EXPR: - case POSTDECREMENT_EXPR: - case POSTINCREMENT_EXPR: - case COMPOUND_EXPR: - *maybe_const_operands = false; - break; - - case VA_ARG_EXPR: - case TARGET_EXPR: - case BIND_EXPR: - case OBJ_TYPE_REF: - *maybe_const_operands = false; - ret = fold (expr); - goto out; - - default: - break; - } - - /* Fold individual tree codes as appropriate. */ - switch (code) - { - case COMPOUND_LITERAL_EXPR: - /* Any non-constancy will have been marked in a containing - C_MAYBE_CONST_EXPR; there is no more folding to do here. */ - goto out; - - case COMPONENT_REF: - orig_op0 = op0 = TREE_OPERAND (expr, 0); - op1 = TREE_OPERAND (expr, 1); - op2 = TREE_OPERAND (expr, 2); - op0 = c_fully_fold_internal (op0, in_init, maybe_const_operands, - maybe_const_itself); - STRIP_TYPE_NOPS (op0); - if (op0 != orig_op0) - ret = build3 (COMPONENT_REF, TREE_TYPE (expr), op0, op1, op2); - if (ret != expr) - { - TREE_READONLY (ret) = TREE_READONLY (expr); - TREE_THIS_VOLATILE (ret) = TREE_THIS_VOLATILE (expr); - } - goto out; - - case ARRAY_REF: - orig_op0 = op0 = TREE_OPERAND (expr, 0); - orig_op1 = op1 = TREE_OPERAND (expr, 1); - op2 = TREE_OPERAND (expr, 2); - op3 = TREE_OPERAND (expr, 3); - op0 = c_fully_fold_internal (op0, in_init, maybe_const_operands, - maybe_const_itself); - STRIP_TYPE_NOPS (op0); - op1 = c_fully_fold_internal (op1, in_init, maybe_const_operands, - maybe_const_itself); - STRIP_TYPE_NOPS (op1); - op1 = decl_constant_value_for_optimization (op1); - if (op0 != orig_op0 || op1 != orig_op1) - ret = build4 (ARRAY_REF, TREE_TYPE (expr), op0, op1, op2, op3); - if (ret != expr) - { - TREE_READONLY (ret) = TREE_READONLY (expr); - TREE_SIDE_EFFECTS (ret) = TREE_SIDE_EFFECTS (expr); - TREE_THIS_VOLATILE (ret) = TREE_THIS_VOLATILE (expr); - } - ret = fold (ret); - goto out; - - case COMPOUND_EXPR: - case MODIFY_EXPR: - case PREDECREMENT_EXPR: - case PREINCREMENT_EXPR: - case POSTDECREMENT_EXPR: - case POSTINCREMENT_EXPR: - case PLUS_EXPR: - case MINUS_EXPR: - case MULT_EXPR: - case POINTER_PLUS_EXPR: - case TRUNC_DIV_EXPR: - case CEIL_DIV_EXPR: - case FLOOR_DIV_EXPR: - case TRUNC_MOD_EXPR: - case RDIV_EXPR: - case EXACT_DIV_EXPR: - case LSHIFT_EXPR: - case RSHIFT_EXPR: - case BIT_IOR_EXPR: - case BIT_XOR_EXPR: - case BIT_AND_EXPR: - case LT_EXPR: - case LE_EXPR: - case GT_EXPR: - case GE_EXPR: - case EQ_EXPR: - case NE_EXPR: - case COMPLEX_EXPR: - case TRUTH_AND_EXPR: - case TRUTH_OR_EXPR: - case TRUTH_XOR_EXPR: - case UNORDERED_EXPR: - case ORDERED_EXPR: - case UNLT_EXPR: - case UNLE_EXPR: - case UNGT_EXPR: - case UNGE_EXPR: - case UNEQ_EXPR: - /* Binary operations evaluating both arguments (increment and - decrement are binary internally in GCC). */ - orig_op0 = op0 = TREE_OPERAND (expr, 0); - orig_op1 = op1 = TREE_OPERAND (expr, 1); - op0 = c_fully_fold_internal (op0, in_init, maybe_const_operands, - maybe_const_itself); - STRIP_TYPE_NOPS (op0); - if (code != MODIFY_EXPR - && code != PREDECREMENT_EXPR - && code != PREINCREMENT_EXPR - && code != POSTDECREMENT_EXPR - && code != POSTINCREMENT_EXPR) - op0 = decl_constant_value_for_optimization (op0); - /* The RHS of a MODIFY_EXPR was fully folded when building that - expression for the sake of conversion warnings. */ - if (code != MODIFY_EXPR) - op1 = c_fully_fold_internal (op1, in_init, maybe_const_operands, - maybe_const_itself); - STRIP_TYPE_NOPS (op1); - op1 = decl_constant_value_for_optimization (op1); - if (op0 != orig_op0 || op1 != orig_op1 || in_init) - ret = in_init - ? fold_build2_initializer_loc (loc, code, TREE_TYPE (expr), op0, op1) - : fold_build2_loc (loc, code, TREE_TYPE (expr), op0, op1); - else - ret = fold (expr); - if (TREE_OVERFLOW_P (ret) - && !TREE_OVERFLOW_P (op0) - && !TREE_OVERFLOW_P (op1)) - overflow_warning (EXPR_LOCATION (expr), ret); - goto out; - - case INDIRECT_REF: - case FIX_TRUNC_EXPR: - case FLOAT_EXPR: - CASE_CONVERT: - case NON_LVALUE_EXPR: - case NEGATE_EXPR: - case BIT_NOT_EXPR: - case TRUTH_NOT_EXPR: - case ADDR_EXPR: - case CONJ_EXPR: - case REALPART_EXPR: - case IMAGPART_EXPR: - /* Unary operations. */ - orig_op0 = op0 = TREE_OPERAND (expr, 0); - op0 = c_fully_fold_internal (op0, in_init, maybe_const_operands, - maybe_const_itself); - STRIP_TYPE_NOPS (op0); - if (code != ADDR_EXPR && code != REALPART_EXPR && code != IMAGPART_EXPR) - op0 = decl_constant_value_for_optimization (op0); - if (op0 != orig_op0 || in_init) - ret = in_init - ? fold_build1_initializer_loc (loc, code, TREE_TYPE (expr), op0) - : fold_build1_loc (loc, code, TREE_TYPE (expr), op0); - else - ret = fold (expr); - if (code == INDIRECT_REF - && ret != expr - && TREE_CODE (ret) == INDIRECT_REF) - { - TREE_READONLY (ret) = TREE_READONLY (expr); - TREE_SIDE_EFFECTS (ret) = TREE_SIDE_EFFECTS (expr); - TREE_THIS_VOLATILE (ret) = TREE_THIS_VOLATILE (expr); - } - switch (code) - { - case FIX_TRUNC_EXPR: - case FLOAT_EXPR: - CASE_CONVERT: - /* Don't warn about explicit conversions. We will already - have warned about suspect implicit conversions. */ - break; - - default: - if (TREE_OVERFLOW_P (ret) && !TREE_OVERFLOW_P (op0)) - overflow_warning (EXPR_LOCATION (expr), ret); - break; - } - goto out; - - case TRUTH_ANDIF_EXPR: - case TRUTH_ORIF_EXPR: - /* Binary operations not necessarily evaluating both - arguments. */ - orig_op0 = op0 = TREE_OPERAND (expr, 0); - orig_op1 = op1 = TREE_OPERAND (expr, 1); - op0 = c_fully_fold_internal (op0, in_init, &op0_const, &op0_const_self); - STRIP_TYPE_NOPS (op0); - - unused_p = (op0 == (code == TRUTH_ANDIF_EXPR - ? truthvalue_false_node - : truthvalue_true_node)); - c_inhibit_evaluation_warnings += unused_p; - op1 = c_fully_fold_internal (op1, in_init, &op1_const, &op1_const_self); - STRIP_TYPE_NOPS (op1); - c_inhibit_evaluation_warnings -= unused_p; - - if (op0 != orig_op0 || op1 != orig_op1 || in_init) - ret = in_init - ? fold_build2_initializer_loc (loc, code, TREE_TYPE (expr), op0, op1) - : fold_build2_loc (loc, code, TREE_TYPE (expr), op0, op1); - else - ret = fold (expr); - *maybe_const_operands &= op0_const; - *maybe_const_itself &= op0_const_self; - if (!(flag_isoc99 - && op0_const - && op0_const_self - && (code == TRUTH_ANDIF_EXPR - ? op0 == truthvalue_false_node - : op0 == truthvalue_true_node))) - *maybe_const_operands &= op1_const; - if (!(op0_const - && op0_const_self - && (code == TRUTH_ANDIF_EXPR - ? op0 == truthvalue_false_node - : op0 == truthvalue_true_node))) - *maybe_const_itself &= op1_const_self; - goto out; - - case COND_EXPR: - orig_op0 = op0 = TREE_OPERAND (expr, 0); - orig_op1 = op1 = TREE_OPERAND (expr, 1); - orig_op2 = op2 = TREE_OPERAND (expr, 2); - op0 = c_fully_fold_internal (op0, in_init, &op0_const, &op0_const_self); - - STRIP_TYPE_NOPS (op0); - c_inhibit_evaluation_warnings += (op0 == truthvalue_false_node); - op1 = c_fully_fold_internal (op1, in_init, &op1_const, &op1_const_self); - STRIP_TYPE_NOPS (op1); - c_inhibit_evaluation_warnings -= (op0 == truthvalue_false_node); - - c_inhibit_evaluation_warnings += (op0 == truthvalue_true_node); - op2 = c_fully_fold_internal (op2, in_init, &op2_const, &op2_const_self); - STRIP_TYPE_NOPS (op2); - c_inhibit_evaluation_warnings -= (op0 == truthvalue_true_node); - - if (op0 != orig_op0 || op1 != orig_op1 || op2 != orig_op2) - ret = fold_build3_loc (loc, code, TREE_TYPE (expr), op0, op1, op2); - else - ret = fold (expr); - *maybe_const_operands &= op0_const; - *maybe_const_itself &= op0_const_self; - if (!(flag_isoc99 - && op0_const - && op0_const_self - && op0 == truthvalue_false_node)) - *maybe_const_operands &= op1_const; - if (!(op0_const - && op0_const_self - && op0 == truthvalue_false_node)) - *maybe_const_itself &= op1_const_self; - if (!(flag_isoc99 - && op0_const - && op0_const_self - && op0 == truthvalue_true_node)) - *maybe_const_operands &= op2_const; - if (!(op0_const - && op0_const_self - && op0 == truthvalue_true_node)) - *maybe_const_itself &= op2_const_self; - goto out; - - case EXCESS_PRECISION_EXPR: - /* Each case where an operand with excess precision may be - encountered must remove the EXCESS_PRECISION_EXPR around - inner operands and possibly put one around the whole - expression or possibly convert to the semantic type (which - c_fully_fold does); we cannot tell at this stage which is - appropriate in any particular case. */ - gcc_unreachable (); - - default: - /* Various codes may appear through folding built-in functions - and their arguments. */ - goto out; - } - - out: - /* Some folding may introduce NON_LVALUE_EXPRs; all lvalue checks - have been done by this point, so remove them again. */ - nowarning |= TREE_NO_WARNING (ret); - STRIP_TYPE_NOPS (ret); - if (nowarning && !TREE_NO_WARNING (ret)) - { - if (!CAN_HAVE_LOCATION_P (ret)) - ret = build1 (NOP_EXPR, TREE_TYPE (ret), ret); - TREE_NO_WARNING (ret) = 1; - } - if (ret != expr) - protected_set_expr_location (ret, loc); - return ret; -} - -/* If not optimizing, EXP is not a VAR_DECL, or EXP has array type, - return EXP. Otherwise, return either EXP or its known constant - value (if it has one), but return EXP if EXP has mode BLKmode. ??? - Is the BLKmode test appropriate? */ - -tree -decl_constant_value_for_optimization (tree exp) -{ - tree ret; - - /* This function is only used by C, for c_fully_fold and other - optimization, and may not be correct for C++. */ - if (c_dialect_cxx ()) - gcc_unreachable (); - - if (!optimize - || TREE_CODE (exp) != VAR_DECL - || TREE_CODE (TREE_TYPE (exp)) == ARRAY_TYPE - || DECL_MODE (exp) == BLKmode) - return exp; - - ret = decl_constant_value (exp); - /* Avoid unwanted tree sharing between the initializer and current - function's body where the tree can be modified e.g. by the - gimplifier. */ - if (ret != exp && TREE_STATIC (exp)) - ret = unshare_expr (ret); - return ret; -} - -/* Print a warning if a constant expression had overflow in folding. - Invoke this function on every expression that the language - requires to be a constant expression. - Note the ANSI C standard says it is erroneous for a - constant expression to overflow. */ - -void -constant_expression_warning (tree value) -{ - if (warn_overflow && pedantic - && (TREE_CODE (value) == INTEGER_CST || TREE_CODE (value) == REAL_CST - || TREE_CODE (value) == FIXED_CST - || TREE_CODE (value) == VECTOR_CST - || TREE_CODE (value) == COMPLEX_CST) - && TREE_OVERFLOW (value)) - pedwarn (input_location, OPT_Woverflow, "overflow in constant expression"); -} - -/* The same as above but print an unconditional error. */ -void -constant_expression_error (tree value) -{ - if ((TREE_CODE (value) == INTEGER_CST || TREE_CODE (value) == REAL_CST - || TREE_CODE (value) == FIXED_CST - || TREE_CODE (value) == VECTOR_CST - || TREE_CODE (value) == COMPLEX_CST) - && TREE_OVERFLOW (value)) - error ("overflow in constant expression"); -} - -/* Print a warning if an expression had overflow in folding and its - operands hadn't. - - Invoke this function on every expression that - (1) appears in the source code, and - (2) is a constant expression that overflowed, and - (3) is not already checked by convert_and_check; - however, do not invoke this function on operands of explicit casts - or when the expression is the result of an operator and any operand - already overflowed. */ - -void -overflow_warning (location_t loc, tree value) -{ - if (c_inhibit_evaluation_warnings != 0) - return; - - switch (TREE_CODE (value)) - { - case INTEGER_CST: - warning_at (loc, OPT_Woverflow, "integer overflow in expression"); - break; - - case REAL_CST: - warning_at (loc, OPT_Woverflow, - "floating point overflow in expression"); - break; - - case FIXED_CST: - warning_at (loc, OPT_Woverflow, "fixed-point overflow in expression"); - break; - - case VECTOR_CST: - warning_at (loc, OPT_Woverflow, "vector overflow in expression"); - break; - - case COMPLEX_CST: - if (TREE_CODE (TREE_REALPART (value)) == INTEGER_CST) - warning_at (loc, OPT_Woverflow, - "complex integer overflow in expression"); - else if (TREE_CODE (TREE_REALPART (value)) == REAL_CST) - warning_at (loc, OPT_Woverflow, - "complex floating point overflow in expression"); - break; - - default: - break; - } -} - -/* Warn about uses of logical || / && operator in a context where it - is likely that the bitwise equivalent was intended by the - programmer. We have seen an expression in which CODE is a binary - operator used to combine expressions OP_LEFT and OP_RIGHT, which before folding - had CODE_LEFT and CODE_RIGHT, into an expression of type TYPE. */ -void -warn_logical_operator (location_t location, enum tree_code code, tree type, - enum tree_code code_left, tree op_left, - enum tree_code ARG_UNUSED (code_right), tree op_right) -{ - int or_op = (code == TRUTH_ORIF_EXPR || code == TRUTH_OR_EXPR); - int in0_p, in1_p, in_p; - tree low0, low1, low, high0, high1, high, lhs, rhs, tem; - bool strict_overflow_p = false; - - if (code != TRUTH_ANDIF_EXPR - && code != TRUTH_AND_EXPR - && code != TRUTH_ORIF_EXPR - && code != TRUTH_OR_EXPR) - return; - - /* Warn if &&/|| are being used in a context where it is - likely that the bitwise equivalent was intended by the - programmer. That is, an expression such as op && MASK - where op should not be any boolean expression, nor a - constant, and mask seems to be a non-boolean integer constant. */ - if (!truth_value_p (code_left) - && INTEGRAL_TYPE_P (TREE_TYPE (op_left)) - && !CONSTANT_CLASS_P (op_left) - && !TREE_NO_WARNING (op_left) - && TREE_CODE (op_right) == INTEGER_CST - && !integer_zerop (op_right) - && !integer_onep (op_right)) - { - if (or_op) - warning_at (location, OPT_Wlogical_op, "logical %" - " applied to non-boolean constant"); - else - warning_at (location, OPT_Wlogical_op, "logical %" - " applied to non-boolean constant"); - TREE_NO_WARNING (op_left) = true; - return; - } - - /* We do not warn for constants because they are typical of macro - expansions that test for features. */ - if (CONSTANT_CLASS_P (op_left) || CONSTANT_CLASS_P (op_right)) - return; - - /* This warning only makes sense with logical operands. */ - if (!(truth_value_p (TREE_CODE (op_left)) - || INTEGRAL_TYPE_P (TREE_TYPE (op_left))) - || !(truth_value_p (TREE_CODE (op_right)) - || INTEGRAL_TYPE_P (TREE_TYPE (op_right)))) - return; - - lhs = make_range (op_left, &in0_p, &low0, &high0, &strict_overflow_p); - rhs = make_range (op_right, &in1_p, &low1, &high1, &strict_overflow_p); - - if (lhs && TREE_CODE (lhs) == C_MAYBE_CONST_EXPR) - lhs = C_MAYBE_CONST_EXPR_EXPR (lhs); - - if (rhs && TREE_CODE (rhs) == C_MAYBE_CONST_EXPR) - rhs = C_MAYBE_CONST_EXPR_EXPR (rhs); - - /* If this is an OR operation, invert both sides; we will invert - again at the end. */ - if (or_op) - in0_p = !in0_p, in1_p = !in1_p; - - /* If both expressions are the same, if we can merge the ranges, and we - can build the range test, return it or it inverted. */ - if (lhs && rhs && operand_equal_p (lhs, rhs, 0) - && merge_ranges (&in_p, &low, &high, in0_p, low0, high0, - in1_p, low1, high1) - && 0 != (tem = build_range_check (UNKNOWN_LOCATION, - type, lhs, in_p, low, high))) - { - if (TREE_CODE (tem) != INTEGER_CST) - return; - - if (or_op) - warning_at (location, OPT_Wlogical_op, - "logical % " - "of collectively exhaustive tests is always true"); - else - warning_at (location, OPT_Wlogical_op, - "logical % " - "of mutually exclusive tests is always false"); - } -} - - -/* Print a warning about casts that might indicate violation - of strict aliasing rules if -Wstrict-aliasing is used and - strict aliasing mode is in effect. OTYPE is the original - TREE_TYPE of EXPR, and TYPE the type we're casting to. */ - -bool -strict_aliasing_warning (tree otype, tree type, tree expr) -{ - /* Strip pointer conversion chains and get to the correct original type. */ - STRIP_NOPS (expr); - otype = TREE_TYPE (expr); - - if (!(flag_strict_aliasing - && POINTER_TYPE_P (type) - && POINTER_TYPE_P (otype) - && !VOID_TYPE_P (TREE_TYPE (type))) - /* If the type we are casting to is a ref-all pointer - dereferencing it is always valid. */ - || TYPE_REF_CAN_ALIAS_ALL (type)) - return false; - - if ((warn_strict_aliasing > 1) && TREE_CODE (expr) == ADDR_EXPR - && (DECL_P (TREE_OPERAND (expr, 0)) - || handled_component_p (TREE_OPERAND (expr, 0)))) - { - /* Casting the address of an object to non void pointer. Warn - if the cast breaks type based aliasing. */ - if (!COMPLETE_TYPE_P (TREE_TYPE (type)) && warn_strict_aliasing == 2) - { - warning (OPT_Wstrict_aliasing, "type-punning to incomplete type " - "might break strict-aliasing rules"); - return true; - } - else - { - /* warn_strict_aliasing >= 3. This includes the default (3). - Only warn if the cast is dereferenced immediately. */ - alias_set_type set1 = - get_alias_set (TREE_TYPE (TREE_OPERAND (expr, 0))); - alias_set_type set2 = get_alias_set (TREE_TYPE (type)); - - if (set1 != set2 && set2 != 0 - && (set1 == 0 || !alias_sets_conflict_p (set1, set2))) - { - warning (OPT_Wstrict_aliasing, "dereferencing type-punned " - "pointer will break strict-aliasing rules"); - return true; - } - else if (warn_strict_aliasing == 2 - && !alias_sets_must_conflict_p (set1, set2)) - { - warning (OPT_Wstrict_aliasing, "dereferencing type-punned " - "pointer might break strict-aliasing rules"); - return true; - } - } - } - else - if ((warn_strict_aliasing == 1) && !VOID_TYPE_P (TREE_TYPE (otype))) - { - /* At this level, warn for any conversions, even if an address is - not taken in the same statement. This will likely produce many - false positives, but could be useful to pinpoint problems that - are not revealed at higher levels. */ - alias_set_type set1 = get_alias_set (TREE_TYPE (otype)); - alias_set_type set2 = get_alias_set (TREE_TYPE (type)); - if (!COMPLETE_TYPE_P (type) - || !alias_sets_must_conflict_p (set1, set2)) - { - warning (OPT_Wstrict_aliasing, "dereferencing type-punned " - "pointer might break strict-aliasing rules"); - return true; - } - } - - return false; -} - -/* Warn for unlikely, improbable, or stupid DECL declarations - of `main'. */ - -void -check_main_parameter_types (tree decl) -{ - tree args; - int argct = 0; - - for (args = TYPE_ARG_TYPES (TREE_TYPE (decl)); args; - args = TREE_CHAIN (args)) - { - tree type = args ? TREE_VALUE (args) : 0; - - if (type == void_type_node || type == error_mark_node ) - break; - - ++argct; - switch (argct) - { - case 1: - if (TYPE_MAIN_VARIANT (type) != integer_type_node) - pedwarn (input_location, OPT_Wmain, "first argument of %q+D should be %", - decl); - break; - - case 2: - if (TREE_CODE (type) != POINTER_TYPE - || TREE_CODE (TREE_TYPE (type)) != POINTER_TYPE - || (TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (type))) - != char_type_node)) - pedwarn (input_location, OPT_Wmain, "second argument of %q+D should be %", - decl); - break; - - case 3: - if (TREE_CODE (type) != POINTER_TYPE - || TREE_CODE (TREE_TYPE (type)) != POINTER_TYPE - || (TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (type))) - != char_type_node)) - pedwarn (input_location, OPT_Wmain, "third argument of %q+D should probably be " - "%", decl); - break; - } - } - - /* It is intentional that this message does not mention the third - argument because it's only mentioned in an appendix of the - standard. */ - if (argct > 0 && (argct < 2 || argct > 3)) - pedwarn (input_location, OPT_Wmain, "%q+D takes only zero or two arguments", decl); -} - -/* True if pointers to distinct types T1 and T2 can be converted to - each other without an explicit cast. Only returns true for opaque - vector types. */ -bool -vector_targets_convertible_p (const_tree t1, const_tree t2) -{ - if (TREE_CODE (t1) == VECTOR_TYPE && TREE_CODE (t2) == VECTOR_TYPE - && (TYPE_VECTOR_OPAQUE (t1) || TYPE_VECTOR_OPAQUE (t2)) - && tree_int_cst_equal (TYPE_SIZE (t1), TYPE_SIZE (t2))) - return true; - - return false; -} - -/* True if vector types T1 and T2 can be converted to each other - without an explicit cast. If EMIT_LAX_NOTE is true, and T1 and T2 - can only be converted with -flax-vector-conversions yet that is not - in effect, emit a note telling the user about that option if such - a note has not previously been emitted. */ -bool -vector_types_convertible_p (const_tree t1, const_tree t2, bool emit_lax_note) -{ - static bool emitted_lax_note = false; - bool convertible_lax; - - if ((TYPE_VECTOR_OPAQUE (t1) || TYPE_VECTOR_OPAQUE (t2)) - && tree_int_cst_equal (TYPE_SIZE (t1), TYPE_SIZE (t2))) - return true; - - convertible_lax = - (tree_int_cst_equal (TYPE_SIZE (t1), TYPE_SIZE (t2)) - && (TREE_CODE (TREE_TYPE (t1)) != REAL_TYPE || - TYPE_PRECISION (t1) == TYPE_PRECISION (t2)) - && (INTEGRAL_TYPE_P (TREE_TYPE (t1)) - == INTEGRAL_TYPE_P (TREE_TYPE (t2)))); - - if (!convertible_lax || flag_lax_vector_conversions) - return convertible_lax; - - if (TYPE_VECTOR_SUBPARTS (t1) == TYPE_VECTOR_SUBPARTS (t2) - && lang_hooks.types_compatible_p (TREE_TYPE (t1), TREE_TYPE (t2))) - return true; - - if (emit_lax_note && !emitted_lax_note) - { - emitted_lax_note = true; - inform (input_location, "use -flax-vector-conversions to permit " - "conversions between vectors with differing " - "element types or numbers of subparts"); - } - - return false; -} - -/* This is a helper function of build_binary_op. - - For certain operations if both args were extended from the same - smaller type, do the arithmetic in that type and then extend. - - BITWISE indicates a bitwise operation. - For them, this optimization is safe only if - both args are zero-extended or both are sign-extended. - Otherwise, we might change the result. - Eg, (short)-1 | (unsigned short)-1 is (int)-1 - but calculated in (unsigned short) it would be (unsigned short)-1. -*/ -tree shorten_binary_op (tree result_type, tree op0, tree op1, bool bitwise) -{ - int unsigned0, unsigned1; - tree arg0, arg1; - int uns; - tree type; - - /* Cast OP0 and OP1 to RESULT_TYPE. Doing so prevents - excessive narrowing when we call get_narrower below. For - example, suppose that OP0 is of unsigned int extended - from signed char and that RESULT_TYPE is long long int. - If we explicitly cast OP0 to RESULT_TYPE, OP0 would look - like - - (long long int) (unsigned int) signed_char - - which get_narrower would narrow down to - - (unsigned int) signed char - - If we do not cast OP0 first, get_narrower would return - signed_char, which is inconsistent with the case of the - explicit cast. */ - op0 = convert (result_type, op0); - op1 = convert (result_type, op1); - - arg0 = get_narrower (op0, &unsigned0); - arg1 = get_narrower (op1, &unsigned1); - - /* UNS is 1 if the operation to be done is an unsigned one. */ - uns = TYPE_UNSIGNED (result_type); - - /* Handle the case that OP0 (or OP1) does not *contain* a conversion - but it *requires* conversion to FINAL_TYPE. */ - - if ((TYPE_PRECISION (TREE_TYPE (op0)) - == TYPE_PRECISION (TREE_TYPE (arg0))) - && TREE_TYPE (op0) != result_type) - unsigned0 = TYPE_UNSIGNED (TREE_TYPE (op0)); - if ((TYPE_PRECISION (TREE_TYPE (op1)) - == TYPE_PRECISION (TREE_TYPE (arg1))) - && TREE_TYPE (op1) != result_type) - unsigned1 = TYPE_UNSIGNED (TREE_TYPE (op1)); - - /* Now UNSIGNED0 is 1 if ARG0 zero-extends to FINAL_TYPE. */ - - /* For bitwise operations, signedness of nominal type - does not matter. Consider only how operands were extended. */ - if (bitwise) - uns = unsigned0; - - /* Note that in all three cases below we refrain from optimizing - an unsigned operation on sign-extended args. - That would not be valid. */ - - /* Both args variable: if both extended in same way - from same width, do it in that width. - Do it unsigned if args were zero-extended. */ - if ((TYPE_PRECISION (TREE_TYPE (arg0)) - < TYPE_PRECISION (result_type)) - && (TYPE_PRECISION (TREE_TYPE (arg1)) - == TYPE_PRECISION (TREE_TYPE (arg0))) - && unsigned0 == unsigned1 - && (unsigned0 || !uns)) - return c_common_signed_or_unsigned_type - (unsigned0, common_type (TREE_TYPE (arg0), TREE_TYPE (arg1))); - - else if (TREE_CODE (arg0) == INTEGER_CST - && (unsigned1 || !uns) - && (TYPE_PRECISION (TREE_TYPE (arg1)) - < TYPE_PRECISION (result_type)) - && (type - = c_common_signed_or_unsigned_type (unsigned1, - TREE_TYPE (arg1))) - && !POINTER_TYPE_P (type) - && int_fits_type_p (arg0, type)) - return type; - - else if (TREE_CODE (arg1) == INTEGER_CST - && (unsigned0 || !uns) - && (TYPE_PRECISION (TREE_TYPE (arg0)) - < TYPE_PRECISION (result_type)) - && (type - = c_common_signed_or_unsigned_type (unsigned0, - TREE_TYPE (arg0))) - && !POINTER_TYPE_P (type) - && int_fits_type_p (arg1, type)) - return type; - - return result_type; -} - -/* Warns if the conversion of EXPR to TYPE may alter a value. - This is a helper function for warnings_for_convert_and_check. */ - -static void -conversion_warning (tree type, tree expr) -{ - bool give_warning = false; - - int i; - const int expr_num_operands = TREE_OPERAND_LENGTH (expr); - tree expr_type = TREE_TYPE (expr); - - if (!warn_conversion && !warn_sign_conversion) - return; - - /* If any operand is artificial, then this expression was generated - by the compiler and we do not warn. */ - for (i = 0; i < expr_num_operands; i++) - { - tree op = TREE_OPERAND (expr, i); - if (op && DECL_P (op) && DECL_ARTIFICIAL (op)) - return; - } - - switch (TREE_CODE (expr)) - { - case EQ_EXPR: - 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: - case TRUTH_NOT_EXPR: - /* Conversion from boolean to a signed:1 bit-field (which only - can hold the values 0 and -1) doesn't lose information - but - it does change the value. */ - if (TYPE_PRECISION (type) == 1 && !TYPE_UNSIGNED (type)) - warning (OPT_Wconversion, - "conversion to %qT from boolean expression", type); - return; - - case REAL_CST: - case INTEGER_CST: - - /* Warn for real constant that is not an exact integer converted - to integer type. */ - if (TREE_CODE (expr_type) == REAL_TYPE - && TREE_CODE (type) == INTEGER_TYPE) - { - if (!real_isinteger (TREE_REAL_CST_PTR (expr), TYPE_MODE (expr_type))) - give_warning = true; - } - /* Warn for an integer constant that does not fit into integer type. */ - else if (TREE_CODE (expr_type) == INTEGER_TYPE - && TREE_CODE (type) == INTEGER_TYPE - && !int_fits_type_p (expr, type)) - { - if (TYPE_UNSIGNED (type) && !TYPE_UNSIGNED (expr_type) - && tree_int_cst_sgn (expr) < 0) - warning (OPT_Wsign_conversion, - "negative integer implicitly converted to unsigned type"); - else if (!TYPE_UNSIGNED (type) && TYPE_UNSIGNED (expr_type)) - warning (OPT_Wsign_conversion, "conversion of unsigned constant " - "value to negative integer"); - else - give_warning = true; - } - else if (TREE_CODE (type) == REAL_TYPE) - { - /* Warn for an integer constant that does not fit into real type. */ - if (TREE_CODE (expr_type) == INTEGER_TYPE) - { - REAL_VALUE_TYPE a = real_value_from_int_cst (0, expr); - if (!exact_real_truncate (TYPE_MODE (type), &a)) - give_warning = true; - } - /* Warn for a real constant that does not fit into a smaller - real type. */ - else if (TREE_CODE (expr_type) == REAL_TYPE - && TYPE_PRECISION (type) < TYPE_PRECISION (expr_type)) - { - REAL_VALUE_TYPE a = TREE_REAL_CST (expr); - if (!exact_real_truncate (TYPE_MODE (type), &a)) - give_warning = true; - } - } - - if (give_warning) - warning (OPT_Wconversion, - "conversion to %qT alters %qT constant value", - type, expr_type); - - return; - - case COND_EXPR: - { - /* In case of COND_EXPR, if both operands are constants or - COND_EXPR, then we do not care about the type of COND_EXPR, - only about the conversion of each operand. */ - tree op1 = TREE_OPERAND (expr, 1); - tree op2 = TREE_OPERAND (expr, 2); - - if ((TREE_CODE (op1) == REAL_CST || TREE_CODE (op1) == INTEGER_CST - || TREE_CODE (op1) == COND_EXPR) - && (TREE_CODE (op2) == REAL_CST || TREE_CODE (op2) == INTEGER_CST - || TREE_CODE (op2) == COND_EXPR)) - { - conversion_warning (type, op1); - conversion_warning (type, op2); - return; - } - /* Fall through. */ - } - - default: /* 'expr' is not a constant. */ - - /* Warn for real types converted to integer types. */ - if (TREE_CODE (expr_type) == REAL_TYPE - && TREE_CODE (type) == INTEGER_TYPE) - give_warning = true; - - else if (TREE_CODE (expr_type) == INTEGER_TYPE - && TREE_CODE (type) == INTEGER_TYPE) - { - /* Don't warn about unsigned char y = 0xff, x = (int) y; */ - expr = get_unwidened (expr, 0); - expr_type = TREE_TYPE (expr); - - /* Don't warn for short y; short x = ((int)y & 0xff); */ - if (TREE_CODE (expr) == BIT_AND_EXPR - || TREE_CODE (expr) == BIT_IOR_EXPR - || TREE_CODE (expr) == BIT_XOR_EXPR) - { - /* If both args were extended from a shortest type, - use that type if that is safe. */ - expr_type = shorten_binary_op (expr_type, - TREE_OPERAND (expr, 0), - TREE_OPERAND (expr, 1), - /* bitwise */1); - - if (TREE_CODE (expr) == BIT_AND_EXPR) - { - tree op0 = TREE_OPERAND (expr, 0); - tree op1 = TREE_OPERAND (expr, 1); - bool unsigned0 = TYPE_UNSIGNED (TREE_TYPE (op0)); - bool unsigned1 = TYPE_UNSIGNED (TREE_TYPE (op1)); - - /* If one of the operands is a non-negative constant - that fits in the target type, then the type of the - other operand does not matter. */ - if ((TREE_CODE (op0) == INTEGER_CST - && int_fits_type_p (op0, c_common_signed_type (type)) - && int_fits_type_p (op0, c_common_unsigned_type (type))) - || (TREE_CODE (op1) == INTEGER_CST - && int_fits_type_p (op1, c_common_signed_type (type)) - && int_fits_type_p (op1, - c_common_unsigned_type (type)))) - return; - /* If constant is unsigned and fits in the target - type, then the result will also fit. */ - else if ((TREE_CODE (op0) == INTEGER_CST - && unsigned0 - && int_fits_type_p (op0, type)) - || (TREE_CODE (op1) == INTEGER_CST - && unsigned1 - && int_fits_type_p (op1, type))) - return; - } - } - /* Warn for integer types converted to smaller integer types. */ - if (TYPE_PRECISION (type) < TYPE_PRECISION (expr_type)) - give_warning = true; - - /* When they are the same width but different signedness, - then the value may change. */ - else if ((TYPE_PRECISION (type) == TYPE_PRECISION (expr_type) - && TYPE_UNSIGNED (expr_type) != TYPE_UNSIGNED (type)) - /* Even when converted to a bigger type, if the type is - unsigned but expr is signed, then negative values - will be changed. */ - || (TYPE_UNSIGNED (type) && !TYPE_UNSIGNED (expr_type))) - warning (OPT_Wsign_conversion, "conversion to %qT from %qT " - "may change the sign of the result", - type, expr_type); - } - - /* Warn for integer types converted to real types if and only if - all the range of values of the integer type cannot be - represented by the real type. */ - else if (TREE_CODE (expr_type) == INTEGER_TYPE - && TREE_CODE (type) == REAL_TYPE) - { - tree type_low_bound, type_high_bound; - REAL_VALUE_TYPE real_low_bound, real_high_bound; - - /* Don't warn about char y = 0xff; float x = (int) y; */ - expr = get_unwidened (expr, 0); - expr_type = TREE_TYPE (expr); - - type_low_bound = TYPE_MIN_VALUE (expr_type); - type_high_bound = TYPE_MAX_VALUE (expr_type); - real_low_bound = real_value_from_int_cst (0, type_low_bound); - real_high_bound = real_value_from_int_cst (0, type_high_bound); - - if (!exact_real_truncate (TYPE_MODE (type), &real_low_bound) - || !exact_real_truncate (TYPE_MODE (type), &real_high_bound)) - give_warning = true; - } - - /* Warn for real types converted to smaller real types. */ - else if (TREE_CODE (expr_type) == REAL_TYPE - && TREE_CODE (type) == REAL_TYPE - && TYPE_PRECISION (type) < TYPE_PRECISION (expr_type)) - give_warning = true; - - - if (give_warning) - warning (OPT_Wconversion, - "conversion to %qT from %qT may alter its value", - type, expr_type); - } -} - -/* Produce warnings after a conversion. RESULT is the result of - converting EXPR to TYPE. This is a helper function for - convert_and_check and cp_convert_and_check. */ - -void -warnings_for_convert_and_check (tree type, tree expr, tree result) -{ - if (TREE_CODE (expr) == INTEGER_CST - && (TREE_CODE (type) == INTEGER_TYPE - || TREE_CODE (type) == ENUMERAL_TYPE) - && !int_fits_type_p (expr, type)) - { - /* Do not diagnose overflow in a constant expression merely - because a conversion overflowed. */ - if (TREE_OVERFLOW (result)) - TREE_OVERFLOW (result) = TREE_OVERFLOW (expr); - - if (TYPE_UNSIGNED (type)) - { - /* This detects cases like converting -129 or 256 to - unsigned char. */ - if (!int_fits_type_p (expr, c_common_signed_type (type))) - warning (OPT_Woverflow, - "large integer implicitly truncated to unsigned type"); - else - conversion_warning (type, expr); - } - else if (!int_fits_type_p (expr, c_common_unsigned_type (type))) - warning (OPT_Woverflow, - "overflow in implicit constant conversion"); - /* No warning for converting 0x80000000 to int. */ - else if (pedantic - && (TREE_CODE (TREE_TYPE (expr)) != INTEGER_TYPE - || TYPE_PRECISION (TREE_TYPE (expr)) - != TYPE_PRECISION (type))) - warning (OPT_Woverflow, - "overflow in implicit constant conversion"); - - else - conversion_warning (type, expr); - } - else if ((TREE_CODE (result) == INTEGER_CST - || TREE_CODE (result) == FIXED_CST) && TREE_OVERFLOW (result)) - warning (OPT_Woverflow, - "overflow in implicit constant conversion"); - else - conversion_warning (type, expr); -} - - -/* Convert EXPR to TYPE, warning about conversion problems with constants. - Invoke this function on every expression that is converted implicitly, - i.e. because of language rules and not because of an explicit cast. */ - -tree -convert_and_check (tree type, tree expr) -{ - tree result; - tree expr_for_warning; - - /* Convert from a value with possible excess precision rather than - via the semantic type, but do not warn about values not fitting - exactly in the semantic type. */ - if (TREE_CODE (expr) == EXCESS_PRECISION_EXPR) - { - tree orig_type = TREE_TYPE (expr); - expr = TREE_OPERAND (expr, 0); - expr_for_warning = convert (orig_type, expr); - if (orig_type == type) - return expr_for_warning; - } - else - expr_for_warning = expr; - - if (TREE_TYPE (expr) == type) - return expr; - - result = convert (type, expr); - - if (c_inhibit_evaluation_warnings == 0 - && !TREE_OVERFLOW_P (expr) - && result != error_mark_node) - warnings_for_convert_and_check (type, expr_for_warning, result); - - return result; -} - -/* A node in a list that describes references to variables (EXPR), which are - either read accesses if WRITER is zero, or write accesses, in which case - WRITER is the parent of EXPR. */ -struct tlist -{ - struct tlist *next; - tree expr, writer; -}; - -/* Used to implement a cache the results of a call to verify_tree. We only - use this for SAVE_EXPRs. */ -struct tlist_cache -{ - struct tlist_cache *next; - struct tlist *cache_before_sp; - struct tlist *cache_after_sp; - tree expr; -}; - -/* Obstack to use when allocating tlist structures, and corresponding - firstobj. */ -static struct obstack tlist_obstack; -static char *tlist_firstobj = 0; - -/* Keep track of the identifiers we've warned about, so we can avoid duplicate - warnings. */ -static struct tlist *warned_ids; -/* SAVE_EXPRs need special treatment. We process them only once and then - cache the results. */ -static struct tlist_cache *save_expr_cache; - -static void add_tlist (struct tlist **, struct tlist *, tree, int); -static void merge_tlist (struct tlist **, struct tlist *, int); -static void verify_tree (tree, struct tlist **, struct tlist **, tree); -static int warning_candidate_p (tree); -static bool candidate_equal_p (const_tree, const_tree); -static void warn_for_collisions (struct tlist *); -static void warn_for_collisions_1 (tree, tree, struct tlist *, int); -static struct tlist *new_tlist (struct tlist *, tree, tree); - -/* Create a new struct tlist and fill in its fields. */ -static struct tlist * -new_tlist (struct tlist *next, tree t, tree writer) -{ - struct tlist *l; - l = XOBNEW (&tlist_obstack, struct tlist); - l->next = next; - l->expr = t; - l->writer = writer; - return l; -} - -/* Add duplicates of the nodes found in ADD to the list *TO. If EXCLUDE_WRITER - is nonnull, we ignore any node we find which has a writer equal to it. */ - -static void -add_tlist (struct tlist **to, struct tlist *add, tree exclude_writer, int copy) -{ - while (add) - { - struct tlist *next = add->next; - if (!copy) - add->next = *to; - if (!exclude_writer || !candidate_equal_p (add->writer, exclude_writer)) - *to = copy ? new_tlist (*to, add->expr, add->writer) : add; - add = next; - } -} - -/* Merge the nodes of ADD into TO. This merging process is done so that for - each variable that already exists in TO, no new node is added; however if - there is a write access recorded in ADD, and an occurrence on TO is only - a read access, then the occurrence in TO will be modified to record the - write. */ - -static void -merge_tlist (struct tlist **to, struct tlist *add, int copy) -{ - struct tlist **end = to; - - while (*end) - end = &(*end)->next; - - while (add) - { - int found = 0; - struct tlist *tmp2; - struct tlist *next = add->next; - - for (tmp2 = *to; tmp2; tmp2 = tmp2->next) - if (candidate_equal_p (tmp2->expr, add->expr)) - { - found = 1; - if (!tmp2->writer) - tmp2->writer = add->writer; - } - if (!found) - { - *end = copy ? add : new_tlist (NULL, add->expr, add->writer); - end = &(*end)->next; - *end = 0; - } - add = next; - } -} - -/* WRITTEN is a variable, WRITER is its parent. Warn if any of the variable - references in list LIST conflict with it, excluding reads if ONLY writers - is nonzero. */ - -static void -warn_for_collisions_1 (tree written, tree writer, struct tlist *list, - int only_writes) -{ - struct tlist *tmp; - - /* Avoid duplicate warnings. */ - for (tmp = warned_ids; tmp; tmp = tmp->next) - if (candidate_equal_p (tmp->expr, written)) - return; - - while (list) - { - if (candidate_equal_p (list->expr, written) - && !candidate_equal_p (list->writer, writer) - && (!only_writes || list->writer)) - { - warned_ids = new_tlist (warned_ids, written, NULL_TREE); - warning_at (EXPR_HAS_LOCATION (writer) - ? EXPR_LOCATION (writer) : input_location, - OPT_Wsequence_point, "operation on %qE may be undefined", - list->expr); - } - list = list->next; - } -} - -/* Given a list LIST of references to variables, find whether any of these - can cause conflicts due to missing sequence points. */ - -static void -warn_for_collisions (struct tlist *list) -{ - struct tlist *tmp; - - for (tmp = list; tmp; tmp = tmp->next) - { - if (tmp->writer) - warn_for_collisions_1 (tmp->expr, tmp->writer, list, 0); - } -} - -/* Return nonzero if X is a tree that can be verified by the sequence point - warnings. */ -static int -warning_candidate_p (tree x) -{ - /* !VOID_TYPE_P (TREE_TYPE (x)) is workaround for cp/tree.c - (lvalue_p) crash on TRY/CATCH. */ - return !(DECL_P (x) && DECL_ARTIFICIAL (x)) - && TREE_TYPE (x) && !VOID_TYPE_P (TREE_TYPE (x)) && lvalue_p (x); -} - -/* Return nonzero if X and Y appear to be the same candidate (or NULL) */ -static bool -candidate_equal_p (const_tree x, const_tree y) -{ - return (x == y) || (x && y && operand_equal_p (x, y, 0)); -} - -/* Walk the tree X, and record accesses to variables. If X is written by the - parent tree, WRITER is the parent. - We store accesses in one of the two lists: PBEFORE_SP, and PNO_SP. If this - expression or its only operand forces a sequence point, then everything up - to the sequence point is stored in PBEFORE_SP. Everything else gets stored - in PNO_SP. - Once we return, we will have emitted warnings if any subexpression before - such a sequence point could be undefined. On a higher level, however, the - sequence point may not be relevant, and we'll merge the two lists. - - Example: (b++, a) + b; - The call that processes the COMPOUND_EXPR will store the increment of B - in PBEFORE_SP, and the use of A in PNO_SP. The higher-level call that - processes the PLUS_EXPR will need to merge the two lists so that - eventually, all accesses end up on the same list (and we'll warn about the - unordered subexpressions b++ and b. - - A note on merging. If we modify the former example so that our expression - becomes - (b++, b) + a - care must be taken not simply to add all three expressions into the final - PNO_SP list. The function merge_tlist takes care of that by merging the - before-SP list of the COMPOUND_EXPR into its after-SP list in a special - way, so that no more than one access to B is recorded. */ - -static void -verify_tree (tree x, struct tlist **pbefore_sp, struct tlist **pno_sp, - tree writer) -{ - struct tlist *tmp_before, *tmp_nosp, *tmp_list2, *tmp_list3; - enum tree_code code; - enum tree_code_class cl; - - /* X may be NULL if it is the operand of an empty statement expression - ({ }). */ - if (x == NULL) - return; - - restart: - code = TREE_CODE (x); - cl = TREE_CODE_CLASS (code); - - if (warning_candidate_p (x)) - *pno_sp = new_tlist (*pno_sp, x, writer); - - switch (code) - { - case CONSTRUCTOR: - return; - - case COMPOUND_EXPR: - case TRUTH_ANDIF_EXPR: - case TRUTH_ORIF_EXPR: - tmp_before = tmp_nosp = tmp_list3 = 0; - verify_tree (TREE_OPERAND (x, 0), &tmp_before, &tmp_nosp, NULL_TREE); - warn_for_collisions (tmp_nosp); - merge_tlist (pbefore_sp, tmp_before, 0); - merge_tlist (pbefore_sp, tmp_nosp, 0); - verify_tree (TREE_OPERAND (x, 1), &tmp_list3, pno_sp, NULL_TREE); - merge_tlist (pbefore_sp, tmp_list3, 0); - return; - - case COND_EXPR: - tmp_before = tmp_list2 = 0; - verify_tree (TREE_OPERAND (x, 0), &tmp_before, &tmp_list2, NULL_TREE); - warn_for_collisions (tmp_list2); - merge_tlist (pbefore_sp, tmp_before, 0); - merge_tlist (pbefore_sp, tmp_list2, 1); - - tmp_list3 = tmp_nosp = 0; - verify_tree (TREE_OPERAND (x, 1), &tmp_list3, &tmp_nosp, NULL_TREE); - warn_for_collisions (tmp_nosp); - merge_tlist (pbefore_sp, tmp_list3, 0); - - tmp_list3 = tmp_list2 = 0; - verify_tree (TREE_OPERAND (x, 2), &tmp_list3, &tmp_list2, NULL_TREE); - warn_for_collisions (tmp_list2); - merge_tlist (pbefore_sp, tmp_list3, 0); - /* Rather than add both tmp_nosp and tmp_list2, we have to merge the - two first, to avoid warning for (a ? b++ : b++). */ - merge_tlist (&tmp_nosp, tmp_list2, 0); - add_tlist (pno_sp, tmp_nosp, NULL_TREE, 0); - return; - - case PREDECREMENT_EXPR: - case PREINCREMENT_EXPR: - case POSTDECREMENT_EXPR: - case POSTINCREMENT_EXPR: - verify_tree (TREE_OPERAND (x, 0), pno_sp, pno_sp, x); - return; - - case MODIFY_EXPR: - tmp_before = tmp_nosp = tmp_list3 = 0; - verify_tree (TREE_OPERAND (x, 1), &tmp_before, &tmp_nosp, NULL_TREE); - verify_tree (TREE_OPERAND (x, 0), &tmp_list3, &tmp_list3, x); - /* Expressions inside the LHS are not ordered wrt. the sequence points - in the RHS. Example: - *a = (a++, 2) - Despite the fact that the modification of "a" is in the before_sp - list (tmp_before), it conflicts with the use of "a" in the LHS. - We can handle this by adding the contents of tmp_list3 - to those of tmp_before, and redoing the collision warnings for that - list. */ - add_tlist (&tmp_before, tmp_list3, x, 1); - warn_for_collisions (tmp_before); - /* Exclude the LHS itself here; we first have to merge it into the - tmp_nosp list. This is done to avoid warning for "a = a"; if we - didn't exclude the LHS, we'd get it twice, once as a read and once - as a write. */ - add_tlist (pno_sp, tmp_list3, x, 0); - warn_for_collisions_1 (TREE_OPERAND (x, 0), x, tmp_nosp, 1); - - merge_tlist (pbefore_sp, tmp_before, 0); - if (warning_candidate_p (TREE_OPERAND (x, 0))) - merge_tlist (&tmp_nosp, new_tlist (NULL, TREE_OPERAND (x, 0), x), 0); - add_tlist (pno_sp, tmp_nosp, NULL_TREE, 1); - return; - - case CALL_EXPR: - /* We need to warn about conflicts among arguments and conflicts between - args and the function address. Side effects of the function address, - however, are not ordered by the sequence point of the call. */ - { - call_expr_arg_iterator iter; - tree arg; - tmp_before = tmp_nosp = 0; - verify_tree (CALL_EXPR_FN (x), &tmp_before, &tmp_nosp, NULL_TREE); - FOR_EACH_CALL_EXPR_ARG (arg, iter, x) - { - tmp_list2 = tmp_list3 = 0; - verify_tree (arg, &tmp_list2, &tmp_list3, NULL_TREE); - merge_tlist (&tmp_list3, tmp_list2, 0); - add_tlist (&tmp_before, tmp_list3, NULL_TREE, 0); - } - add_tlist (&tmp_before, tmp_nosp, NULL_TREE, 0); - warn_for_collisions (tmp_before); - add_tlist (pbefore_sp, tmp_before, NULL_TREE, 0); - return; - } - - case TREE_LIST: - /* Scan all the list, e.g. indices of multi dimensional array. */ - while (x) - { - tmp_before = tmp_nosp = 0; - verify_tree (TREE_VALUE (x), &tmp_before, &tmp_nosp, NULL_TREE); - merge_tlist (&tmp_nosp, tmp_before, 0); - add_tlist (pno_sp, tmp_nosp, NULL_TREE, 0); - x = TREE_CHAIN (x); - } - return; - - case SAVE_EXPR: - { - struct tlist_cache *t; - for (t = save_expr_cache; t; t = t->next) - if (candidate_equal_p (t->expr, x)) - break; - - if (!t) - { - t = XOBNEW (&tlist_obstack, struct tlist_cache); - t->next = save_expr_cache; - t->expr = x; - save_expr_cache = t; - - tmp_before = tmp_nosp = 0; - verify_tree (TREE_OPERAND (x, 0), &tmp_before, &tmp_nosp, NULL_TREE); - warn_for_collisions (tmp_nosp); - - tmp_list3 = 0; - while (tmp_nosp) - { - struct tlist *t = tmp_nosp; - tmp_nosp = t->next; - merge_tlist (&tmp_list3, t, 0); - } - t->cache_before_sp = tmp_before; - t->cache_after_sp = tmp_list3; - } - merge_tlist (pbefore_sp, t->cache_before_sp, 1); - add_tlist (pno_sp, t->cache_after_sp, NULL_TREE, 1); - return; - } - - case ADDR_EXPR: - x = TREE_OPERAND (x, 0); - if (DECL_P (x)) - return; - writer = 0; - goto restart; - - default: - /* For other expressions, simply recurse on their operands. - Manual tail recursion for unary expressions. - Other non-expressions need not be processed. */ - if (cl == tcc_unary) - { - x = TREE_OPERAND (x, 0); - writer = 0; - goto restart; - } - else if (IS_EXPR_CODE_CLASS (cl)) - { - int lp; - int max = TREE_OPERAND_LENGTH (x); - for (lp = 0; lp < max; lp++) - { - tmp_before = tmp_nosp = 0; - verify_tree (TREE_OPERAND (x, lp), &tmp_before, &tmp_nosp, 0); - merge_tlist (&tmp_nosp, tmp_before, 0); - add_tlist (pno_sp, tmp_nosp, NULL_TREE, 0); - } - } - return; - } -} - -/* Try to warn for undefined behavior in EXPR due to missing sequence - points. */ - -DEBUG_FUNCTION void -verify_sequence_points (tree expr) -{ - struct tlist *before_sp = 0, *after_sp = 0; - - warned_ids = 0; - save_expr_cache = 0; - if (tlist_firstobj == 0) - { - gcc_obstack_init (&tlist_obstack); - tlist_firstobj = (char *) obstack_alloc (&tlist_obstack, 0); - } - - verify_tree (expr, &before_sp, &after_sp, 0); - warn_for_collisions (after_sp); - obstack_free (&tlist_obstack, tlist_firstobj); -} - -/* Validate the expression after `case' and apply default promotions. */ - -static tree -check_case_value (tree value) -{ - if (value == NULL_TREE) - return value; - - /* ??? Can we ever get nops here for a valid case value? We - shouldn't for C. */ - STRIP_TYPE_NOPS (value); - /* In C++, the following is allowed: - - const int i = 3; - switch (...) { case i: ... } - - So, we try to reduce the VALUE to a constant that way. */ - if (c_dialect_cxx ()) - { - value = decl_constant_value (value); - STRIP_TYPE_NOPS (value); - value = fold (value); - } - - if (TREE_CODE (value) == INTEGER_CST) - /* Promote char or short to int. */ - value = perform_integral_promotions (value); - else if (value != error_mark_node) - { - error ("case label does not reduce to an integer constant"); - value = error_mark_node; - } - - constant_expression_warning (value); - - return value; -} - -/* See if the case values LOW and HIGH are in the range of the original - type (i.e. before the default conversion to int) of the switch testing - expression. - TYPE is the promoted type of the testing expression, and ORIG_TYPE is - the type before promoting it. CASE_LOW_P is a pointer to the lower - bound of the case label, and CASE_HIGH_P is the upper bound or NULL - if the case is not a case range. - The caller has to make sure that we are not called with NULL for - CASE_LOW_P (i.e. the default case). - Returns true if the case label is in range of ORIG_TYPE (saturated or - untouched) or false if the label is out of range. */ - -static bool -check_case_bounds (tree type, tree orig_type, - tree *case_low_p, tree *case_high_p) -{ - tree min_value, max_value; - tree case_low = *case_low_p; - tree case_high = case_high_p ? *case_high_p : case_low; - - /* If there was a problem with the original type, do nothing. */ - if (orig_type == error_mark_node) - return true; - - min_value = TYPE_MIN_VALUE (orig_type); - max_value = TYPE_MAX_VALUE (orig_type); - - /* Case label is less than minimum for type. */ - if (tree_int_cst_compare (case_low, min_value) < 0 - && tree_int_cst_compare (case_high, min_value) < 0) - { - warning (0, "case label value is less than minimum value for type"); - return false; - } - - /* Case value is greater than maximum for type. */ - if (tree_int_cst_compare (case_low, max_value) > 0 - && tree_int_cst_compare (case_high, max_value) > 0) - { - warning (0, "case label value exceeds maximum value for type"); - return false; - } - - /* Saturate lower case label value to minimum. */ - if (tree_int_cst_compare (case_high, min_value) >= 0 - && tree_int_cst_compare (case_low, min_value) < 0) - { - warning (0, "lower value in case label range" - " less than minimum value for type"); - case_low = min_value; - } - - /* Saturate upper case label value to maximum. */ - if (tree_int_cst_compare (case_low, max_value) <= 0 - && tree_int_cst_compare (case_high, max_value) > 0) - { - warning (0, "upper value in case label range" - " exceeds maximum value for type"); - case_high = max_value; - } - - if (*case_low_p != case_low) - *case_low_p = convert (type, case_low); - if (case_high_p && *case_high_p != case_high) - *case_high_p = convert (type, case_high); - - return true; -} - -/* Return an integer type with BITS bits of precision, - that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */ - -tree -c_common_type_for_size (unsigned int bits, int unsignedp) -{ - 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); - - if (int128_integer_type_node - && bits == TYPE_PRECISION (int128_integer_type_node)) - return (unsignedp ? int128_unsigned_type_node - : int128_integer_type_node); - - if (bits == TYPE_PRECISION (widest_integer_literal_type_node)) - return (unsignedp ? widest_unsigned_literal_type_node - : widest_integer_literal_type_node); - - if (bits <= TYPE_PRECISION (intQI_type_node)) - return unsignedp ? unsigned_intQI_type_node : intQI_type_node; - - if (bits <= TYPE_PRECISION (intHI_type_node)) - return unsignedp ? unsigned_intHI_type_node : intHI_type_node; - - if (bits <= TYPE_PRECISION (intSI_type_node)) - return unsignedp ? unsigned_intSI_type_node : intSI_type_node; - - if (bits <= TYPE_PRECISION (intDI_type_node)) - return unsignedp ? unsigned_intDI_type_node : intDI_type_node; - - return 0; -} - -/* Return a fixed-point type that has at least IBIT ibits and FBIT fbits - that is unsigned if UNSIGNEDP is nonzero, otherwise signed; - and saturating if SATP is nonzero, otherwise not saturating. */ - -tree -c_common_fixed_point_type_for_size (unsigned int ibit, unsigned int fbit, - int unsignedp, int satp) -{ - enum machine_mode mode; - if (ibit == 0) - mode = unsignedp ? UQQmode : QQmode; - else - mode = unsignedp ? UHAmode : HAmode; - - for (; mode != VOIDmode; mode = GET_MODE_WIDER_MODE (mode)) - if (GET_MODE_IBIT (mode) >= ibit && GET_MODE_FBIT (mode) >= fbit) - break; - - if (mode == VOIDmode || !targetm.scalar_mode_supported_p (mode)) - { - sorry ("GCC cannot support operators with integer types and " - "fixed-point types that have too many integral and " - "fractional bits together"); - return 0; - } - - return c_common_type_for_mode (mode, satp); -} - -/* Used for communication between c_common_type_for_mode and - c_register_builtin_type. */ -static GTY(()) tree registered_builtin_types; - -/* Return a data type that has machine mode MODE. - If the mode is an integer, - then UNSIGNEDP selects between signed and unsigned types. - If the mode is a fixed-point mode, - then UNSIGNEDP selects between saturating and nonsaturating types. */ - -tree -c_common_type_for_mode (enum machine_mode mode, int unsignedp) -{ - 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 (int128_integer_type_node - && mode == TYPE_MODE (int128_integer_type_node)) - return unsignedp ? int128_unsigned_type_node : int128_integer_type_node; - - if (mode == TYPE_MODE (widest_integer_literal_type_node)) - return unsignedp ? widest_unsigned_literal_type_node - : widest_integer_literal_type_node; - - if (mode == QImode) - return unsignedp ? unsigned_intQI_type_node : intQI_type_node; - - if (mode == HImode) - return unsignedp ? unsigned_intHI_type_node : intHI_type_node; - - if (mode == SImode) - return unsignedp ? unsigned_intSI_type_node : intSI_type_node; - - if (mode == DImode) - return unsignedp ? unsigned_intDI_type_node : intDI_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 (void_type_node)) - return void_type_node; - - if (mode == TYPE_MODE (build_pointer_type (char_type_node))) - return (unsignedp - ? make_unsigned_type (GET_MODE_PRECISION (mode)) - : make_signed_type (GET_MODE_PRECISION (mode))); - - if (mode == TYPE_MODE (build_pointer_type (integer_type_node))) - return (unsignedp - ? make_unsigned_type (GET_MODE_PRECISION (mode)) - : make_signed_type (GET_MODE_PRECISION (mode))); - - if (COMPLEX_MODE_P (mode)) - { - enum machine_mode inner_mode; - tree inner_type; - - if (mode == TYPE_MODE (complex_float_type_node)) - return complex_float_type_node; - if (mode == TYPE_MODE (complex_double_type_node)) - return complex_double_type_node; - if (mode == TYPE_MODE (complex_long_double_type_node)) - return complex_long_double_type_node; - - if (mode == TYPE_MODE (complex_integer_type_node) && !unsignedp) - return complex_integer_type_node; - - inner_mode = GET_MODE_INNER (mode); - inner_type = c_common_type_for_mode (inner_mode, unsignedp); - if (inner_type != NULL_TREE) - return build_complex_type (inner_type); - } - else if (VECTOR_MODE_P (mode)) - { - enum machine_mode inner_mode = GET_MODE_INNER (mode); - tree inner_type = c_common_type_for_mode (inner_mode, unsignedp); - if (inner_type != NULL_TREE) - return build_vector_type_for_mode (inner_type, mode); - } - - if (mode == TYPE_MODE (dfloat32_type_node)) - return dfloat32_type_node; - if (mode == TYPE_MODE (dfloat64_type_node)) - return dfloat64_type_node; - if (mode == TYPE_MODE (dfloat128_type_node)) - return dfloat128_type_node; - - if (ALL_SCALAR_FIXED_POINT_MODE_P (mode)) - { - if (mode == TYPE_MODE (short_fract_type_node)) - return unsignedp ? sat_short_fract_type_node : short_fract_type_node; - if (mode == TYPE_MODE (fract_type_node)) - return unsignedp ? sat_fract_type_node : fract_type_node; - if (mode == TYPE_MODE (long_fract_type_node)) - return unsignedp ? sat_long_fract_type_node : long_fract_type_node; - if (mode == TYPE_MODE (long_long_fract_type_node)) - return unsignedp ? sat_long_long_fract_type_node - : long_long_fract_type_node; - - if (mode == TYPE_MODE (unsigned_short_fract_type_node)) - return unsignedp ? sat_unsigned_short_fract_type_node - : unsigned_short_fract_type_node; - if (mode == TYPE_MODE (unsigned_fract_type_node)) - return unsignedp ? sat_unsigned_fract_type_node - : unsigned_fract_type_node; - if (mode == TYPE_MODE (unsigned_long_fract_type_node)) - return unsignedp ? sat_unsigned_long_fract_type_node - : unsigned_long_fract_type_node; - if (mode == TYPE_MODE (unsigned_long_long_fract_type_node)) - return unsignedp ? sat_unsigned_long_long_fract_type_node - : unsigned_long_long_fract_type_node; - - if (mode == TYPE_MODE (short_accum_type_node)) - return unsignedp ? sat_short_accum_type_node : short_accum_type_node; - if (mode == TYPE_MODE (accum_type_node)) - return unsignedp ? sat_accum_type_node : accum_type_node; - if (mode == TYPE_MODE (long_accum_type_node)) - return unsignedp ? sat_long_accum_type_node : long_accum_type_node; - if (mode == TYPE_MODE (long_long_accum_type_node)) - return unsignedp ? sat_long_long_accum_type_node - : long_long_accum_type_node; - - if (mode == TYPE_MODE (unsigned_short_accum_type_node)) - return unsignedp ? sat_unsigned_short_accum_type_node - : unsigned_short_accum_type_node; - if (mode == TYPE_MODE (unsigned_accum_type_node)) - return unsignedp ? sat_unsigned_accum_type_node - : unsigned_accum_type_node; - if (mode == TYPE_MODE (unsigned_long_accum_type_node)) - return unsignedp ? sat_unsigned_long_accum_type_node - : unsigned_long_accum_type_node; - if (mode == TYPE_MODE (unsigned_long_long_accum_type_node)) - return unsignedp ? sat_unsigned_long_long_accum_type_node - : unsigned_long_long_accum_type_node; - - if (mode == QQmode) - return unsignedp ? sat_qq_type_node : qq_type_node; - if (mode == HQmode) - return unsignedp ? sat_hq_type_node : hq_type_node; - if (mode == SQmode) - return unsignedp ? sat_sq_type_node : sq_type_node; - if (mode == DQmode) - return unsignedp ? sat_dq_type_node : dq_type_node; - if (mode == TQmode) - return unsignedp ? sat_tq_type_node : tq_type_node; - - if (mode == UQQmode) - return unsignedp ? sat_uqq_type_node : uqq_type_node; - if (mode == UHQmode) - return unsignedp ? sat_uhq_type_node : uhq_type_node; - if (mode == USQmode) - return unsignedp ? sat_usq_type_node : usq_type_node; - if (mode == UDQmode) - return unsignedp ? sat_udq_type_node : udq_type_node; - if (mode == UTQmode) - return unsignedp ? sat_utq_type_node : utq_type_node; - - if (mode == HAmode) - return unsignedp ? sat_ha_type_node : ha_type_node; - if (mode == SAmode) - return unsignedp ? sat_sa_type_node : sa_type_node; - if (mode == DAmode) - return unsignedp ? sat_da_type_node : da_type_node; - if (mode == TAmode) - return unsignedp ? sat_ta_type_node : ta_type_node; - - if (mode == UHAmode) - return unsignedp ? sat_uha_type_node : uha_type_node; - if (mode == USAmode) - return unsignedp ? sat_usa_type_node : usa_type_node; - if (mode == UDAmode) - return unsignedp ? sat_uda_type_node : uda_type_node; - if (mode == UTAmode) - return unsignedp ? sat_uta_type_node : uta_type_node; - } - - for (t = registered_builtin_types; t; t = TREE_CHAIN (t)) - if (TYPE_MODE (TREE_VALUE (t)) == mode) - return TREE_VALUE (t); - - return 0; -} - -tree -c_common_unsigned_type (tree type) -{ - return c_common_signed_or_unsigned_type (1, type); -} - -/* Return a signed type the same as TYPE in other respects. */ - -tree -c_common_signed_type (tree type) -{ - return c_common_signed_or_unsigned_type (0, type); -} - -/* Return a type the same as TYPE except unsigned or - signed according to UNSIGNEDP. */ - -tree -c_common_signed_or_unsigned_type (int unsignedp, tree type) -{ - tree type1; - - /* This block of code emulates the behavior of the old - c_common_unsigned_type. In particular, it returns - long_unsigned_type_node if passed a long, even when a int would - have the same size. This is necessary for warnings to work - correctly in archs where sizeof(int) == sizeof(long) */ - - type1 = TYPE_MAIN_VARIANT (type); - if (type1 == signed_char_type_node || type1 == char_type_node || type1 == unsigned_char_type_node) - return unsignedp ? unsigned_char_type_node : signed_char_type_node; - if (type1 == integer_type_node || type1 == unsigned_type_node) - return unsignedp ? unsigned_type_node : integer_type_node; - if (type1 == short_integer_type_node || type1 == short_unsigned_type_node) - return unsignedp ? short_unsigned_type_node : short_integer_type_node; - if (type1 == long_integer_type_node || type1 == long_unsigned_type_node) - return unsignedp ? long_unsigned_type_node : long_integer_type_node; - if (type1 == long_long_integer_type_node || type1 == long_long_unsigned_type_node) - return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node; - if (int128_integer_type_node - && (type1 == int128_integer_type_node - || type1 == int128_unsigned_type_node)) - return unsignedp ? int128_unsigned_type_node : int128_integer_type_node; - if (type1 == widest_integer_literal_type_node || type1 == widest_unsigned_literal_type_node) - return unsignedp ? widest_unsigned_literal_type_node : widest_integer_literal_type_node; -#if HOST_BITS_PER_WIDE_INT >= 64 - if (type1 == intTI_type_node || type1 == unsigned_intTI_type_node) - return unsignedp ? unsigned_intTI_type_node : intTI_type_node; -#endif - if (type1 == intDI_type_node || type1 == unsigned_intDI_type_node) - return unsignedp ? unsigned_intDI_type_node : intDI_type_node; - if (type1 == intSI_type_node || type1 == unsigned_intSI_type_node) - return unsignedp ? unsigned_intSI_type_node : intSI_type_node; - if (type1 == intHI_type_node || type1 == unsigned_intHI_type_node) - return unsignedp ? unsigned_intHI_type_node : intHI_type_node; - if (type1 == intQI_type_node || type1 == unsigned_intQI_type_node) - return unsignedp ? unsigned_intQI_type_node : intQI_type_node; - -#define C_COMMON_FIXED_TYPES(NAME) \ - if (type1 == short_ ## NAME ## _type_node \ - || type1 == unsigned_short_ ## NAME ## _type_node) \ - return unsignedp ? unsigned_short_ ## NAME ## _type_node \ - : short_ ## NAME ## _type_node; \ - if (type1 == NAME ## _type_node \ - || type1 == unsigned_ ## NAME ## _type_node) \ - return unsignedp ? unsigned_ ## NAME ## _type_node \ - : NAME ## _type_node; \ - if (type1 == long_ ## NAME ## _type_node \ - || type1 == unsigned_long_ ## NAME ## _type_node) \ - return unsignedp ? unsigned_long_ ## NAME ## _type_node \ - : long_ ## NAME ## _type_node; \ - if (type1 == long_long_ ## NAME ## _type_node \ - || type1 == unsigned_long_long_ ## NAME ## _type_node) \ - return unsignedp ? unsigned_long_long_ ## NAME ## _type_node \ - : long_long_ ## NAME ## _type_node; - -#define C_COMMON_FIXED_MODE_TYPES(NAME) \ - if (type1 == NAME ## _type_node \ - || type1 == u ## NAME ## _type_node) \ - return unsignedp ? u ## NAME ## _type_node \ - : NAME ## _type_node; - -#define C_COMMON_FIXED_TYPES_SAT(NAME) \ - if (type1 == sat_ ## short_ ## NAME ## _type_node \ - || type1 == sat_ ## unsigned_short_ ## NAME ## _type_node) \ - return unsignedp ? sat_ ## unsigned_short_ ## NAME ## _type_node \ - : sat_ ## short_ ## NAME ## _type_node; \ - if (type1 == sat_ ## NAME ## _type_node \ - || type1 == sat_ ## unsigned_ ## NAME ## _type_node) \ - return unsignedp ? sat_ ## unsigned_ ## NAME ## _type_node \ - : sat_ ## NAME ## _type_node; \ - if (type1 == sat_ ## long_ ## NAME ## _type_node \ - || type1 == sat_ ## unsigned_long_ ## NAME ## _type_node) \ - return unsignedp ? sat_ ## unsigned_long_ ## NAME ## _type_node \ - : sat_ ## long_ ## NAME ## _type_node; \ - if (type1 == sat_ ## long_long_ ## NAME ## _type_node \ - || type1 == sat_ ## unsigned_long_long_ ## NAME ## _type_node) \ - return unsignedp ? sat_ ## unsigned_long_long_ ## NAME ## _type_node \ - : sat_ ## long_long_ ## NAME ## _type_node; - -#define C_COMMON_FIXED_MODE_TYPES_SAT(NAME) \ - if (type1 == sat_ ## NAME ## _type_node \ - || type1 == sat_ ## u ## NAME ## _type_node) \ - return unsignedp ? sat_ ## u ## NAME ## _type_node \ - : sat_ ## NAME ## _type_node; - - C_COMMON_FIXED_TYPES (fract); - C_COMMON_FIXED_TYPES_SAT (fract); - C_COMMON_FIXED_TYPES (accum); - C_COMMON_FIXED_TYPES_SAT (accum); - - C_COMMON_FIXED_MODE_TYPES (qq); - C_COMMON_FIXED_MODE_TYPES (hq); - C_COMMON_FIXED_MODE_TYPES (sq); - C_COMMON_FIXED_MODE_TYPES (dq); - C_COMMON_FIXED_MODE_TYPES (tq); - C_COMMON_FIXED_MODE_TYPES_SAT (qq); - C_COMMON_FIXED_MODE_TYPES_SAT (hq); - C_COMMON_FIXED_MODE_TYPES_SAT (sq); - C_COMMON_FIXED_MODE_TYPES_SAT (dq); - C_COMMON_FIXED_MODE_TYPES_SAT (tq); - C_COMMON_FIXED_MODE_TYPES (ha); - C_COMMON_FIXED_MODE_TYPES (sa); - C_COMMON_FIXED_MODE_TYPES (da); - C_COMMON_FIXED_MODE_TYPES (ta); - C_COMMON_FIXED_MODE_TYPES_SAT (ha); - C_COMMON_FIXED_MODE_TYPES_SAT (sa); - C_COMMON_FIXED_MODE_TYPES_SAT (da); - C_COMMON_FIXED_MODE_TYPES_SAT (ta); - - /* For ENUMERAL_TYPEs in C++, must check the mode of the types, not - the precision; they have precision set to match their range, but - may use a wider mode to match an ABI. If we change modes, we may - wind up with bad conversions. For INTEGER_TYPEs in C, must check - the precision as well, so as to yield correct results for - bit-field types. C++ does not have these separate bit-field - types, and producing a signed or unsigned variant of an - ENUMERAL_TYPE may cause other problems as well. */ - - if (!INTEGRAL_TYPE_P (type) - || TYPE_UNSIGNED (type) == unsignedp) - return type; - -#define TYPE_OK(node) \ - (TYPE_MODE (type) == TYPE_MODE (node) \ - && TYPE_PRECISION (type) == TYPE_PRECISION (node)) - if (TYPE_OK (signed_char_type_node)) - return unsignedp ? unsigned_char_type_node : signed_char_type_node; - if (TYPE_OK (integer_type_node)) - return unsignedp ? unsigned_type_node : integer_type_node; - if (TYPE_OK (short_integer_type_node)) - return unsignedp ? short_unsigned_type_node : short_integer_type_node; - if (TYPE_OK (long_integer_type_node)) - return unsignedp ? long_unsigned_type_node : long_integer_type_node; - if (TYPE_OK (long_long_integer_type_node)) - return (unsignedp ? long_long_unsigned_type_node - : long_long_integer_type_node); - if (int128_integer_type_node && TYPE_OK (int128_integer_type_node)) - return (unsignedp ? int128_unsigned_type_node - : int128_integer_type_node); - if (TYPE_OK (widest_integer_literal_type_node)) - return (unsignedp ? widest_unsigned_literal_type_node - : widest_integer_literal_type_node); - -#if HOST_BITS_PER_WIDE_INT >= 64 - if (TYPE_OK (intTI_type_node)) - return unsignedp ? unsigned_intTI_type_node : intTI_type_node; -#endif - if (TYPE_OK (intDI_type_node)) - return unsignedp ? unsigned_intDI_type_node : intDI_type_node; - if (TYPE_OK (intSI_type_node)) - return unsignedp ? unsigned_intSI_type_node : intSI_type_node; - if (TYPE_OK (intHI_type_node)) - return unsignedp ? unsigned_intHI_type_node : intHI_type_node; - if (TYPE_OK (intQI_type_node)) - return unsignedp ? unsigned_intQI_type_node : intQI_type_node; -#undef TYPE_OK - - return build_nonstandard_integer_type (TYPE_PRECISION (type), unsignedp); -} - -/* Build a bit-field integer type for the given WIDTH and UNSIGNEDP. */ - -tree -c_build_bitfield_integer_type (unsigned HOST_WIDE_INT width, int unsignedp) -{ - /* Extended integer types of the same width as a standard type have - lesser rank, so those of the same width as int promote to int or - unsigned int and are valid for printf formats expecting int or - unsigned int. To avoid such special cases, avoid creating - extended integer types for bit-fields if a standard integer type - is available. */ - if (width == TYPE_PRECISION (integer_type_node)) - return unsignedp ? unsigned_type_node : integer_type_node; - if (width == TYPE_PRECISION (signed_char_type_node)) - return unsignedp ? unsigned_char_type_node : signed_char_type_node; - if (width == TYPE_PRECISION (short_integer_type_node)) - return unsignedp ? short_unsigned_type_node : short_integer_type_node; - if (width == TYPE_PRECISION (long_integer_type_node)) - return unsignedp ? long_unsigned_type_node : long_integer_type_node; - if (width == TYPE_PRECISION (long_long_integer_type_node)) - return (unsignedp ? long_long_unsigned_type_node - : long_long_integer_type_node); - if (int128_integer_type_node - && width == TYPE_PRECISION (int128_integer_type_node)) - return (unsignedp ? int128_unsigned_type_node - : int128_integer_type_node); - return build_nonstandard_integer_type (width, unsignedp); -} - -/* The C version of the register_builtin_type langhook. */ - -void -c_register_builtin_type (tree type, const char* name) -{ - tree decl; - - decl = build_decl (UNKNOWN_LOCATION, - TYPE_DECL, get_identifier (name), type); - DECL_ARTIFICIAL (decl) = 1; - if (!TYPE_NAME (type)) - TYPE_NAME (type) = decl; - pushdecl (decl); - - registered_builtin_types = tree_cons (0, type, registered_builtin_types); -} - -/* Print an error message for invalid operands to arith operation - CODE with TYPE0 for operand 0, and TYPE1 for operand 1. - LOCATION is the location of the message. */ - -void -binary_op_error (location_t location, enum tree_code code, - tree type0, tree type1) -{ - const char *opname; - - switch (code) - { - case PLUS_EXPR: - opname = "+"; break; - case MINUS_EXPR: - opname = "-"; break; - case MULT_EXPR: - opname = "*"; break; - case MAX_EXPR: - opname = "max"; break; - case MIN_EXPR: - opname = "min"; break; - case EQ_EXPR: - opname = "=="; break; - case NE_EXPR: - opname = "!="; break; - case LE_EXPR: - opname = "<="; break; - case GE_EXPR: - opname = ">="; break; - case LT_EXPR: - opname = "<"; break; - case GT_EXPR: - opname = ">"; break; - case LSHIFT_EXPR: - opname = "<<"; break; - case RSHIFT_EXPR: - opname = ">>"; break; - case TRUNC_MOD_EXPR: - case FLOOR_MOD_EXPR: - opname = "%"; break; - case TRUNC_DIV_EXPR: - case FLOOR_DIV_EXPR: - opname = "/"; break; - case BIT_AND_EXPR: - opname = "&"; break; - case BIT_IOR_EXPR: - opname = "|"; break; - case TRUTH_ANDIF_EXPR: - opname = "&&"; break; - case TRUTH_ORIF_EXPR: - opname = "||"; break; - case BIT_XOR_EXPR: - opname = "^"; break; - default: - gcc_unreachable (); - } - error_at (location, - "invalid operands to binary %s (have %qT and %qT)", opname, - type0, type1); -} - -/* Subroutine of build_binary_op, used for comparison operations. - See if the operands have both been converted from subword integer types - and, if so, perhaps change them both back to their original type. - This function is also responsible for converting the two operands - to the proper common type for comparison. - - The arguments of this function are all pointers to local variables - of build_binary_op: OP0_PTR is &OP0, OP1_PTR is &OP1, - RESTYPE_PTR is &RESULT_TYPE and RESCODE_PTR is &RESULTCODE. - - If this function returns nonzero, it means that the comparison has - a constant value. What this function returns is an expression for - that value. */ - -tree -shorten_compare (tree *op0_ptr, tree *op1_ptr, tree *restype_ptr, - enum tree_code *rescode_ptr) -{ - tree type; - tree op0 = *op0_ptr; - tree op1 = *op1_ptr; - int unsignedp0, unsignedp1; - int real1, real2; - tree primop0, primop1; - enum tree_code code = *rescode_ptr; - - /* Throw away any conversions to wider types - already present in the operands. */ - - primop0 = get_narrower (op0, &unsignedp0); - primop1 = get_narrower (op1, &unsignedp1); - - /* Handle the case that OP0 does not *contain* a conversion - but it *requires* conversion to FINAL_TYPE. */ - - if (op0 == primop0 && TREE_TYPE (op0) != *restype_ptr) - unsignedp0 = TYPE_UNSIGNED (TREE_TYPE (op0)); - if (op1 == primop1 && TREE_TYPE (op1) != *restype_ptr) - unsignedp1 = TYPE_UNSIGNED (TREE_TYPE (op1)); - - /* If one of the operands must be floated, we cannot optimize. */ - real1 = TREE_CODE (TREE_TYPE (primop0)) == REAL_TYPE; - real2 = TREE_CODE (TREE_TYPE (primop1)) == REAL_TYPE; - - /* If first arg is constant, swap the args (changing operation - so value is preserved), for canonicalization. Don't do this if - the second arg is 0. */ - - if (TREE_CONSTANT (primop0) - && !integer_zerop (primop1) && !real_zerop (primop1) - && !fixed_zerop (primop1)) - { - tree tem = primop0; - int temi = unsignedp0; - primop0 = primop1; - primop1 = tem; - tem = op0; - op0 = op1; - op1 = tem; - *op0_ptr = op0; - *op1_ptr = op1; - unsignedp0 = unsignedp1; - unsignedp1 = temi; - temi = real1; - real1 = real2; - real2 = temi; - - switch (code) - { - case LT_EXPR: - code = GT_EXPR; - break; - case GT_EXPR: - code = LT_EXPR; - break; - case LE_EXPR: - code = GE_EXPR; - break; - case GE_EXPR: - code = LE_EXPR; - break; - default: - break; - } - *rescode_ptr = code; - } - - /* If comparing an integer against a constant more bits wide, - maybe we can deduce a value of 1 or 0 independent of the data. - Or else truncate the constant now - rather than extend the variable at run time. - - This is only interesting if the constant is the wider arg. - Also, it is not safe if the constant is unsigned and the - variable arg is signed, since in this case the variable - would be sign-extended and then regarded as unsigned. - Our technique fails in this case because the lowest/highest - possible unsigned results don't follow naturally from the - lowest/highest possible values of the variable operand. - For just EQ_EXPR and NE_EXPR there is another technique that - could be used: see if the constant can be faithfully represented - in the other operand's type, by truncating it and reextending it - and see if that preserves the constant's value. */ - - if (!real1 && !real2 - && TREE_CODE (TREE_TYPE (primop0)) != FIXED_POINT_TYPE - && TREE_CODE (primop1) == INTEGER_CST - && TYPE_PRECISION (TREE_TYPE (primop0)) < TYPE_PRECISION (*restype_ptr)) - { - int min_gt, max_gt, min_lt, max_lt; - tree maxval, minval; - /* 1 if comparison is nominally unsigned. */ - int unsignedp = TYPE_UNSIGNED (*restype_ptr); - tree val; - - type = c_common_signed_or_unsigned_type (unsignedp0, - TREE_TYPE (primop0)); - - maxval = TYPE_MAX_VALUE (type); - minval = TYPE_MIN_VALUE (type); - - if (unsignedp && !unsignedp0) - *restype_ptr = c_common_signed_type (*restype_ptr); - - if (TREE_TYPE (primop1) != *restype_ptr) - { - /* Convert primop1 to target type, but do not introduce - additional overflow. We know primop1 is an int_cst. */ - primop1 = force_fit_type_double (*restype_ptr, - TREE_INT_CST_LOW (primop1), - TREE_INT_CST_HIGH (primop1), 0, - TREE_OVERFLOW (primop1)); - } - if (type != *restype_ptr) - { - minval = convert (*restype_ptr, minval); - maxval = convert (*restype_ptr, maxval); - } - - if (unsignedp && unsignedp0) - { - min_gt = INT_CST_LT_UNSIGNED (primop1, minval); - max_gt = INT_CST_LT_UNSIGNED (primop1, maxval); - min_lt = INT_CST_LT_UNSIGNED (minval, primop1); - max_lt = INT_CST_LT_UNSIGNED (maxval, primop1); - } - else - { - min_gt = INT_CST_LT (primop1, minval); - max_gt = INT_CST_LT (primop1, maxval); - min_lt = INT_CST_LT (minval, primop1); - max_lt = INT_CST_LT (maxval, primop1); - } - - val = 0; - /* This used to be a switch, but Genix compiler can't handle that. */ - if (code == NE_EXPR) - { - if (max_lt || min_gt) - val = truthvalue_true_node; - } - else if (code == EQ_EXPR) - { - if (max_lt || min_gt) - val = truthvalue_false_node; - } - else if (code == LT_EXPR) - { - if (max_lt) - val = truthvalue_true_node; - if (!min_lt) - val = truthvalue_false_node; - } - else if (code == GT_EXPR) - { - if (min_gt) - val = truthvalue_true_node; - if (!max_gt) - val = truthvalue_false_node; - } - else if (code == LE_EXPR) - { - if (!max_gt) - val = truthvalue_true_node; - if (min_gt) - val = truthvalue_false_node; - } - else if (code == GE_EXPR) - { - if (!min_lt) - val = truthvalue_true_node; - if (max_lt) - val = truthvalue_false_node; - } - - /* If primop0 was sign-extended and unsigned comparison specd, - we did a signed comparison above using the signed type bounds. - But the comparison we output must be unsigned. - - Also, for inequalities, VAL is no good; but if the signed - comparison had *any* fixed result, it follows that the - unsigned comparison just tests the sign in reverse - (positive values are LE, negative ones GE). - So we can generate an unsigned comparison - against an extreme value of the signed type. */ - - if (unsignedp && !unsignedp0) - { - if (val != 0) - switch (code) - { - case LT_EXPR: - case GE_EXPR: - primop1 = TYPE_MIN_VALUE (type); - val = 0; - break; - - case LE_EXPR: - case GT_EXPR: - primop1 = TYPE_MAX_VALUE (type); - val = 0; - break; - - default: - break; - } - type = c_common_unsigned_type (type); - } - - if (TREE_CODE (primop0) != INTEGER_CST) - { - if (val == truthvalue_false_node) - warning (OPT_Wtype_limits, "comparison is always false due to limited range of data type"); - if (val == truthvalue_true_node) - warning (OPT_Wtype_limits, "comparison is always true due to limited range of data type"); - } - - if (val != 0) - { - /* Don't forget to evaluate PRIMOP0 if it has side effects. */ - if (TREE_SIDE_EFFECTS (primop0)) - return build2 (COMPOUND_EXPR, TREE_TYPE (val), primop0, val); - return val; - } - - /* Value is not predetermined, but do the comparison - in the type of the operand that is not constant. - TYPE is already properly set. */ - } - - /* If either arg is decimal float and the other is float, find the - proper common type to use for comparison. */ - else if (real1 && real2 - && (DECIMAL_FLOAT_MODE_P (TYPE_MODE (TREE_TYPE (primop0))) - || DECIMAL_FLOAT_MODE_P (TYPE_MODE (TREE_TYPE (primop1))))) - type = common_type (TREE_TYPE (primop0), TREE_TYPE (primop1)); - - else if (real1 && real2 - && (TYPE_PRECISION (TREE_TYPE (primop0)) - == TYPE_PRECISION (TREE_TYPE (primop1)))) - type = TREE_TYPE (primop0); - - /* If args' natural types are both narrower than nominal type - and both extend in the same manner, compare them - in the type of the wider arg. - Otherwise must actually extend both to the nominal - common type lest different ways of extending - alter the result. - (eg, (short)-1 == (unsigned short)-1 should be 0.) */ - - else if (unsignedp0 == unsignedp1 && real1 == real2 - && TYPE_PRECISION (TREE_TYPE (primop0)) < TYPE_PRECISION (*restype_ptr) - && TYPE_PRECISION (TREE_TYPE (primop1)) < TYPE_PRECISION (*restype_ptr)) - { - type = common_type (TREE_TYPE (primop0), TREE_TYPE (primop1)); - type = c_common_signed_or_unsigned_type (unsignedp0 - || TYPE_UNSIGNED (*restype_ptr), - type); - /* Make sure shorter operand is extended the right way - to match the longer operand. */ - primop0 - = convert (c_common_signed_or_unsigned_type (unsignedp0, - TREE_TYPE (primop0)), - primop0); - primop1 - = convert (c_common_signed_or_unsigned_type (unsignedp1, - TREE_TYPE (primop1)), - primop1); - } - else - { - /* Here we must do the comparison on the nominal type - using the args exactly as we received them. */ - type = *restype_ptr; - primop0 = op0; - primop1 = op1; - - if (!real1 && !real2 && integer_zerop (primop1) - && TYPE_UNSIGNED (*restype_ptr)) - { - tree value = 0; - switch (code) - { - case GE_EXPR: - /* All unsigned values are >= 0, so we warn. However, - if OP0 is a constant that is >= 0, the signedness of - the comparison isn't an issue, so suppress the - warning. */ - if (warn_type_limits && !in_system_header - && !(TREE_CODE (primop0) == INTEGER_CST - && !TREE_OVERFLOW (convert (c_common_signed_type (type), - primop0)))) - warning (OPT_Wtype_limits, - "comparison of unsigned expression >= 0 is always true"); - value = truthvalue_true_node; - break; - - case LT_EXPR: - if (warn_type_limits && !in_system_header - && !(TREE_CODE (primop0) == INTEGER_CST - && !TREE_OVERFLOW (convert (c_common_signed_type (type), - primop0)))) - warning (OPT_Wtype_limits, - "comparison of unsigned expression < 0 is always false"); - value = truthvalue_false_node; - break; - - default: - break; - } - - if (value != 0) - { - /* Don't forget to evaluate PRIMOP0 if it has side effects. */ - if (TREE_SIDE_EFFECTS (primop0)) - return build2 (COMPOUND_EXPR, TREE_TYPE (value), - primop0, value); - return value; - } - } - } - - *op0_ptr = convert (type, primop0); - *op1_ptr = convert (type, primop1); - - *restype_ptr = truthvalue_type_node; - - return 0; -} - -/* Return a tree for the sum or difference (RESULTCODE says which) - of pointer PTROP and integer INTOP. */ - -tree -pointer_int_sum (location_t loc, enum tree_code resultcode, - tree ptrop, tree intop) -{ - tree size_exp, ret; - - /* The result is a pointer of the same type that is being added. */ - tree result_type = TREE_TYPE (ptrop); - - if (TREE_CODE (TREE_TYPE (result_type)) == VOID_TYPE) - { - pedwarn (loc, pedantic ? OPT_pedantic : OPT_Wpointer_arith, - "pointer of type % used in arithmetic"); - size_exp = integer_one_node; - } - else if (TREE_CODE (TREE_TYPE (result_type)) == FUNCTION_TYPE) - { - pedwarn (loc, pedantic ? OPT_pedantic : OPT_Wpointer_arith, - "pointer to a function used in arithmetic"); - size_exp = integer_one_node; - } - else if (TREE_CODE (TREE_TYPE (result_type)) == METHOD_TYPE) - { - pedwarn (loc, pedantic ? OPT_pedantic : OPT_Wpointer_arith, - "pointer to member function used in arithmetic"); - size_exp = integer_one_node; - } - else - size_exp = size_in_bytes (TREE_TYPE (result_type)); - - /* We are manipulating pointer values, so we don't need to warn - about relying on undefined signed overflow. We disable the - warning here because we use integer types so fold won't know that - they are really pointers. */ - fold_defer_overflow_warnings (); - - /* If what we are about to multiply by the size of the elements - contains a constant term, apply distributive law - and multiply that constant term separately. - This helps produce common subexpressions. */ - if ((TREE_CODE (intop) == PLUS_EXPR || TREE_CODE (intop) == MINUS_EXPR) - && !TREE_CONSTANT (intop) - && TREE_CONSTANT (TREE_OPERAND (intop, 1)) - && TREE_CONSTANT (size_exp) - /* If the constant comes from pointer subtraction, - skip this optimization--it would cause an error. */ - && TREE_CODE (TREE_TYPE (TREE_OPERAND (intop, 0))) == INTEGER_TYPE - /* If the constant is unsigned, and smaller than the pointer size, - then we must skip this optimization. This is because it could cause - an overflow error if the constant is negative but INTOP is not. */ - && (!TYPE_UNSIGNED (TREE_TYPE (intop)) - || (TYPE_PRECISION (TREE_TYPE (intop)) - == TYPE_PRECISION (TREE_TYPE (ptrop))))) - { - enum tree_code subcode = resultcode; - tree int_type = TREE_TYPE (intop); - if (TREE_CODE (intop) == MINUS_EXPR) - subcode = (subcode == PLUS_EXPR ? MINUS_EXPR : PLUS_EXPR); - /* Convert both subexpression types to the type of intop, - because weird cases involving pointer arithmetic - can result in a sum or difference with different type args. */ - ptrop = build_binary_op (EXPR_LOCATION (TREE_OPERAND (intop, 1)), - subcode, ptrop, - convert (int_type, TREE_OPERAND (intop, 1)), 1); - intop = convert (int_type, TREE_OPERAND (intop, 0)); - } - - /* Convert the integer argument to a type the same size as sizetype - so the multiply won't overflow spuriously. */ - if (TYPE_PRECISION (TREE_TYPE (intop)) != TYPE_PRECISION (sizetype) - || TYPE_UNSIGNED (TREE_TYPE (intop)) != TYPE_UNSIGNED (sizetype)) - intop = convert (c_common_type_for_size (TYPE_PRECISION (sizetype), - TYPE_UNSIGNED (sizetype)), intop); - - /* Replace the integer argument with a suitable product by the object size. - Do this multiplication as signed, then convert to the appropriate type - for the pointer operation and disregard an overflow that occured only - because of the sign-extension change in the latter conversion. */ - { - tree t = build_binary_op (loc, - MULT_EXPR, intop, - convert (TREE_TYPE (intop), size_exp), 1); - intop = convert (sizetype, t); - if (TREE_OVERFLOW_P (intop) && !TREE_OVERFLOW (t)) - intop = build_int_cst_wide (TREE_TYPE (intop), TREE_INT_CST_LOW (intop), - TREE_INT_CST_HIGH (intop)); - } - - /* Create the sum or difference. */ - if (resultcode == MINUS_EXPR) - intop = fold_build1_loc (loc, NEGATE_EXPR, sizetype, intop); - - ret = fold_build2_loc (loc, POINTER_PLUS_EXPR, result_type, ptrop, intop); - - fold_undefer_and_ignore_overflow_warnings (); - - return ret; -} - -/* Wrap a C_MAYBE_CONST_EXPR around an expression that is fully folded - and if NON_CONST is known not to be permitted in an evaluated part - of a constant expression. */ - -tree -c_wrap_maybe_const (tree expr, bool non_const) -{ - bool nowarning = TREE_NO_WARNING (expr); - location_t loc = EXPR_LOCATION (expr); - - /* This should never be called for C++. */ - if (c_dialect_cxx ()) - gcc_unreachable (); - - /* The result of folding may have a NOP_EXPR to set TREE_NO_WARNING. */ - STRIP_TYPE_NOPS (expr); - expr = build2 (C_MAYBE_CONST_EXPR, TREE_TYPE (expr), NULL, expr); - C_MAYBE_CONST_EXPR_NON_CONST (expr) = non_const; - if (nowarning) - TREE_NO_WARNING (expr) = 1; - protected_set_expr_location (expr, loc); - - return expr; -} - -/* Wrap a SAVE_EXPR around EXPR, if appropriate. Like save_expr, but - for C folds the inside expression and wraps a C_MAYBE_CONST_EXPR - around the SAVE_EXPR if needed so that c_fully_fold does not need - to look inside SAVE_EXPRs. */ - -tree -c_save_expr (tree expr) -{ - bool maybe_const = true; - if (c_dialect_cxx ()) - return save_expr (expr); - expr = c_fully_fold (expr, false, &maybe_const); - expr = save_expr (expr); - if (!maybe_const) - expr = c_wrap_maybe_const (expr, true); - return expr; -} - -/* Return whether EXPR is a declaration whose address can never be - NULL. */ - -bool -decl_with_nonnull_addr_p (const_tree expr) -{ - return (DECL_P (expr) - && (TREE_CODE (expr) == PARM_DECL - || TREE_CODE (expr) == LABEL_DECL - || !DECL_WEAK (expr))); -} - -/* Prepare expr to be an argument of a TRUTH_NOT_EXPR, - or for an `if' or `while' statement or ?..: exp. It should already - have been validated to be of suitable type; otherwise, a bad - diagnostic may result. - - The EXPR is located at LOCATION. - - 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, truthvalue_false_node, 1), - but we optimize comparisons, &&, ||, and !. - - The resulting type should always be `truthvalue_type_node'. */ - -tree -c_common_truthvalue_conversion (location_t location, tree expr) -{ - switch (TREE_CODE (expr)) - { - case EQ_EXPR: case NE_EXPR: case UNEQ_EXPR: case LTGT_EXPR: - case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR: - case UNLE_EXPR: case UNGE_EXPR: case UNLT_EXPR: case UNGT_EXPR: - case ORDERED_EXPR: case UNORDERED_EXPR: - if (TREE_TYPE (expr) == truthvalue_type_node) - return expr; - expr = build2 (TREE_CODE (expr), truthvalue_type_node, - TREE_OPERAND (expr, 0), TREE_OPERAND (expr, 1)); - goto ret; - - case TRUTH_ANDIF_EXPR: - case TRUTH_ORIF_EXPR: - case TRUTH_AND_EXPR: - case TRUTH_OR_EXPR: - case TRUTH_XOR_EXPR: - if (TREE_TYPE (expr) == truthvalue_type_node) - return expr; - expr = build2 (TREE_CODE (expr), truthvalue_type_node, - c_common_truthvalue_conversion (location, - TREE_OPERAND (expr, 0)), - c_common_truthvalue_conversion (location, - TREE_OPERAND (expr, 1))); - goto ret; - - case TRUTH_NOT_EXPR: - if (TREE_TYPE (expr) == truthvalue_type_node) - return expr; - expr = build1 (TREE_CODE (expr), truthvalue_type_node, - c_common_truthvalue_conversion (location, - TREE_OPERAND (expr, 0))); - goto ret; - - case ERROR_MARK: - return expr; - - case INTEGER_CST: - return integer_zerop (expr) ? truthvalue_false_node - : truthvalue_true_node; - - case REAL_CST: - return real_compare (NE_EXPR, &TREE_REAL_CST (expr), &dconst0) - ? truthvalue_true_node - : truthvalue_false_node; - - case FIXED_CST: - return fixed_compare (NE_EXPR, &TREE_FIXED_CST (expr), - &FCONST0 (TYPE_MODE (TREE_TYPE (expr)))) - ? truthvalue_true_node - : truthvalue_false_node; - - case FUNCTION_DECL: - expr = build_unary_op (location, ADDR_EXPR, expr, 0); - /* Fall through. */ - - case ADDR_EXPR: - { - tree inner = TREE_OPERAND (expr, 0); - if (decl_with_nonnull_addr_p (inner)) - { - /* Common Ada/Pascal programmer's mistake. */ - warning_at (location, - OPT_Waddress, - "the address of %qD will always evaluate as %", - inner); - return truthvalue_true_node; - } - - /* If we still have a decl, it is possible for its address to - be NULL, so we cannot optimize. */ - if (DECL_P (inner)) - { - gcc_assert (DECL_WEAK (inner)); - break; - } - - if (TREE_SIDE_EFFECTS (inner)) - { - expr = build2 (COMPOUND_EXPR, truthvalue_type_node, - inner, truthvalue_true_node); - goto ret; - } - else - return truthvalue_true_node; - } - - case COMPLEX_EXPR: - expr = build_binary_op (EXPR_LOCATION (expr), - (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)) - ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR), - c_common_truthvalue_conversion (location, - TREE_OPERAND (expr, 0)), - c_common_truthvalue_conversion (location, - TREE_OPERAND (expr, 1)), - 0); - goto ret; - - case NEGATE_EXPR: - case ABS_EXPR: - case FLOAT_EXPR: - case EXCESS_PRECISION_EXPR: - /* These don't change whether an object is nonzero or zero. */ - return c_common_truthvalue_conversion (location, 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))) - { - expr = build2 (COMPOUND_EXPR, truthvalue_type_node, - TREE_OPERAND (expr, 1), - c_common_truthvalue_conversion - (location, TREE_OPERAND (expr, 0))); - goto ret; - } - else - return c_common_truthvalue_conversion (location, - TREE_OPERAND (expr, 0)); - - case COND_EXPR: - /* Distribute the conversion into the arms of a COND_EXPR. */ - if (c_dialect_cxx ()) - { - expr = fold_build3_loc (location, COND_EXPR, truthvalue_type_node, - TREE_OPERAND (expr, 0), - c_common_truthvalue_conversion (location, - TREE_OPERAND (expr, - 1)), - c_common_truthvalue_conversion (location, - TREE_OPERAND (expr, - 2))); - goto ret; - } - else - { - /* Folding will happen later for C. */ - expr = build3 (COND_EXPR, truthvalue_type_node, - TREE_OPERAND (expr, 0), - c_common_truthvalue_conversion (location, - TREE_OPERAND (expr, 1)), - c_common_truthvalue_conversion (location, - TREE_OPERAND (expr, 2))); - goto ret; - } - - CASE_CONVERT: - /* 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; - /* 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 c_common_truthvalue_conversion (location, - TREE_OPERAND (expr, 0)); - break; - - case MODIFY_EXPR: - if (!TREE_NO_WARNING (expr) - && warn_parentheses) - { - warning (OPT_Wparentheses, - "suggest parentheses around assignment used as truth value"); - TREE_NO_WARNING (expr) = 1; - } - break; - - default: - break; - } - - if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE) - { - tree t = c_save_expr (expr); - expr = (build_binary_op - (EXPR_LOCATION (expr), - (TREE_SIDE_EFFECTS (expr) - ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR), - c_common_truthvalue_conversion - (location, - build_unary_op (location, REALPART_EXPR, t, 0)), - c_common_truthvalue_conversion - (location, - build_unary_op (location, IMAGPART_EXPR, t, 0)), - 0)); - goto ret; - } - - if (TREE_CODE (TREE_TYPE (expr)) == FIXED_POINT_TYPE) - { - tree fixed_zero_node = build_fixed (TREE_TYPE (expr), - FCONST0 (TYPE_MODE - (TREE_TYPE (expr)))); - return build_binary_op (location, NE_EXPR, expr, fixed_zero_node, 1); - } - else - return build_binary_op (location, NE_EXPR, expr, integer_zero_node, 1); - - ret: - protected_set_expr_location (expr, location); - return expr; -} - -static void def_builtin_1 (enum built_in_function fncode, - const char *name, - enum built_in_class fnclass, - tree fntype, tree libtype, - bool both_p, bool fallback_p, bool nonansi_p, - tree fnattrs, bool implicit_p); - - -/* Apply the TYPE_QUALS to the new DECL. */ - -void -c_apply_type_quals_to_decl (int type_quals, tree decl) -{ - tree type = TREE_TYPE (decl); - - if (type == error_mark_node) - return; - - if (((type_quals & TYPE_QUAL_CONST) - || (type && TREE_CODE (type) == REFERENCE_TYPE)) - /* An object declared 'const' is only readonly after it is - initialized. We don't have any way of expressing this currently, - so we need to be conservative and unset TREE_READONLY for types - with constructors. Otherwise aliasing code will ignore stores in - an inline constructor. */ - && !(type && TYPE_NEEDS_CONSTRUCTING (type))) - TREE_READONLY (decl) = 1; - if (type_quals & TYPE_QUAL_VOLATILE) - { - TREE_SIDE_EFFECTS (decl) = 1; - TREE_THIS_VOLATILE (decl) = 1; - } - if (type_quals & TYPE_QUAL_RESTRICT) - { - while (type && TREE_CODE (type) == ARRAY_TYPE) - /* Allow 'restrict' on arrays of pointers. - FIXME currently we just ignore it. */ - type = TREE_TYPE (type); - if (!type - || !POINTER_TYPE_P (type) - || !C_TYPE_OBJECT_OR_INCOMPLETE_P (TREE_TYPE (type))) - error ("invalid use of %"); - } -} - -/* Hash function for the problem of multiple type definitions in - different files. This must hash all types that will compare - equal via comptypes to the same value. In practice it hashes - on some of the simple stuff and leaves the details to comptypes. */ - -static hashval_t -c_type_hash (const void *p) -{ - int i = 0; - int shift, size; - const_tree const t = (const_tree) p; - tree t2; - switch (TREE_CODE (t)) - { - /* For pointers, hash on pointee type plus some swizzling. */ - case POINTER_TYPE: - return c_type_hash (TREE_TYPE (t)) ^ 0x3003003; - /* Hash on number of elements and total size. */ - case ENUMERAL_TYPE: - shift = 3; - t2 = TYPE_VALUES (t); - break; - case RECORD_TYPE: - shift = 0; - t2 = TYPE_FIELDS (t); - break; - case QUAL_UNION_TYPE: - shift = 1; - t2 = TYPE_FIELDS (t); - break; - case UNION_TYPE: - shift = 2; - t2 = TYPE_FIELDS (t); - break; - default: - gcc_unreachable (); - } - for (; t2; t2 = TREE_CHAIN (t2)) - i++; - /* We might have a VLA here. */ - if (TREE_CODE (TYPE_SIZE (t)) != INTEGER_CST) - size = 0; - else - size = TREE_INT_CST_LOW (TYPE_SIZE (t)); - return ((size << 24) | (i << shift)); -} - -static GTY((param_is (union tree_node))) htab_t type_hash_table; - -/* Return the typed-based alias set for T, which may be an expression - or a type. Return -1 if we don't do anything special. */ - -alias_set_type -c_common_get_alias_set (tree t) -{ - tree u; - PTR *slot; - - /* For VLAs, use the alias set of the element type rather than the - default of alias set 0 for types compared structurally. */ - if (TYPE_P (t) && TYPE_STRUCTURAL_EQUALITY_P (t)) - { - if (TREE_CODE (t) == ARRAY_TYPE) - return get_alias_set (TREE_TYPE (t)); - return -1; - } - - /* Permit type-punning when accessing a union, provided the access - is directly through the union. For example, this code does not - permit taking the address of a union member and then storing - through it. Even the type-punning allowed here is a GCC - extension, albeit a common and useful one; the C standard says - that such accesses have implementation-defined behavior. */ - for (u = t; - TREE_CODE (u) == COMPONENT_REF || TREE_CODE (u) == ARRAY_REF; - u = TREE_OPERAND (u, 0)) - if (TREE_CODE (u) == COMPONENT_REF - && TREE_CODE (TREE_TYPE (TREE_OPERAND (u, 0))) == UNION_TYPE) - return 0; - - /* That's all the expressions we handle specially. */ - if (!TYPE_P (t)) - return -1; - - /* The C standard guarantees that any object may be accessed via an - lvalue that has character type. */ - if (t == char_type_node - || t == signed_char_type_node - || t == unsigned_char_type_node) - return 0; - - /* The C standard specifically allows aliasing between signed and - unsigned variants of the same type. We treat the signed - variant as canonical. */ - if (TREE_CODE (t) == INTEGER_TYPE && TYPE_UNSIGNED (t)) - { - tree t1 = c_common_signed_type (t); - - /* t1 == t can happen for boolean nodes which are always unsigned. */ - if (t1 != t) - return get_alias_set (t1); - } - else if (POINTER_TYPE_P (t)) - { - tree t1; - - /* Unfortunately, there is no canonical form of a pointer type. - In particular, if we have `typedef int I', then `int *', and - `I *' are different types. So, we have to pick a canonical - representative. We do this below. - - Technically, this approach is actually more conservative that - it needs to be. In particular, `const int *' and `int *' - should be in different alias sets, according to the C and C++ - standard, since their types are not the same, and so, - technically, an `int **' and `const int **' cannot point at - the same thing. - - But, the standard is wrong. In particular, this code is - legal C++: - - int *ip; - int **ipp = &ip; - const int* const* cipp = ipp; - - And, it doesn't make sense for that to be legal unless you - can dereference IPP and CIPP. So, we ignore cv-qualifiers on - the pointed-to types. This issue has been reported to the - C++ committee. */ - t1 = build_type_no_quals (t); - if (t1 != t) - return get_alias_set (t1); - } - - /* Handle the case of multiple type nodes referring to "the same" type, - which occurs with IMA. These share an alias set. FIXME: Currently only - C90 is handled. (In C99 type compatibility is not transitive, which - complicates things mightily. The alias set splay trees can theoretically - represent this, but insertion is tricky when you consider all the - different orders things might arrive in.) */ - - if (c_language != clk_c || flag_isoc99) - return -1; - - /* Save time if there's only one input file. */ - if (num_in_fnames == 1) - return -1; - - /* Pointers need special handling if they point to any type that - needs special handling (below). */ - if (TREE_CODE (t) == POINTER_TYPE) - { - tree t2; - /* Find bottom type under any nested POINTERs. */ - for (t2 = TREE_TYPE (t); - TREE_CODE (t2) == POINTER_TYPE; - t2 = TREE_TYPE (t2)) - ; - if (TREE_CODE (t2) != RECORD_TYPE - && TREE_CODE (t2) != ENUMERAL_TYPE - && TREE_CODE (t2) != QUAL_UNION_TYPE - && TREE_CODE (t2) != UNION_TYPE) - return -1; - if (TYPE_SIZE (t2) == 0) - return -1; - } - /* These are the only cases that need special handling. */ - if (TREE_CODE (t) != RECORD_TYPE - && TREE_CODE (t) != ENUMERAL_TYPE - && TREE_CODE (t) != QUAL_UNION_TYPE - && TREE_CODE (t) != UNION_TYPE - && TREE_CODE (t) != POINTER_TYPE) - return -1; - /* Undefined? */ - if (TYPE_SIZE (t) == 0) - return -1; - - /* Look up t in hash table. Only one of the compatible types within each - alias set is recorded in the table. */ - if (!type_hash_table) - type_hash_table = htab_create_ggc (1021, c_type_hash, - (htab_eq) lang_hooks.types_compatible_p, - NULL); - slot = htab_find_slot (type_hash_table, t, INSERT); - if (*slot != NULL) - { - TYPE_ALIAS_SET (t) = TYPE_ALIAS_SET ((tree)*slot); - return TYPE_ALIAS_SET ((tree)*slot); - } - else - /* Our caller will assign and record (in t) a new alias set; all we need - to do is remember t in the hash table. */ - *slot = t; - - return -1; -} - -/* Compute the value of 'sizeof (TYPE)' or '__alignof__ (TYPE)', where - the second parameter indicates which OPERATOR is being applied. - The COMPLAIN flag controls whether we should diagnose possibly - ill-formed constructs or not. LOC is the location of the SIZEOF or - TYPEOF operator. */ - -tree -c_sizeof_or_alignof_type (location_t loc, - tree type, bool is_sizeof, int complain) -{ - const char *op_name; - tree value = NULL; - enum tree_code type_code = TREE_CODE (type); - - op_name = is_sizeof ? "sizeof" : "__alignof__"; - - if (type_code == FUNCTION_TYPE) - { - if (is_sizeof) - { - if (complain && (pedantic || warn_pointer_arith)) - pedwarn (loc, pedantic ? OPT_pedantic : OPT_Wpointer_arith, - "invalid application of % to a function type"); - else if (!complain) - return error_mark_node; - value = size_one_node; - } - else - value = size_int (FUNCTION_BOUNDARY / BITS_PER_UNIT); - } - else if (type_code == VOID_TYPE || type_code == ERROR_MARK) - { - if (type_code == VOID_TYPE - && complain && (pedantic || warn_pointer_arith)) - pedwarn (loc, pedantic ? OPT_pedantic : OPT_Wpointer_arith, - "invalid application of %qs to a void type", op_name); - else if (!complain) - return error_mark_node; - value = size_one_node; - } - else if (!COMPLETE_TYPE_P (type)) - { - if (complain) - error_at (loc, "invalid application of %qs to incomplete type %qT ", - op_name, type); - return error_mark_node; - } - else - { - if (is_sizeof) - /* Convert in case a char is more than one unit. */ - value = size_binop_loc (loc, CEIL_DIV_EXPR, TYPE_SIZE_UNIT (type), - size_int (TYPE_PRECISION (char_type_node) - / BITS_PER_UNIT)); - else - value = size_int (TYPE_ALIGN_UNIT (type)); - } - - /* VALUE will have an integer type with TYPE_IS_SIZETYPE set. - TYPE_IS_SIZETYPE means that certain things (like overflow) will - never happen. However, this node should really have type - `size_t', which is just a typedef for an ordinary integer type. */ - value = fold_convert_loc (loc, size_type_node, value); - gcc_assert (!TYPE_IS_SIZETYPE (TREE_TYPE (value))); - - return value; -} - -/* Implement the __alignof keyword: Return the minimum required - alignment of EXPR, measured in bytes. For VAR_DECLs, - FUNCTION_DECLs and FIELD_DECLs return DECL_ALIGN (which can be set - from an "aligned" __attribute__ specification). LOC is the - location of the ALIGNOF operator. */ - -tree -c_alignof_expr (location_t loc, tree expr) -{ - tree t; - - if (VAR_OR_FUNCTION_DECL_P (expr)) - t = size_int (DECL_ALIGN_UNIT (expr)); - - else if (TREE_CODE (expr) == COMPONENT_REF - && DECL_C_BIT_FIELD (TREE_OPERAND (expr, 1))) - { - error_at (loc, "%<__alignof%> applied to a bit-field"); - t = size_one_node; - } - else if (TREE_CODE (expr) == COMPONENT_REF - && TREE_CODE (TREE_OPERAND (expr, 1)) == FIELD_DECL) - t = size_int (DECL_ALIGN_UNIT (TREE_OPERAND (expr, 1))); - - else if (TREE_CODE (expr) == INDIRECT_REF) - { - tree t = TREE_OPERAND (expr, 0); - tree best = t; - int bestalign = TYPE_ALIGN (TREE_TYPE (TREE_TYPE (t))); - - while (CONVERT_EXPR_P (t) - && TREE_CODE (TREE_TYPE (TREE_OPERAND (t, 0))) == POINTER_TYPE) - { - int thisalign; - - t = TREE_OPERAND (t, 0); - thisalign = TYPE_ALIGN (TREE_TYPE (TREE_TYPE (t))); - if (thisalign > bestalign) - best = t, bestalign = thisalign; - } - return c_alignof (loc, TREE_TYPE (TREE_TYPE (best))); - } - else - return c_alignof (loc, TREE_TYPE (expr)); - - return fold_convert_loc (loc, size_type_node, t); -} - -/* Handle C and C++ default attributes. */ - -enum built_in_attribute -{ -#define DEF_ATTR_NULL_TREE(ENUM) ENUM, -#define DEF_ATTR_INT(ENUM, VALUE) ENUM, -#define DEF_ATTR_IDENT(ENUM, STRING) ENUM, -#define DEF_ATTR_TREE_LIST(ENUM, PURPOSE, VALUE, CHAIN) ENUM, -#include "builtin-attrs.def" -#undef DEF_ATTR_NULL_TREE -#undef DEF_ATTR_INT -#undef DEF_ATTR_IDENT -#undef DEF_ATTR_TREE_LIST - ATTR_LAST -}; - -static GTY(()) tree built_in_attributes[(int) ATTR_LAST]; - -static void c_init_attributes (void); - -enum c_builtin_type -{ -#define DEF_PRIMITIVE_TYPE(NAME, VALUE) NAME, -#define DEF_FUNCTION_TYPE_0(NAME, RETURN) NAME, -#define DEF_FUNCTION_TYPE_1(NAME, RETURN, ARG1) NAME, -#define DEF_FUNCTION_TYPE_2(NAME, RETURN, ARG1, ARG2) NAME, -#define DEF_FUNCTION_TYPE_3(NAME, RETURN, ARG1, ARG2, ARG3) NAME, -#define DEF_FUNCTION_TYPE_4(NAME, RETURN, ARG1, ARG2, ARG3, ARG4) NAME, -#define DEF_FUNCTION_TYPE_5(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) NAME, -#define DEF_FUNCTION_TYPE_6(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6) NAME, -#define DEF_FUNCTION_TYPE_7(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, ARG7) NAME, -#define DEF_FUNCTION_TYPE_VAR_0(NAME, RETURN) NAME, -#define DEF_FUNCTION_TYPE_VAR_1(NAME, RETURN, ARG1) NAME, -#define DEF_FUNCTION_TYPE_VAR_2(NAME, RETURN, ARG1, ARG2) NAME, -#define DEF_FUNCTION_TYPE_VAR_3(NAME, RETURN, ARG1, ARG2, ARG3) NAME, -#define DEF_FUNCTION_TYPE_VAR_4(NAME, RETURN, ARG1, ARG2, ARG3, ARG4) NAME, -#define DEF_FUNCTION_TYPE_VAR_5(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG6) \ - NAME, -#define DEF_POINTER_TYPE(NAME, TYPE) NAME, -#include "builtin-types.def" -#undef DEF_PRIMITIVE_TYPE -#undef DEF_FUNCTION_TYPE_0 -#undef DEF_FUNCTION_TYPE_1 -#undef DEF_FUNCTION_TYPE_2 -#undef DEF_FUNCTION_TYPE_3 -#undef DEF_FUNCTION_TYPE_4 -#undef DEF_FUNCTION_TYPE_5 -#undef DEF_FUNCTION_TYPE_6 -#undef DEF_FUNCTION_TYPE_7 -#undef DEF_FUNCTION_TYPE_VAR_0 -#undef DEF_FUNCTION_TYPE_VAR_1 -#undef DEF_FUNCTION_TYPE_VAR_2 -#undef DEF_FUNCTION_TYPE_VAR_3 -#undef DEF_FUNCTION_TYPE_VAR_4 -#undef DEF_FUNCTION_TYPE_VAR_5 -#undef DEF_POINTER_TYPE - BT_LAST -}; - -typedef enum c_builtin_type builtin_type; - -/* A temporary array for c_common_nodes_and_builtins. Used in - communication with def_fn_type. */ -static tree builtin_types[(int) BT_LAST + 1]; - -/* A helper function for c_common_nodes_and_builtins. Build function type - for DEF with return type RET and N arguments. If VAR is true, then the - function should be variadic after those N arguments. - - Takes special care not to ICE if any of the types involved are - error_mark_node, which indicates that said type is not in fact available - (see builtin_type_for_size). In which case the function type as a whole - should be error_mark_node. */ - -static void -def_fn_type (builtin_type def, builtin_type ret, bool var, int n, ...) -{ - tree args = NULL, t; - va_list list; - int i; - - va_start (list, n); - for (i = 0; i < n; ++i) - { - builtin_type a = (builtin_type) va_arg (list, int); - t = builtin_types[a]; - if (t == error_mark_node) - goto egress; - args = tree_cons (NULL_TREE, t, args); - } - va_end (list); - - args = nreverse (args); - if (!var) - args = chainon (args, void_list_node); - - t = builtin_types[ret]; - if (t == error_mark_node) - goto egress; - t = build_function_type (t, args); - - egress: - builtin_types[def] = t; -} - -/* Build builtin functions common to both C and C++ language - frontends. */ - -static void -c_define_builtins (tree va_list_ref_type_node, tree va_list_arg_type_node) -{ -#define DEF_PRIMITIVE_TYPE(ENUM, VALUE) \ - builtin_types[ENUM] = VALUE; -#define DEF_FUNCTION_TYPE_0(ENUM, RETURN) \ - def_fn_type (ENUM, RETURN, 0, 0); -#define DEF_FUNCTION_TYPE_1(ENUM, RETURN, ARG1) \ - def_fn_type (ENUM, RETURN, 0, 1, ARG1); -#define DEF_FUNCTION_TYPE_2(ENUM, RETURN, ARG1, ARG2) \ - def_fn_type (ENUM, RETURN, 0, 2, ARG1, ARG2); -#define DEF_FUNCTION_TYPE_3(ENUM, RETURN, ARG1, ARG2, ARG3) \ - def_fn_type (ENUM, RETURN, 0, 3, ARG1, ARG2, ARG3); -#define DEF_FUNCTION_TYPE_4(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4) \ - def_fn_type (ENUM, RETURN, 0, 4, ARG1, ARG2, ARG3, ARG4); -#define DEF_FUNCTION_TYPE_5(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) \ - def_fn_type (ENUM, RETURN, 0, 5, ARG1, ARG2, ARG3, ARG4, ARG5); -#define DEF_FUNCTION_TYPE_6(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ - ARG6) \ - def_fn_type (ENUM, RETURN, 0, 6, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6); -#define DEF_FUNCTION_TYPE_7(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ - ARG6, ARG7) \ - def_fn_type (ENUM, RETURN, 0, 7, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, ARG7); -#define DEF_FUNCTION_TYPE_VAR_0(ENUM, RETURN) \ - def_fn_type (ENUM, RETURN, 1, 0); -#define DEF_FUNCTION_TYPE_VAR_1(ENUM, RETURN, ARG1) \ - def_fn_type (ENUM, RETURN, 1, 1, ARG1); -#define DEF_FUNCTION_TYPE_VAR_2(ENUM, RETURN, ARG1, ARG2) \ - def_fn_type (ENUM, RETURN, 1, 2, ARG1, ARG2); -#define DEF_FUNCTION_TYPE_VAR_3(ENUM, RETURN, ARG1, ARG2, ARG3) \ - def_fn_type (ENUM, RETURN, 1, 3, ARG1, ARG2, ARG3); -#define DEF_FUNCTION_TYPE_VAR_4(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4) \ - def_fn_type (ENUM, RETURN, 1, 4, ARG1, ARG2, ARG3, ARG4); -#define DEF_FUNCTION_TYPE_VAR_5(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) \ - def_fn_type (ENUM, RETURN, 1, 5, ARG1, ARG2, ARG3, ARG4, ARG5); -#define DEF_POINTER_TYPE(ENUM, TYPE) \ - builtin_types[(int) ENUM] = build_pointer_type (builtin_types[(int) TYPE]); - -#include "builtin-types.def" - -#undef DEF_PRIMITIVE_TYPE -#undef DEF_FUNCTION_TYPE_1 -#undef DEF_FUNCTION_TYPE_2 -#undef DEF_FUNCTION_TYPE_3 -#undef DEF_FUNCTION_TYPE_4 -#undef DEF_FUNCTION_TYPE_5 -#undef DEF_FUNCTION_TYPE_6 -#undef DEF_FUNCTION_TYPE_VAR_0 -#undef DEF_FUNCTION_TYPE_VAR_1 -#undef DEF_FUNCTION_TYPE_VAR_2 -#undef DEF_FUNCTION_TYPE_VAR_3 -#undef DEF_FUNCTION_TYPE_VAR_4 -#undef DEF_FUNCTION_TYPE_VAR_5 -#undef DEF_POINTER_TYPE - builtin_types[(int) BT_LAST] = NULL_TREE; - - c_init_attributes (); - -#define DEF_BUILTIN(ENUM, NAME, CLASS, TYPE, LIBTYPE, BOTH_P, FALLBACK_P, \ - NONANSI_P, ATTRS, IMPLICIT, COND) \ - if (NAME && COND) \ - def_builtin_1 (ENUM, NAME, CLASS, \ - builtin_types[(int) TYPE], \ - builtin_types[(int) LIBTYPE], \ - BOTH_P, FALLBACK_P, NONANSI_P, \ - built_in_attributes[(int) ATTRS], IMPLICIT); -#include "builtins.def" -#undef DEF_BUILTIN - - targetm.init_builtins (); - - build_common_builtin_nodes (); - - if (flag_mudflap) - mudflap_init (); -} - -/* Like get_identifier, but avoid warnings about null arguments when - the argument may be NULL for targets where GCC lacks stdint.h type - information. */ - -static inline tree -c_get_ident (const char *id) -{ - return get_identifier (id); -} - -/* Build tree nodes and builtin functions common to both C and C++ language - frontends. */ - -void -c_common_nodes_and_builtins (void) -{ - int char16_type_size; - int char32_type_size; - int wchar_type_size; - tree array_domain_type; - tree va_list_ref_type_node; - tree va_list_arg_type_node; - - /* Define `int' and `char' first so that dbx will output them first. */ - record_builtin_type (RID_INT, NULL, integer_type_node); - record_builtin_type (RID_CHAR, "char", char_type_node); - - /* `signed' is the same as `int'. FIXME: the declarations of "signed", - "unsigned long", "long long unsigned" and "unsigned short" were in C++ - but not C. Are the conditionals here needed? */ - if (c_dialect_cxx ()) - record_builtin_type (RID_SIGNED, NULL, integer_type_node); - record_builtin_type (RID_LONG, "long int", long_integer_type_node); - record_builtin_type (RID_UNSIGNED, "unsigned int", unsigned_type_node); - record_builtin_type (RID_MAX, "long unsigned int", - long_unsigned_type_node); - if (int128_integer_type_node != NULL_TREE) - { - record_builtin_type (RID_INT128, "__int128", - int128_integer_type_node); - record_builtin_type (RID_MAX, "__int128 unsigned", - int128_unsigned_type_node); - } - if (c_dialect_cxx ()) - record_builtin_type (RID_MAX, "unsigned long", long_unsigned_type_node); - record_builtin_type (RID_MAX, "long long int", - long_long_integer_type_node); - record_builtin_type (RID_MAX, "long long unsigned int", - long_long_unsigned_type_node); - if (c_dialect_cxx ()) - record_builtin_type (RID_MAX, "long long unsigned", - long_long_unsigned_type_node); - record_builtin_type (RID_SHORT, "short int", short_integer_type_node); - record_builtin_type (RID_MAX, "short unsigned int", - short_unsigned_type_node); - if (c_dialect_cxx ()) - record_builtin_type (RID_MAX, "unsigned short", - short_unsigned_type_node); - - /* Define both `signed char' and `unsigned char'. */ - record_builtin_type (RID_MAX, "signed char", signed_char_type_node); - record_builtin_type (RID_MAX, "unsigned char", unsigned_char_type_node); - - /* These are types that c_common_type_for_size and - c_common_type_for_mode use. */ - lang_hooks.decls.pushdecl (build_decl (UNKNOWN_LOCATION, - TYPE_DECL, NULL_TREE, - intQI_type_node)); - lang_hooks.decls.pushdecl (build_decl (UNKNOWN_LOCATION, - TYPE_DECL, NULL_TREE, - intHI_type_node)); - lang_hooks.decls.pushdecl (build_decl (UNKNOWN_LOCATION, - TYPE_DECL, NULL_TREE, - intSI_type_node)); - lang_hooks.decls.pushdecl (build_decl (UNKNOWN_LOCATION, - TYPE_DECL, NULL_TREE, - intDI_type_node)); -#if HOST_BITS_PER_WIDE_INT >= 64 - if (targetm.scalar_mode_supported_p (TImode)) - lang_hooks.decls.pushdecl (build_decl (UNKNOWN_LOCATION, - TYPE_DECL, - get_identifier ("__int128_t"), - intTI_type_node)); -#endif - lang_hooks.decls.pushdecl (build_decl (UNKNOWN_LOCATION, - TYPE_DECL, NULL_TREE, - unsigned_intQI_type_node)); - lang_hooks.decls.pushdecl (build_decl (UNKNOWN_LOCATION, - TYPE_DECL, NULL_TREE, - unsigned_intHI_type_node)); - lang_hooks.decls.pushdecl (build_decl (UNKNOWN_LOCATION, - TYPE_DECL, NULL_TREE, - unsigned_intSI_type_node)); - lang_hooks.decls.pushdecl (build_decl (UNKNOWN_LOCATION, - TYPE_DECL, NULL_TREE, - unsigned_intDI_type_node)); -#if HOST_BITS_PER_WIDE_INT >= 64 - if (targetm.scalar_mode_supported_p (TImode)) - lang_hooks.decls.pushdecl (build_decl (UNKNOWN_LOCATION, - TYPE_DECL, - get_identifier ("__uint128_t"), - unsigned_intTI_type_node)); -#endif - - /* Create the widest literal types. */ - widest_integer_literal_type_node - = make_signed_type (HOST_BITS_PER_WIDE_INT * 2); - lang_hooks.decls.pushdecl (build_decl (UNKNOWN_LOCATION, - TYPE_DECL, NULL_TREE, - widest_integer_literal_type_node)); - - widest_unsigned_literal_type_node - = make_unsigned_type (HOST_BITS_PER_WIDE_INT * 2); - lang_hooks.decls.pushdecl (build_decl (UNKNOWN_LOCATION, - TYPE_DECL, NULL_TREE, - widest_unsigned_literal_type_node)); - - /* `unsigned long' is the standard type for sizeof. - Note that stddef.h uses `unsigned long', - and this must agree, even if long and int are the same size. */ - size_type_node = - TREE_TYPE (identifier_global_value (get_identifier (SIZE_TYPE))); - signed_size_type_node = c_common_signed_type (size_type_node); - set_sizetype (size_type_node); - - pid_type_node = - TREE_TYPE (identifier_global_value (get_identifier (PID_TYPE))); - - build_common_tree_nodes_2 (flag_short_double); - - record_builtin_type (RID_FLOAT, NULL, float_type_node); - record_builtin_type (RID_DOUBLE, NULL, double_type_node); - record_builtin_type (RID_MAX, "long double", long_double_type_node); - - /* Only supported decimal floating point extension if the target - actually supports underlying modes. */ - if (targetm.scalar_mode_supported_p (SDmode) - && targetm.scalar_mode_supported_p (DDmode) - && targetm.scalar_mode_supported_p (TDmode)) - { - record_builtin_type (RID_DFLOAT32, NULL, dfloat32_type_node); - record_builtin_type (RID_DFLOAT64, NULL, dfloat64_type_node); - record_builtin_type (RID_DFLOAT128, NULL, dfloat128_type_node); - } - - if (targetm.fixed_point_supported_p ()) - { - record_builtin_type (RID_MAX, "short _Fract", short_fract_type_node); - record_builtin_type (RID_FRACT, NULL, fract_type_node); - record_builtin_type (RID_MAX, "long _Fract", long_fract_type_node); - record_builtin_type (RID_MAX, "long long _Fract", - long_long_fract_type_node); - record_builtin_type (RID_MAX, "unsigned short _Fract", - unsigned_short_fract_type_node); - record_builtin_type (RID_MAX, "unsigned _Fract", - unsigned_fract_type_node); - record_builtin_type (RID_MAX, "unsigned long _Fract", - unsigned_long_fract_type_node); - record_builtin_type (RID_MAX, "unsigned long long _Fract", - unsigned_long_long_fract_type_node); - record_builtin_type (RID_MAX, "_Sat short _Fract", - sat_short_fract_type_node); - record_builtin_type (RID_MAX, "_Sat _Fract", sat_fract_type_node); - record_builtin_type (RID_MAX, "_Sat long _Fract", - sat_long_fract_type_node); - record_builtin_type (RID_MAX, "_Sat long long _Fract", - sat_long_long_fract_type_node); - record_builtin_type (RID_MAX, "_Sat unsigned short _Fract", - sat_unsigned_short_fract_type_node); - record_builtin_type (RID_MAX, "_Sat unsigned _Fract", - sat_unsigned_fract_type_node); - record_builtin_type (RID_MAX, "_Sat unsigned long _Fract", - sat_unsigned_long_fract_type_node); - record_builtin_type (RID_MAX, "_Sat unsigned long long _Fract", - sat_unsigned_long_long_fract_type_node); - record_builtin_type (RID_MAX, "short _Accum", short_accum_type_node); - record_builtin_type (RID_ACCUM, NULL, accum_type_node); - record_builtin_type (RID_MAX, "long _Accum", long_accum_type_node); - record_builtin_type (RID_MAX, "long long _Accum", - long_long_accum_type_node); - record_builtin_type (RID_MAX, "unsigned short _Accum", - unsigned_short_accum_type_node); - record_builtin_type (RID_MAX, "unsigned _Accum", - unsigned_accum_type_node); - record_builtin_type (RID_MAX, "unsigned long _Accum", - unsigned_long_accum_type_node); - record_builtin_type (RID_MAX, "unsigned long long _Accum", - unsigned_long_long_accum_type_node); - record_builtin_type (RID_MAX, "_Sat short _Accum", - sat_short_accum_type_node); - record_builtin_type (RID_MAX, "_Sat _Accum", sat_accum_type_node); - record_builtin_type (RID_MAX, "_Sat long _Accum", - sat_long_accum_type_node); - record_builtin_type (RID_MAX, "_Sat long long _Accum", - sat_long_long_accum_type_node); - record_builtin_type (RID_MAX, "_Sat unsigned short _Accum", - sat_unsigned_short_accum_type_node); - record_builtin_type (RID_MAX, "_Sat unsigned _Accum", - sat_unsigned_accum_type_node); - record_builtin_type (RID_MAX, "_Sat unsigned long _Accum", - sat_unsigned_long_accum_type_node); - record_builtin_type (RID_MAX, "_Sat unsigned long long _Accum", - sat_unsigned_long_long_accum_type_node); - - } - - lang_hooks.decls.pushdecl (build_decl (UNKNOWN_LOCATION, - TYPE_DECL, - get_identifier ("complex int"), - complex_integer_type_node)); - lang_hooks.decls.pushdecl (build_decl (UNKNOWN_LOCATION, - TYPE_DECL, - get_identifier ("complex float"), - complex_float_type_node)); - lang_hooks.decls.pushdecl (build_decl (UNKNOWN_LOCATION, - TYPE_DECL, - get_identifier ("complex double"), - complex_double_type_node)); - lang_hooks.decls.pushdecl - (build_decl (UNKNOWN_LOCATION, - TYPE_DECL, get_identifier ("complex long double"), - complex_long_double_type_node)); - - if (c_dialect_cxx ()) - /* For C++, make fileptr_type_node a distinct void * type until - FILE type is defined. */ - fileptr_type_node = build_variant_type_copy (ptr_type_node); - - record_builtin_type (RID_VOID, NULL, void_type_node); - - /* Set the TYPE_NAME for any variants that were built before - record_builtin_type gave names to the built-in types. */ - { - tree void_name = TYPE_NAME (void_type_node); - TYPE_NAME (void_type_node) = NULL_TREE; - TYPE_NAME (build_qualified_type (void_type_node, TYPE_QUAL_CONST)) - = void_name; - TYPE_NAME (void_type_node) = void_name; - } - - /* This node must not be shared. */ - void_zero_node = make_node (INTEGER_CST); - TREE_TYPE (void_zero_node) = void_type_node; - - void_list_node = build_void_list_node (); - - /* Make a type to be the domain of a few array types - whose domains don't really matter. - 200 is small enough that it always fits in size_t - and large enough that it can hold most function names for the - initializations of __FUNCTION__ and __PRETTY_FUNCTION__. */ - array_domain_type = build_index_type (size_int (200)); - - /* Make a type for arrays of characters. - With luck nothing will ever really depend on the length of this - array type. */ - char_array_type_node - = build_array_type (char_type_node, array_domain_type); - - /* Likewise for arrays of ints. */ - int_array_type_node - = build_array_type (integer_type_node, array_domain_type); - - string_type_node = build_pointer_type (char_type_node); - const_string_type_node - = build_pointer_type (build_qualified_type - (char_type_node, TYPE_QUAL_CONST)); - - /* This is special for C++ so functions can be overloaded. */ - wchar_type_node = get_identifier (MODIFIED_WCHAR_TYPE); - wchar_type_node = TREE_TYPE (identifier_global_value (wchar_type_node)); - wchar_type_size = TYPE_PRECISION (wchar_type_node); - underlying_wchar_type_node = wchar_type_node; - if (c_dialect_cxx ()) - { - if (TYPE_UNSIGNED (wchar_type_node)) - wchar_type_node = make_unsigned_type (wchar_type_size); - else - wchar_type_node = make_signed_type (wchar_type_size); - record_builtin_type (RID_WCHAR, "wchar_t", wchar_type_node); - } - - /* This is for wide string constants. */ - wchar_array_type_node - = build_array_type (wchar_type_node, array_domain_type); - - /* Define 'char16_t'. */ - char16_type_node = get_identifier (CHAR16_TYPE); - char16_type_node = TREE_TYPE (identifier_global_value (char16_type_node)); - char16_type_size = TYPE_PRECISION (char16_type_node); - if (c_dialect_cxx ()) - { - char16_type_node = make_unsigned_type (char16_type_size); - - if (cxx_dialect == cxx0x) - record_builtin_type (RID_CHAR16, "char16_t", char16_type_node); - } - - /* This is for UTF-16 string constants. */ - char16_array_type_node - = build_array_type (char16_type_node, array_domain_type); - - /* Define 'char32_t'. */ - char32_type_node = get_identifier (CHAR32_TYPE); - char32_type_node = TREE_TYPE (identifier_global_value (char32_type_node)); - char32_type_size = TYPE_PRECISION (char32_type_node); - if (c_dialect_cxx ()) - { - char32_type_node = make_unsigned_type (char32_type_size); - - if (cxx_dialect == cxx0x) - record_builtin_type (RID_CHAR32, "char32_t", char32_type_node); - } - - /* This is for UTF-32 string constants. */ - char32_array_type_node - = build_array_type (char32_type_node, array_domain_type); - - wint_type_node = - TREE_TYPE (identifier_global_value (get_identifier (WINT_TYPE))); - - intmax_type_node = - TREE_TYPE (identifier_global_value (get_identifier (INTMAX_TYPE))); - uintmax_type_node = - TREE_TYPE (identifier_global_value (get_identifier (UINTMAX_TYPE))); - - if (SIG_ATOMIC_TYPE) - sig_atomic_type_node = - TREE_TYPE (identifier_global_value (c_get_ident (SIG_ATOMIC_TYPE))); - if (INT8_TYPE) - int8_type_node = - TREE_TYPE (identifier_global_value (c_get_ident (INT8_TYPE))); - if (INT16_TYPE) - int16_type_node = - TREE_TYPE (identifier_global_value (c_get_ident (INT16_TYPE))); - if (INT32_TYPE) - int32_type_node = - TREE_TYPE (identifier_global_value (c_get_ident (INT32_TYPE))); - if (INT64_TYPE) - int64_type_node = - TREE_TYPE (identifier_global_value (c_get_ident (INT64_TYPE))); - if (UINT8_TYPE) - uint8_type_node = - TREE_TYPE (identifier_global_value (c_get_ident (UINT8_TYPE))); - if (UINT16_TYPE) - uint16_type_node = - TREE_TYPE (identifier_global_value (c_get_ident (UINT16_TYPE))); - if (UINT32_TYPE) - c_uint32_type_node = - TREE_TYPE (identifier_global_value (c_get_ident (UINT32_TYPE))); - if (UINT64_TYPE) - c_uint64_type_node = - TREE_TYPE (identifier_global_value (c_get_ident (UINT64_TYPE))); - if (INT_LEAST8_TYPE) - int_least8_type_node = - TREE_TYPE (identifier_global_value (c_get_ident (INT_LEAST8_TYPE))); - if (INT_LEAST16_TYPE) - int_least16_type_node = - TREE_TYPE (identifier_global_value (c_get_ident (INT_LEAST16_TYPE))); - if (INT_LEAST32_TYPE) - int_least32_type_node = - TREE_TYPE (identifier_global_value (c_get_ident (INT_LEAST32_TYPE))); - if (INT_LEAST64_TYPE) - int_least64_type_node = - TREE_TYPE (identifier_global_value (c_get_ident (INT_LEAST64_TYPE))); - if (UINT_LEAST8_TYPE) - uint_least8_type_node = - TREE_TYPE (identifier_global_value (c_get_ident (UINT_LEAST8_TYPE))); - if (UINT_LEAST16_TYPE) - uint_least16_type_node = - TREE_TYPE (identifier_global_value (c_get_ident (UINT_LEAST16_TYPE))); - if (UINT_LEAST32_TYPE) - uint_least32_type_node = - TREE_TYPE (identifier_global_value (c_get_ident (UINT_LEAST32_TYPE))); - if (UINT_LEAST64_TYPE) - uint_least64_type_node = - TREE_TYPE (identifier_global_value (c_get_ident (UINT_LEAST64_TYPE))); - if (INT_FAST8_TYPE) - int_fast8_type_node = - TREE_TYPE (identifier_global_value (c_get_ident (INT_FAST8_TYPE))); - if (INT_FAST16_TYPE) - int_fast16_type_node = - TREE_TYPE (identifier_global_value (c_get_ident (INT_FAST16_TYPE))); - if (INT_FAST32_TYPE) - int_fast32_type_node = - TREE_TYPE (identifier_global_value (c_get_ident (INT_FAST32_TYPE))); - if (INT_FAST64_TYPE) - int_fast64_type_node = - TREE_TYPE (identifier_global_value (c_get_ident (INT_FAST64_TYPE))); - if (UINT_FAST8_TYPE) - uint_fast8_type_node = - TREE_TYPE (identifier_global_value (c_get_ident (UINT_FAST8_TYPE))); - if (UINT_FAST16_TYPE) - uint_fast16_type_node = - TREE_TYPE (identifier_global_value (c_get_ident (UINT_FAST16_TYPE))); - if (UINT_FAST32_TYPE) - uint_fast32_type_node = - TREE_TYPE (identifier_global_value (c_get_ident (UINT_FAST32_TYPE))); - if (UINT_FAST64_TYPE) - uint_fast64_type_node = - TREE_TYPE (identifier_global_value (c_get_ident (UINT_FAST64_TYPE))); - if (INTPTR_TYPE) - intptr_type_node = - TREE_TYPE (identifier_global_value (c_get_ident (INTPTR_TYPE))); - if (UINTPTR_TYPE) - uintptr_type_node = - TREE_TYPE (identifier_global_value (c_get_ident (UINTPTR_TYPE))); - - default_function_type = build_function_type (integer_type_node, NULL_TREE); - ptrdiff_type_node - = TREE_TYPE (identifier_global_value (get_identifier (PTRDIFF_TYPE))); - unsigned_ptrdiff_type_node = c_common_unsigned_type (ptrdiff_type_node); - - lang_hooks.decls.pushdecl - (build_decl (UNKNOWN_LOCATION, - TYPE_DECL, get_identifier ("__builtin_va_list"), - va_list_type_node)); - if (targetm.enum_va_list) - { - int l; - const char *pname; - tree ptype; - - for (l = 0; targetm.enum_va_list (l, &pname, &ptype); ++l) - { - lang_hooks.decls.pushdecl - (build_decl (UNKNOWN_LOCATION, - TYPE_DECL, get_identifier (pname), - ptype)); - - } - } - - if (TREE_CODE (va_list_type_node) == ARRAY_TYPE) - { - va_list_arg_type_node = va_list_ref_type_node = - build_pointer_type (TREE_TYPE (va_list_type_node)); - } - else - { - va_list_arg_type_node = va_list_type_node; - va_list_ref_type_node = build_reference_type (va_list_type_node); - } - - if (!flag_preprocess_only) - c_define_builtins (va_list_ref_type_node, va_list_arg_type_node); - - main_identifier_node = get_identifier ("main"); - - /* Create the built-in __null node. It is important that this is - not shared. */ - null_node = make_node (INTEGER_CST); - TREE_TYPE (null_node) = c_common_type_for_size (POINTER_SIZE, 0); - - /* Since builtin_types isn't gc'ed, don't export these nodes. */ - memset (builtin_types, 0, sizeof (builtin_types)); -} - -/* The number of named compound-literals generated thus far. */ -static GTY(()) int compound_literal_number; - -/* Set DECL_NAME for DECL, a VAR_DECL for a compound-literal. */ - -void -set_compound_literal_name (tree decl) -{ - char *name; - ASM_FORMAT_PRIVATE_NAME (name, "__compound_literal", - compound_literal_number); - compound_literal_number++; - DECL_NAME (decl) = get_identifier (name); -} - -tree -build_va_arg (location_t loc, tree expr, tree type) -{ - expr = build1 (VA_ARG_EXPR, type, expr); - SET_EXPR_LOCATION (expr, loc); - return expr; -} - - -/* Linked list of disabled built-in functions. */ - -typedef struct disabled_builtin -{ - const char *name; - struct disabled_builtin *next; -} disabled_builtin; -static disabled_builtin *disabled_builtins = NULL; - -static bool builtin_function_disabled_p (const char *); - -/* Disable a built-in function specified by -fno-builtin-NAME. If NAME - begins with "__builtin_", give an error. */ - -void -disable_builtin_function (const char *name) -{ - if (strncmp (name, "__builtin_", strlen ("__builtin_")) == 0) - error ("cannot disable built-in function %qs", name); - else - { - disabled_builtin *new_disabled_builtin = XNEW (disabled_builtin); - new_disabled_builtin->name = name; - new_disabled_builtin->next = disabled_builtins; - disabled_builtins = new_disabled_builtin; - } -} - - -/* Return true if the built-in function NAME has been disabled, false - otherwise. */ - -static bool -builtin_function_disabled_p (const char *name) -{ - disabled_builtin *p; - for (p = disabled_builtins; p != NULL; p = p->next) - { - if (strcmp (name, p->name) == 0) - return true; - } - return false; -} - - -/* Worker for DEF_BUILTIN. - Possibly define a builtin function with one or two names. - Does not declare a non-__builtin_ function if flag_no_builtin, or if - nonansi_p and flag_no_nonansi_builtin. */ - -static void -def_builtin_1 (enum built_in_function fncode, - const char *name, - enum built_in_class fnclass, - tree fntype, tree libtype, - bool both_p, bool fallback_p, bool nonansi_p, - tree fnattrs, bool implicit_p) -{ - tree decl; - const char *libname; - - if (fntype == error_mark_node) - return; - - gcc_assert ((!both_p && !fallback_p) - || !strncmp (name, "__builtin_", - strlen ("__builtin_"))); - - libname = name + strlen ("__builtin_"); - decl = add_builtin_function (name, fntype, fncode, fnclass, - (fallback_p ? libname : NULL), - fnattrs); - if (both_p - && !flag_no_builtin && !builtin_function_disabled_p (libname) - && !(nonansi_p && flag_no_nonansi_builtin)) - add_builtin_function (libname, libtype, fncode, fnclass, - NULL, fnattrs); - - built_in_decls[(int) fncode] = decl; - if (implicit_p) - implicit_built_in_decls[(int) fncode] = decl; -} - -/* Nonzero if the type T promotes to int. This is (nearly) the - integral promotions defined in ISO C99 6.3.1.1/2. */ - -bool -c_promoting_integer_type_p (const_tree t) -{ - switch (TREE_CODE (t)) - { - case INTEGER_TYPE: - return (TYPE_MAIN_VARIANT (t) == char_type_node - || TYPE_MAIN_VARIANT (t) == signed_char_type_node - || TYPE_MAIN_VARIANT (t) == unsigned_char_type_node - || TYPE_MAIN_VARIANT (t) == short_integer_type_node - || TYPE_MAIN_VARIANT (t) == short_unsigned_type_node - || TYPE_PRECISION (t) < TYPE_PRECISION (integer_type_node)); - - case ENUMERAL_TYPE: - /* ??? Technically all enumerations not larger than an int - promote to an int. But this is used along code paths - that only want to notice a size change. */ - return TYPE_PRECISION (t) < TYPE_PRECISION (integer_type_node); - - case BOOLEAN_TYPE: - return 1; - - default: - return 0; - } -} - -/* Return 1 if PARMS specifies a fixed number of parameters - and none of their types is affected by default promotions. */ - -int -self_promoting_args_p (const_tree parms) -{ - const_tree t; - for (t = parms; t; t = TREE_CHAIN (t)) - { - tree type = TREE_VALUE (t); - - if (type == error_mark_node) - continue; - - if (TREE_CHAIN (t) == 0 && type != void_type_node) - return 0; - - if (type == 0) - return 0; - - if (TYPE_MAIN_VARIANT (type) == float_type_node) - return 0; - - if (c_promoting_integer_type_p (type)) - return 0; - } - return 1; -} - -/* Recursively remove any '*' or '&' operator from TYPE. */ -tree -strip_pointer_operator (tree t) -{ - while (POINTER_TYPE_P (t)) - t = TREE_TYPE (t); - return t; -} - -/* Recursively remove pointer or array type from TYPE. */ -tree -strip_pointer_or_array_types (tree t) -{ - while (TREE_CODE (t) == ARRAY_TYPE || POINTER_TYPE_P (t)) - t = TREE_TYPE (t); - return t; -} - -/* Used to compare case labels. K1 and K2 are actually tree nodes - representing case labels, or NULL_TREE for a `default' label. - Returns -1 if K1 is ordered before K2, -1 if K1 is ordered after - K2, and 0 if K1 and K2 are equal. */ - -int -case_compare (splay_tree_key k1, splay_tree_key k2) -{ - /* Consider a NULL key (such as arises with a `default' label) to be - smaller than anything else. */ - if (!k1) - return k2 ? -1 : 0; - else if (!k2) - return k1 ? 1 : 0; - - return tree_int_cst_compare ((tree) k1, (tree) k2); -} - -/* Process a case label, located at LOC, for the range LOW_VALUE - ... HIGH_VALUE. If LOW_VALUE and HIGH_VALUE are both NULL_TREE - then this case label is actually a `default' label. If only - HIGH_VALUE is NULL_TREE, then case label was declared using the - usual C/C++ syntax, rather than the GNU case range extension. - CASES is a tree containing all the case ranges processed so far; - COND is the condition for the switch-statement itself. Returns the - CASE_LABEL_EXPR created, or ERROR_MARK_NODE if no CASE_LABEL_EXPR - is created. */ - -tree -c_add_case_label (location_t loc, splay_tree cases, tree cond, tree orig_type, - tree low_value, tree high_value) -{ - tree type; - tree label; - tree case_label; - splay_tree_node node; - - /* Create the LABEL_DECL itself. */ - label = create_artificial_label (loc); - - /* If there was an error processing the switch condition, bail now - before we get more confused. */ - if (!cond || cond == error_mark_node) - goto error_out; - - if ((low_value && TREE_TYPE (low_value) - && POINTER_TYPE_P (TREE_TYPE (low_value))) - || (high_value && TREE_TYPE (high_value) - && POINTER_TYPE_P (TREE_TYPE (high_value)))) - { - error_at (loc, "pointers are not permitted as case values"); - goto error_out; - } - - /* Case ranges are a GNU extension. */ - if (high_value) - pedwarn (loc, OPT_pedantic, - "range expressions in switch statements are non-standard"); - - type = TREE_TYPE (cond); - if (low_value) - { - low_value = check_case_value (low_value); - low_value = convert_and_check (type, low_value); - if (low_value == error_mark_node) - goto error_out; - } - if (high_value) - { - high_value = check_case_value (high_value); - high_value = convert_and_check (type, high_value); - if (high_value == error_mark_node) - goto error_out; - } - - if (low_value && high_value) - { - /* If the LOW_VALUE and HIGH_VALUE are the same, then this isn't - really a case range, even though it was written that way. - Remove the HIGH_VALUE to simplify later processing. */ - if (tree_int_cst_equal (low_value, high_value)) - high_value = NULL_TREE; - else if (!tree_int_cst_lt (low_value, high_value)) - warning_at (loc, 0, "empty range specified"); - } - - /* See if the case is in range of the type of the original testing - expression. If both low_value and high_value are out of range, - don't insert the case label and return NULL_TREE. */ - if (low_value - && !check_case_bounds (type, orig_type, - &low_value, high_value ? &high_value : NULL)) - return NULL_TREE; - - /* Look up the LOW_VALUE in the table of case labels we already - have. */ - node = splay_tree_lookup (cases, (splay_tree_key) low_value); - /* If there was not an exact match, check for overlapping ranges. - There's no need to do this if there's no LOW_VALUE or HIGH_VALUE; - that's a `default' label and the only overlap is an exact match. */ - if (!node && (low_value || high_value)) - { - splay_tree_node low_bound; - splay_tree_node high_bound; - - /* Even though there wasn't an exact match, there might be an - overlap between this case range and another case range. - Since we've (inductively) not allowed any overlapping case - ranges, we simply need to find the greatest low case label - that is smaller that LOW_VALUE, and the smallest low case - label that is greater than LOW_VALUE. If there is an overlap - it will occur in one of these two ranges. */ - low_bound = splay_tree_predecessor (cases, - (splay_tree_key) low_value); - high_bound = splay_tree_successor (cases, - (splay_tree_key) low_value); - - /* Check to see if the LOW_BOUND overlaps. It is smaller than - the LOW_VALUE, so there is no need to check unless the - LOW_BOUND is in fact itself a case range. */ - if (low_bound - && CASE_HIGH ((tree) low_bound->value) - && tree_int_cst_compare (CASE_HIGH ((tree) low_bound->value), - low_value) >= 0) - node = low_bound; - /* Check to see if the HIGH_BOUND overlaps. The low end of that - range is bigger than the low end of the current range, so we - are only interested if the current range is a real range, and - not an ordinary case label. */ - else if (high_bound - && high_value - && (tree_int_cst_compare ((tree) high_bound->key, - high_value) - <= 0)) - node = high_bound; - } - /* If there was an overlap, issue an error. */ - if (node) - { - tree duplicate = CASE_LABEL ((tree) node->value); - - if (high_value) - { - error_at (loc, "duplicate (or overlapping) case value"); - error_at (DECL_SOURCE_LOCATION (duplicate), - "this is the first entry overlapping that value"); - } - else if (low_value) - { - error_at (loc, "duplicate case value") ; - error_at (DECL_SOURCE_LOCATION (duplicate), "previously used here"); - } - else - { - error_at (loc, "multiple default labels in one switch"); - error_at (DECL_SOURCE_LOCATION (duplicate), - "this is the first default label"); - } - goto error_out; - } - - /* Add a CASE_LABEL to the statement-tree. */ - case_label = add_stmt (build_case_label (loc, low_value, high_value, label)); - /* Register this case label in the splay tree. */ - splay_tree_insert (cases, - (splay_tree_key) low_value, - (splay_tree_value) case_label); - - return case_label; - - error_out: - /* Add a label so that the back-end doesn't think that the beginning of - the switch is unreachable. Note that we do not add a case label, as - that just leads to duplicates and thence to failure later on. */ - if (!cases->root) - { - tree t = create_artificial_label (loc); - add_stmt (build_stmt (loc, LABEL_EXPR, t)); - } - return error_mark_node; -} - -/* Subroutines of c_do_switch_warnings, called via splay_tree_foreach. - Used to verify that case values match up with enumerator values. */ - -static void -match_case_to_enum_1 (tree key, tree type, tree label) -{ - char buf[2 + 2*HOST_BITS_PER_WIDE_INT/4 + 1]; - - /* ??? Not working too hard to print the double-word value. - Should perhaps be done with %lwd in the diagnostic routines? */ - if (TREE_INT_CST_HIGH (key) == 0) - snprintf (buf, sizeof (buf), HOST_WIDE_INT_PRINT_UNSIGNED, - TREE_INT_CST_LOW (key)); - else if (!TYPE_UNSIGNED (type) - && TREE_INT_CST_HIGH (key) == -1 - && TREE_INT_CST_LOW (key) != 0) - snprintf (buf, sizeof (buf), "-" HOST_WIDE_INT_PRINT_UNSIGNED, - -TREE_INT_CST_LOW (key)); - else - snprintf (buf, sizeof (buf), HOST_WIDE_INT_PRINT_DOUBLE_HEX, - (unsigned HOST_WIDE_INT) TREE_INT_CST_HIGH (key), - (unsigned HOST_WIDE_INT) TREE_INT_CST_LOW (key)); - - if (TYPE_NAME (type) == 0) - warning_at (DECL_SOURCE_LOCATION (CASE_LABEL (label)), - warn_switch ? OPT_Wswitch : OPT_Wswitch_enum, - "case value %qs not in enumerated type", - buf); - else - warning_at (DECL_SOURCE_LOCATION (CASE_LABEL (label)), - warn_switch ? OPT_Wswitch : OPT_Wswitch_enum, - "case value %qs not in enumerated type %qT", - buf, type); -} - -/* Subroutine of c_do_switch_warnings, called via splay_tree_foreach. - Used to verify that case values match up with enumerator values. */ - -static int -match_case_to_enum (splay_tree_node node, void *data) -{ - tree label = (tree) node->value; - tree type = (tree) data; - - /* Skip default case. */ - if (!CASE_LOW (label)) - return 0; - - /* If CASE_LOW_SEEN is not set, that means CASE_LOW did not appear - when we did our enum->case scan. Reset our scratch bit after. */ - if (!CASE_LOW_SEEN (label)) - match_case_to_enum_1 (CASE_LOW (label), type, label); - else - CASE_LOW_SEEN (label) = 0; - - /* If CASE_HIGH is non-null, we have a range. If CASE_HIGH_SEEN is - not set, that means that CASE_HIGH did not appear when we did our - enum->case scan. Reset our scratch bit after. */ - if (CASE_HIGH (label)) - { - if (!CASE_HIGH_SEEN (label)) - match_case_to_enum_1 (CASE_HIGH (label), type, label); - else - CASE_HIGH_SEEN (label) = 0; - } - - return 0; -} - -/* Handle -Wswitch*. Called from the front end after parsing the - switch construct. */ -/* ??? Should probably be somewhere generic, since other languages - besides C and C++ would want this. At the moment, however, C/C++ - are the only tree-ssa languages that support enumerations at all, - so the point is moot. */ - -void -c_do_switch_warnings (splay_tree cases, location_t switch_location, - tree type, tree cond) -{ - splay_tree_node default_node; - splay_tree_node node; - tree chain; - - if (!warn_switch && !warn_switch_enum && !warn_switch_default) - return; - - default_node = splay_tree_lookup (cases, (splay_tree_key) NULL); - if (!default_node) - warning_at (switch_location, OPT_Wswitch_default, - "switch missing default case"); - - /* From here on, we only care about about enumerated types. */ - if (!type || TREE_CODE (type) != ENUMERAL_TYPE) - return; - - /* From here on, we only care about -Wswitch and -Wswitch-enum. */ - if (!warn_switch_enum && !warn_switch) - return; - - /* Check the cases. Warn about case values which are not members of - the enumerated type. For -Wswitch-enum, or for -Wswitch when - there is no default case, check that exactly all enumeration - literals are covered by the cases. */ - - /* Clearing COND if it is not an integer constant simplifies - the tests inside the loop below. */ - if (TREE_CODE (cond) != INTEGER_CST) - cond = NULL_TREE; - - /* The time complexity here is O(N*lg(N)) worst case, but for the - common case of monotonically increasing enumerators, it is - O(N), since the nature of the splay tree will keep the next - element adjacent to the root at all times. */ - - for (chain = TYPE_VALUES (type); chain; chain = TREE_CHAIN (chain)) - { - tree value = TREE_VALUE (chain); - if (TREE_CODE (value) == CONST_DECL) - value = DECL_INITIAL (value); - node = splay_tree_lookup (cases, (splay_tree_key) value); - if (node) - { - /* Mark the CASE_LOW part of the case entry as seen. */ - tree label = (tree) node->value; - CASE_LOW_SEEN (label) = 1; - continue; - } - - /* Even though there wasn't an exact match, there might be a - case range which includes the enumerator's value. */ - node = splay_tree_predecessor (cases, (splay_tree_key) value); - if (node && CASE_HIGH ((tree) node->value)) - { - tree label = (tree) node->value; - int cmp = tree_int_cst_compare (CASE_HIGH (label), value); - if (cmp >= 0) - { - /* If we match the upper bound exactly, mark the CASE_HIGH - part of the case entry as seen. */ - if (cmp == 0) - CASE_HIGH_SEEN (label) = 1; - continue; - } - } - - /* We've now determined that this enumerated literal isn't - handled by the case labels of the switch statement. */ - - /* If the switch expression is a constant, we only really care - about whether that constant is handled by the switch. */ - if (cond && tree_int_cst_compare (cond, value)) - continue; - - /* If there is a default_node, the only relevant option is - Wswitch-enum. Otherwise, if both are enabled then we prefer - to warn using -Wswitch because -Wswitch is enabled by -Wall - while -Wswitch-enum is explicit. */ - warning_at (switch_location, - (default_node || !warn_switch - ? OPT_Wswitch_enum - : OPT_Wswitch), - "enumeration value %qE not handled in switch", - TREE_PURPOSE (chain)); - } - - /* Warn if there are case expressions that don't correspond to - enumerators. This can occur since C and C++ don't enforce - type-checking of assignments to enumeration variables. - - The time complexity here is now always O(N) worst case, since - we should have marked both the lower bound and upper bound of - every disjoint case label, with CASE_LOW_SEEN and CASE_HIGH_SEEN - above. This scan also resets those fields. */ - - splay_tree_foreach (cases, match_case_to_enum, type); -} - -/* Finish an expression taking the address of LABEL (an - IDENTIFIER_NODE). Returns an expression for the address. - - LOC is the location for the expression returned. */ - -tree -finish_label_address_expr (tree label, location_t loc) -{ - tree result; - - pedwarn (input_location, OPT_pedantic, "taking the address of a label is non-standard"); - - if (label == error_mark_node) - return error_mark_node; - - label = lookup_label (label); - if (label == NULL_TREE) - result = null_pointer_node; - else - { - TREE_USED (label) = 1; - result = build1 (ADDR_EXPR, ptr_type_node, label); - /* The current function is not necessarily uninlinable. - Computed gotos are incompatible with inlining, but the value - here could be used only in a diagnostic, for example. */ - protected_set_expr_location (result, loc); - } - - return result; -} - - -/* Given a boolean expression ARG, return a tree representing an increment - or decrement (as indicated by CODE) of ARG. The front end must check for - invalid cases (e.g., decrement in C++). */ -tree -boolean_increment (enum tree_code code, tree arg) -{ - tree val; - tree true_res = build_int_cst (TREE_TYPE (arg), 1); - - arg = stabilize_reference (arg); - switch (code) - { - case PREINCREMENT_EXPR: - val = build2 (MODIFY_EXPR, TREE_TYPE (arg), arg, true_res); - break; - case POSTINCREMENT_EXPR: - val = build2 (MODIFY_EXPR, TREE_TYPE (arg), arg, true_res); - arg = save_expr (arg); - val = build2 (COMPOUND_EXPR, TREE_TYPE (arg), val, arg); - val = build2 (COMPOUND_EXPR, TREE_TYPE (arg), arg, val); - break; - case PREDECREMENT_EXPR: - val = build2 (MODIFY_EXPR, TREE_TYPE (arg), arg, - invert_truthvalue_loc (input_location, arg)); - break; - case POSTDECREMENT_EXPR: - val = build2 (MODIFY_EXPR, TREE_TYPE (arg), arg, - invert_truthvalue_loc (input_location, arg)); - arg = save_expr (arg); - val = build2 (COMPOUND_EXPR, TREE_TYPE (arg), val, arg); - val = build2 (COMPOUND_EXPR, TREE_TYPE (arg), arg, val); - break; - default: - gcc_unreachable (); - } - TREE_SIDE_EFFECTS (val) = 1; - return val; -} - -/* Built-in macros for stddef.h and stdint.h, that require macros - defined in this file. */ -void -c_stddef_cpp_builtins(void) -{ - builtin_define_with_value ("__SIZE_TYPE__", SIZE_TYPE, 0); - builtin_define_with_value ("__PTRDIFF_TYPE__", PTRDIFF_TYPE, 0); - builtin_define_with_value ("__WCHAR_TYPE__", MODIFIED_WCHAR_TYPE, 0); - builtin_define_with_value ("__WINT_TYPE__", WINT_TYPE, 0); - builtin_define_with_value ("__INTMAX_TYPE__", INTMAX_TYPE, 0); - builtin_define_with_value ("__UINTMAX_TYPE__", UINTMAX_TYPE, 0); - builtin_define_with_value ("__CHAR16_TYPE__", CHAR16_TYPE, 0); - builtin_define_with_value ("__CHAR32_TYPE__", CHAR32_TYPE, 0); - if (SIG_ATOMIC_TYPE) - builtin_define_with_value ("__SIG_ATOMIC_TYPE__", SIG_ATOMIC_TYPE, 0); - if (INT8_TYPE) - builtin_define_with_value ("__INT8_TYPE__", INT8_TYPE, 0); - if (INT16_TYPE) - builtin_define_with_value ("__INT16_TYPE__", INT16_TYPE, 0); - if (INT32_TYPE) - builtin_define_with_value ("__INT32_TYPE__", INT32_TYPE, 0); - if (INT64_TYPE) - builtin_define_with_value ("__INT64_TYPE__", INT64_TYPE, 0); - if (UINT8_TYPE) - builtin_define_with_value ("__UINT8_TYPE__", UINT8_TYPE, 0); - if (UINT16_TYPE) - builtin_define_with_value ("__UINT16_TYPE__", UINT16_TYPE, 0); - if (UINT32_TYPE) - builtin_define_with_value ("__UINT32_TYPE__", UINT32_TYPE, 0); - if (UINT64_TYPE) - builtin_define_with_value ("__UINT64_TYPE__", UINT64_TYPE, 0); - if (INT_LEAST8_TYPE) - builtin_define_with_value ("__INT_LEAST8_TYPE__", INT_LEAST8_TYPE, 0); - if (INT_LEAST16_TYPE) - builtin_define_with_value ("__INT_LEAST16_TYPE__", INT_LEAST16_TYPE, 0); - if (INT_LEAST32_TYPE) - builtin_define_with_value ("__INT_LEAST32_TYPE__", INT_LEAST32_TYPE, 0); - if (INT_LEAST64_TYPE) - builtin_define_with_value ("__INT_LEAST64_TYPE__", INT_LEAST64_TYPE, 0); - if (UINT_LEAST8_TYPE) - builtin_define_with_value ("__UINT_LEAST8_TYPE__", UINT_LEAST8_TYPE, 0); - if (UINT_LEAST16_TYPE) - builtin_define_with_value ("__UINT_LEAST16_TYPE__", UINT_LEAST16_TYPE, 0); - if (UINT_LEAST32_TYPE) - builtin_define_with_value ("__UINT_LEAST32_TYPE__", UINT_LEAST32_TYPE, 0); - if (UINT_LEAST64_TYPE) - builtin_define_with_value ("__UINT_LEAST64_TYPE__", UINT_LEAST64_TYPE, 0); - if (INT_FAST8_TYPE) - builtin_define_with_value ("__INT_FAST8_TYPE__", INT_FAST8_TYPE, 0); - if (INT_FAST16_TYPE) - builtin_define_with_value ("__INT_FAST16_TYPE__", INT_FAST16_TYPE, 0); - if (INT_FAST32_TYPE) - builtin_define_with_value ("__INT_FAST32_TYPE__", INT_FAST32_TYPE, 0); - if (INT_FAST64_TYPE) - builtin_define_with_value ("__INT_FAST64_TYPE__", INT_FAST64_TYPE, 0); - if (UINT_FAST8_TYPE) - builtin_define_with_value ("__UINT_FAST8_TYPE__", UINT_FAST8_TYPE, 0); - if (UINT_FAST16_TYPE) - builtin_define_with_value ("__UINT_FAST16_TYPE__", UINT_FAST16_TYPE, 0); - if (UINT_FAST32_TYPE) - builtin_define_with_value ("__UINT_FAST32_TYPE__", UINT_FAST32_TYPE, 0); - if (UINT_FAST64_TYPE) - builtin_define_with_value ("__UINT_FAST64_TYPE__", UINT_FAST64_TYPE, 0); - if (INTPTR_TYPE) - builtin_define_with_value ("__INTPTR_TYPE__", INTPTR_TYPE, 0); - if (UINTPTR_TYPE) - builtin_define_with_value ("__UINTPTR_TYPE__", UINTPTR_TYPE, 0); -} - -static void -c_init_attributes (void) -{ - /* Fill in the built_in_attributes array. */ -#define DEF_ATTR_NULL_TREE(ENUM) \ - built_in_attributes[(int) ENUM] = NULL_TREE; -#define DEF_ATTR_INT(ENUM, VALUE) \ - built_in_attributes[(int) ENUM] = build_int_cst (NULL_TREE, VALUE); -#define DEF_ATTR_IDENT(ENUM, STRING) \ - built_in_attributes[(int) ENUM] = get_identifier (STRING); -#define DEF_ATTR_TREE_LIST(ENUM, PURPOSE, VALUE, CHAIN) \ - built_in_attributes[(int) ENUM] \ - = tree_cons (built_in_attributes[(int) PURPOSE], \ - built_in_attributes[(int) VALUE], \ - built_in_attributes[(int) CHAIN]); -#include "builtin-attrs.def" -#undef DEF_ATTR_NULL_TREE -#undef DEF_ATTR_INT -#undef DEF_ATTR_IDENT -#undef DEF_ATTR_TREE_LIST -} - -/* Returns TRUE iff the attribute indicated by ATTR_ID takes a plain - identifier as an argument, so the front end shouldn't look it up. */ - -bool -attribute_takes_identifier_p (const_tree attr_id) -{ - if (is_attribute_p ("mode", attr_id) - || is_attribute_p ("format", attr_id) - || is_attribute_p ("cleanup", attr_id)) - return true; - else - return targetm.attribute_takes_identifier_p (attr_id); -} - -/* Attribute handlers common to C front ends. */ - -/* Handle a "packed" attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_packed_attribute (tree *node, tree name, tree ARG_UNUSED (args), - int flags, bool *no_add_attrs) -{ - if (TYPE_P (*node)) - { - if (!(flags & (int) ATTR_FLAG_TYPE_IN_PLACE)) - *node = build_variant_type_copy (*node); - TYPE_PACKED (*node) = 1; - } - else if (TREE_CODE (*node) == FIELD_DECL) - { - if (TYPE_ALIGN (TREE_TYPE (*node)) <= BITS_PER_UNIT - /* Still pack bitfields. */ - && ! DECL_INITIAL (*node)) - warning (OPT_Wattributes, - "%qE attribute ignored for field of type %qT", - name, TREE_TYPE (*node)); - else - DECL_PACKED (*node) = 1; - } - /* We can't set DECL_PACKED for a VAR_DECL, because the bit is - used for DECL_REGISTER. It wouldn't mean anything anyway. - We can't set DECL_PACKED on the type of a TYPE_DECL, because - that changes what the typedef is typing. */ - else - { - warning (OPT_Wattributes, "%qE attribute ignored", name); - *no_add_attrs = true; - } - - return NULL_TREE; -} - -/* Handle a "nocommon" attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_nocommon_attribute (tree *node, tree name, - tree ARG_UNUSED (args), - int ARG_UNUSED (flags), bool *no_add_attrs) -{ - if (TREE_CODE (*node) == VAR_DECL) - DECL_COMMON (*node) = 0; - else - { - warning (OPT_Wattributes, "%qE attribute ignored", name); - *no_add_attrs = true; - } - - return NULL_TREE; -} - -/* Handle a "common" attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_common_attribute (tree *node, tree name, tree ARG_UNUSED (args), - int ARG_UNUSED (flags), bool *no_add_attrs) -{ - if (TREE_CODE (*node) == VAR_DECL) - DECL_COMMON (*node) = 1; - else - { - warning (OPT_Wattributes, "%qE attribute ignored", name); - *no_add_attrs = true; - } - - return NULL_TREE; -} - -/* Handle a "noreturn" attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_noreturn_attribute (tree *node, tree name, tree ARG_UNUSED (args), - int ARG_UNUSED (flags), bool *no_add_attrs) -{ - tree type = TREE_TYPE (*node); - - /* See FIXME comment in c_common_attribute_table. */ - if (TREE_CODE (*node) == FUNCTION_DECL) - TREE_THIS_VOLATILE (*node) = 1; - else if (TREE_CODE (type) == POINTER_TYPE - && TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE) - TREE_TYPE (*node) - = build_pointer_type - (build_type_variant (TREE_TYPE (type), - TYPE_READONLY (TREE_TYPE (type)), 1)); - else - { - warning (OPT_Wattributes, "%qE attribute ignored", name); - *no_add_attrs = true; - } - - return NULL_TREE; -} - -/* Handle a "hot" and attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_hot_attribute (tree *node, tree name, tree ARG_UNUSED (args), - int ARG_UNUSED (flags), bool *no_add_attrs) -{ - if (TREE_CODE (*node) == FUNCTION_DECL) - { - if (lookup_attribute ("cold", DECL_ATTRIBUTES (*node)) != NULL) - { - warning (OPT_Wattributes, "%qE attribute conflicts with attribute %s", - name, "cold"); - *no_add_attrs = true; - } - /* Most of the rest of the hot processing is done later with - lookup_attribute. */ - } - else - { - warning (OPT_Wattributes, "%qE attribute ignored", name); - *no_add_attrs = true; - } - - return NULL_TREE; -} -/* Handle a "cold" and attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_cold_attribute (tree *node, tree name, tree ARG_UNUSED (args), - int ARG_UNUSED (flags), bool *no_add_attrs) -{ - if (TREE_CODE (*node) == FUNCTION_DECL) - { - if (lookup_attribute ("hot", DECL_ATTRIBUTES (*node)) != NULL) - { - warning (OPT_Wattributes, "%qE attribute conflicts with attribute %s", - name, "hot"); - *no_add_attrs = true; - } - /* Most of the rest of the cold processing is done later with - lookup_attribute. */ - } - else - { - warning (OPT_Wattributes, "%qE attribute ignored", name); - *no_add_attrs = true; - } - - return NULL_TREE; -} - -/* Handle a "noinline" attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_noinline_attribute (tree *node, tree name, - tree ARG_UNUSED (args), - int ARG_UNUSED (flags), bool *no_add_attrs) -{ - if (TREE_CODE (*node) == FUNCTION_DECL) - DECL_UNINLINABLE (*node) = 1; - else - { - warning (OPT_Wattributes, "%qE attribute ignored", name); - *no_add_attrs = true; - } - - return NULL_TREE; -} - -/* Handle a "noclone" attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_noclone_attribute (tree *node, tree name, - tree ARG_UNUSED (args), - int ARG_UNUSED (flags), bool *no_add_attrs) -{ - if (TREE_CODE (*node) != FUNCTION_DECL) - { - warning (OPT_Wattributes, "%qE attribute ignored", name); - *no_add_attrs = true; - } - - return NULL_TREE; -} - -/* Handle a "always_inline" attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_always_inline_attribute (tree *node, tree name, - tree ARG_UNUSED (args), - int ARG_UNUSED (flags), - bool *no_add_attrs) -{ - if (TREE_CODE (*node) == FUNCTION_DECL) - { - /* Set the attribute and mark it for disregarding inline - limits. */ - DECL_DISREGARD_INLINE_LIMITS (*node) = 1; - } - else - { - warning (OPT_Wattributes, "%qE attribute ignored", name); - *no_add_attrs = true; - } - - return NULL_TREE; -} - -/* Handle a "gnu_inline" attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_gnu_inline_attribute (tree *node, tree name, - tree ARG_UNUSED (args), - int ARG_UNUSED (flags), - bool *no_add_attrs) -{ - if (TREE_CODE (*node) == FUNCTION_DECL && DECL_DECLARED_INLINE_P (*node)) - { - /* Do nothing else, just set the attribute. We'll get at - it later with lookup_attribute. */ - } - else - { - warning (OPT_Wattributes, "%qE attribute ignored", name); - *no_add_attrs = true; - } - - return NULL_TREE; -} - -/* Handle an "artificial" attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_artificial_attribute (tree *node, tree name, - tree ARG_UNUSED (args), - int ARG_UNUSED (flags), - bool *no_add_attrs) -{ - if (TREE_CODE (*node) == FUNCTION_DECL && DECL_DECLARED_INLINE_P (*node)) - { - /* Do nothing else, just set the attribute. We'll get at - it later with lookup_attribute. */ - } - else - { - warning (OPT_Wattributes, "%qE attribute ignored", name); - *no_add_attrs = true; - } - - return NULL_TREE; -} - -/* Handle a "flatten" attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_flatten_attribute (tree *node, tree name, - tree args ATTRIBUTE_UNUSED, - int flags ATTRIBUTE_UNUSED, bool *no_add_attrs) -{ - if (TREE_CODE (*node) == FUNCTION_DECL) - /* Do nothing else, just set the attribute. We'll get at - it later with lookup_attribute. */ - ; - else - { - warning (OPT_Wattributes, "%qE attribute ignored", name); - *no_add_attrs = true; - } - - return NULL_TREE; -} - -/* Handle a "warning" or "error" attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_error_attribute (tree *node, tree name, tree args, - int ARG_UNUSED (flags), bool *no_add_attrs) -{ - if (TREE_CODE (*node) == FUNCTION_DECL - || TREE_CODE (TREE_VALUE (args)) == STRING_CST) - /* Do nothing else, just set the attribute. We'll get at - it later with lookup_attribute. */ - ; - else - { - warning (OPT_Wattributes, "%qE attribute ignored", name); - *no_add_attrs = true; - } - - return NULL_TREE; -} - -/* Handle a "used" attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_used_attribute (tree *pnode, tree name, tree ARG_UNUSED (args), - int ARG_UNUSED (flags), bool *no_add_attrs) -{ - tree node = *pnode; - - if (TREE_CODE (node) == FUNCTION_DECL - || (TREE_CODE (node) == VAR_DECL && TREE_STATIC (node))) - { - TREE_USED (node) = 1; - DECL_PRESERVE_P (node) = 1; - if (TREE_CODE (node) == VAR_DECL) - DECL_READ_P (node) = 1; - } - else - { - warning (OPT_Wattributes, "%qE attribute ignored", name); - *no_add_attrs = true; - } - - return NULL_TREE; -} - -/* Handle a "unused" attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_unused_attribute (tree *node, tree name, tree ARG_UNUSED (args), - int flags, bool *no_add_attrs) -{ - if (DECL_P (*node)) - { - tree decl = *node; - - if (TREE_CODE (decl) == PARM_DECL - || TREE_CODE (decl) == VAR_DECL - || TREE_CODE (decl) == FUNCTION_DECL - || TREE_CODE (decl) == LABEL_DECL - || TREE_CODE (decl) == TYPE_DECL) - { - TREE_USED (decl) = 1; - if (TREE_CODE (decl) == VAR_DECL - || TREE_CODE (decl) == PARM_DECL) - DECL_READ_P (decl) = 1; - } - else - { - warning (OPT_Wattributes, "%qE attribute ignored", name); - *no_add_attrs = true; - } - } - else - { - if (!(flags & (int) ATTR_FLAG_TYPE_IN_PLACE)) - *node = build_variant_type_copy (*node); - TREE_USED (*node) = 1; - } - - return NULL_TREE; -} - -/* Handle a "externally_visible" attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_externally_visible_attribute (tree *pnode, tree name, - tree ARG_UNUSED (args), - int ARG_UNUSED (flags), - bool *no_add_attrs) -{ - tree node = *pnode; - - if (TREE_CODE (node) == FUNCTION_DECL || TREE_CODE (node) == VAR_DECL) - { - if ((!TREE_STATIC (node) && TREE_CODE (node) != FUNCTION_DECL - && !DECL_EXTERNAL (node)) || !TREE_PUBLIC (node)) - { - warning (OPT_Wattributes, - "%qE attribute have effect only on public objects", name); - *no_add_attrs = true; - } - } - else - { - warning (OPT_Wattributes, "%qE attribute ignored", name); - *no_add_attrs = true; - } - - return NULL_TREE; -} - -/* Handle a "const" attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_const_attribute (tree *node, tree name, tree ARG_UNUSED (args), - int ARG_UNUSED (flags), bool *no_add_attrs) -{ - tree type = TREE_TYPE (*node); - - /* See FIXME comment on noreturn in c_common_attribute_table. */ - if (TREE_CODE (*node) == FUNCTION_DECL) - TREE_READONLY (*node) = 1; - else if (TREE_CODE (type) == POINTER_TYPE - && TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE) - TREE_TYPE (*node) - = build_pointer_type - (build_type_variant (TREE_TYPE (type), 1, - TREE_THIS_VOLATILE (TREE_TYPE (type)))); - else - { - warning (OPT_Wattributes, "%qE attribute ignored", name); - *no_add_attrs = true; - } - - return NULL_TREE; -} - -/* Handle a "transparent_union" attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_transparent_union_attribute (tree *node, tree name, - tree ARG_UNUSED (args), int flags, - bool *no_add_attrs) -{ - tree type; - - *no_add_attrs = true; - - if (TREE_CODE (*node) == TYPE_DECL) - node = &TREE_TYPE (*node); - type = *node; - - if (TREE_CODE (type) == UNION_TYPE) - { - /* When IN_PLACE is set, leave the check for FIELDS and MODE to - the code in finish_struct. */ - if (!(flags & (int) ATTR_FLAG_TYPE_IN_PLACE)) - { - if (TYPE_FIELDS (type) == NULL_TREE - || TYPE_MODE (type) != DECL_MODE (TYPE_FIELDS (type))) - goto ignored; - - /* A type variant isn't good enough, since we don't a cast - to such a type removed as a no-op. */ - *node = type = build_duplicate_type (type); - } - - TYPE_TRANSPARENT_AGGR (type) = 1; - return NULL_TREE; - } - - ignored: - warning (OPT_Wattributes, "%qE attribute ignored", name); - return NULL_TREE; -} - -/* Subroutine of handle_{con,de}structor_attribute. Evaluate ARGS to - get the requested priority for a constructor or destructor, - possibly issuing diagnostics for invalid or reserved - priorities. */ - -static priority_type -get_priority (tree args, bool is_destructor) -{ - HOST_WIDE_INT pri; - tree arg; - - if (!args) - return DEFAULT_INIT_PRIORITY; - - if (!SUPPORTS_INIT_PRIORITY) - { - if (is_destructor) - error ("destructor priorities are not supported"); - else - error ("constructor priorities are not supported"); - return DEFAULT_INIT_PRIORITY; - } - - arg = TREE_VALUE (args); - if (!host_integerp (arg, /*pos=*/0) - || !INTEGRAL_TYPE_P (TREE_TYPE (arg))) - goto invalid; - - pri = tree_low_cst (TREE_VALUE (args), /*pos=*/0); - if (pri < 0 || pri > MAX_INIT_PRIORITY) - goto invalid; - - if (pri <= MAX_RESERVED_INIT_PRIORITY) - { - if (is_destructor) - warning (0, - "destructor priorities from 0 to %d are reserved " - "for the implementation", - MAX_RESERVED_INIT_PRIORITY); - else - warning (0, - "constructor priorities from 0 to %d are reserved " - "for the implementation", - MAX_RESERVED_INIT_PRIORITY); - } - return pri; - - invalid: - if (is_destructor) - error ("destructor priorities must be integers from 0 to %d inclusive", - MAX_INIT_PRIORITY); - else - error ("constructor priorities must be integers from 0 to %d inclusive", - MAX_INIT_PRIORITY); - return DEFAULT_INIT_PRIORITY; -} - -/* Handle a "constructor" attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_constructor_attribute (tree *node, tree name, tree args, - int ARG_UNUSED (flags), - bool *no_add_attrs) -{ - tree decl = *node; - tree type = TREE_TYPE (decl); - - if (TREE_CODE (decl) == FUNCTION_DECL - && TREE_CODE (type) == FUNCTION_TYPE - && decl_function_context (decl) == 0) - { - priority_type priority; - DECL_STATIC_CONSTRUCTOR (decl) = 1; - priority = get_priority (args, /*is_destructor=*/false); - SET_DECL_INIT_PRIORITY (decl, priority); - TREE_USED (decl) = 1; - } - else - { - warning (OPT_Wattributes, "%qE attribute ignored", name); - *no_add_attrs = true; - } - - return NULL_TREE; -} - -/* Handle a "destructor" attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_destructor_attribute (tree *node, tree name, tree args, - int ARG_UNUSED (flags), - bool *no_add_attrs) -{ - tree decl = *node; - tree type = TREE_TYPE (decl); - - if (TREE_CODE (decl) == FUNCTION_DECL - && TREE_CODE (type) == FUNCTION_TYPE - && decl_function_context (decl) == 0) - { - priority_type priority; - DECL_STATIC_DESTRUCTOR (decl) = 1; - priority = get_priority (args, /*is_destructor=*/true); - SET_DECL_FINI_PRIORITY (decl, priority); - TREE_USED (decl) = 1; - } - else - { - warning (OPT_Wattributes, "%qE attribute ignored", name); - *no_add_attrs = true; - } - - return NULL_TREE; -} - -/* Handle a "mode" attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_mode_attribute (tree *node, tree name, tree args, - int ARG_UNUSED (flags), bool *no_add_attrs) -{ - tree type = *node; - tree ident = TREE_VALUE (args); - - *no_add_attrs = true; - - if (TREE_CODE (ident) != IDENTIFIER_NODE) - warning (OPT_Wattributes, "%qE attribute ignored", name); - else - { - int j; - const char *p = IDENTIFIER_POINTER (ident); - int len = strlen (p); - enum machine_mode mode = VOIDmode; - tree typefm; - bool valid_mode; - - if (len > 4 && p[0] == '_' && p[1] == '_' - && p[len - 1] == '_' && p[len - 2] == '_') - { - char *newp = (char *) alloca (len - 1); - - strcpy (newp, &p[2]); - newp[len - 4] = '\0'; - p = newp; - } - - /* Change this type to have a type with the specified mode. - First check for the special modes. */ - if (!strcmp (p, "byte")) - mode = byte_mode; - else if (!strcmp (p, "word")) - mode = word_mode; - else if (!strcmp (p, "pointer")) - mode = ptr_mode; - else if (!strcmp (p, "libgcc_cmp_return")) - mode = targetm.libgcc_cmp_return_mode (); - else if (!strcmp (p, "libgcc_shift_count")) - mode = targetm.libgcc_shift_count_mode (); - else if (!strcmp (p, "unwind_word")) - mode = targetm.unwind_word_mode (); - else - for (j = 0; j < NUM_MACHINE_MODES; j++) - if (!strcmp (p, GET_MODE_NAME (j))) - { - mode = (enum machine_mode) j; - break; - } - - if (mode == VOIDmode) - { - error ("unknown machine mode %qE", ident); - return NULL_TREE; - } - - valid_mode = false; - switch (GET_MODE_CLASS (mode)) - { - case MODE_INT: - case MODE_PARTIAL_INT: - case MODE_FLOAT: - case MODE_DECIMAL_FLOAT: - case MODE_FRACT: - case MODE_UFRACT: - case MODE_ACCUM: - case MODE_UACCUM: - valid_mode = targetm.scalar_mode_supported_p (mode); - break; - - case MODE_COMPLEX_INT: - case MODE_COMPLEX_FLOAT: - valid_mode = targetm.scalar_mode_supported_p (GET_MODE_INNER (mode)); - break; - - case MODE_VECTOR_INT: - case MODE_VECTOR_FLOAT: - case MODE_VECTOR_FRACT: - case MODE_VECTOR_UFRACT: - case MODE_VECTOR_ACCUM: - case MODE_VECTOR_UACCUM: - warning (OPT_Wattributes, "specifying vector types with " - "__attribute__ ((mode)) is deprecated"); - warning (OPT_Wattributes, - "use __attribute__ ((vector_size)) instead"); - valid_mode = vector_mode_valid_p (mode); - break; - - default: - break; - } - if (!valid_mode) - { - error ("unable to emulate %qs", p); - return NULL_TREE; - } - - if (POINTER_TYPE_P (type)) - { - addr_space_t as = TYPE_ADDR_SPACE (TREE_TYPE (type)); - tree (*fn)(tree, enum machine_mode, bool); - - if (!targetm.addr_space.valid_pointer_mode (mode, as)) - { - error ("invalid pointer mode %qs", p); - return NULL_TREE; - } - - if (TREE_CODE (type) == POINTER_TYPE) - fn = build_pointer_type_for_mode; - else - fn = build_reference_type_for_mode; - typefm = fn (TREE_TYPE (type), mode, false); - } - else - { - /* For fixed-point modes, we need to test if the signness of type - and the machine mode are consistent. */ - if (ALL_FIXED_POINT_MODE_P (mode) - && TYPE_UNSIGNED (type) != UNSIGNED_FIXED_POINT_MODE_P (mode)) - { - error ("signness of type and machine mode %qs don't match", p); - return NULL_TREE; - } - /* For fixed-point modes, we need to pass saturating info. */ - typefm = lang_hooks.types.type_for_mode (mode, - ALL_FIXED_POINT_MODE_P (mode) ? TYPE_SATURATING (type) - : TYPE_UNSIGNED (type)); - } - - if (typefm == NULL_TREE) - { - error ("no data type for mode %qs", p); - return NULL_TREE; - } - else if (TREE_CODE (type) == ENUMERAL_TYPE) - { - /* For enumeral types, copy the precision from the integer - type returned above. If not an INTEGER_TYPE, we can't use - this mode for this type. */ - if (TREE_CODE (typefm) != INTEGER_TYPE) - { - error ("cannot use mode %qs for enumeral types", p); - return NULL_TREE; - } - - if (flags & ATTR_FLAG_TYPE_IN_PLACE) - { - TYPE_PRECISION (type) = TYPE_PRECISION (typefm); - typefm = type; - } - else - { - /* We cannot build a type variant, as there's code that assumes - that TYPE_MAIN_VARIANT has the same mode. This includes the - debug generators. Instead, create a subrange type. This - results in all of the enumeral values being emitted only once - in the original, and the subtype gets them by reference. */ - if (TYPE_UNSIGNED (type)) - typefm = make_unsigned_type (TYPE_PRECISION (typefm)); - else - typefm = make_signed_type (TYPE_PRECISION (typefm)); - TREE_TYPE (typefm) = type; - } - } - else if (VECTOR_MODE_P (mode) - ? TREE_CODE (type) != TREE_CODE (TREE_TYPE (typefm)) - : TREE_CODE (type) != TREE_CODE (typefm)) - { - error ("mode %qs applied to inappropriate type", p); - return NULL_TREE; - } - - *node = typefm; - } - - return NULL_TREE; -} - -/* Handle a "section" attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_section_attribute (tree *node, tree ARG_UNUSED (name), tree args, - int ARG_UNUSED (flags), bool *no_add_attrs) -{ - tree decl = *node; - - if (targetm.have_named_sections) - { - user_defined_section_attribute = true; - - if ((TREE_CODE (decl) == FUNCTION_DECL - || TREE_CODE (decl) == VAR_DECL) - && TREE_CODE (TREE_VALUE (args)) == STRING_CST) - { - if (TREE_CODE (decl) == VAR_DECL - && current_function_decl != NULL_TREE - && !TREE_STATIC (decl)) - { - error_at (DECL_SOURCE_LOCATION (decl), - "section attribute cannot be specified for " - "local variables"); - *no_add_attrs = true; - } - - /* The decl may have already been given a section attribute - from a previous declaration. Ensure they match. */ - else if (DECL_SECTION_NAME (decl) != NULL_TREE - && strcmp (TREE_STRING_POINTER (DECL_SECTION_NAME (decl)), - TREE_STRING_POINTER (TREE_VALUE (args))) != 0) - { - error ("section of %q+D conflicts with previous declaration", - *node); - *no_add_attrs = true; - } - else if (TREE_CODE (decl) == VAR_DECL - && !targetm.have_tls && targetm.emutls.tmpl_section - && DECL_THREAD_LOCAL_P (decl)) - { - error ("section of %q+D cannot be overridden", *node); - *no_add_attrs = true; - } - else - DECL_SECTION_NAME (decl) = TREE_VALUE (args); - } - else - { - error ("section attribute not allowed for %q+D", *node); - *no_add_attrs = true; - } - } - else - { - error_at (DECL_SOURCE_LOCATION (*node), - "section attributes are not supported for this target"); - *no_add_attrs = true; - } - - return NULL_TREE; -} - -/* Handle a "aligned" attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_aligned_attribute (tree *node, tree ARG_UNUSED (name), tree args, - int flags, bool *no_add_attrs) -{ - tree decl = NULL_TREE; - tree *type = NULL; - int is_type = 0; - tree align_expr = (args ? TREE_VALUE (args) - : size_int (ATTRIBUTE_ALIGNED_VALUE / BITS_PER_UNIT)); - int i; - - if (DECL_P (*node)) - { - decl = *node; - type = &TREE_TYPE (decl); - is_type = TREE_CODE (*node) == TYPE_DECL; - } - else if (TYPE_P (*node)) - type = node, is_type = 1; - - if (TREE_CODE (align_expr) != INTEGER_CST) - { - error ("requested alignment is not a constant"); - *no_add_attrs = true; - } - else if ((i = tree_log2 (align_expr)) == -1) - { - error ("requested alignment is not a power of 2"); - *no_add_attrs = true; - } - else if (i >= HOST_BITS_PER_INT - BITS_PER_UNIT_LOG) - { - error ("requested alignment is too large"); - *no_add_attrs = true; - } - else if (is_type) - { - if ((flags & (int) ATTR_FLAG_TYPE_IN_PLACE)) - /* OK, modify the type in place. */; - /* If we have a TYPE_DECL, then copy the type, so that we - don't accidentally modify a builtin type. See pushdecl. */ - else if (decl && TREE_TYPE (decl) != error_mark_node - && DECL_ORIGINAL_TYPE (decl) == NULL_TREE) - { - tree tt = TREE_TYPE (decl); - *type = build_variant_type_copy (*type); - DECL_ORIGINAL_TYPE (decl) = tt; - TYPE_NAME (*type) = decl; - TREE_USED (*type) = TREE_USED (decl); - TREE_TYPE (decl) = *type; - } - else - *type = build_variant_type_copy (*type); - - TYPE_ALIGN (*type) = (1U << i) * BITS_PER_UNIT; - TYPE_USER_ALIGN (*type) = 1; - } - else if (! VAR_OR_FUNCTION_DECL_P (decl) - && TREE_CODE (decl) != FIELD_DECL) - { - error ("alignment may not be specified for %q+D", decl); - *no_add_attrs = true; - } - else if (TREE_CODE (decl) == FUNCTION_DECL - && DECL_ALIGN (decl) > (1U << i) * BITS_PER_UNIT) - { - if (DECL_USER_ALIGN (decl)) - error ("alignment for %q+D was previously specified as %d " - "and may not be decreased", decl, - DECL_ALIGN (decl) / BITS_PER_UNIT); - else - error ("alignment for %q+D must be at least %d", decl, - DECL_ALIGN (decl) / BITS_PER_UNIT); - *no_add_attrs = true; - } - else - { - DECL_ALIGN (decl) = (1U << i) * BITS_PER_UNIT; - DECL_USER_ALIGN (decl) = 1; - } - - return NULL_TREE; -} - -/* Handle a "weak" attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_weak_attribute (tree *node, tree name, - tree ARG_UNUSED (args), - int ARG_UNUSED (flags), - bool * ARG_UNUSED (no_add_attrs)) -{ - if (TREE_CODE (*node) == FUNCTION_DECL - && DECL_DECLARED_INLINE_P (*node)) - { - error ("inline function %q+D cannot be declared weak", *node); - *no_add_attrs = true; - } - else if (TREE_CODE (*node) == FUNCTION_DECL - || TREE_CODE (*node) == VAR_DECL) - declare_weak (*node); - else - warning (OPT_Wattributes, "%qE attribute ignored", name); - - return NULL_TREE; -} - -/* Handle an "alias" attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_alias_attribute (tree *node, tree name, tree args, - int ARG_UNUSED (flags), bool *no_add_attrs) -{ - tree decl = *node; - - if (TREE_CODE (decl) != FUNCTION_DECL && TREE_CODE (decl) != VAR_DECL) - { - warning (OPT_Wattributes, "%qE attribute ignored", name); - *no_add_attrs = true; - } - else if ((TREE_CODE (decl) == FUNCTION_DECL && DECL_INITIAL (decl)) - || (TREE_CODE (decl) != FUNCTION_DECL - && TREE_PUBLIC (decl) && !DECL_EXTERNAL (decl)) - /* A static variable declaration is always a tentative definition, - but the alias is a non-tentative definition which overrides. */ - || (TREE_CODE (decl) != FUNCTION_DECL - && ! TREE_PUBLIC (decl) && DECL_INITIAL (decl))) - { - error ("%q+D defined both normally and as an alias", decl); - *no_add_attrs = true; - } - - /* Note that the very first time we process a nested declaration, - decl_function_context will not be set. Indeed, *would* never - be set except for the DECL_INITIAL/DECL_EXTERNAL frobbery that - we do below. After such frobbery, pushdecl would set the context. - In any case, this is never what we want. */ - else if (decl_function_context (decl) == 0 && current_function_decl == NULL) - { - tree id; - - id = TREE_VALUE (args); - if (TREE_CODE (id) != STRING_CST) - { - error ("alias argument not a string"); - *no_add_attrs = true; - return NULL_TREE; - } - id = get_identifier (TREE_STRING_POINTER (id)); - /* This counts as a use of the object pointed to. */ - TREE_USED (id) = 1; - - if (TREE_CODE (decl) == FUNCTION_DECL) - DECL_INITIAL (decl) = error_mark_node; - else - { - if (lookup_attribute ("weakref", DECL_ATTRIBUTES (decl))) - DECL_EXTERNAL (decl) = 1; - else - DECL_EXTERNAL (decl) = 0; - TREE_STATIC (decl) = 1; - } - } - else - { - warning (OPT_Wattributes, "%qE attribute ignored", name); - *no_add_attrs = true; - } - - return NULL_TREE; -} - -/* Handle a "weakref" attribute; arguments as in struct - attribute_spec.handler. */ - -static tree -handle_weakref_attribute (tree *node, tree ARG_UNUSED (name), tree args, - int flags, bool *no_add_attrs) -{ - tree attr = NULL_TREE; - - /* We must ignore the attribute when it is associated with - local-scoped decls, since attribute alias is ignored and many - such symbols do not even have a DECL_WEAK field. */ - if (decl_function_context (*node) - || current_function_decl - || (TREE_CODE (*node) != VAR_DECL && TREE_CODE (*node) != FUNCTION_DECL)) - { - warning (OPT_Wattributes, "%qE attribute ignored", name); - *no_add_attrs = true; - return NULL_TREE; - } - - /* The idea here is that `weakref("name")' mutates into `weakref, - alias("name")', and weakref without arguments, in turn, - implicitly adds weak. */ - - if (args) - { - attr = tree_cons (get_identifier ("alias"), args, attr); - attr = tree_cons (get_identifier ("weakref"), NULL_TREE, attr); - - *no_add_attrs = true; - - decl_attributes (node, attr, flags); - } - else - { - if (lookup_attribute ("alias", DECL_ATTRIBUTES (*node))) - error_at (DECL_SOURCE_LOCATION (*node), - "weakref attribute must appear before alias attribute"); - - /* Can't call declare_weak because it wants this to be TREE_PUBLIC, - and that isn't supported; and because it wants to add it to - the list of weak decls, which isn't helpful. */ - DECL_WEAK (*node) = 1; - } - - return NULL_TREE; -} - -/* Handle an "visibility" attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_visibility_attribute (tree *node, tree name, tree args, - int ARG_UNUSED (flags), - bool *ARG_UNUSED (no_add_attrs)) -{ - tree decl = *node; - tree id = TREE_VALUE (args); - enum symbol_visibility vis; - - if (TYPE_P (*node)) - { - if (TREE_CODE (*node) == ENUMERAL_TYPE) - /* OK */; - else if (TREE_CODE (*node) != RECORD_TYPE && TREE_CODE (*node) != UNION_TYPE) - { - warning (OPT_Wattributes, "%qE attribute ignored on non-class types", - name); - return NULL_TREE; - } - else if (TYPE_FIELDS (*node)) - { - error ("%qE attribute ignored because %qT is already defined", - name, *node); - return NULL_TREE; - } - } - else if (decl_function_context (decl) != 0 || !TREE_PUBLIC (decl)) - { - warning (OPT_Wattributes, "%qE attribute ignored", name); - return NULL_TREE; - } - - if (TREE_CODE (id) != STRING_CST) - { - error ("visibility argument not a string"); - return NULL_TREE; - } - - /* If this is a type, set the visibility on the type decl. */ - if (TYPE_P (decl)) - { - decl = TYPE_NAME (decl); - if (!decl) - return NULL_TREE; - if (TREE_CODE (decl) == IDENTIFIER_NODE) - { - warning (OPT_Wattributes, "%qE attribute ignored on types", - name); - return NULL_TREE; - } - } - - if (strcmp (TREE_STRING_POINTER (id), "default") == 0) - vis = VISIBILITY_DEFAULT; - else if (strcmp (TREE_STRING_POINTER (id), "internal") == 0) - vis = VISIBILITY_INTERNAL; - else if (strcmp (TREE_STRING_POINTER (id), "hidden") == 0) - vis = VISIBILITY_HIDDEN; - else if (strcmp (TREE_STRING_POINTER (id), "protected") == 0) - vis = VISIBILITY_PROTECTED; - else - { - error ("visibility argument must be one of \"default\", \"hidden\", \"protected\" or \"internal\""); - vis = VISIBILITY_DEFAULT; - } - - if (DECL_VISIBILITY_SPECIFIED (decl) - && vis != DECL_VISIBILITY (decl)) - { - tree attributes = (TYPE_P (*node) - ? TYPE_ATTRIBUTES (*node) - : DECL_ATTRIBUTES (decl)); - if (lookup_attribute ("visibility", attributes)) - error ("%qD redeclared with different visibility", decl); - else if (TARGET_DLLIMPORT_DECL_ATTRIBUTES - && lookup_attribute ("dllimport", attributes)) - error ("%qD was declared %qs which implies default visibility", - decl, "dllimport"); - else if (TARGET_DLLIMPORT_DECL_ATTRIBUTES - && lookup_attribute ("dllexport", attributes)) - error ("%qD was declared %qs which implies default visibility", - decl, "dllexport"); - } - - DECL_VISIBILITY (decl) = vis; - DECL_VISIBILITY_SPECIFIED (decl) = 1; - - /* Go ahead and attach the attribute to the node as well. This is needed - so we can determine whether we have VISIBILITY_DEFAULT because the - visibility was not specified, or because it was explicitly overridden - from the containing scope. */ - - return NULL_TREE; -} - -/* Determine the ELF symbol visibility for DECL, which is either a - variable or a function. It is an error to use this function if a - definition of DECL is not available in this translation unit. - Returns true if the final visibility has been determined by this - function; false if the caller is free to make additional - modifications. */ - -bool -c_determine_visibility (tree decl) -{ - gcc_assert (TREE_CODE (decl) == VAR_DECL - || TREE_CODE (decl) == FUNCTION_DECL); - - /* If the user explicitly specified the visibility with an - attribute, honor that. DECL_VISIBILITY will have been set during - the processing of the attribute. We check for an explicit - attribute, rather than just checking DECL_VISIBILITY_SPECIFIED, - to distinguish the use of an attribute from the use of a "#pragma - GCC visibility push(...)"; in the latter case we still want other - considerations to be able to overrule the #pragma. */ - if (lookup_attribute ("visibility", DECL_ATTRIBUTES (decl)) - || (TARGET_DLLIMPORT_DECL_ATTRIBUTES - && (lookup_attribute ("dllimport", DECL_ATTRIBUTES (decl)) - || lookup_attribute ("dllexport", DECL_ATTRIBUTES (decl))))) - return true; - - /* Set default visibility to whatever the user supplied with - visibility_specified depending on #pragma GCC visibility. */ - if (!DECL_VISIBILITY_SPECIFIED (decl)) - { - if (visibility_options.inpragma - || DECL_VISIBILITY (decl) != default_visibility) - { - DECL_VISIBILITY (decl) = default_visibility; - DECL_VISIBILITY_SPECIFIED (decl) = visibility_options.inpragma; - /* If visibility changed and DECL already has DECL_RTL, ensure - symbol flags are updated. */ - if (((TREE_CODE (decl) == VAR_DECL && TREE_STATIC (decl)) - || TREE_CODE (decl) == FUNCTION_DECL) - && DECL_RTL_SET_P (decl)) - make_decl_rtl (decl); - } - } - return false; -} - -/* Handle an "tls_model" attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_tls_model_attribute (tree *node, tree name, tree args, - int ARG_UNUSED (flags), bool *no_add_attrs) -{ - tree id; - tree decl = *node; - enum tls_model kind; - - *no_add_attrs = true; - - if (TREE_CODE (decl) != VAR_DECL || !DECL_THREAD_LOCAL_P (decl)) - { - warning (OPT_Wattributes, "%qE attribute ignored", name); - return NULL_TREE; - } - - kind = DECL_TLS_MODEL (decl); - id = TREE_VALUE (args); - if (TREE_CODE (id) != STRING_CST) - { - error ("tls_model argument not a string"); - return NULL_TREE; - } - - if (!strcmp (TREE_STRING_POINTER (id), "local-exec")) - kind = TLS_MODEL_LOCAL_EXEC; - else if (!strcmp (TREE_STRING_POINTER (id), "initial-exec")) - kind = TLS_MODEL_INITIAL_EXEC; - else if (!strcmp (TREE_STRING_POINTER (id), "local-dynamic")) - kind = optimize ? TLS_MODEL_LOCAL_DYNAMIC : TLS_MODEL_GLOBAL_DYNAMIC; - else if (!strcmp (TREE_STRING_POINTER (id), "global-dynamic")) - kind = TLS_MODEL_GLOBAL_DYNAMIC; - else - error ("tls_model argument must be one of \"local-exec\", \"initial-exec\", \"local-dynamic\" or \"global-dynamic\""); - - DECL_TLS_MODEL (decl) = kind; - return NULL_TREE; -} - -/* Handle a "no_instrument_function" attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_no_instrument_function_attribute (tree *node, tree name, - tree ARG_UNUSED (args), - int ARG_UNUSED (flags), - bool *no_add_attrs) -{ - tree decl = *node; - - if (TREE_CODE (decl) != FUNCTION_DECL) - { - error_at (DECL_SOURCE_LOCATION (decl), - "%qE attribute applies only to functions", name); - *no_add_attrs = true; - } - else if (DECL_INITIAL (decl)) - { - error_at (DECL_SOURCE_LOCATION (decl), - "can%'t set %qE attribute after definition", name); - *no_add_attrs = true; - } - else - DECL_NO_INSTRUMENT_FUNCTION_ENTRY_EXIT (decl) = 1; - - return NULL_TREE; -} - -/* Handle a "malloc" attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_malloc_attribute (tree *node, tree name, tree ARG_UNUSED (args), - int ARG_UNUSED (flags), bool *no_add_attrs) -{ - if (TREE_CODE (*node) == FUNCTION_DECL - && POINTER_TYPE_P (TREE_TYPE (TREE_TYPE (*node)))) - DECL_IS_MALLOC (*node) = 1; - else - { - warning (OPT_Wattributes, "%qE attribute ignored", name); - *no_add_attrs = true; - } - - return NULL_TREE; -} - -/* Handle a "alloc_size" attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_alloc_size_attribute (tree *node, tree ARG_UNUSED (name), tree args, - int ARG_UNUSED (flags), bool *no_add_attrs) -{ - unsigned arg_count = type_num_arguments (*node); - for (; args; args = TREE_CHAIN (args)) - { - tree position = TREE_VALUE (args); - - if (TREE_CODE (position) != INTEGER_CST - || TREE_INT_CST_HIGH (position) - || TREE_INT_CST_LOW (position) < 1 - || TREE_INT_CST_LOW (position) > arg_count ) - { - warning (OPT_Wattributes, - "alloc_size parameter outside range"); - *no_add_attrs = true; - return NULL_TREE; - } - } - return NULL_TREE; -} - -/* Handle a "fn spec" attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_fnspec_attribute (tree *node ATTRIBUTE_UNUSED, tree ARG_UNUSED (name), - tree args, int ARG_UNUSED (flags), - bool *no_add_attrs ATTRIBUTE_UNUSED) -{ - gcc_assert (args - && TREE_CODE (TREE_VALUE (args)) == STRING_CST - && !TREE_CHAIN (args)); - return NULL_TREE; -} - -/* Handle a "returns_twice" attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_returns_twice_attribute (tree *node, tree name, tree ARG_UNUSED (args), - int ARG_UNUSED (flags), bool *no_add_attrs) -{ - if (TREE_CODE (*node) == FUNCTION_DECL) - DECL_IS_RETURNS_TWICE (*node) = 1; - else - { - warning (OPT_Wattributes, "%qE attribute ignored", name); - *no_add_attrs = true; - } - - return NULL_TREE; -} - -/* Handle a "no_limit_stack" attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_no_limit_stack_attribute (tree *node, tree name, - tree ARG_UNUSED (args), - int ARG_UNUSED (flags), - bool *no_add_attrs) -{ - tree decl = *node; - - if (TREE_CODE (decl) != FUNCTION_DECL) - { - error_at (DECL_SOURCE_LOCATION (decl), - "%qE attribute applies only to functions", name); - *no_add_attrs = true; - } - else if (DECL_INITIAL (decl)) - { - error_at (DECL_SOURCE_LOCATION (decl), - "can%'t set %qE attribute after definition", name); - *no_add_attrs = true; - } - else - DECL_NO_LIMIT_STACK (decl) = 1; - - return NULL_TREE; -} - -/* Handle a "pure" attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_pure_attribute (tree *node, tree name, tree ARG_UNUSED (args), - int ARG_UNUSED (flags), bool *no_add_attrs) -{ - if (TREE_CODE (*node) == FUNCTION_DECL) - DECL_PURE_P (*node) = 1; - /* ??? TODO: Support types. */ - else - { - warning (OPT_Wattributes, "%qE attribute ignored", name); - *no_add_attrs = true; - } - - return NULL_TREE; -} - -/* Handle a "no vops" attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_novops_attribute (tree *node, tree ARG_UNUSED (name), - tree ARG_UNUSED (args), int ARG_UNUSED (flags), - bool *ARG_UNUSED (no_add_attrs)) -{ - gcc_assert (TREE_CODE (*node) == FUNCTION_DECL); - DECL_IS_NOVOPS (*node) = 1; - return NULL_TREE; -} - -/* Handle a "deprecated" attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_deprecated_attribute (tree *node, tree name, - tree args, int flags, - bool *no_add_attrs) -{ - tree type = NULL_TREE; - int warn = 0; - tree what = NULL_TREE; - - if (!args) - *no_add_attrs = true; - else if (TREE_CODE (TREE_VALUE (args)) != STRING_CST) - { - error ("deprecated message is not a string"); - *no_add_attrs = true; - } - - if (DECL_P (*node)) - { - tree decl = *node; - type = TREE_TYPE (decl); - - if (TREE_CODE (decl) == TYPE_DECL - || TREE_CODE (decl) == PARM_DECL - || TREE_CODE (decl) == VAR_DECL - || TREE_CODE (decl) == FUNCTION_DECL - || TREE_CODE (decl) == FIELD_DECL) - TREE_DEPRECATED (decl) = 1; - else - warn = 1; - } - else if (TYPE_P (*node)) - { - if (!(flags & (int) ATTR_FLAG_TYPE_IN_PLACE)) - *node = build_variant_type_copy (*node); - TREE_DEPRECATED (*node) = 1; - type = *node; - } - else - warn = 1; - - if (warn) - { - *no_add_attrs = true; - if (type && TYPE_NAME (type)) - { - if (TREE_CODE (TYPE_NAME (type)) == IDENTIFIER_NODE) - what = TYPE_NAME (*node); - else if (TREE_CODE (TYPE_NAME (type)) == TYPE_DECL - && DECL_NAME (TYPE_NAME (type))) - what = DECL_NAME (TYPE_NAME (type)); - } - if (what) - warning (OPT_Wattributes, "%qE attribute ignored for %qE", name, what); - else - warning (OPT_Wattributes, "%qE attribute ignored", name); - } - - return NULL_TREE; -} - -/* Handle a "vector_size" attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_vector_size_attribute (tree *node, tree name, tree args, - int ARG_UNUSED (flags), - bool *no_add_attrs) -{ - unsigned HOST_WIDE_INT vecsize, nunits; - enum machine_mode orig_mode; - tree type = *node, new_type, size; - - *no_add_attrs = true; - - size = TREE_VALUE (args); - - if (!host_integerp (size, 1)) - { - warning (OPT_Wattributes, "%qE attribute ignored", name); - return NULL_TREE; - } - - /* Get the vector size (in bytes). */ - vecsize = tree_low_cst (size, 1); - - /* We need to provide for vector pointers, vector arrays, and - functions returning vectors. For example: - - __attribute__((vector_size(16))) short *foo; - - In this case, the mode is SI, but the type being modified is - HI, so we need to look further. */ - - while (POINTER_TYPE_P (type) - || TREE_CODE (type) == FUNCTION_TYPE - || TREE_CODE (type) == METHOD_TYPE - || TREE_CODE (type) == ARRAY_TYPE - || TREE_CODE (type) == OFFSET_TYPE) - type = TREE_TYPE (type); - - /* Get the mode of the type being modified. */ - orig_mode = TYPE_MODE (type); - - if ((!INTEGRAL_TYPE_P (type) - && !SCALAR_FLOAT_TYPE_P (type) - && !FIXED_POINT_TYPE_P (type)) - || (!SCALAR_FLOAT_MODE_P (orig_mode) - && GET_MODE_CLASS (orig_mode) != MODE_INT - && !ALL_SCALAR_FIXED_POINT_MODE_P (orig_mode)) - || !host_integerp (TYPE_SIZE_UNIT (type), 1) - || TREE_CODE (type) == BOOLEAN_TYPE) - { - error ("invalid vector type for attribute %qE", name); - return NULL_TREE; - } - - if (vecsize % tree_low_cst (TYPE_SIZE_UNIT (type), 1)) - { - error ("vector size not an integral multiple of component size"); - return NULL; - } - - if (vecsize == 0) - { - error ("zero vector size"); - return NULL; - } - - /* Calculate how many units fit in the vector. */ - nunits = vecsize / tree_low_cst (TYPE_SIZE_UNIT (type), 1); - if (nunits & (nunits - 1)) - { - error ("number of components of the vector not a power of two"); - return NULL_TREE; - } - - new_type = build_vector_type (type, nunits); - - /* Build back pointers if needed. */ - *node = lang_hooks.types.reconstruct_complex_type (*node, new_type); - - return NULL_TREE; -} - -/* Handle the "nonnull" attribute. */ -static tree -handle_nonnull_attribute (tree *node, tree ARG_UNUSED (name), - tree args, int ARG_UNUSED (flags), - bool *no_add_attrs) -{ - tree type = *node; - unsigned HOST_WIDE_INT attr_arg_num; - - /* If no arguments are specified, all pointer arguments should be - non-null. Verify a full prototype is given so that the arguments - will have the correct types when we actually check them later. */ - if (!args) - { - if (!TYPE_ARG_TYPES (type)) - { - error ("nonnull attribute without arguments on a non-prototype"); - *no_add_attrs = true; - } - return NULL_TREE; - } - - /* Argument list specified. Verify that each argument number references - a pointer argument. */ - for (attr_arg_num = 1; args; args = TREE_CHAIN (args)) - { - tree argument; - unsigned HOST_WIDE_INT arg_num = 0, ck_num; - - if (!get_nonnull_operand (TREE_VALUE (args), &arg_num)) - { - error ("nonnull argument has invalid operand number (argument %lu)", - (unsigned long) attr_arg_num); - *no_add_attrs = true; - return NULL_TREE; - } - - argument = TYPE_ARG_TYPES (type); - if (argument) - { - for (ck_num = 1; ; ck_num++) - { - if (!argument || ck_num == arg_num) - break; - argument = TREE_CHAIN (argument); - } - - if (!argument - || TREE_CODE (TREE_VALUE (argument)) == VOID_TYPE) - { - error ("nonnull argument with out-of-range operand number (argument %lu, operand %lu)", - (unsigned long) attr_arg_num, (unsigned long) arg_num); - *no_add_attrs = true; - return NULL_TREE; - } - - if (TREE_CODE (TREE_VALUE (argument)) != POINTER_TYPE) - { - error ("nonnull argument references non-pointer operand (argument %lu, operand %lu)", - (unsigned long) attr_arg_num, (unsigned long) arg_num); - *no_add_attrs = true; - return NULL_TREE; - } - } - } - - return NULL_TREE; -} - -/* Check the argument list of a function call for null in argument slots - that are marked as requiring a non-null pointer argument. The NARGS - arguments are passed in the array ARGARRAY. -*/ - -static void -check_function_nonnull (tree attrs, int nargs, tree *argarray) -{ - tree a, args; - int i; - - for (a = attrs; a; a = TREE_CHAIN (a)) - { - if (is_attribute_p ("nonnull", TREE_PURPOSE (a))) - { - args = TREE_VALUE (a); - - /* Walk the argument list. If we encounter an argument number we - should check for non-null, do it. If the attribute has no args, - then every pointer argument is checked (in which case the check - for pointer type is done in check_nonnull_arg). */ - for (i = 0; i < nargs; i++) - { - if (!args || nonnull_check_p (args, i + 1)) - check_function_arguments_recurse (check_nonnull_arg, NULL, - argarray[i], - i + 1); - } - } - } -} - -/* Check that the Nth argument of a function call (counting backwards - from the end) is a (pointer)0. The NARGS arguments are passed in the - array ARGARRAY. */ - -static void -check_function_sentinel (tree attrs, int nargs, tree *argarray, tree typelist) -{ - tree attr = lookup_attribute ("sentinel", attrs); - - if (attr) - { - int len = 0; - int pos = 0; - tree sentinel; - - /* Skip over the named arguments. */ - while (typelist && len < nargs) - { - typelist = TREE_CHAIN (typelist); - len++; - } - - if (TREE_VALUE (attr)) - { - tree p = TREE_VALUE (TREE_VALUE (attr)); - pos = TREE_INT_CST_LOW (p); - } - - /* The sentinel must be one of the varargs, i.e. - in position >= the number of fixed arguments. */ - if ((nargs - 1 - pos) < len) - { - warning (OPT_Wformat, - "not enough variable arguments to fit a sentinel"); - return; - } - - /* Validate the sentinel. */ - sentinel = argarray[nargs - 1 - pos]; - if ((!POINTER_TYPE_P (TREE_TYPE (sentinel)) - || !integer_zerop (sentinel)) - /* Although __null (in C++) is only an integer we allow it - nevertheless, as we are guaranteed that it's exactly - as wide as a pointer, and we don't want to force - users to cast the NULL they have written there. - We warn with -Wstrict-null-sentinel, though. */ - && (warn_strict_null_sentinel || null_node != sentinel)) - warning (OPT_Wformat, "missing sentinel in function call"); - } -} - -/* Helper for check_function_nonnull; given a list of operands which - must be non-null in ARGS, determine if operand PARAM_NUM should be - checked. */ - -static bool -nonnull_check_p (tree args, unsigned HOST_WIDE_INT param_num) -{ - unsigned HOST_WIDE_INT arg_num = 0; - - for (; args; args = TREE_CHAIN (args)) - { - bool found = get_nonnull_operand (TREE_VALUE (args), &arg_num); - - gcc_assert (found); - - if (arg_num == param_num) - return true; - } - return false; -} - -/* Check that the function argument PARAM (which is operand number - PARAM_NUM) is non-null. This is called by check_function_nonnull - via check_function_arguments_recurse. */ - -static void -check_nonnull_arg (void * ARG_UNUSED (ctx), tree param, - unsigned HOST_WIDE_INT param_num) -{ - /* Just skip checking the argument if it's not a pointer. This can - happen if the "nonnull" attribute was given without an operand - list (which means to check every pointer argument). */ - - if (TREE_CODE (TREE_TYPE (param)) != POINTER_TYPE) - return; - - if (integer_zerop (param)) - warning (OPT_Wnonnull, "null argument where non-null required " - "(argument %lu)", (unsigned long) param_num); -} - -/* Helper for nonnull attribute handling; fetch the operand number - from the attribute argument list. */ - -static bool -get_nonnull_operand (tree arg_num_expr, unsigned HOST_WIDE_INT *valp) -{ - /* Verify the arg number is a constant. */ - if (TREE_CODE (arg_num_expr) != INTEGER_CST - || TREE_INT_CST_HIGH (arg_num_expr) != 0) - return false; - - *valp = TREE_INT_CST_LOW (arg_num_expr); - return true; -} - -/* Handle a "nothrow" attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_nothrow_attribute (tree *node, tree name, tree ARG_UNUSED (args), - int ARG_UNUSED (flags), bool *no_add_attrs) -{ - if (TREE_CODE (*node) == FUNCTION_DECL) - TREE_NOTHROW (*node) = 1; - /* ??? TODO: Support types. */ - else - { - warning (OPT_Wattributes, "%qE attribute ignored", name); - *no_add_attrs = true; - } - - return NULL_TREE; -} - -/* Handle a "cleanup" attribute; arguments as in - struct attribute_spec.handler. */ - -static tree -handle_cleanup_attribute (tree *node, tree name, tree args, - int ARG_UNUSED (flags), bool *no_add_attrs) -{ - tree decl = *node; - tree cleanup_id, cleanup_decl; - - /* ??? Could perhaps support cleanups on TREE_STATIC, much like we do - for global destructors in C++. This requires infrastructure that - we don't have generically at the moment. It's also not a feature - we'd be missing too much, since we do have attribute constructor. */ - if (TREE_CODE (decl) != VAR_DECL || TREE_STATIC (decl)) - { - warning (OPT_Wattributes, "%qE attribute ignored", name); - *no_add_attrs = true; - return NULL_TREE; - } - - /* Verify that the argument is a function in scope. */ - /* ??? We could support pointers to functions here as well, if - that was considered desirable. */ - cleanup_id = TREE_VALUE (args); - if (TREE_CODE (cleanup_id) != IDENTIFIER_NODE) - { - error ("cleanup argument not an identifier"); - *no_add_attrs = true; - return NULL_TREE; - } - cleanup_decl = lookup_name (cleanup_id); - if (!cleanup_decl || TREE_CODE (cleanup_decl) != FUNCTION_DECL) - { - error ("cleanup argument not a function"); - *no_add_attrs = true; - return NULL_TREE; - } - - /* That the function has proper type is checked with the - eventual call to build_function_call. */ - - return NULL_TREE; -} - -/* Handle a "warn_unused_result" attribute. No special handling. */ - -static tree -handle_warn_unused_result_attribute (tree *node, tree name, - tree ARG_UNUSED (args), - int ARG_UNUSED (flags), bool *no_add_attrs) -{ - /* Ignore the attribute for functions not returning any value. */ - if (VOID_TYPE_P (TREE_TYPE (*node))) - { - warning (OPT_Wattributes, "%qE attribute ignored", name); - *no_add_attrs = true; - } - - return NULL_TREE; -} - -/* Handle a "sentinel" attribute. */ - -static tree -handle_sentinel_attribute (tree *node, tree name, tree args, - int ARG_UNUSED (flags), bool *no_add_attrs) -{ - tree params = TYPE_ARG_TYPES (*node); - - if (!params) - { - warning (OPT_Wattributes, - "%qE attribute requires prototypes with named arguments", name); - *no_add_attrs = true; - } - else - { - while (TREE_CHAIN (params)) - params = TREE_CHAIN (params); - - if (VOID_TYPE_P (TREE_VALUE (params))) - { - warning (OPT_Wattributes, - "%qE attribute only applies to variadic functions", name); - *no_add_attrs = true; - } - } - - if (args) - { - tree position = TREE_VALUE (args); - - if (TREE_CODE (position) != INTEGER_CST) - { - warning (OPT_Wattributes, - "requested position is not an integer constant"); - *no_add_attrs = true; - } - else - { - if (tree_int_cst_lt (position, integer_zero_node)) - { - warning (OPT_Wattributes, - "requested position is less than zero"); - *no_add_attrs = true; - } - } - } - - return NULL_TREE; -} - -/* Handle a "type_generic" attribute. */ - -static tree -handle_type_generic_attribute (tree *node, tree ARG_UNUSED (name), - tree ARG_UNUSED (args), int ARG_UNUSED (flags), - bool * ARG_UNUSED (no_add_attrs)) -{ - tree params; - - /* Ensure we have a function type. */ - gcc_assert (TREE_CODE (*node) == FUNCTION_TYPE); - - params = TYPE_ARG_TYPES (*node); - while (params && ! VOID_TYPE_P (TREE_VALUE (params))) - params = TREE_CHAIN (params); - - /* Ensure we have a variadic function. */ - gcc_assert (!params); - - return NULL_TREE; -} - -/* Handle a "target" attribute. */ - -static tree -handle_target_attribute (tree *node, tree name, tree args, int flags, - bool *no_add_attrs) -{ - /* Ensure we have a function type. */ - if (TREE_CODE (*node) != FUNCTION_DECL) - { - warning (OPT_Wattributes, "%qE attribute ignored", name); - *no_add_attrs = true; - } - else if (! targetm.target_option.valid_attribute_p (*node, name, args, - flags)) - *no_add_attrs = true; - - return NULL_TREE; -} - -/* Arguments being collected for optimization. */ -typedef const char *const_char_p; /* For DEF_VEC_P. */ -DEF_VEC_P(const_char_p); -DEF_VEC_ALLOC_P(const_char_p, gc); -static GTY(()) VEC(const_char_p, gc) *optimize_args; - - -/* Inner function to convert a TREE_LIST to argv string to parse the optimize - options in ARGS. ATTR_P is true if this is for attribute(optimize), and - false for #pragma GCC optimize. */ - -bool -parse_optimize_options (tree args, bool attr_p) -{ - bool ret = true; - unsigned opt_argc; - unsigned i; - int saved_flag_strict_aliasing; - const char **opt_argv; - tree ap; - - /* Build up argv vector. Just in case the string is stored away, use garbage - collected strings. */ - VEC_truncate (const_char_p, optimize_args, 0); - VEC_safe_push (const_char_p, gc, optimize_args, NULL); - - for (ap = args; ap != NULL_TREE; ap = TREE_CHAIN (ap)) - { - tree value = TREE_VALUE (ap); - - if (TREE_CODE (value) == INTEGER_CST) - { - char buffer[20]; - sprintf (buffer, "-O%ld", (long) TREE_INT_CST_LOW (value)); - VEC_safe_push (const_char_p, gc, optimize_args, ggc_strdup (buffer)); - } - - else if (TREE_CODE (value) == STRING_CST) - { - /* Split string into multiple substrings. */ - size_t len = TREE_STRING_LENGTH (value); - char *p = ASTRDUP (TREE_STRING_POINTER (value)); - char *end = p + len; - char *comma; - char *next_p = p; - - while (next_p != NULL) - { - size_t len2; - char *q, *r; - - p = next_p; - comma = strchr (p, ','); - if (comma) - { - len2 = comma - p; - *comma = '\0'; - next_p = comma+1; - } - else - { - len2 = end - p; - next_p = NULL; - } - - r = q = (char *) ggc_alloc (len2 + 3); - - /* If the user supplied -Oxxx or -fxxx, only allow -Oxxx or -fxxx - options. */ - if (*p == '-' && p[1] != 'O' && p[1] != 'f') - { - ret = false; - if (attr_p) - warning (OPT_Wattributes, - "Bad option %s to optimize attribute.", p); - else - warning (OPT_Wpragmas, - "Bad option %s to pragma attribute", p); - continue; - } - - if (*p != '-') - { - *r++ = '-'; - - /* Assume that Ox is -Ox, a numeric value is -Ox, a s by - itself is -Os, and any other switch begins with a -f. */ - if ((*p >= '0' && *p <= '9') - || (p[0] == 's' && p[1] == '\0')) - *r++ = 'O'; - else if (*p != 'O') - *r++ = 'f'; - } - - memcpy (r, p, len2); - r[len2] = '\0'; - VEC_safe_push (const_char_p, gc, optimize_args, q); - } - - } - } - - opt_argc = VEC_length (const_char_p, optimize_args); - opt_argv = (const char **) alloca (sizeof (char *) * (opt_argc + 1)); - - for (i = 1; i < opt_argc; i++) - opt_argv[i] = VEC_index (const_char_p, optimize_args, i); - - saved_flag_strict_aliasing = flag_strict_aliasing; - - /* Now parse the options. */ - decode_options (opt_argc, opt_argv); - - targetm.override_options_after_change(); - - /* Don't allow changing -fstrict-aliasing. */ - flag_strict_aliasing = saved_flag_strict_aliasing; - - VEC_truncate (const_char_p, optimize_args, 0); - return ret; -} - -/* For handling "optimize" attribute. arguments as in - struct attribute_spec.handler. */ - -static tree -handle_optimize_attribute (tree *node, tree name, tree args, - int ARG_UNUSED (flags), bool *no_add_attrs) -{ - /* Ensure we have a function type. */ - if (TREE_CODE (*node) != FUNCTION_DECL) - { - warning (OPT_Wattributes, "%qE attribute ignored", name); - *no_add_attrs = true; - } - else - { - struct cl_optimization cur_opts; - tree old_opts = DECL_FUNCTION_SPECIFIC_OPTIMIZATION (*node); - - /* Save current options. */ - cl_optimization_save (&cur_opts); - - /* If we previously had some optimization options, use them as the - default. */ - if (old_opts) - cl_optimization_restore (TREE_OPTIMIZATION (old_opts)); - - /* Parse options, and update the vector. */ - parse_optimize_options (args, true); - DECL_FUNCTION_SPECIFIC_OPTIMIZATION (*node) - = build_optimization_node (); - - /* Restore current options. */ - cl_optimization_restore (&cur_opts); - } - - return NULL_TREE; -} - -/* Check for valid arguments being passed to a function. - ATTRS is a list of attributes. There are NARGS arguments in the array - ARGARRAY. TYPELIST is the list of argument types for the function. - */ -void -check_function_arguments (tree attrs, int nargs, tree *argarray, tree typelist) -{ - /* Check for null being passed in a pointer argument that must be - non-null. We also need to do this if format checking is enabled. */ - - if (warn_nonnull) - check_function_nonnull (attrs, nargs, argarray); - - /* Check for errors in format strings. */ - - if (warn_format || warn_missing_format_attribute) - check_function_format (attrs, nargs, argarray); - - if (warn_format) - check_function_sentinel (attrs, nargs, argarray, typelist); -} - -/* Generic argument checking recursion routine. PARAM is the argument to - be checked. PARAM_NUM is the number of the argument. CALLBACK is invoked - once the argument is resolved. CTX is context for the callback. */ -void -check_function_arguments_recurse (void (*callback) - (void *, tree, unsigned HOST_WIDE_INT), - void *ctx, tree param, - unsigned HOST_WIDE_INT param_num) -{ - if (CONVERT_EXPR_P (param) - && (TYPE_PRECISION (TREE_TYPE (param)) - == TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (param, 0))))) - { - /* Strip coercion. */ - check_function_arguments_recurse (callback, ctx, - TREE_OPERAND (param, 0), param_num); - return; - } - - if (TREE_CODE (param) == CALL_EXPR) - { - tree type = TREE_TYPE (TREE_TYPE (CALL_EXPR_FN (param))); - tree attrs; - bool found_format_arg = false; - - /* See if this is a call to a known internationalization function - that modifies a format arg. Such a function may have multiple - format_arg attributes (for example, ngettext). */ - - for (attrs = TYPE_ATTRIBUTES (type); - attrs; - attrs = TREE_CHAIN (attrs)) - if (is_attribute_p ("format_arg", TREE_PURPOSE (attrs))) - { - tree inner_arg; - tree format_num_expr; - int format_num; - int i; - call_expr_arg_iterator iter; - - /* Extract the argument number, which was previously checked - to be valid. */ - format_num_expr = TREE_VALUE (TREE_VALUE (attrs)); - - gcc_assert (TREE_CODE (format_num_expr) == INTEGER_CST - && !TREE_INT_CST_HIGH (format_num_expr)); - - format_num = TREE_INT_CST_LOW (format_num_expr); - - for (inner_arg = first_call_expr_arg (param, &iter), i = 1; - inner_arg != 0; - inner_arg = next_call_expr_arg (&iter), i++) - if (i == format_num) - { - check_function_arguments_recurse (callback, ctx, - inner_arg, param_num); - found_format_arg = true; - break; - } - } - - /* If we found a format_arg attribute and did a recursive check, - we are done with checking this argument. Otherwise, we continue - and this will be considered a non-literal. */ - if (found_format_arg) - return; - } - - if (TREE_CODE (param) == COND_EXPR) - { - /* Check both halves of the conditional expression. */ - check_function_arguments_recurse (callback, ctx, - TREE_OPERAND (param, 1), param_num); - check_function_arguments_recurse (callback, ctx, - TREE_OPERAND (param, 2), param_num); - return; - } - - (*callback) (ctx, param, param_num); -} - -/* Checks for a builtin function FNDECL that the number of arguments - NARGS against the required number REQUIRED and issues an error if - there is a mismatch. Returns true if the number of arguments is - correct, otherwise false. */ - -static bool -builtin_function_validate_nargs (tree fndecl, int nargs, int required) -{ - if (nargs < required) - { - error_at (input_location, - "not enough arguments to function %qE", fndecl); - return false; - } - else if (nargs > required) - { - error_at (input_location, - "too many arguments to function %qE", fndecl); - return false; - } - return true; -} - -/* Verifies the NARGS arguments ARGS to the builtin function FNDECL. - Returns false if there was an error, otherwise true. */ - -bool -check_builtin_function_arguments (tree fndecl, int nargs, tree *args) -{ - if (!DECL_BUILT_IN (fndecl) - || DECL_BUILT_IN_CLASS (fndecl) != BUILT_IN_NORMAL) - return true; - - switch (DECL_FUNCTION_CODE (fndecl)) - { - case BUILT_IN_CONSTANT_P: - return builtin_function_validate_nargs (fndecl, nargs, 1); - - case BUILT_IN_ISFINITE: - case BUILT_IN_ISINF: - case BUILT_IN_ISINF_SIGN: - case BUILT_IN_ISNAN: - case BUILT_IN_ISNORMAL: - if (builtin_function_validate_nargs (fndecl, nargs, 1)) - { - if (TREE_CODE (TREE_TYPE (args[0])) != REAL_TYPE) - { - error ("non-floating-point argument in call to " - "function %qE", fndecl); - return false; - } - return true; - } - return false; - - case BUILT_IN_ISGREATER: - case BUILT_IN_ISGREATEREQUAL: - case BUILT_IN_ISLESS: - case BUILT_IN_ISLESSEQUAL: - case BUILT_IN_ISLESSGREATER: - case BUILT_IN_ISUNORDERED: - if (builtin_function_validate_nargs (fndecl, nargs, 2)) - { - enum tree_code code0, code1; - code0 = TREE_CODE (TREE_TYPE (args[0])); - code1 = TREE_CODE (TREE_TYPE (args[1])); - if (!((code0 == REAL_TYPE && code1 == REAL_TYPE) - || (code0 == REAL_TYPE && code1 == INTEGER_TYPE) - || (code0 == INTEGER_TYPE && code1 == REAL_TYPE))) - { - error ("non-floating-point arguments in call to " - "function %qE", fndecl); - return false; - } - return true; - } - return false; - - case BUILT_IN_FPCLASSIFY: - if (builtin_function_validate_nargs (fndecl, nargs, 6)) - { - unsigned i; - - for (i=0; i<5; i++) - if (TREE_CODE (args[i]) != INTEGER_CST) - { - error ("non-const integer argument %u in call to function %qE", - i+1, fndecl); - return false; - } - - if (TREE_CODE (TREE_TYPE (args[5])) != REAL_TYPE) - { - error ("non-floating-point argument in call to function %qE", - fndecl); - return false; - } - return true; - } - return false; - - default: - return true; - } -} - -/* Function to help qsort sort FIELD_DECLs by name order. */ - -int -field_decl_cmp (const void *x_p, const void *y_p) -{ - const tree *const x = (const tree *const) x_p; - const tree *const y = (const tree *const) y_p; - - if (DECL_NAME (*x) == DECL_NAME (*y)) - /* A nontype is "greater" than a type. */ - return (TREE_CODE (*y) == TYPE_DECL) - (TREE_CODE (*x) == TYPE_DECL); - if (DECL_NAME (*x) == NULL_TREE) - return -1; - if (DECL_NAME (*y) == NULL_TREE) - return 1; - if (DECL_NAME (*x) < DECL_NAME (*y)) - return -1; - return 1; -} - -static struct { - gt_pointer_operator new_value; - void *cookie; -} resort_data; - -/* This routine compares two fields like field_decl_cmp but using the -pointer operator in resort_data. */ - -static int -resort_field_decl_cmp (const void *x_p, const void *y_p) -{ - const tree *const x = (const tree *const) x_p; - const tree *const y = (const tree *const) y_p; - - if (DECL_NAME (*x) == DECL_NAME (*y)) - /* A nontype is "greater" than a type. */ - return (TREE_CODE (*y) == TYPE_DECL) - (TREE_CODE (*x) == TYPE_DECL); - if (DECL_NAME (*x) == NULL_TREE) - return -1; - if (DECL_NAME (*y) == NULL_TREE) - return 1; - { - tree d1 = DECL_NAME (*x); - tree d2 = DECL_NAME (*y); - resort_data.new_value (&d1, resort_data.cookie); - resort_data.new_value (&d2, resort_data.cookie); - if (d1 < d2) - return -1; - } - return 1; -} - -/* Resort DECL_SORTED_FIELDS because pointers have been reordered. */ - -void -resort_sorted_fields (void *obj, - void * ARG_UNUSED (orig_obj), - gt_pointer_operator new_value, - void *cookie) -{ - struct sorted_fields_type *sf = (struct sorted_fields_type *) obj; - resort_data.new_value = new_value; - resort_data.cookie = cookie; - qsort (&sf->elts[0], sf->len, sizeof (tree), - resort_field_decl_cmp); -} - -/* Subroutine of c_parse_error. - Return the result of concatenating LHS and RHS. RHS is really - a string literal, its first character is indicated by RHS_START and - RHS_SIZE is its length (including the terminating NUL character). - - The caller is responsible for deleting the returned pointer. */ - -static char * -catenate_strings (const char *lhs, const char *rhs_start, int rhs_size) -{ - const int lhs_size = strlen (lhs); - char *result = XNEWVEC (char, lhs_size + rhs_size); - strncpy (result, lhs, lhs_size); - strncpy (result + lhs_size, rhs_start, rhs_size); - return result; -} - -/* Issue the error given by GMSGID, indicating that it occurred before - TOKEN, which had the associated VALUE. */ - -void -c_parse_error (const char *gmsgid, enum cpp_ttype token_type, - tree value, unsigned char token_flags) -{ -#define catenate_messages(M1, M2) catenate_strings ((M1), (M2), sizeof (M2)) - - char *message = NULL; - - if (token_type == CPP_EOF) - message = catenate_messages (gmsgid, " at end of input"); - else if (token_type == CPP_CHAR - || token_type == CPP_WCHAR - || token_type == CPP_CHAR16 - || token_type == CPP_CHAR32) - { - unsigned int val = TREE_INT_CST_LOW (value); - const char *prefix; - - switch (token_type) - { - default: - prefix = ""; - break; - case CPP_WCHAR: - prefix = "L"; - break; - case CPP_CHAR16: - prefix = "u"; - break; - case CPP_CHAR32: - prefix = "U"; - break; - } - - if (val <= UCHAR_MAX && ISGRAPH (val)) - message = catenate_messages (gmsgid, " before %s'%c'"); - else - message = catenate_messages (gmsgid, " before %s'\\x%x'"); - - error (message, prefix, val); - free (message); - message = NULL; - } - else if (token_type == CPP_STRING - || token_type == CPP_WSTRING - || token_type == CPP_STRING16 - || token_type == CPP_STRING32 - || token_type == CPP_UTF8STRING) - message = catenate_messages (gmsgid, " before string constant"); - else if (token_type == CPP_NUMBER) - message = catenate_messages (gmsgid, " before numeric constant"); - else if (token_type == CPP_NAME) - { - message = catenate_messages (gmsgid, " before %qE"); - error (message, value); - free (message); - message = NULL; - } - else if (token_type == CPP_PRAGMA) - message = catenate_messages (gmsgid, " before %<#pragma%>"); - else if (token_type == CPP_PRAGMA_EOL) - message = catenate_messages (gmsgid, " before end of line"); - else if (token_type < N_TTYPES) - { - message = catenate_messages (gmsgid, " before %qs token"); - error (message, cpp_type2name (token_type, token_flags)); - free (message); - message = NULL; - } - else - error (gmsgid); - - if (message) - { - error (message); - free (message); - } -#undef catenate_messages -} - -/* Mapping for cpp message reasons to the options that enable them. */ - -struct reason_option_codes_t -{ - const int reason; /* cpplib message reason. */ - const int option_code; /* gcc option that controls this message. */ -}; - -static const struct reason_option_codes_t option_codes[] = { - {CPP_W_DEPRECATED, OPT_Wdeprecated}, - {CPP_W_COMMENTS, OPT_Wcomments}, - {CPP_W_TRIGRAPHS, OPT_Wtrigraphs}, - {CPP_W_MULTICHAR, OPT_Wmultichar}, - {CPP_W_TRADITIONAL, OPT_Wtraditional}, - {CPP_W_LONG_LONG, OPT_Wlong_long}, - {CPP_W_ENDIF_LABELS, OPT_Wendif_labels}, - {CPP_W_VARIADIC_MACROS, OPT_Wvariadic_macros}, - {CPP_W_BUILTIN_MACRO_REDEFINED, OPT_Wbuiltin_macro_redefined}, - {CPP_W_UNDEF, OPT_Wundef}, - {CPP_W_UNUSED_MACROS, OPT_Wunused_macros}, - {CPP_W_CXX_OPERATOR_NAMES, OPT_Wc___compat}, - {CPP_W_NORMALIZE, OPT_Wnormalized_}, - {CPP_W_INVALID_PCH, OPT_Winvalid_pch}, - {CPP_W_WARNING_DIRECTIVE, OPT_Wcpp}, - {CPP_W_NONE, 0} -}; - -/* Return the gcc option code associated with the reason for a cpp - message, or 0 if none. */ - -static int -c_option_controlling_cpp_error (int reason) -{ - const struct reason_option_codes_t *entry; - - for (entry = option_codes; entry->reason != CPP_W_NONE; entry++) - { - if (entry->reason == reason) - return entry->option_code; - } - return 0; -} - -/* Callback from cpp_error for PFILE to print diagnostics from the - preprocessor. The diagnostic is of type LEVEL, with REASON set - to the reason code if LEVEL is represents a warning, at location - LOCATION unless this is after lexing and the compiler's location - should be used instead, with column number possibly overridden by - COLUMN_OVERRIDE if not zero; MSG is the translated message and AP - the arguments. Returns true if a diagnostic was emitted, false - otherwise. */ - -bool -c_cpp_error (cpp_reader *pfile ATTRIBUTE_UNUSED, int level, int reason, - location_t location, unsigned int column_override, - const char *msg, va_list *ap) -{ - diagnostic_info diagnostic; - diagnostic_t dlevel; - bool save_warn_system_headers = global_dc->warn_system_headers; - bool ret; - - switch (level) - { - case CPP_DL_WARNING_SYSHDR: - if (flag_no_output) - return false; - global_dc->warn_system_headers = 1; - /* Fall through. */ - case CPP_DL_WARNING: - if (flag_no_output) - return false; - dlevel = DK_WARNING; - break; - case CPP_DL_PEDWARN: - if (flag_no_output && !flag_pedantic_errors) - return false; - dlevel = DK_PEDWARN; - break; - case CPP_DL_ERROR: - dlevel = DK_ERROR; - break; - case CPP_DL_ICE: - dlevel = DK_ICE; - break; - case CPP_DL_NOTE: - dlevel = DK_NOTE; - break; - case CPP_DL_FATAL: - dlevel = DK_FATAL; - break; - default: - gcc_unreachable (); - } - if (done_lexing) - location = input_location; - diagnostic_set_info_translated (&diagnostic, msg, ap, - location, dlevel); - if (column_override) - diagnostic_override_column (&diagnostic, column_override); - diagnostic_override_option_index (&diagnostic, - c_option_controlling_cpp_error (reason)); - ret = report_diagnostic (&diagnostic); - if (level == CPP_DL_WARNING_SYSHDR) - global_dc->warn_system_headers = save_warn_system_headers; - return ret; -} - -/* Convert a character from the host to the target execution character - set. cpplib handles this, mostly. */ - -HOST_WIDE_INT -c_common_to_target_charset (HOST_WIDE_INT c) -{ - /* Character constants in GCC proper are sign-extended under -fsigned-char, - zero-extended under -fno-signed-char. cpplib insists that characters - and character constants are always unsigned. Hence we must convert - back and forth. */ - cppchar_t uc = ((cppchar_t)c) & ((((cppchar_t)1) << CHAR_BIT)-1); - - uc = cpp_host_to_exec_charset (parse_in, uc); - - if (flag_signed_char) - return ((HOST_WIDE_INT)uc) << (HOST_BITS_PER_WIDE_INT - CHAR_TYPE_SIZE) - >> (HOST_BITS_PER_WIDE_INT - CHAR_TYPE_SIZE); - else - return uc; -} - -/* Build the result of __builtin_offsetof. EXPR is a nested sequence of - component references, with STOP_REF, or alternatively an INDIRECT_REF of - NULL, at the bottom; much like the traditional rendering of offsetof as a - macro. Returns the folded and properly cast result. */ - -static tree -fold_offsetof_1 (tree expr, tree stop_ref) -{ - enum tree_code code = PLUS_EXPR; - tree base, off, t; - - if (expr == stop_ref && TREE_CODE (expr) != ERROR_MARK) - return size_zero_node; - - switch (TREE_CODE (expr)) - { - case ERROR_MARK: - return expr; - - case VAR_DECL: - error ("cannot apply % to static data member %qD", expr); - return error_mark_node; - - case CALL_EXPR: - case TARGET_EXPR: - error ("cannot apply % when % is overloaded"); - return error_mark_node; - - case NOP_EXPR: - case INDIRECT_REF: - if (!integer_zerop (TREE_OPERAND (expr, 0))) - { - error ("cannot apply % to a non constant address"); - return error_mark_node; - } - return size_zero_node; - - case COMPONENT_REF: - base = fold_offsetof_1 (TREE_OPERAND (expr, 0), stop_ref); - if (base == error_mark_node) - return base; - - t = TREE_OPERAND (expr, 1); - if (DECL_C_BIT_FIELD (t)) - { - error ("attempt to take address of bit-field structure " - "member %qD", t); - return error_mark_node; - } - off = size_binop_loc (input_location, PLUS_EXPR, DECL_FIELD_OFFSET (t), - size_int (tree_low_cst (DECL_FIELD_BIT_OFFSET (t), - 1) - / BITS_PER_UNIT)); - break; - - case ARRAY_REF: - base = fold_offsetof_1 (TREE_OPERAND (expr, 0), stop_ref); - if (base == error_mark_node) - return base; - - t = TREE_OPERAND (expr, 1); - if (TREE_CODE (t) == INTEGER_CST && tree_int_cst_sgn (t) < 0) - { - code = MINUS_EXPR; - t = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (t), t); - } - t = convert (sizetype, t); - off = size_binop (MULT_EXPR, TYPE_SIZE_UNIT (TREE_TYPE (expr)), t); - - /* Check if the offset goes beyond the upper bound of the array. */ - if (code == PLUS_EXPR && TREE_CODE (t) == INTEGER_CST) - { - tree upbound = array_ref_up_bound (expr); - if (upbound != NULL_TREE - && TREE_CODE (upbound) == INTEGER_CST - && !tree_int_cst_equal (upbound, - TYPE_MAX_VALUE (TREE_TYPE (upbound)))) - { - upbound = size_binop (PLUS_EXPR, upbound, - build_int_cst (TREE_TYPE (upbound), 1)); - if (tree_int_cst_lt (upbound, t)) - { - tree v; - - for (v = TREE_OPERAND (expr, 0); - TREE_CODE (v) == COMPONENT_REF; - v = TREE_OPERAND (v, 0)) - if (TREE_CODE (TREE_TYPE (TREE_OPERAND (v, 0))) - == RECORD_TYPE) - { - tree fld_chain = TREE_CHAIN (TREE_OPERAND (v, 1)); - for (; fld_chain; fld_chain = TREE_CHAIN (fld_chain)) - if (TREE_CODE (fld_chain) == FIELD_DECL) - break; - - if (fld_chain) - break; - } - /* Don't warn if the array might be considered a poor - man's flexible array member with a very permissive - definition thereof. */ - if (TREE_CODE (v) == ARRAY_REF - || TREE_CODE (v) == COMPONENT_REF) - warning (OPT_Warray_bounds, - "index %E denotes an offset " - "greater than size of %qT", - t, TREE_TYPE (TREE_OPERAND (expr, 0))); - } - } - } - break; - - case COMPOUND_EXPR: - /* Handle static members of volatile structs. */ - t = TREE_OPERAND (expr, 1); - gcc_assert (TREE_CODE (t) == VAR_DECL); - return fold_offsetof_1 (t, stop_ref); - - default: - gcc_unreachable (); - } - - return size_binop (code, base, off); -} - -tree -fold_offsetof (tree expr, tree stop_ref) -{ - /* Convert back from the internal sizetype to size_t. */ - return convert (size_type_node, fold_offsetof_1 (expr, stop_ref)); -} - -/* Print an error message for an invalid lvalue. USE says - how the lvalue is being used and so selects the error message. */ - -void -lvalue_error (enum lvalue_use use) -{ - switch (use) - { - case lv_assign: - error ("lvalue required as left operand of assignment"); - break; - case lv_increment: - error ("lvalue required as increment operand"); - break; - case lv_decrement: - error ("lvalue required as decrement operand"); - break; - case lv_addressof: - error ("lvalue required as unary %<&%> operand"); - break; - case lv_asm: - error ("lvalue required in asm statement"); - break; - default: - gcc_unreachable (); - } -} - -/* *PTYPE is an incomplete array. Complete it with a domain based on - INITIAL_VALUE. If INITIAL_VALUE is not present, use 1 if DO_DEFAULT - is true. Return 0 if successful, 1 if INITIAL_VALUE can't be deciphered, - 2 if INITIAL_VALUE was NULL, and 3 if INITIAL_VALUE was empty. */ - -int -complete_array_type (tree *ptype, tree initial_value, bool do_default) -{ - tree maxindex, type, main_type, elt, unqual_elt; - int failure = 0, quals; - hashval_t hashcode = 0; - - maxindex = size_zero_node; - if (initial_value) - { - if (TREE_CODE (initial_value) == STRING_CST) - { - int eltsize - = int_size_in_bytes (TREE_TYPE (TREE_TYPE (initial_value))); - maxindex = size_int (TREE_STRING_LENGTH (initial_value)/eltsize - 1); - } - else if (TREE_CODE (initial_value) == CONSTRUCTOR) - { - VEC(constructor_elt,gc) *v = CONSTRUCTOR_ELTS (initial_value); - - if (VEC_empty (constructor_elt, v)) - { - if (pedantic) - failure = 3; - maxindex = integer_minus_one_node; - } - else - { - tree curindex; - unsigned HOST_WIDE_INT cnt; - constructor_elt *ce; - bool fold_p = false; - - if (VEC_index (constructor_elt, v, 0)->index) - maxindex = fold_convert_loc (input_location, sizetype, - VEC_index (constructor_elt, - v, 0)->index); - curindex = maxindex; - - for (cnt = 1; - VEC_iterate (constructor_elt, v, cnt, ce); - cnt++) - { - bool curfold_p = false; - if (ce->index) - curindex = ce->index, curfold_p = true; - else - { - if (fold_p) - curindex = fold_convert (sizetype, curindex); - curindex = size_binop (PLUS_EXPR, curindex, - size_one_node); - } - if (tree_int_cst_lt (maxindex, curindex)) - maxindex = curindex, fold_p = curfold_p; - } - if (fold_p) - maxindex = fold_convert (sizetype, maxindex); - } - } - else - { - /* Make an error message unless that happened already. */ - if (initial_value != error_mark_node) - failure = 1; - } - } - else - { - failure = 2; - if (!do_default) - return failure; - } - - type = *ptype; - elt = TREE_TYPE (type); - quals = TYPE_QUALS (strip_array_types (elt)); - if (quals == 0) - unqual_elt = elt; - else - unqual_elt = c_build_qualified_type (elt, KEEP_QUAL_ADDR_SPACE (quals)); - - /* Using build_distinct_type_copy and modifying things afterward instead - of using build_array_type to create a new type preserves all of the - TYPE_LANG_FLAG_? bits that the front end may have set. */ - main_type = build_distinct_type_copy (TYPE_MAIN_VARIANT (type)); - TREE_TYPE (main_type) = unqual_elt; - TYPE_DOMAIN (main_type) = build_index_type (maxindex); - layout_type (main_type); - - /* Make sure we have the canonical MAIN_TYPE. */ - hashcode = iterative_hash_object (TYPE_HASH (unqual_elt), hashcode); - hashcode = iterative_hash_object (TYPE_HASH (TYPE_DOMAIN (main_type)), - hashcode); - main_type = type_hash_canon (hashcode, main_type); - - /* Fix the canonical type. */ - if (TYPE_STRUCTURAL_EQUALITY_P (TREE_TYPE (main_type)) - || TYPE_STRUCTURAL_EQUALITY_P (TYPE_DOMAIN (main_type))) - SET_TYPE_STRUCTURAL_EQUALITY (main_type); - else if (TYPE_CANONICAL (TREE_TYPE (main_type)) != TREE_TYPE (main_type) - || (TYPE_CANONICAL (TYPE_DOMAIN (main_type)) - != TYPE_DOMAIN (main_type))) - TYPE_CANONICAL (main_type) - = build_array_type (TYPE_CANONICAL (TREE_TYPE (main_type)), - TYPE_CANONICAL (TYPE_DOMAIN (main_type))); - else - TYPE_CANONICAL (main_type) = main_type; - - if (quals == 0) - type = main_type; - else - type = c_build_qualified_type (main_type, quals); - - if (COMPLETE_TYPE_P (type) - && TREE_CODE (TYPE_SIZE_UNIT (type)) == INTEGER_CST - && TREE_OVERFLOW (TYPE_SIZE_UNIT (type))) - { - error ("size of array is too large"); - /* If we proceed with the array type as it is, we'll eventually - crash in tree_low_cst(). */ - type = error_mark_node; - } - - *ptype = type; - return failure; -} - - -/* Used to help initialize the builtin-types.def table. When a type of - the correct size doesn't exist, use error_mark_node instead of NULL. - The later results in segfaults even when a decl using the type doesn't - get invoked. */ - -tree -builtin_type_for_size (int size, bool unsignedp) -{ - tree type = lang_hooks.types.type_for_size (size, unsignedp); - return type ? type : error_mark_node; -} - -/* A helper function for resolve_overloaded_builtin in resolving the - overloaded __sync_ builtins. Returns a positive power of 2 if the - first operand of PARAMS is a pointer to a supported data type. - Returns 0 if an error is encountered. */ - -static int -sync_resolve_size (tree function, VEC(tree,gc) *params) -{ - tree type; - int size; - - if (VEC_empty (tree, params)) - { - error ("too few arguments to function %qE", function); - return 0; - } - - type = TREE_TYPE (VEC_index (tree, params, 0)); - if (TREE_CODE (type) != POINTER_TYPE) - goto incompatible; - - type = TREE_TYPE (type); - if (!INTEGRAL_TYPE_P (type) && !POINTER_TYPE_P (type)) - goto incompatible; - - size = tree_low_cst (TYPE_SIZE_UNIT (type), 1); - if (size == 1 || size == 2 || size == 4 || size == 8 || size == 16) - return size; - - incompatible: - error ("incompatible type for argument %d of %qE", 1, function); - return 0; -} - -/* A helper function for resolve_overloaded_builtin. Adds casts to - PARAMS to make arguments match up with those of FUNCTION. Drops - the variadic arguments at the end. Returns false if some error - was encountered; true on success. */ - -static bool -sync_resolve_params (tree orig_function, tree function, VEC(tree, gc) *params) -{ - tree arg_types = TYPE_ARG_TYPES (TREE_TYPE (function)); - tree ptype; - unsigned int parmnum; - - /* We've declared the implementation functions to use "volatile void *" - as the pointer parameter, so we shouldn't get any complaints from the - call to check_function_arguments what ever type the user used. */ - arg_types = TREE_CHAIN (arg_types); - ptype = TREE_TYPE (TREE_TYPE (VEC_index (tree, params, 0))); - - /* For the rest of the values, we need to cast these to FTYPE, so that we - don't get warnings for passing pointer types, etc. */ - parmnum = 0; - while (arg_types != void_list_node) - { - tree val; - - ++parmnum; - if (VEC_length (tree, params) <= parmnum) - { - error ("too few arguments to function %qE", orig_function); - return false; - } - - /* ??? Ideally for the first conversion we'd use convert_for_assignment - so that we get warnings for anything that doesn't match the pointer - type. This isn't portable across the C and C++ front ends atm. */ - val = VEC_index (tree, params, parmnum); - val = convert (ptype, val); - val = convert (TREE_VALUE (arg_types), val); - VEC_replace (tree, params, parmnum, val); - - arg_types = TREE_CHAIN (arg_types); - } - - /* The definition of these primitives is variadic, with the remaining - being "an optional list of variables protected by the memory barrier". - No clue what that's supposed to mean, precisely, but we consider all - call-clobbered variables to be protected so we're safe. */ - VEC_truncate (tree, params, parmnum + 1); - - return true; -} - -/* A helper function for resolve_overloaded_builtin. Adds a cast to - RESULT to make it match the type of the first pointer argument in - PARAMS. */ - -static tree -sync_resolve_return (tree first_param, tree result) -{ - tree ptype = TREE_TYPE (TREE_TYPE (first_param)); - ptype = TYPE_MAIN_VARIANT (ptype); - return convert (ptype, result); -} - -/* Some builtin functions are placeholders for other expressions. This - function should be called immediately after parsing the call expression - before surrounding code has committed to the type of the expression. - - LOC is the location of the builtin call. - - FUNCTION is the DECL that has been invoked; it is known to be a builtin. - PARAMS is the argument list for the call. The return value is non-null - when expansion is complete, and null if normal processing should - continue. */ - -tree -resolve_overloaded_builtin (location_t loc, tree function, VEC(tree,gc) *params) -{ - enum built_in_function orig_code = DECL_FUNCTION_CODE (function); - switch (DECL_BUILT_IN_CLASS (function)) - { - case BUILT_IN_NORMAL: - break; - case BUILT_IN_MD: - if (targetm.resolve_overloaded_builtin) - return targetm.resolve_overloaded_builtin (loc, function, params); - else - return NULL_TREE; - default: - return NULL_TREE; - } - - /* Handle BUILT_IN_NORMAL here. */ - switch (orig_code) - { - case BUILT_IN_FETCH_AND_ADD_N: - case BUILT_IN_FETCH_AND_SUB_N: - case BUILT_IN_FETCH_AND_OR_N: - case BUILT_IN_FETCH_AND_AND_N: - case BUILT_IN_FETCH_AND_XOR_N: - case BUILT_IN_FETCH_AND_NAND_N: - case BUILT_IN_ADD_AND_FETCH_N: - case BUILT_IN_SUB_AND_FETCH_N: - case BUILT_IN_OR_AND_FETCH_N: - case BUILT_IN_AND_AND_FETCH_N: - case BUILT_IN_XOR_AND_FETCH_N: - case BUILT_IN_NAND_AND_FETCH_N: - case BUILT_IN_BOOL_COMPARE_AND_SWAP_N: - case BUILT_IN_VAL_COMPARE_AND_SWAP_N: - case BUILT_IN_LOCK_TEST_AND_SET_N: - case BUILT_IN_LOCK_RELEASE_N: - { - int n = sync_resolve_size (function, params); - tree new_function, first_param, result; - - if (n == 0) - return error_mark_node; - - new_function = built_in_decls[orig_code + exact_log2 (n) + 1]; - if (!sync_resolve_params (function, new_function, params)) - return error_mark_node; - - first_param = VEC_index (tree, params, 0); - result = build_function_call_vec (loc, new_function, params, NULL); - if (orig_code != BUILT_IN_BOOL_COMPARE_AND_SWAP_N - && orig_code != BUILT_IN_LOCK_RELEASE_N) - result = sync_resolve_return (first_param, result); - - return result; - } - - default: - return NULL_TREE; - } -} - -/* Ignoring their sign, return true if two scalar types are the same. */ -bool -same_scalar_type_ignoring_signedness (tree t1, tree t2) -{ - enum tree_code c1 = TREE_CODE (t1), c2 = TREE_CODE (t2); - - gcc_assert ((c1 == INTEGER_TYPE || c1 == REAL_TYPE || c1 == FIXED_POINT_TYPE) - && (c2 == INTEGER_TYPE || c2 == REAL_TYPE - || c2 == FIXED_POINT_TYPE)); - - /* Equality works here because c_common_signed_type uses - TYPE_MAIN_VARIANT. */ - return c_common_signed_type (t1) - == c_common_signed_type (t2); -} - -/* Check for missing format attributes on function pointers. LTYPE is - the new type or left-hand side type. RTYPE is the old type or - right-hand side type. Returns TRUE if LTYPE is missing the desired - attribute. */ - -bool -check_missing_format_attribute (tree ltype, tree rtype) -{ - tree const ttr = TREE_TYPE (rtype), ttl = TREE_TYPE (ltype); - tree ra; - - for (ra = TYPE_ATTRIBUTES (ttr); ra; ra = TREE_CHAIN (ra)) - if (is_attribute_p ("format", TREE_PURPOSE (ra))) - break; - if (ra) - { - tree la; - for (la = TYPE_ATTRIBUTES (ttl); la; la = TREE_CHAIN (la)) - if (is_attribute_p ("format", TREE_PURPOSE (la))) - break; - return !la; - } - else - return false; -} - -/* Subscripting with type char is likely to lose on a machine where - chars are signed. So warn on any machine, but optionally. Don't - warn for unsigned char since that type is safe. Don't warn for - signed char because anyone who uses that must have done so - deliberately. Furthermore, we reduce the false positive load by - warning only for non-constant value of type char. */ - -void -warn_array_subscript_with_type_char (tree index) -{ - if (TYPE_MAIN_VARIANT (TREE_TYPE (index)) == char_type_node - && TREE_CODE (index) != INTEGER_CST) - warning (OPT_Wchar_subscripts, "array subscript has type %"); -} - -/* Implement -Wparentheses for the unexpected C precedence rules, to - cover cases like x + y << z which readers are likely to - misinterpret. We have seen an expression in which CODE is a binary - operator used to combine expressions ARG_LEFT and ARG_RIGHT, which - before folding had CODE_LEFT and CODE_RIGHT. CODE_LEFT and - CODE_RIGHT may be ERROR_MARK, which means that that side of the - expression was not formed using a binary or unary operator, or it - was enclosed in parentheses. */ - -void -warn_about_parentheses (enum tree_code code, - enum tree_code code_left, tree arg_left, - enum tree_code code_right, tree arg_right) -{ - if (!warn_parentheses) - return; - - /* This macro tests that the expression ARG with original tree code - CODE appears to be a boolean expression. or the result of folding a - boolean expression. */ -#define APPEARS_TO_BE_BOOLEAN_EXPR_P(CODE, ARG) \ - (truth_value_p (TREE_CODE (ARG)) \ - || TREE_CODE (TREE_TYPE (ARG)) == BOOLEAN_TYPE \ - /* Folding may create 0 or 1 integers from other expressions. */ \ - || ((CODE) != INTEGER_CST \ - && (integer_onep (ARG) || integer_zerop (ARG)))) - - switch (code) - { - case LSHIFT_EXPR: - if (code_left == PLUS_EXPR || code_right == PLUS_EXPR) - warning (OPT_Wparentheses, - "suggest parentheses around %<+%> inside %<<<%>"); - else if (code_left == MINUS_EXPR || code_right == MINUS_EXPR) - warning (OPT_Wparentheses, - "suggest parentheses around %<-%> inside %<<<%>"); - return; - - case RSHIFT_EXPR: - if (code_left == PLUS_EXPR || code_right == PLUS_EXPR) - warning (OPT_Wparentheses, - "suggest parentheses around %<+%> inside %<>>%>"); - else if (code_left == MINUS_EXPR || code_right == MINUS_EXPR) - warning (OPT_Wparentheses, - "suggest parentheses around %<-%> inside %<>>%>"); - return; - - case TRUTH_ORIF_EXPR: - if (code_left == TRUTH_ANDIF_EXPR || code_right == TRUTH_ANDIF_EXPR) - warning (OPT_Wparentheses, - "suggest parentheses around %<&&%> within %<||%>"); - return; - - case BIT_IOR_EXPR: - if (code_left == BIT_AND_EXPR || code_left == BIT_XOR_EXPR - || code_left == PLUS_EXPR || code_left == MINUS_EXPR - || code_right == BIT_AND_EXPR || code_right == BIT_XOR_EXPR - || code_right == PLUS_EXPR || code_right == MINUS_EXPR) - warning (OPT_Wparentheses, - "suggest parentheses around arithmetic in operand of %<|%>"); - /* Check cases like x|y==z */ - else if (TREE_CODE_CLASS (code_left) == tcc_comparison - || TREE_CODE_CLASS (code_right) == tcc_comparison) - warning (OPT_Wparentheses, - "suggest parentheses around comparison in operand of %<|%>"); - /* Check cases like !x | y */ - else if (code_left == TRUTH_NOT_EXPR - && !APPEARS_TO_BE_BOOLEAN_EXPR_P (code_right, arg_right)) - warning (OPT_Wparentheses, "suggest parentheses around operand of " - "% or change %<|%> to %<||%> or % to %<~%>"); - return; - - case BIT_XOR_EXPR: - if (code_left == BIT_AND_EXPR - || code_left == PLUS_EXPR || code_left == MINUS_EXPR - || code_right == BIT_AND_EXPR - || code_right == PLUS_EXPR || code_right == MINUS_EXPR) - warning (OPT_Wparentheses, - "suggest parentheses around arithmetic in operand of %<^%>"); - /* Check cases like x^y==z */ - else if (TREE_CODE_CLASS (code_left) == tcc_comparison - || TREE_CODE_CLASS (code_right) == tcc_comparison) - warning (OPT_Wparentheses, - "suggest parentheses around comparison in operand of %<^%>"); - return; - - case BIT_AND_EXPR: - if (code_left == PLUS_EXPR || code_right == PLUS_EXPR) - warning (OPT_Wparentheses, - "suggest parentheses around %<+%> in operand of %<&%>"); - else if (code_left == MINUS_EXPR || code_right == MINUS_EXPR) - warning (OPT_Wparentheses, - "suggest parentheses around %<-%> in operand of %<&%>"); - /* Check cases like x&y==z */ - else if (TREE_CODE_CLASS (code_left) == tcc_comparison - || TREE_CODE_CLASS (code_right) == tcc_comparison) - warning (OPT_Wparentheses, - "suggest parentheses around comparison in operand of %<&%>"); - /* Check cases like !x & y */ - else if (code_left == TRUTH_NOT_EXPR - && !APPEARS_TO_BE_BOOLEAN_EXPR_P (code_right, arg_right)) - warning (OPT_Wparentheses, "suggest parentheses around operand of " - "% or change %<&%> to %<&&%> or % to %<~%>"); - return; - - case EQ_EXPR: - if (TREE_CODE_CLASS (code_left) == tcc_comparison - || TREE_CODE_CLASS (code_right) == tcc_comparison) - warning (OPT_Wparentheses, - "suggest parentheses around comparison in operand of %<==%>"); - return; - case NE_EXPR: - if (TREE_CODE_CLASS (code_left) == tcc_comparison - || TREE_CODE_CLASS (code_right) == tcc_comparison) - warning (OPT_Wparentheses, - "suggest parentheses around comparison in operand of %"); - return; - - default: - if (TREE_CODE_CLASS (code) == tcc_comparison - && ((TREE_CODE_CLASS (code_left) == tcc_comparison - && code_left != NE_EXPR && code_left != EQ_EXPR - && INTEGRAL_TYPE_P (TREE_TYPE (arg_left))) - || (TREE_CODE_CLASS (code_right) == tcc_comparison - && code_right != NE_EXPR && code_right != EQ_EXPR - && INTEGRAL_TYPE_P (TREE_TYPE (arg_right))))) - warning (OPT_Wparentheses, "comparisons like % do not " - "have their mathematical meaning"); - return; - } -#undef NOT_A_BOOLEAN_EXPR_P -} - -/* If LABEL (a LABEL_DECL) has not been used, issue a warning. */ - -void -warn_for_unused_label (tree label) -{ - if (!TREE_USED (label)) - { - if (DECL_INITIAL (label)) - warning (OPT_Wunused_label, "label %q+D defined but not used", label); - else - warning (OPT_Wunused_label, "label %q+D declared but not defined", label); - } -} - -#ifndef TARGET_HAS_TARGETCM -struct gcc_targetcm targetcm = TARGETCM_INITIALIZER; -#endif - -/* Warn for division by zero according to the value of DIVISOR. LOC - is the location of the division operator. */ - -void -warn_for_div_by_zero (location_t loc, tree divisor) -{ - /* If DIVISOR is zero, and has integral or fixed-point type, issue a warning - about division by zero. Do not issue a warning if DIVISOR has a - floating-point type, since we consider 0.0/0.0 a valid way of - generating a NaN. */ - if (c_inhibit_evaluation_warnings == 0 - && (integer_zerop (divisor) || fixed_zerop (divisor))) - warning_at (loc, OPT_Wdiv_by_zero, "division by zero"); -} - -/* Subroutine of build_binary_op. Give warnings for comparisons - between signed and unsigned quantities that may fail. Do the - checking based on the original operand trees ORIG_OP0 and ORIG_OP1, - so that casts will be considered, but default promotions won't - be. - - LOCATION is the location of the comparison operator. - - The arguments of this function map directly to local variables - of build_binary_op. */ - -void -warn_for_sign_compare (location_t location, - tree orig_op0, tree orig_op1, - tree op0, tree op1, - tree result_type, enum tree_code resultcode) -{ - int op0_signed = !TYPE_UNSIGNED (TREE_TYPE (orig_op0)); - int op1_signed = !TYPE_UNSIGNED (TREE_TYPE (orig_op1)); - int unsignedp0, unsignedp1; - - /* In C++, check for comparison of different enum types. */ - if (c_dialect_cxx() - && TREE_CODE (TREE_TYPE (orig_op0)) == ENUMERAL_TYPE - && TREE_CODE (TREE_TYPE (orig_op1)) == ENUMERAL_TYPE - && TYPE_MAIN_VARIANT (TREE_TYPE (orig_op0)) - != TYPE_MAIN_VARIANT (TREE_TYPE (orig_op1))) - { - warning_at (location, - OPT_Wsign_compare, "comparison between types %qT and %qT", - TREE_TYPE (orig_op0), TREE_TYPE (orig_op1)); - } - - /* Do not warn if the comparison is being done in a signed type, - since the signed type will only be chosen if it can represent - all the values of the unsigned type. */ - if (!TYPE_UNSIGNED (result_type)) - /* OK */; - /* Do not warn if both operands are unsigned. */ - else if (op0_signed == op1_signed) - /* OK */; - else - { - tree sop, uop, base_type; - bool ovf; - - if (op0_signed) - sop = orig_op0, uop = orig_op1; - else - sop = orig_op1, uop = orig_op0; - - STRIP_TYPE_NOPS (sop); - STRIP_TYPE_NOPS (uop); - base_type = (TREE_CODE (result_type) == COMPLEX_TYPE - ? TREE_TYPE (result_type) : result_type); - - /* Do not warn if the signed quantity is an unsuffixed integer - literal (or some static constant expression involving such - literals or a conditional expression involving such literals) - and it is non-negative. */ - if (tree_expr_nonnegative_warnv_p (sop, &ovf)) - /* OK */; - /* Do not warn if the comparison is an equality operation, the - unsigned quantity is an integral constant, and it would fit - in the result if the result were signed. */ - else if (TREE_CODE (uop) == INTEGER_CST - && (resultcode == EQ_EXPR || resultcode == NE_EXPR) - && int_fits_type_p (uop, c_common_signed_type (base_type))) - /* OK */; - /* In C, do not warn if the unsigned quantity is an enumeration - constant and its maximum value would fit in the result if the - result were signed. */ - else if (!c_dialect_cxx() && TREE_CODE (uop) == INTEGER_CST - && TREE_CODE (TREE_TYPE (uop)) == ENUMERAL_TYPE - && int_fits_type_p (TYPE_MAX_VALUE (TREE_TYPE (uop)), - c_common_signed_type (base_type))) - /* OK */; - else - warning_at (location, - OPT_Wsign_compare, - "comparison between signed and unsigned integer expressions"); - } - - /* Warn if two unsigned values are being compared in a size larger - than their original size, and one (and only one) is the result of - a `~' operator. This comparison will always fail. - - Also warn if one operand is a constant, and the constant does not - have all bits set that are set in the ~ operand when it is - extended. */ - - op0 = get_narrower (op0, &unsignedp0); - op1 = get_narrower (op1, &unsignedp1); - - if ((TREE_CODE (op0) == BIT_NOT_EXPR) - ^ (TREE_CODE (op1) == BIT_NOT_EXPR)) - { - if (TREE_CODE (op0) == BIT_NOT_EXPR) - op0 = get_narrower (TREE_OPERAND (op0, 0), &unsignedp0); - if (TREE_CODE (op1) == BIT_NOT_EXPR) - op1 = get_narrower (TREE_OPERAND (op1, 0), &unsignedp1); - - if (host_integerp (op0, 0) || host_integerp (op1, 0)) - { - tree primop; - HOST_WIDE_INT constant, mask; - int unsignedp; - unsigned int bits; - - if (host_integerp (op0, 0)) - { - primop = op1; - unsignedp = unsignedp1; - constant = tree_low_cst (op0, 0); - } - else - { - primop = op0; - unsignedp = unsignedp0; - constant = tree_low_cst (op1, 0); - } - - bits = TYPE_PRECISION (TREE_TYPE (primop)); - if (bits < TYPE_PRECISION (result_type) - && bits < HOST_BITS_PER_LONG && unsignedp) - { - mask = (~ (HOST_WIDE_INT) 0) << bits; - if ((mask & constant) != mask) - { - if (constant == 0) - warning (OPT_Wsign_compare, - "promoted ~unsigned is always non-zero"); - else - warning_at (location, OPT_Wsign_compare, - "comparison of promoted ~unsigned with constant"); - } - } - } - else if (unsignedp0 && unsignedp1 - && (TYPE_PRECISION (TREE_TYPE (op0)) - < TYPE_PRECISION (result_type)) - && (TYPE_PRECISION (TREE_TYPE (op1)) - < TYPE_PRECISION (result_type))) - warning_at (location, OPT_Wsign_compare, - "comparison of promoted ~unsigned with unsigned"); - } -} - -/* Setup a TYPE_DECL node as a typedef representation. - - X is a TYPE_DECL for a typedef statement. Create a brand new - ..._TYPE node (which will be just a variant of the existing - ..._TYPE node with identical properties) and then install X - 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. */ - -void -set_underlying_type (tree x) -{ - if (x == error_mark_node) - return; - if (DECL_IS_BUILTIN (x)) - { - if (TYPE_NAME (TREE_TYPE (x)) == 0) - TYPE_NAME (TREE_TYPE (x)) = x; - } - else if (TREE_TYPE (x) != error_mark_node - && DECL_ORIGINAL_TYPE (x) == NULL_TREE) - { - tree tt = TREE_TYPE (x); - DECL_ORIGINAL_TYPE (x) = tt; - tt = build_variant_type_copy (tt); - TYPE_STUB_DECL (tt) = TYPE_STUB_DECL (DECL_ORIGINAL_TYPE (x)); - TYPE_NAME (tt) = x; - TREE_USED (tt) = TREE_USED (x); - TREE_TYPE (x) = tt; - } -} - -/* Returns true if X is a typedef decl. */ - -bool -is_typedef_decl (tree x) -{ - return (x && TREE_CODE (x) == TYPE_DECL - && DECL_ORIGINAL_TYPE (x) != NULL_TREE); -} - -/* Record the types used by the current global variable declaration - being parsed, so that we can decide later to emit their debug info. - Those types are in types_used_by_cur_var_decl, and we are going to - store them in the types_used_by_vars_hash hash table. - DECL is the declaration of the global variable that has been parsed. */ - -void -record_types_used_by_current_var_decl (tree decl) -{ - gcc_assert (decl && DECL_P (decl) && TREE_STATIC (decl)); - - if (types_used_by_cur_var_decl) - { - tree node; - for (node = types_used_by_cur_var_decl; - node; - node = TREE_CHAIN (node)) - { - tree type = TREE_PURPOSE (node); - types_used_by_var_decl_insert (type, decl); - } - types_used_by_cur_var_decl = NULL; - } -} - -/* The C and C++ parsers both use vectors to hold function arguments. - For efficiency, we keep a cache of unused vectors. This is the - cache. */ - -typedef VEC(tree,gc)* tree_gc_vec; -DEF_VEC_P(tree_gc_vec); -DEF_VEC_ALLOC_P(tree_gc_vec,gc); -static GTY((deletable)) VEC(tree_gc_vec,gc) *tree_vector_cache; - -/* Return a new vector from the cache. If the cache is empty, - allocate a new vector. These vectors are GC'ed, so it is OK if the - pointer is not released.. */ - -VEC(tree,gc) * -make_tree_vector (void) -{ - if (!VEC_empty (tree_gc_vec, tree_vector_cache)) - return VEC_pop (tree_gc_vec, tree_vector_cache); - else - { - /* Passing 0 to VEC_alloc returns NULL, and our callers require - that we always return a non-NULL value. The vector code uses - 4 when growing a NULL vector, so we do too. */ - return VEC_alloc (tree, gc, 4); - } -} - -/* Release a vector of trees back to the cache. */ - -void -release_tree_vector (VEC(tree,gc) *vec) -{ - if (vec != NULL) - { - VEC_truncate (tree, vec, 0); - VEC_safe_push (tree_gc_vec, gc, tree_vector_cache, vec); - } -} - -/* Get a new tree vector holding a single tree. */ - -VEC(tree,gc) * -make_tree_vector_single (tree t) -{ - VEC(tree,gc) *ret = make_tree_vector (); - VEC_quick_push (tree, ret, t); - return ret; -} - -/* Get a new tree vector which is a copy of an existing one. */ - -VEC(tree,gc) * -make_tree_vector_copy (const VEC(tree,gc) *orig) -{ - VEC(tree,gc) *ret; - unsigned int ix; - tree t; - - ret = make_tree_vector (); - VEC_reserve (tree, gc, ret, VEC_length (tree, orig)); - for (ix = 0; VEC_iterate (tree, orig, ix, t); ++ix) - VEC_quick_push (tree, ret, t); - return ret; -} - -#include "gt-c-common.h" diff --git a/gcc/c-common.def b/gcc/c-common.def deleted file mode 100644 index 1c593633e12..00000000000 --- a/gcc/c-common.def +++ /dev/null @@ -1,53 +0,0 @@ -/* This file contains the definitions and documentation for the - additional tree codes used in the GNU C compiler (see tree.def - for the standard codes). - Copyright (C) 1987, 1988, 1990, 1993, 1997, 1998, - 1999, 2000, 2001, 2004, 2005, 2007, 2009 Free Software Foundation, Inc. - Written by Benjamin Chelf - -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 3, 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 COPYING3. If not see -. */ - -/* Tree nodes used in the C frontend. These are also shared with the - C++ and Objective C frontends. */ - -/* A C_MAYBE_CONST_EXPR, currently only used for C and Objective C, - tracks information about constancy of an expression and VLA type - sizes or VM expressions from typeof that need to be evaluated - before the main expression. It is used during parsing and removed - in c_fully_fold. C_MAYBE_CONST_EXPR_PRE is the expression to - evaluate first, if not NULL; C_MAYBE_CONST_EXPR_EXPR is the main - expression. If C_MAYBE_CONST_EXPR_INT_OPERANDS is set then the - expression may be used in an unevaluated part of an integer - constant expression, but not in an evaluated part. If - C_MAYBE_CONST_EXPR_NON_CONST is set then the expression contains - something that cannot occur in an evaluated part of a constant - expression (or outside of sizeof in C90 mode); otherwise it does - not. */ -DEFTREECODE (C_MAYBE_CONST_EXPR, "c_maybe_const_expr", tcc_expression, 2) - -/* An EXCESS_PRECISION_EXPR, currently only used for C and Objective - C, represents an expression evaluated in greater range or precision - than its type. The type of the EXCESS_PRECISION_EXPR is the - semantic type while the operand represents what is actually being - evaluated. */ -DEFTREECODE (EXCESS_PRECISION_EXPR, "excess_precision_expr", tcc_expression, 1) - -/* -Local variables: -mode:c -End: -*/ diff --git a/gcc/c-common.h b/gcc/c-common.h deleted file mode 100644 index f0541e92721..00000000000 --- a/gcc/c-common.h +++ /dev/null @@ -1,1191 +0,0 @@ -/* Definitions for c-common.c. - Copyright (C) 1987, 1993, 1994, 1995, 1997, 1998, - 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009 - 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 3, 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 COPYING3. If not see -. */ - -#ifndef GCC_C_COMMON_H -#define GCC_C_COMMON_H - -#include "splay-tree.h" -#include "cpplib.h" -#include "ggc.h" - -/* In order for the format checking to accept the C frontend - diagnostic framework extensions, you must include this file before - toplev.h, not after. The C front end formats are a subset of those - for C++, so they are the appropriate set to use in common code; - cp-tree.h overrides this for C++. */ -#ifndef GCC_DIAG_STYLE -#define GCC_DIAG_STYLE __gcc_cdiag__ -#endif -#include "diagnostic-core.h" - -/* Usage of TREE_LANG_FLAG_?: - 0: TREE_NEGATED_INT (in INTEGER_CST). - IDENTIFIER_MARKED (used by search routines). - DECL_PRETTY_FUNCTION_P (in VAR_DECL) - C_MAYBE_CONST_EXPR_INT_OPERANDS (in C_MAYBE_CONST_EXPR, for C) - 1: C_DECLARED_LABEL_FLAG (in LABEL_DECL) - STATEMENT_LIST_STMT_EXPR (in STATEMENT_LIST) - C_MAYBE_CONST_EXPR_NON_CONST (in C_MAYBE_CONST_EXPR, for C) - 2: unused - 3: STATEMENT_LIST_HAS_LABEL (in STATEMENT_LIST) - 4: unused -*/ - -/* Reserved identifiers. This is the union of all the keywords for C, - C++, and Objective-C. All the type modifiers have to be in one - block at the beginning, because they are used as mask bits. There - are 27 type modifiers; if we add many more we will have to redesign - the mask mechanism. */ - -enum rid -{ - /* Modifiers: */ - /* C, in empirical order of frequency. */ - RID_STATIC = 0, - RID_UNSIGNED, RID_LONG, RID_CONST, RID_EXTERN, - RID_REGISTER, RID_TYPEDEF, RID_SHORT, RID_INLINE, - RID_VOLATILE, RID_SIGNED, RID_AUTO, RID_RESTRICT, - - /* C extensions */ - RID_COMPLEX, RID_THREAD, RID_SAT, - - /* C++ */ - RID_FRIEND, RID_VIRTUAL, RID_EXPLICIT, RID_EXPORT, RID_MUTABLE, - - /* ObjC */ - RID_IN, RID_OUT, RID_INOUT, RID_BYCOPY, RID_BYREF, RID_ONEWAY, - - /* C (reserved and imaginary types not implemented, so any use is a - syntax error) */ - RID_IMAGINARY, - - /* C */ - RID_INT, RID_CHAR, RID_FLOAT, RID_DOUBLE, RID_VOID, - RID_INT128, - RID_ENUM, RID_STRUCT, RID_UNION, RID_IF, RID_ELSE, - RID_WHILE, RID_DO, RID_FOR, RID_SWITCH, RID_CASE, - RID_DEFAULT, RID_BREAK, RID_CONTINUE, RID_RETURN, RID_GOTO, - RID_SIZEOF, - - /* C extensions */ - RID_ASM, RID_TYPEOF, RID_ALIGNOF, RID_ATTRIBUTE, RID_VA_ARG, - RID_EXTENSION, RID_IMAGPART, RID_REALPART, RID_LABEL, RID_CHOOSE_EXPR, - RID_TYPES_COMPATIBLE_P, - RID_DFLOAT32, RID_DFLOAT64, RID_DFLOAT128, - RID_FRACT, RID_ACCUM, - - /* This means to warn that this is a C++ keyword, and then treat it - as a normal identifier. */ - RID_CXX_COMPAT_WARN, - - /* Too many ways of getting the name of a function as a string */ - RID_FUNCTION_NAME, RID_PRETTY_FUNCTION_NAME, RID_C99_FUNCTION_NAME, - - /* C++ */ - RID_BOOL, RID_WCHAR, RID_CLASS, - RID_PUBLIC, RID_PRIVATE, RID_PROTECTED, - RID_TEMPLATE, RID_NULL, RID_CATCH, - RID_DELETE, RID_FALSE, RID_NAMESPACE, - RID_NEW, RID_OFFSETOF, RID_OPERATOR, - RID_THIS, RID_THROW, RID_TRUE, - RID_TRY, RID_TYPENAME, RID_TYPEID, - RID_USING, RID_CHAR16, RID_CHAR32, - - /* casts */ - RID_CONSTCAST, RID_DYNCAST, RID_REINTCAST, RID_STATCAST, - - /* C++ extensions */ - RID_HAS_NOTHROW_ASSIGN, RID_HAS_NOTHROW_CONSTRUCTOR, - RID_HAS_NOTHROW_COPY, RID_HAS_TRIVIAL_ASSIGN, - RID_HAS_TRIVIAL_CONSTRUCTOR, RID_HAS_TRIVIAL_COPY, - RID_HAS_TRIVIAL_DESTRUCTOR, RID_HAS_VIRTUAL_DESTRUCTOR, - RID_IS_ABSTRACT, RID_IS_BASE_OF, - RID_IS_CONVERTIBLE_TO, RID_IS_CLASS, - RID_IS_EMPTY, RID_IS_ENUM, - RID_IS_POD, RID_IS_POLYMORPHIC, - RID_IS_STD_LAYOUT, RID_IS_TRIVIAL, - RID_IS_UNION, - - /* C++0x */ - RID_CONSTEXPR, RID_DECLTYPE, RID_NULLPTR, RID_STATIC_ASSERT, - - /* Objective-C */ - RID_AT_ENCODE, RID_AT_END, - RID_AT_CLASS, RID_AT_ALIAS, RID_AT_DEFS, - RID_AT_PRIVATE, RID_AT_PROTECTED, RID_AT_PUBLIC, - RID_AT_PROTOCOL, RID_AT_SELECTOR, - RID_AT_THROW, RID_AT_TRY, RID_AT_CATCH, - RID_AT_FINALLY, RID_AT_SYNCHRONIZED, - RID_AT_INTERFACE, - RID_AT_IMPLEMENTATION, - - /* Named address support, mapping the keyword to a particular named address - number. Named address space 0 is reserved for the generic address. If - there are more than 254 named addresses, the addr_space_t type will need - to be grown from an unsigned char to unsigned short. */ - RID_ADDR_SPACE_0, /* generic address */ - RID_ADDR_SPACE_1, - RID_ADDR_SPACE_2, - RID_ADDR_SPACE_3, - RID_ADDR_SPACE_4, - RID_ADDR_SPACE_5, - RID_ADDR_SPACE_6, - RID_ADDR_SPACE_7, - RID_ADDR_SPACE_8, - RID_ADDR_SPACE_9, - RID_ADDR_SPACE_10, - RID_ADDR_SPACE_11, - RID_ADDR_SPACE_12, - RID_ADDR_SPACE_13, - RID_ADDR_SPACE_14, - RID_ADDR_SPACE_15, - - RID_FIRST_ADDR_SPACE = RID_ADDR_SPACE_0, - RID_LAST_ADDR_SPACE = RID_ADDR_SPACE_15, - - RID_MAX, - - RID_FIRST_MODIFIER = RID_STATIC, - RID_LAST_MODIFIER = RID_ONEWAY, - - RID_FIRST_CXX0X = RID_CONSTEXPR, - RID_LAST_CXX0X = RID_STATIC_ASSERT, - RID_FIRST_AT = RID_AT_ENCODE, - RID_LAST_AT = RID_AT_IMPLEMENTATION, - RID_FIRST_PQ = RID_IN, - RID_LAST_PQ = RID_ONEWAY -}; - -#define OBJC_IS_AT_KEYWORD(rid) \ - ((unsigned int) (rid) >= (unsigned int) RID_FIRST_AT && \ - (unsigned int) (rid) <= (unsigned int) RID_LAST_AT) - -#define OBJC_IS_PQ_KEYWORD(rid) \ - ((unsigned int) (rid) >= (unsigned int) RID_FIRST_PQ && \ - (unsigned int) (rid) <= (unsigned int) RID_LAST_PQ) - -/* The elements of `ridpointers' are identifier nodes for the reserved - type names and storage classes. It is indexed by a RID_... value. */ -extern GTY ((length ("(int) RID_MAX"))) tree *ridpointers; - -/* Standard named or nameless data types of the C compiler. */ - -enum c_tree_index -{ - CTI_CHAR16_TYPE, - CTI_CHAR32_TYPE, - CTI_WCHAR_TYPE, - CTI_UNDERLYING_WCHAR_TYPE, - CTI_WINT_TYPE, - CTI_SIGNED_SIZE_TYPE, /* For format checking only. */ - CTI_UNSIGNED_PTRDIFF_TYPE, /* For format checking only. */ - CTI_INTMAX_TYPE, - CTI_UINTMAX_TYPE, - CTI_WIDEST_INT_LIT_TYPE, - CTI_WIDEST_UINT_LIT_TYPE, - - /* Types for , that may not be defined on all - targets. */ - CTI_SIG_ATOMIC_TYPE, - CTI_INT8_TYPE, - CTI_INT16_TYPE, - CTI_INT32_TYPE, - CTI_INT64_TYPE, - CTI_UINT8_TYPE, - CTI_UINT16_TYPE, - CTI_UINT32_TYPE, - CTI_UINT64_TYPE, - CTI_INT_LEAST8_TYPE, - CTI_INT_LEAST16_TYPE, - CTI_INT_LEAST32_TYPE, - CTI_INT_LEAST64_TYPE, - CTI_UINT_LEAST8_TYPE, - CTI_UINT_LEAST16_TYPE, - CTI_UINT_LEAST32_TYPE, - CTI_UINT_LEAST64_TYPE, - CTI_INT_FAST8_TYPE, - CTI_INT_FAST16_TYPE, - CTI_INT_FAST32_TYPE, - CTI_INT_FAST64_TYPE, - CTI_UINT_FAST8_TYPE, - CTI_UINT_FAST16_TYPE, - CTI_UINT_FAST32_TYPE, - CTI_UINT_FAST64_TYPE, - CTI_INTPTR_TYPE, - CTI_UINTPTR_TYPE, - - CTI_CHAR_ARRAY_TYPE, - CTI_CHAR16_ARRAY_TYPE, - CTI_CHAR32_ARRAY_TYPE, - CTI_WCHAR_ARRAY_TYPE, - CTI_INT_ARRAY_TYPE, - CTI_STRING_TYPE, - CTI_CONST_STRING_TYPE, - - /* Type for boolean expressions (bool in C++, int in C). */ - CTI_TRUTHVALUE_TYPE, - CTI_TRUTHVALUE_TRUE, - CTI_TRUTHVALUE_FALSE, - - CTI_DEFAULT_FUNCTION_TYPE, - - /* These are not types, but we have to look them up all the time. */ - CTI_FUNCTION_NAME_DECL, - CTI_PRETTY_FUNCTION_NAME_DECL, - CTI_C99_FUNCTION_NAME_DECL, - CTI_SAVED_FUNCTION_NAME_DECLS, - - CTI_VOID_ZERO, - - CTI_NULL, - - CTI_MAX -}; - -#define C_CPP_HASHNODE(id) \ - (&(((struct c_common_identifier *) (id))->node)) -#define C_RID_CODE(id) \ - ((enum rid) (((struct c_common_identifier *) (id))->node.rid_code)) -#define C_SET_RID_CODE(id, code) \ - (((struct c_common_identifier *) (id))->node.rid_code = (unsigned char) code) - -/* Identifier part common to the C front ends. Inherits from - tree_identifier, despite appearances. */ -struct GTY(()) c_common_identifier { - struct tree_common common; - struct cpp_hashnode node; -}; - -/* An entry in the reserved keyword table. */ - -struct c_common_resword -{ - const char *const word; - ENUM_BITFIELD(rid) const rid : 16; - const unsigned int disable : 16; -}; - -/* Disable mask. Keywords are disabled if (reswords[i].disable & - mask) is _true_. Thus for keywords which are present in all - languages the disable field is zero. */ - -#define D_CONLY 0x001 /* C only (not in C++). */ -#define D_CXXONLY 0x002 /* C++ only (not in C). */ -#define D_C99 0x004 /* In C, C99 only. */ -#define D_CXX0X 0x008 /* In C++, C++0X only. */ -#define D_EXT 0x010 /* GCC extension. */ -#define D_EXT89 0x020 /* GCC extension incorporated in C99. */ -#define D_ASM 0x040 /* Disabled by -fno-asm. */ -#define D_OBJC 0x080 /* In Objective C and neither C nor C++. */ -#define D_CXX_OBJC 0x100 /* In Objective C, and C++, but not C. */ -#define D_CXXWARN 0x200 /* In C warn with -Wcxx-compat. */ - -/* The reserved keyword table. */ -extern const struct c_common_resword c_common_reswords[]; - -/* The number of items in the reserved keyword table. */ -extern const unsigned int num_c_common_reswords; - -#define char16_type_node c_global_trees[CTI_CHAR16_TYPE] -#define char32_type_node c_global_trees[CTI_CHAR32_TYPE] -#define wchar_type_node c_global_trees[CTI_WCHAR_TYPE] -#define underlying_wchar_type_node c_global_trees[CTI_UNDERLYING_WCHAR_TYPE] -#define wint_type_node c_global_trees[CTI_WINT_TYPE] -#define signed_size_type_node c_global_trees[CTI_SIGNED_SIZE_TYPE] -#define unsigned_ptrdiff_type_node c_global_trees[CTI_UNSIGNED_PTRDIFF_TYPE] -#define intmax_type_node c_global_trees[CTI_INTMAX_TYPE] -#define uintmax_type_node c_global_trees[CTI_UINTMAX_TYPE] -#define widest_integer_literal_type_node c_global_trees[CTI_WIDEST_INT_LIT_TYPE] -#define widest_unsigned_literal_type_node c_global_trees[CTI_WIDEST_UINT_LIT_TYPE] - -#define sig_atomic_type_node c_global_trees[CTI_SIG_ATOMIC_TYPE] -#define int8_type_node c_global_trees[CTI_INT8_TYPE] -#define int16_type_node c_global_trees[CTI_INT16_TYPE] -#define int32_type_node c_global_trees[CTI_INT32_TYPE] -#define int64_type_node c_global_trees[CTI_INT64_TYPE] -#define uint8_type_node c_global_trees[CTI_UINT8_TYPE] -#define uint16_type_node c_global_trees[CTI_UINT16_TYPE] -#define c_uint32_type_node c_global_trees[CTI_UINT32_TYPE] -#define c_uint64_type_node c_global_trees[CTI_UINT64_TYPE] -#define int_least8_type_node c_global_trees[CTI_INT_LEAST8_TYPE] -#define int_least16_type_node c_global_trees[CTI_INT_LEAST16_TYPE] -#define int_least32_type_node c_global_trees[CTI_INT_LEAST32_TYPE] -#define int_least64_type_node c_global_trees[CTI_INT_LEAST64_TYPE] -#define uint_least8_type_node c_global_trees[CTI_UINT_LEAST8_TYPE] -#define uint_least16_type_node c_global_trees[CTI_UINT_LEAST16_TYPE] -#define uint_least32_type_node c_global_trees[CTI_UINT_LEAST32_TYPE] -#define uint_least64_type_node c_global_trees[CTI_UINT_LEAST64_TYPE] -#define int_fast8_type_node c_global_trees[CTI_INT_FAST8_TYPE] -#define int_fast16_type_node c_global_trees[CTI_INT_FAST16_TYPE] -#define int_fast32_type_node c_global_trees[CTI_INT_FAST32_TYPE] -#define int_fast64_type_node c_global_trees[CTI_INT_FAST64_TYPE] -#define uint_fast8_type_node c_global_trees[CTI_UINT_FAST8_TYPE] -#define uint_fast16_type_node c_global_trees[CTI_UINT_FAST16_TYPE] -#define uint_fast32_type_node c_global_trees[CTI_UINT_FAST32_TYPE] -#define uint_fast64_type_node c_global_trees[CTI_UINT_FAST64_TYPE] -#define intptr_type_node c_global_trees[CTI_INTPTR_TYPE] -#define uintptr_type_node c_global_trees[CTI_UINTPTR_TYPE] - -#define truthvalue_type_node c_global_trees[CTI_TRUTHVALUE_TYPE] -#define truthvalue_true_node c_global_trees[CTI_TRUTHVALUE_TRUE] -#define truthvalue_false_node c_global_trees[CTI_TRUTHVALUE_FALSE] - -#define char_array_type_node c_global_trees[CTI_CHAR_ARRAY_TYPE] -#define char16_array_type_node c_global_trees[CTI_CHAR16_ARRAY_TYPE] -#define char32_array_type_node c_global_trees[CTI_CHAR32_ARRAY_TYPE] -#define wchar_array_type_node c_global_trees[CTI_WCHAR_ARRAY_TYPE] -#define int_array_type_node c_global_trees[CTI_INT_ARRAY_TYPE] -#define string_type_node c_global_trees[CTI_STRING_TYPE] -#define const_string_type_node c_global_trees[CTI_CONST_STRING_TYPE] - -#define default_function_type c_global_trees[CTI_DEFAULT_FUNCTION_TYPE] - -#define function_name_decl_node c_global_trees[CTI_FUNCTION_NAME_DECL] -#define pretty_function_name_decl_node c_global_trees[CTI_PRETTY_FUNCTION_NAME_DECL] -#define c99_function_name_decl_node c_global_trees[CTI_C99_FUNCTION_NAME_DECL] -#define saved_function_name_decls c_global_trees[CTI_SAVED_FUNCTION_NAME_DECLS] - -/* A node for `((void) 0)'. */ -#define void_zero_node c_global_trees[CTI_VOID_ZERO] - -/* The node for C++ `__null'. */ -#define null_node c_global_trees[CTI_NULL] - -extern GTY(()) tree c_global_trees[CTI_MAX]; - -/* In a RECORD_TYPE, a sorted array of the fields of the type, not a - tree for size reasons. */ -struct GTY(()) sorted_fields_type { - int len; - tree GTY((length ("%h.len"))) elts[1]; -}; - -/* Mark which labels are explicitly declared. - These may be shadowed, and may be referenced from nested functions. */ -#define C_DECLARED_LABEL_FLAG(label) TREE_LANG_FLAG_1 (label) - -typedef enum c_language_kind -{ - clk_c = 0, /* C90, C94 or C99 */ - clk_objc = 1, /* clk_c with ObjC features. */ - clk_cxx = 2, /* ANSI/ISO C++ */ - clk_objcxx = 3 /* clk_cxx with ObjC features. */ -} -c_language_kind; - -/* To test for a specific language use c_language, defined by each - front end. For "ObjC features" or "not C++" use the macros. */ -extern c_language_kind c_language; - -#define c_dialect_cxx() ((c_language & clk_cxx) != 0) -#define c_dialect_objc() ((c_language & clk_objc) != 0) - -/* The various name of operator that appears in error messages. */ -typedef enum ref_operator { - /* NULL */ - RO_NULL, - /* array indexing */ - RO_ARRAY_INDEXING, - /* unary * */ - RO_UNARY_STAR, - /* -> */ - RO_ARROW, - /* implicit conversion */ - RO_IMPLICIT_CONVERSION -} ref_operator; - -/* Information about a statement tree. */ - -struct GTY(()) stmt_tree_s { - /* The current statement list being collected. */ - tree x_cur_stmt_list; - - /* In C++, Nonzero if we should treat statements as full - expressions. In particular, this variable is no-zero if at the - end of a statement we should destroy any temporaries created - during that statement. Similarly, if, at the end of a block, we - should destroy any local variables in this block. Normally, this - variable is nonzero, since those are the normal semantics of - C++. - - However, in order to represent aggregate initialization code as - tree structure, we use statement-expressions. The statements - within the statement expression should not result in cleanups - being run until the entire enclosing statement is complete. - - This flag has no effect in C. */ - int stmts_are_full_exprs_p; -}; - -typedef struct stmt_tree_s *stmt_tree; - -/* Global state pertinent to the current function. Some C dialects - extend this structure with additional fields. */ - -struct GTY(()) c_language_function { - /* While we are parsing the function, this contains information - about the statement-tree that we are building. */ - struct stmt_tree_s x_stmt_tree; -}; - -/* When building a statement-tree, this is the current statement list - being collected. It's TREE_CHAIN is a back-pointer to the previous - statement list. */ - -#define cur_stmt_list (current_stmt_tree ()->x_cur_stmt_list) - -/* Language-specific hooks. */ - -/* If non-NULL, this function is called after a precompile header file - is loaded. */ -extern void (*lang_post_pch_load) (void); - -extern void push_file_scope (void); -extern void pop_file_scope (void); -extern stmt_tree current_stmt_tree (void); -extern tree push_stmt_list (void); -extern tree pop_stmt_list (tree); -extern tree add_stmt (tree); -extern void push_cleanup (tree, tree, bool); -extern tree pushdecl_top_level (tree); -extern tree pushdecl (tree); -extern tree build_modify_expr (location_t, tree, tree, enum tree_code, - location_t, tree, tree); -extern tree build_indirect_ref (location_t, tree, ref_operator); - -extern int c_expand_decl (tree); - -extern int field_decl_cmp (const void *, const void *); -extern void resort_sorted_fields (void *, void *, gt_pointer_operator, - void *); -extern bool has_c_linkage (const_tree decl); - -/* Switches common to the C front ends. */ - -/* Nonzero if prepreprocessing only. */ - -extern int flag_preprocess_only; - -/* Zero means that faster, ...NonNil variants of objc_msgSend... - calls will be used in ObjC; passing nil receivers to such calls - will most likely result in crashes. */ -extern int flag_nil_receivers; - -/* Nonzero means that we will allow new ObjC exception syntax (@throw, - @try, etc.) in source code. */ -extern int flag_objc_exceptions; - -/* Nonzero means that we generate NeXT setjmp based exceptions. */ -extern int flag_objc_sjlj_exceptions; - -/* Nonzero means that code generation will be altered to support - "zero-link" execution. This currently affects ObjC only, but may - affect other languages in the future. */ -extern int flag_zero_link; - -/* Nonzero means emit an '__OBJC, __image_info' for the current translation - unit. It will inform the ObjC runtime that class definition(s) herein - contained are to replace one(s) previously loaded. */ -extern int flag_replace_objc_classes; - -/* Nonzero means don't output line number information. */ - -extern char flag_no_line_commands; - -/* Nonzero causes -E output not to be done, but directives such as - #define that have side effects are still obeyed. */ - -extern char flag_no_output; - -/* Nonzero means dump macros in some fashion; contains the 'D', 'M', - 'N' or 'U' of the command line switch. */ - -extern char flag_dump_macros; - -/* Nonzero means pass #include lines through to the output. */ - -extern char flag_dump_includes; - -/* Nonzero means process PCH files while preprocessing. */ - -extern bool flag_pch_preprocess; - -/* The file name to which we should write a precompiled header, or - NULL if no header will be written in this compile. */ - -extern const char *pch_file; - -/* Nonzero if an ISO standard was selected. It rejects macros in the - user's namespace. */ - -extern int flag_iso; - -/* Nonzero if -undef was given. It suppresses target built-in macros - and assertions. */ - -extern int flag_undef; - -/* Nonzero means don't recognize the non-ANSI builtin functions. */ - -extern int flag_no_builtin; - -/* Nonzero means don't recognize the non-ANSI builtin functions. - -ansi sets this. */ - -extern int flag_no_nonansi_builtin; - -/* Nonzero means give `double' the same size as `float'. */ - -extern int flag_short_double; - -/* Nonzero means give `wchar_t' the same size as `short'. */ - -extern int flag_short_wchar; - -/* Nonzero means allow implicit conversions between vectors with - differing numbers of subparts and/or differing element types. */ -extern int flag_lax_vector_conversions; - -/* Nonzero means allow Microsoft extensions without warnings or errors. */ -extern int flag_ms_extensions; - -/* Nonzero means don't recognize the keyword `asm'. */ - -extern int flag_no_asm; - -/* Nonzero means give string constants the type `const char *', as mandated - by the standard. */ - -extern int flag_const_strings; - -/* Nonzero means to treat bitfields as signed unless they say `unsigned'. */ - -extern int flag_signed_bitfields; - -/* Warn about #pragma directives that are not recognized. */ - -extern int warn_unknown_pragmas; /* Tri state variable. */ - -/* Warn about format/argument anomalies in calls to formatted I/O functions - (*printf, *scanf, strftime, strfmon, etc.). */ - -extern int warn_format; - - -/* C/ObjC language option variables. */ - - -/* Nonzero means allow type mismatches in conditional expressions; - just make their values `void'. */ - -extern int flag_cond_mismatch; - -/* Nonzero means enable C89 Amendment 1 features. */ - -extern int flag_isoc94; - -/* Nonzero means use the ISO C99 (or C1X) dialect of C. */ - -extern int flag_isoc99; - -/* Nonzero means use the ISO C1X dialect of C. */ - -extern int flag_isoc1x; - -/* Nonzero means that we have builtin functions, and main is an int. */ - -extern int flag_hosted; - -/* ObjC language option variables. */ - - -/* Open and close the file for outputting class declarations, if - requested (ObjC). */ - -extern int flag_gen_declaration; - -/* Tells the compiler that this is a special run. Do not perform any - compiling, instead we are to test some platform dependent features - and output a C header file with appropriate definitions. */ - -extern int print_struct_values; - -/* ???. Undocumented. */ - -extern const char *constant_string_class_name; - - -/* C++ language option variables. */ - - -/* Nonzero means don't recognize any extension keywords. */ - -extern int flag_no_gnu_keywords; - -/* Nonzero means do emit exported implementations of functions even if - they can be inlined. */ - -extern int flag_implement_inlines; - -/* Nonzero means that implicit instantiations will be emitted if needed. */ - -extern int flag_implicit_templates; - -/* Nonzero means that implicit instantiations of inline templates will be - emitted if needed, even if instantiations of non-inline templates - aren't. */ - -extern int flag_implicit_inline_templates; - -/* Nonzero means generate separate instantiation control files and - juggle them at link time. */ - -extern int flag_use_repository; - -/* Nonzero if we want to issue diagnostics that the standard says are not - required. */ - -extern int flag_optional_diags; - -/* Nonzero means we should attempt to elide constructors when possible. */ - -extern int flag_elide_constructors; - -/* Nonzero means that member functions defined in class scope are - inline by default. */ - -extern int flag_default_inline; - -/* Controls whether compiler generates 'type descriptor' that give - run-time type information. */ - -extern int flag_rtti; - -/* Nonzero if we want to conserve space in the .o files. We do this - by putting uninitialized data and runtime initialized data into - .common instead of .data at the expense of not flagging multiple - definitions. */ - -extern int flag_conserve_space; - -/* Nonzero if we want to obey access control semantics. */ - -extern int flag_access_control; - -/* Nonzero if we want to check the return value of new and avoid calling - constructors if it is a null pointer. */ - -extern int flag_check_new; - -/* The supported C++ dialects. */ - -enum cxx_dialect { - /* C++98 */ - cxx98, - /* Experimental features that are likely to become part of - C++0x. */ - cxx0x -}; - -/* The C++ dialect being used. C++98 is the default. */ -extern enum cxx_dialect cxx_dialect; - -/* Nonzero if we want the new ISO rules for pushing a new scope for `for' - initialization variables. - 0: Old rules, set by -fno-for-scope. - 2: New ISO rules, set by -ffor-scope. - 1: Try to implement new ISO rules, but with backup compatibility - (and warnings). This is the default, for now. */ - -extern int flag_new_for_scope; - -/* Nonzero if we want to emit defined symbols with common-like linkage as - weak symbols where possible, in order to conform to C++ semantics. - Otherwise, emit them as local symbols. */ - -extern int flag_weak; - -/* 0 means we want the preprocessor to not emit line directives for - the current working directory. 1 means we want it to do it. -1 - means we should decide depending on whether debugging information - is being emitted or not. */ - -extern int flag_working_directory; - -/* Nonzero to use __cxa_atexit, rather than atexit, to register - destructors for local statics and global objects. */ - -extern int flag_use_cxa_atexit; - -/* Nonzero to use __cxa_get_exception_ptr in the C++ exception-handling - logic. */ - -extern int flag_use_cxa_get_exception_ptr; - -/* Nonzero means to implement standard semantics for exception - specifications, calling unexpected if an exception is thrown that - doesn't match the specification. Zero means to treat them as - assertions and optimize accordingly, but not check them. */ - -extern int flag_enforce_eh_specs; - -/* Nonzero (the default) means to generate thread-safe code for - initializing local statics. */ - -extern int flag_threadsafe_statics; - -/* Nonzero if we want to pretty-print template specializations as the - template signature followed by the arguments. */ - -extern int flag_pretty_templates; - -/* Warn about using __null (as NULL in C++) as sentinel. For code compiled - with GCC this doesn't matter as __null is guaranteed to have the right - size. */ - -extern int warn_strict_null_sentinel; - -/* Maximum template instantiation depth. This limit is rather - arbitrary, but it exists to limit the time it takes to notice - infinite template instantiations. */ - -extern int max_tinst_depth; - -/* Nonzero means that we should not issue warnings about problems that - occur when the code is executed, because the code being processed - is not expected to be executed. This is set during parsing. This - is used for cases like sizeof() and "0 ? a : b". This is a count, - not a bool, because unexecuted expressions can nest. */ - -extern int c_inhibit_evaluation_warnings; - -/* Whether lexing has been completed, so subsequent preprocessor - errors should use the compiler's input_location. */ - -extern bool done_lexing; - -/* C types are partitioned into three subsets: object, function, and - incomplete types. */ -#define C_TYPE_OBJECT_P(type) \ - (TREE_CODE (type) != FUNCTION_TYPE && TYPE_SIZE (type)) - -#define C_TYPE_INCOMPLETE_P(type) \ - (TREE_CODE (type) != FUNCTION_TYPE && TYPE_SIZE (type) == 0) - -#define C_TYPE_FUNCTION_P(type) \ - (TREE_CODE (type) == FUNCTION_TYPE) - -/* For convenience we define a single macro to identify the class of - object or incomplete types. */ -#define C_TYPE_OBJECT_OR_INCOMPLETE_P(type) \ - (!C_TYPE_FUNCTION_P (type)) - -/* Attribute table common to the C front ends. */ -extern const struct attribute_spec c_common_attribute_table[]; -extern const struct attribute_spec c_common_format_attribute_table[]; - -/* Pointer to function to lazily generate the VAR_DECL for __FUNCTION__ etc. - ID is the identifier to use, NAME is the string. - TYPE_DEP indicates whether it depends on type of the function or not - (i.e. __PRETTY_FUNCTION__). */ - -extern tree (*make_fname_decl) (location_t, tree, int); - -/* In c-decl.c and cp/tree.c. FIXME. */ -extern void c_register_addr_space (const char *str, addr_space_t as); - -/* In c-common.c. */ -extern const char *c_addr_space_name (addr_space_t as); -extern tree identifier_global_value (tree); -extern void record_builtin_type (enum rid, const char *, tree); -extern tree build_void_list_node (void); -extern void start_fname_decls (void); -extern void finish_fname_decls (void); -extern const char *fname_as_string (int); -extern tree fname_decl (location_t, unsigned, tree); - -extern void check_function_arguments (tree, int, tree *, tree); -extern void check_function_arguments_recurse (void (*) - (void *, tree, - unsigned HOST_WIDE_INT), - void *, tree, - unsigned HOST_WIDE_INT); -extern bool check_builtin_function_arguments (tree, int, tree *); -extern void check_function_format (tree, int, tree *); -extern void set_Wformat (int); -extern tree handle_format_attribute (tree *, tree, tree, int, bool *); -extern tree handle_format_arg_attribute (tree *, tree, tree, int, bool *); -extern bool attribute_takes_identifier_p (const_tree); -extern int c_common_handle_option (size_t code, const char *arg, int value, int kind); -extern bool c_common_missing_argument (const char *opt, size_t code); -extern tree c_common_type_for_mode (enum machine_mode, int); -extern tree c_common_type_for_size (unsigned int, int); -extern tree c_common_fixed_point_type_for_size (unsigned int, unsigned int, - int, int); -extern tree c_common_unsigned_type (tree); -extern tree c_common_signed_type (tree); -extern tree c_common_signed_or_unsigned_type (int, tree); -extern tree c_build_bitfield_integer_type (unsigned HOST_WIDE_INT, int); -extern bool decl_with_nonnull_addr_p (const_tree); -extern tree c_fully_fold (tree, bool, bool *); -extern tree decl_constant_value_for_optimization (tree); -extern tree c_wrap_maybe_const (tree, bool); -extern tree c_save_expr (tree); -extern tree c_common_truthvalue_conversion (location_t, tree); -extern void c_apply_type_quals_to_decl (int, tree); -extern tree c_sizeof_or_alignof_type (location_t, tree, bool, int); -extern tree c_alignof_expr (location_t, tree); -/* Print an error message for invalid operands to arith operation CODE. - NOP_EXPR is used as a special case (see truthvalue_conversion). */ -extern void binary_op_error (location_t, enum tree_code, tree, tree); -extern tree fix_string_type (tree); -extern void constant_expression_warning (tree); -extern void constant_expression_error (tree); -extern bool strict_aliasing_warning (tree, tree, tree); -extern void warnings_for_convert_and_check (tree, tree, tree); -extern tree convert_and_check (tree, tree); -extern void overflow_warning (location_t, tree); -extern void warn_logical_operator (location_t, enum tree_code, tree, - enum tree_code, tree, enum tree_code, tree); -extern void check_main_parameter_types (tree decl); -extern bool c_determine_visibility (tree); -extern bool same_scalar_type_ignoring_signedness (tree, tree); -extern void mark_valid_location_for_stdc_pragma (bool); -extern bool valid_location_for_stdc_pragma_p (void); -extern void set_float_const_decimal64 (void); -extern void clear_float_const_decimal64 (void); -extern bool float_const_decimal64_p (void); - -#define c_sizeof(LOC, T) c_sizeof_or_alignof_type (LOC, T, true, 1) -#define c_alignof(LOC, T) c_sizeof_or_alignof_type (LOC, T, false, 1) - -/* Subroutine of build_binary_op, used for certain operations. */ -extern tree shorten_binary_op (tree result_type, tree op0, tree op1, bool bitwise); - -/* Subroutine of build_binary_op, used for comparison operations. - See if the operands have both been converted from subword integer types - and, if so, perhaps change them both back to their original type. */ -extern tree shorten_compare (tree *, tree *, tree *, enum tree_code *); - -extern tree pointer_int_sum (location_t, enum tree_code, tree, tree); - -/* Add qualifiers to a type, in the fashion for C. */ -extern tree c_build_qualified_type (tree, int); - -/* Build tree nodes and builtin functions common to both C and C++ language - frontends. */ -extern void c_common_nodes_and_builtins (void); - -extern void disable_builtin_function (const char *); - -extern void set_compound_literal_name (tree decl); - -extern tree build_va_arg (location_t, tree, tree); - -extern unsigned int c_common_init_options (unsigned int, const char **); -extern bool c_common_post_options (const char **); -extern bool c_common_init (void); -extern void c_common_finish (void); -extern void c_common_parse_file (int); -extern alias_set_type c_common_get_alias_set (tree); -extern void c_register_builtin_type (tree, const char*); -extern bool c_promoting_integer_type_p (const_tree); -extern int self_promoting_args_p (const_tree); -extern tree strip_pointer_operator (tree); -extern tree strip_pointer_or_array_types (tree); -extern HOST_WIDE_INT c_common_to_target_charset (HOST_WIDE_INT); - -/* This is the basic parsing function. */ -extern void c_parse_file (void); -/* This is misnamed, it actually performs end-of-compilation processing. */ -extern void finish_file (void); - - -/* These macros provide convenient access to the various _STMT nodes. */ - -/* Nonzero if a given STATEMENT_LIST represents the outermost binding - if a statement expression. */ -#define STATEMENT_LIST_STMT_EXPR(NODE) \ - TREE_LANG_FLAG_1 (STATEMENT_LIST_CHECK (NODE)) - -/* Nonzero if a label has been added to the statement list. */ -#define STATEMENT_LIST_HAS_LABEL(NODE) \ - TREE_LANG_FLAG_3 (STATEMENT_LIST_CHECK (NODE)) - -/* C_MAYBE_CONST_EXPR accessors. */ -#define C_MAYBE_CONST_EXPR_PRE(NODE) \ - TREE_OPERAND (C_MAYBE_CONST_EXPR_CHECK (NODE), 0) -#define C_MAYBE_CONST_EXPR_EXPR(NODE) \ - TREE_OPERAND (C_MAYBE_CONST_EXPR_CHECK (NODE), 1) -#define C_MAYBE_CONST_EXPR_INT_OPERANDS(NODE) \ - TREE_LANG_FLAG_0 (C_MAYBE_CONST_EXPR_CHECK (NODE)) -#define C_MAYBE_CONST_EXPR_NON_CONST(NODE) \ - TREE_LANG_FLAG_1 (C_MAYBE_CONST_EXPR_CHECK (NODE)) -#define EXPR_INT_CONST_OPERANDS(EXPR) \ - (INTEGRAL_TYPE_P (TREE_TYPE (EXPR)) \ - && (TREE_CODE (EXPR) == INTEGER_CST \ - || (TREE_CODE (EXPR) == C_MAYBE_CONST_EXPR \ - && C_MAYBE_CONST_EXPR_INT_OPERANDS (EXPR)))) - -/* In a FIELD_DECL, nonzero if the decl was originally a bitfield. */ -#define DECL_C_BIT_FIELD(NODE) \ - (DECL_LANG_FLAG_4 (FIELD_DECL_CHECK (NODE)) == 1) -#define SET_DECL_C_BIT_FIELD(NODE) \ - (DECL_LANG_FLAG_4 (FIELD_DECL_CHECK (NODE)) = 1) -#define CLEAR_DECL_C_BIT_FIELD(NODE) \ - (DECL_LANG_FLAG_4 (FIELD_DECL_CHECK (NODE)) = 0) - -extern tree do_case (location_t, tree, tree); -extern tree build_stmt (location_t, enum tree_code, ...); -extern tree build_case_label (location_t, tree, tree, tree); - -/* These functions must be defined by each front-end which implements - a variant of the C language. They are used in c-common.c. */ - -extern tree build_unary_op (location_t, enum tree_code, tree, int); -extern tree build_binary_op (location_t, enum tree_code, tree, tree, int); -extern tree perform_integral_promotions (tree); - -/* These functions must be defined by each front-end which implements - a variant of the C language. They are used by port files. */ - -extern tree default_conversion (tree); - -/* Given two integer or real types, return the type for their sum. - Given two compatible ANSI C types, returns the merged type. */ - -extern tree common_type (tree, tree); - -extern tree decl_constant_value (tree); - -/* Handle increment and decrement of boolean types. */ -extern tree boolean_increment (enum tree_code, tree); - -extern int case_compare (splay_tree_key, splay_tree_key); - -extern tree c_add_case_label (location_t, splay_tree, tree, tree, tree, tree); - -extern void c_do_switch_warnings (splay_tree, location_t, tree, tree); - -extern tree build_function_call (location_t, tree, tree); - -extern tree build_function_call_vec (location_t, tree, - VEC(tree,gc) *, VEC(tree,gc) *); - -extern tree resolve_overloaded_builtin (location_t, tree, VEC(tree,gc) *); - -extern tree finish_label_address_expr (tree, location_t); - -/* Same function prototype, but the C and C++ front ends have - different implementations. Used in c-common.c. */ -extern tree lookup_label (tree); -extern tree lookup_name (tree); -extern bool lvalue_p (const_tree); - -extern bool vector_targets_convertible_p (const_tree t1, const_tree t2); -extern bool vector_types_convertible_p (const_tree t1, const_tree t2, bool emit_lax_note); - -extern rtx c_expand_expr (tree, rtx, enum machine_mode, int, rtx *); - -extern void init_c_lex (void); - -extern void c_cpp_builtins (cpp_reader *); -extern void c_cpp_builtins_optimize_pragma (cpp_reader *, tree, tree); -extern bool c_cpp_error (cpp_reader *, int, int, location_t, unsigned int, - const char *, va_list *) - ATTRIBUTE_GCC_DIAG(6,0); - -/* Positive if an implicit `extern "C"' scope has just been entered; - negative if such a scope has just been exited. */ -extern GTY(()) int pending_lang_change; - -/* Information recorded about each file examined during compilation. */ - -struct c_fileinfo -{ - int time; /* Time spent in the file. */ - - /* Flags used only by C++. - INTERFACE_ONLY nonzero means that we are in an "interface" section - of the compiler. INTERFACE_UNKNOWN nonzero means we cannot trust - the value of INTERFACE_ONLY. If INTERFACE_UNKNOWN is zero and - INTERFACE_ONLY is zero, it means that we are responsible for - exporting definitions that others might need. */ - short interface_only; - short interface_unknown; -}; - -struct c_fileinfo *get_fileinfo (const char *); -extern void dump_time_statistics (void); - -extern bool c_dump_tree (void *, tree); - -extern void verify_sequence_points (tree); - -extern tree fold_offsetof (tree, tree); - -/* Places where an lvalue, or modifiable lvalue, may be required. - Used to select diagnostic messages in lvalue_error and - readonly_error. */ -enum lvalue_use { - lv_assign, - lv_increment, - lv_decrement, - lv_addressof, - lv_asm -}; - -extern void lvalue_error (enum lvalue_use); - -extern int complete_array_type (tree *, tree, bool); - -extern tree builtin_type_for_size (int, bool); - -extern void warn_array_subscript_with_type_char (tree); -extern void warn_about_parentheses (enum tree_code, - enum tree_code, tree, - enum tree_code, tree); -extern void warn_for_unused_label (tree label); -extern void warn_for_div_by_zero (location_t, tree divisor); -extern void warn_for_sign_compare (location_t, - tree orig_op0, tree orig_op1, - tree op0, tree op1, - tree result_type, - enum tree_code resultcode); -extern void set_underlying_type (tree x); -extern bool is_typedef_decl (tree x); -extern VEC(tree,gc) *make_tree_vector (void); -extern void release_tree_vector (VEC(tree,gc) *); -extern VEC(tree,gc) *make_tree_vector_single (tree); -extern VEC(tree,gc) *make_tree_vector_copy (const VEC(tree,gc) *); - -/* In c-gimplify.c */ -extern void c_genericize (tree); -extern int c_gimplify_expr (tree *, gimple_seq *, gimple_seq *); -extern tree c_build_bind_expr (location_t, tree, tree); - -/* In c-pch.c */ -extern void pch_init (void); -extern int c_common_valid_pch (cpp_reader *pfile, const char *name, int fd); -extern void c_common_read_pch (cpp_reader *pfile, const char *name, int fd, - const char *orig); -extern void c_common_write_pch (void); -extern void c_common_no_more_pch (void); -extern void c_common_pch_pragma (cpp_reader *pfile, const char *); -extern void c_common_print_pch_checksum (FILE *f); - -/* In *-checksum.c */ -extern const unsigned char executable_checksum[16]; - -/* In c-cppbuiltin.c */ -extern void builtin_define_std (const char *macro); -extern void builtin_define_with_value (const char *, const char *, int); -extern void c_stddef_cpp_builtins (void); -extern void fe_file_change (const struct line_map *); -extern void c_parse_error (const char *, enum cpp_ttype, tree, unsigned char); - -/* Objective-C / Objective-C++ entry points. */ - -/* The following ObjC/ObjC++ functions are called by the C and/or C++ - front-ends; they all must have corresponding stubs in stub-objc.c. */ -extern tree objc_is_class_name (tree); -extern tree objc_is_object_ptr (tree); -extern void objc_check_decl (tree); -extern int objc_is_reserved_word (tree); -extern bool objc_compare_types (tree, tree, int, tree); -extern void objc_volatilize_decl (tree); -extern bool objc_type_quals_match (tree, tree); -extern tree objc_rewrite_function_call (tree, tree); -extern tree objc_message_selector (void); -extern tree objc_lookup_ivar (tree, tree); -extern void objc_clear_super_receiver (void); -extern int objc_is_public (tree, tree); -extern tree objc_is_id (tree); -extern void objc_declare_alias (tree, tree); -extern void objc_declare_class (tree); -extern void objc_declare_protocols (tree); -extern tree objc_build_message_expr (tree); -extern tree objc_finish_message_expr (tree, tree, tree); -extern tree objc_build_selector_expr (location_t, tree); -extern tree objc_build_protocol_expr (tree); -extern tree objc_build_encode_expr (tree); -extern tree objc_build_string_object (tree); -extern tree objc_get_protocol_qualified_type (tree, tree); -extern tree objc_get_class_reference (tree); -extern tree objc_get_class_ivars (tree); -extern void objc_start_class_interface (tree, tree, tree); -extern void objc_start_category_interface (tree, tree, tree); -extern void objc_start_protocol (tree, tree); -extern void objc_continue_interface (void); -extern void objc_finish_interface (void); -extern void objc_start_class_implementation (tree, tree); -extern void objc_start_category_implementation (tree, tree); -extern void objc_continue_implementation (void); -extern void objc_finish_implementation (void); -extern void objc_set_visibility (int); -extern void objc_set_method_type (enum tree_code); -extern tree objc_build_method_signature (tree, tree, tree, bool); -extern void objc_add_method_declaration (tree); -extern void objc_start_method_definition (tree); -extern void objc_finish_method_definition (tree); -extern void objc_add_instance_variable (tree); -extern tree objc_build_keyword_decl (tree, tree, tree); -extern tree objc_build_throw_stmt (location_t, tree); -extern void objc_begin_try_stmt (location_t, tree); -extern tree objc_finish_try_stmt (void); -extern void objc_begin_catch_clause (tree); -extern void objc_finish_catch_clause (void); -extern void objc_build_finally_clause (location_t, tree); -extern tree objc_build_synchronized (location_t, tree, tree); -extern int objc_static_init_needed_p (void); -extern tree objc_generate_static_init_call (tree); -extern tree objc_generate_write_barrier (tree, enum tree_code, tree); - -/* The following are provided by the C and C++ front-ends, and called by - ObjC/ObjC++. */ -extern void *objc_get_current_scope (void); -extern void objc_mark_locals_volatile (void *); - -/* In c-ppoutput.c */ -extern void init_pp_output (FILE *); -extern void preprocess_file (cpp_reader *); -extern void pp_file_change (const struct line_map *); -extern void pp_dir_change (cpp_reader *, const char *); -extern bool check_missing_format_attribute (tree, tree); - -/* In c-omp.c */ -extern tree c_finish_omp_master (location_t, tree); -extern tree c_finish_omp_critical (location_t, tree, tree); -extern tree c_finish_omp_ordered (location_t, tree); -extern void c_finish_omp_barrier (location_t); -extern tree c_finish_omp_atomic (location_t, enum tree_code, tree, tree); -extern void c_finish_omp_flush (location_t); -extern void c_finish_omp_taskwait (location_t); -extern tree c_finish_omp_for (location_t, tree, tree, tree, tree, tree, tree); -extern void c_split_parallel_clauses (location_t, tree, tree *, tree *); -extern enum omp_clause_default_kind c_omp_predetermined_sharing (tree); - -/* Not in c-omp.c; provided by the front end. */ -extern bool c_omp_sharing_predetermined (tree); -extern tree c_omp_remap_decl (tree, bool); -extern void record_types_used_by_current_var_decl (tree); - -#endif /* ! GCC_C_COMMON_H */ diff --git a/gcc/c-config-lang.in b/gcc/c-config-lang.in index d3cd6f9efea..d9138031190 100644 --- a/gcc/c-config-lang.in +++ b/gcc/c-config-lang.in @@ -22,4 +22,4 @@ # files used by C that have garbage collection GTY macros in them # which therefore need to be scanned by gengtype.c. -gtfiles="\$(srcdir)/c-lang.c \$(srcdir)/c-tree.h \$(srcdir)/c-decl.c \$(srcdir)/c-common.c \$(srcdir)/c-common.h \$(srcdir)/c-pragma.h \$(srcdir)/c-pragma.c \$(srcdir)/c-objc-common.c \$(srcdir)/c-parser.c \$(srcdir)/c-lang.h" +gtfiles="\$(srcdir)/c-lang.c \$(srcdir)/c-tree.h \$(srcdir)/c-decl.c \$(srcdir)/c-family/c-common.c \$(srcdir)/c-family/c-common.h \$(srcdir)/c-family/c-cppbuiltin.c \$(srcdir)/c-family/c-pragma.h \$(srcdir)/c-family/c-pragma.c \$(srcdir)/c-objc-common.c \$(srcdir)/c-parser.c \$(srcdir)/c-lang.h" diff --git a/gcc/c-convert.c b/gcc/c-convert.c index 09638d5b151..4de3cdb1c57 100644 --- a/gcc/c-convert.c +++ b/gcc/c-convert.c @@ -31,7 +31,7 @@ along with GCC; see the file COPYING3. If not see #include "tree.h" #include "flags.h" #include "convert.h" -#include "c-common.h" +#include "c-family/c-common.h" #include "c-tree.h" #include "langhooks.h" #include "toplev.h" diff --git a/gcc/c-cppbuiltin.c b/gcc/c-cppbuiltin.c deleted file mode 100644 index 6bbdb460e7a..00000000000 --- a/gcc/c-cppbuiltin.c +++ /dev/null @@ -1,1107 +0,0 @@ -/* Define builtin-in macros for the C family front ends. - Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 - 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 3, 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 COPYING3. If not see -. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "tm.h" -#include "tree.h" -#include "version.h" -#include "flags.h" -#include "c-common.h" -#include "c-pragma.h" -#include "output.h" -#include "except.h" /* For USING_SJLJ_EXCEPTIONS. */ -#include "debug.h" /* For dwarf2out_do_cfi_asm. */ -#include "toplev.h" -#include "tm_p.h" /* For TARGET_CPU_CPP_BUILTINS & friends. */ -#include "target.h" - -#ifndef TARGET_OS_CPP_BUILTINS -# define TARGET_OS_CPP_BUILTINS() -#endif - -#ifndef TARGET_OBJFMT_CPP_BUILTINS -# define TARGET_OBJFMT_CPP_BUILTINS() -#endif - -#ifndef REGISTER_PREFIX -#define REGISTER_PREFIX "" -#endif - -/* Non-static as some targets don't use it. */ -void builtin_define_std (const char *) ATTRIBUTE_UNUSED; -static void builtin_define_with_int_value (const char *, HOST_WIDE_INT); -static void builtin_define_with_hex_fp_value (const char *, tree, - int, const char *, - const char *, - const char *); -static void builtin_define_stdint_macros (void); -static void builtin_define_constants (const char *, tree); -static void builtin_define_type_max (const char *, tree); -static void builtin_define_type_minmax (const char *, const char *, tree); -static void builtin_define_type_precision (const char *, tree); -static void builtin_define_type_sizeof (const char *, tree); -static void builtin_define_float_constants (const char *, - const char *, - const char *, - tree); -static void define__GNUC__ (void); - -/* Define NAME with value TYPE precision. */ -static void -builtin_define_type_precision (const char *name, tree type) -{ - builtin_define_with_int_value (name, TYPE_PRECISION (type)); -} - -/* Define NAME with value TYPE size_unit. */ -static void -builtin_define_type_sizeof (const char *name, tree type) -{ - builtin_define_with_int_value (name, - tree_low_cst (TYPE_SIZE_UNIT (type), 1)); -} - -/* Define the float.h constants for TYPE using NAME_PREFIX, FP_SUFFIX, - and FP_CAST. */ -static void -builtin_define_float_constants (const char *name_prefix, - const char *fp_suffix, - const char *fp_cast, - tree type) -{ - /* Used to convert radix-based values to base 10 values in several cases. - - In the max_exp -> max_10_exp conversion for 128-bit IEEE, we need at - least 6 significant digits for correct results. Using the fraction - formed by (log(2)*1e6)/(log(10)*1e6) overflows a 32-bit integer as an - intermediate; perhaps someone can find a better approximation, in the - mean time, I suspect using doubles won't harm the bootstrap here. */ - - const double log10_2 = .30102999566398119521; - double log10_b; - const struct real_format *fmt; - const struct real_format *ldfmt; - - char name[64], buf[128]; - int dig, min_10_exp, max_10_exp; - int decimal_dig; - int type_decimal_dig; - - fmt = REAL_MODE_FORMAT (TYPE_MODE (type)); - gcc_assert (fmt->b != 10); - ldfmt = REAL_MODE_FORMAT (TYPE_MODE (long_double_type_node)); - gcc_assert (ldfmt->b != 10); - - /* The radix of the exponent representation. */ - if (type == float_type_node) - builtin_define_with_int_value ("__FLT_RADIX__", fmt->b); - log10_b = log10_2; - - /* The number of radix digits, p, in the floating-point significand. */ - sprintf (name, "__%s_MANT_DIG__", name_prefix); - builtin_define_with_int_value (name, fmt->p); - - /* The number of decimal digits, q, such that any floating-point number - with q decimal digits can be rounded into a floating-point number with - p radix b digits and back again without change to the q decimal digits, - - p log10 b if b is a power of 10 - floor((p - 1) log10 b) otherwise - */ - dig = (fmt->p - 1) * log10_b; - sprintf (name, "__%s_DIG__", name_prefix); - builtin_define_with_int_value (name, dig); - - /* The minimum negative int x such that b**(x-1) is a normalized float. */ - sprintf (name, "__%s_MIN_EXP__", name_prefix); - sprintf (buf, "(%d)", fmt->emin); - builtin_define_with_value (name, buf, 0); - - /* The minimum negative int x such that 10**x is a normalized float, - - ceil (log10 (b ** (emin - 1))) - = ceil (log10 (b) * (emin - 1)) - - Recall that emin is negative, so the integer truncation calculates - the ceiling, not the floor, in this case. */ - min_10_exp = (fmt->emin - 1) * log10_b; - sprintf (name, "__%s_MIN_10_EXP__", name_prefix); - sprintf (buf, "(%d)", min_10_exp); - builtin_define_with_value (name, buf, 0); - - /* The maximum int x such that b**(x-1) is a representable float. */ - sprintf (name, "__%s_MAX_EXP__", name_prefix); - builtin_define_with_int_value (name, fmt->emax); - - /* The maximum int x such that 10**x is in the range of representable - finite floating-point numbers, - - floor (log10((1 - b**-p) * b**emax)) - = floor (log10(1 - b**-p) + log10(b**emax)) - = floor (log10(1 - b**-p) + log10(b)*emax) - - The safest thing to do here is to just compute this number. But since - we don't link cc1 with libm, we cannot. We could implement log10 here - a series expansion, but that seems too much effort because: - - Note that the first term, for all extant p, is a number exceedingly close - to zero, but slightly negative. Note that the second term is an integer - scaling an irrational number, and that because of the floor we are only - interested in its integral portion. - - In order for the first term to have any effect on the integral portion - of the second term, the second term has to be exceedingly close to an - integer itself (e.g. 123.000000000001 or something). Getting a result - that close to an integer requires that the irrational multiplicand have - a long series of zeros in its expansion, which doesn't occur in the - first 20 digits or so of log10(b). - - Hand-waving aside, crunching all of the sets of constants above by hand - does not yield a case for which the first term is significant, which - in the end is all that matters. */ - max_10_exp = fmt->emax * log10_b; - sprintf (name, "__%s_MAX_10_EXP__", name_prefix); - builtin_define_with_int_value (name, max_10_exp); - - /* The number of decimal digits, n, such that any floating-point number - can be rounded to n decimal digits and back again without change to - the value. - - p * log10(b) if b is a power of 10 - ceil(1 + p * log10(b)) otherwise - - The only macro we care about is this number for the widest supported - floating type, but we want this value for rendering constants below. */ - { - double d_decimal_dig - = 1 + (fmt->p < ldfmt->p ? ldfmt->p : fmt->p) * log10_b; - decimal_dig = d_decimal_dig; - if (decimal_dig < d_decimal_dig) - decimal_dig++; - } - /* Similar, for this type rather than long double. */ - { - double type_d_decimal_dig = 1 + fmt->p * log10_b; - type_decimal_dig = type_d_decimal_dig; - if (type_decimal_dig < type_d_decimal_dig) - type_decimal_dig++; - } - if (type == long_double_type_node) - builtin_define_with_int_value ("__DECIMAL_DIG__", decimal_dig); - else - { - sprintf (name, "__%s_DECIMAL_DIG__", name_prefix); - builtin_define_with_int_value (name, type_decimal_dig); - } - - /* Since, for the supported formats, B is always a power of 2, we - construct the following numbers directly as a hexadecimal - constants. */ - get_max_float (fmt, buf, sizeof (buf)); - - sprintf (name, "__%s_MAX__", name_prefix); - builtin_define_with_hex_fp_value (name, type, decimal_dig, buf, fp_suffix, fp_cast); - - /* The minimum normalized positive floating-point number, - b**(emin-1). */ - sprintf (name, "__%s_MIN__", name_prefix); - sprintf (buf, "0x1p%d", fmt->emin - 1); - builtin_define_with_hex_fp_value (name, type, decimal_dig, buf, fp_suffix, fp_cast); - - /* The difference between 1 and the least value greater than 1 that is - representable in the given floating point type, b**(1-p). */ - sprintf (name, "__%s_EPSILON__", name_prefix); - if (fmt->pnan < fmt->p) - /* This is an IBM extended double format, so 1.0 + any double is - representable precisely. */ - sprintf (buf, "0x1p%d", fmt->emin - fmt->p); - else - sprintf (buf, "0x1p%d", 1 - fmt->p); - builtin_define_with_hex_fp_value (name, type, decimal_dig, buf, fp_suffix, fp_cast); - - /* For C++ std::numeric_limits::denorm_min. The minimum denormalized - positive floating-point number, b**(emin-p). Zero for formats that - don't support denormals. */ - sprintf (name, "__%s_DENORM_MIN__", name_prefix); - if (fmt->has_denorm) - { - sprintf (buf, "0x1p%d", fmt->emin - fmt->p); - builtin_define_with_hex_fp_value (name, type, decimal_dig, - buf, fp_suffix, fp_cast); - } - else - { - sprintf (buf, "0.0%s", fp_suffix); - builtin_define_with_value (name, buf, 0); - } - - sprintf (name, "__%s_HAS_DENORM__", name_prefix); - builtin_define_with_value (name, fmt->has_denorm ? "1" : "0", 0); - - /* For C++ std::numeric_limits::has_infinity. */ - sprintf (name, "__%s_HAS_INFINITY__", name_prefix); - builtin_define_with_int_value (name, - MODE_HAS_INFINITIES (TYPE_MODE (type))); - /* For C++ std::numeric_limits::has_quiet_NaN. We do not have a - predicate to distinguish a target that has both quiet and - signalling NaNs from a target that has only quiet NaNs or only - signalling NaNs, so we assume that a target that has any kind of - NaN has quiet NaNs. */ - sprintf (name, "__%s_HAS_QUIET_NAN__", name_prefix); - builtin_define_with_int_value (name, MODE_HAS_NANS (TYPE_MODE (type))); -} - -/* Define __DECx__ constants for TYPE using NAME_PREFIX and SUFFIX. */ -static void -builtin_define_decimal_float_constants (const char *name_prefix, - const char *suffix, - tree type) -{ - const struct real_format *fmt; - char name[64], buf[128], *p; - int digits; - - fmt = REAL_MODE_FORMAT (TYPE_MODE (type)); - - /* The number of radix digits, p, in the significand. */ - sprintf (name, "__%s_MANT_DIG__", name_prefix); - builtin_define_with_int_value (name, fmt->p); - - /* The minimum negative int x such that b**(x-1) is a normalized float. */ - sprintf (name, "__%s_MIN_EXP__", name_prefix); - sprintf (buf, "(%d)", fmt->emin); - builtin_define_with_value (name, buf, 0); - - /* The maximum int x such that b**(x-1) is a representable float. */ - sprintf (name, "__%s_MAX_EXP__", name_prefix); - builtin_define_with_int_value (name, fmt->emax); - - /* Compute the minimum representable value. */ - sprintf (name, "__%s_MIN__", name_prefix); - sprintf (buf, "1E%d%s", fmt->emin - 1, suffix); - builtin_define_with_value (name, buf, 0); - - /* Compute the maximum representable value. */ - sprintf (name, "__%s_MAX__", name_prefix); - p = buf; - for (digits = fmt->p; digits; digits--) - { - *p++ = '9'; - if (digits == fmt->p) - *p++ = '.'; - } - *p = 0; - /* fmt->p plus 1, to account for the decimal point and fmt->emax - minus 1 because the digits are nines, not 1.0. */ - sprintf (&buf[fmt->p + 1], "E%d%s", fmt->emax - 1, suffix); - builtin_define_with_value (name, buf, 0); - - /* Compute epsilon (the difference between 1 and least value greater - than 1 representable). */ - sprintf (name, "__%s_EPSILON__", name_prefix); - sprintf (buf, "1E-%d%s", fmt->p - 1, suffix); - builtin_define_with_value (name, buf, 0); - - /* Minimum subnormal positive decimal value. */ - sprintf (name, "__%s_SUBNORMAL_MIN__", name_prefix); - p = buf; - for (digits = fmt->p; digits > 1; digits--) - { - *p++ = '0'; - if (digits == fmt->p) - *p++ = '.'; - } - *p = 0; - sprintf (&buf[fmt->p], "1E%d%s", fmt->emin - 1, suffix); - builtin_define_with_value (name, buf, 0); -} - -/* Define fixed-point constants for TYPE using NAME_PREFIX and SUFFIX. */ - -static void -builtin_define_fixed_point_constants (const char *name_prefix, - const char *suffix, - tree type) -{ - char name[64], buf[256], *new_buf; - int i, mod; - - sprintf (name, "__%s_FBIT__", name_prefix); - builtin_define_with_int_value (name, TYPE_FBIT (type)); - - sprintf (name, "__%s_IBIT__", name_prefix); - builtin_define_with_int_value (name, TYPE_IBIT (type)); - - /* If there is no suffix, defines are for fixed-point modes. - We just return. */ - if (strcmp (suffix, "") == 0) - return; - - if (TYPE_UNSIGNED (type)) - { - sprintf (name, "__%s_MIN__", name_prefix); - sprintf (buf, "0.0%s", suffix); - builtin_define_with_value (name, buf, 0); - } - else - { - sprintf (name, "__%s_MIN__", name_prefix); - if (ALL_ACCUM_MODE_P (TYPE_MODE (type))) - sprintf (buf, "(-0X1P%d%s-0X1P%d%s)", TYPE_IBIT (type) - 1, suffix, - TYPE_IBIT (type) - 1, suffix); - else - sprintf (buf, "(-0.5%s-0.5%s)", suffix, suffix); - builtin_define_with_value (name, buf, 0); - } - - sprintf (name, "__%s_MAX__", name_prefix); - sprintf (buf, "0X"); - new_buf = buf + 2; - mod = (TYPE_FBIT (type) + TYPE_IBIT (type)) % 4; - if (mod) - sprintf (new_buf++, "%x", (1 << mod) - 1); - for (i = 0; i < (TYPE_FBIT (type) + TYPE_IBIT (type)) / 4; i++) - sprintf (new_buf++, "F"); - sprintf (new_buf, "P-%d%s", TYPE_FBIT (type), suffix); - builtin_define_with_value (name, buf, 0); - - sprintf (name, "__%s_EPSILON__", name_prefix); - sprintf (buf, "0x1P-%d%s", TYPE_FBIT (type), suffix); - builtin_define_with_value (name, buf, 0); -} - -/* Define __GNUC__, __GNUC_MINOR__ and __GNUC_PATCHLEVEL__. */ -static void -define__GNUC__ (void) -{ - int major, minor, patchlevel; - - if (sscanf (BASEVER, "%d.%d.%d", &major, &minor, &patchlevel) != 3) - { - sscanf (BASEVER, "%d.%d", &major, &minor); - patchlevel = 0; - } - cpp_define_formatted (parse_in, "__GNUC__=%d", major); - cpp_define_formatted (parse_in, "__GNUC_MINOR__=%d", minor); - cpp_define_formatted (parse_in, "__GNUC_PATCHLEVEL__=%d", patchlevel); - - if (c_dialect_cxx ()) - cpp_define_formatted (parse_in, "__GNUG__=%d", major); -} - -/* Define macros used by . */ -static void -builtin_define_stdint_macros (void) -{ - builtin_define_type_max ("__INTMAX_MAX__", intmax_type_node); - builtin_define_constants ("__INTMAX_C", intmax_type_node); - builtin_define_type_max ("__UINTMAX_MAX__", uintmax_type_node); - builtin_define_constants ("__UINTMAX_C", uintmax_type_node); - if (sig_atomic_type_node) - builtin_define_type_minmax ("__SIG_ATOMIC_MIN__", "__SIG_ATOMIC_MAX__", - sig_atomic_type_node); - if (int8_type_node) - builtin_define_type_max ("__INT8_MAX__", int8_type_node); - if (int16_type_node) - builtin_define_type_max ("__INT16_MAX__", int16_type_node); - if (int32_type_node) - builtin_define_type_max ("__INT32_MAX__", int32_type_node); - if (int64_type_node) - builtin_define_type_max ("__INT64_MAX__", int64_type_node); - if (uint8_type_node) - builtin_define_type_max ("__UINT8_MAX__", uint8_type_node); - if (uint16_type_node) - builtin_define_type_max ("__UINT16_MAX__", uint16_type_node); - if (c_uint32_type_node) - builtin_define_type_max ("__UINT32_MAX__", c_uint32_type_node); - if (c_uint64_type_node) - builtin_define_type_max ("__UINT64_MAX__", c_uint64_type_node); - if (int_least8_type_node) - { - builtin_define_type_max ("__INT_LEAST8_MAX__", int_least8_type_node); - builtin_define_constants ("__INT8_C", int_least8_type_node); - } - if (int_least16_type_node) - { - builtin_define_type_max ("__INT_LEAST16_MAX__", int_least16_type_node); - builtin_define_constants ("__INT16_C", int_least16_type_node); - } - if (int_least32_type_node) - { - builtin_define_type_max ("__INT_LEAST32_MAX__", int_least32_type_node); - builtin_define_constants ("__INT32_C", int_least32_type_node); - } - if (int_least64_type_node) - { - builtin_define_type_max ("__INT_LEAST64_MAX__", int_least64_type_node); - builtin_define_constants ("__INT64_C", int_least64_type_node); - } - if (uint_least8_type_node) - { - builtin_define_type_max ("__UINT_LEAST8_MAX__", uint_least8_type_node); - builtin_define_constants ("__UINT8_C", uint_least8_type_node); - } - if (uint_least16_type_node) - { - builtin_define_type_max ("__UINT_LEAST16_MAX__", uint_least16_type_node); - builtin_define_constants ("__UINT16_C", uint_least16_type_node); - } - if (uint_least32_type_node) - { - builtin_define_type_max ("__UINT_LEAST32_MAX__", uint_least32_type_node); - builtin_define_constants ("__UINT32_C", uint_least32_type_node); - } - if (uint_least64_type_node) - { - builtin_define_type_max ("__UINT_LEAST64_MAX__", uint_least64_type_node); - builtin_define_constants ("__UINT64_C", uint_least64_type_node); - } - if (int_fast8_type_node) - builtin_define_type_max ("__INT_FAST8_MAX__", int_fast8_type_node); - if (int_fast16_type_node) - builtin_define_type_max ("__INT_FAST16_MAX__", int_fast16_type_node); - if (int_fast32_type_node) - builtin_define_type_max ("__INT_FAST32_MAX__", int_fast32_type_node); - if (int_fast64_type_node) - builtin_define_type_max ("__INT_FAST64_MAX__", int_fast64_type_node); - if (uint_fast8_type_node) - builtin_define_type_max ("__UINT_FAST8_MAX__", uint_fast8_type_node); - if (uint_fast16_type_node) - builtin_define_type_max ("__UINT_FAST16_MAX__", uint_fast16_type_node); - if (uint_fast32_type_node) - builtin_define_type_max ("__UINT_FAST32_MAX__", uint_fast32_type_node); - if (uint_fast64_type_node) - builtin_define_type_max ("__UINT_FAST64_MAX__", uint_fast64_type_node); - if (intptr_type_node) - builtin_define_type_max ("__INTPTR_MAX__", intptr_type_node); - if (uintptr_type_node) - builtin_define_type_max ("__UINTPTR_MAX__", uintptr_type_node); -} - -/* Adjust the optimization macros when a #pragma GCC optimization is done to - reflect the current level. */ -void -c_cpp_builtins_optimize_pragma (cpp_reader *pfile, tree prev_tree, - tree cur_tree) -{ - struct cl_optimization *prev = TREE_OPTIMIZATION (prev_tree); - struct cl_optimization *cur = TREE_OPTIMIZATION (cur_tree); - bool prev_fast_math; - bool cur_fast_math; - - /* -undef turns off target-specific built-ins. */ - if (flag_undef) - return; - - /* Other target-independent built-ins determined by command-line - options. */ - if (!prev->optimize_size && cur->optimize_size) - cpp_define (pfile, "__OPTIMIZE_SIZE__"); - else if (prev->optimize_size && !cur->optimize_size) - cpp_undef (pfile, "__OPTIMIZE_SIZE__"); - - if (!prev->optimize && cur->optimize) - cpp_define (pfile, "__OPTIMIZE__"); - else if (prev->optimize && !cur->optimize) - cpp_undef (pfile, "__OPTIMIZE__"); - - prev_fast_math = fast_math_flags_struct_set_p (prev); - cur_fast_math = fast_math_flags_struct_set_p (cur); - if (!prev_fast_math && cur_fast_math) - cpp_define (pfile, "__FAST_MATH__"); - else if (prev_fast_math && !cur_fast_math) - cpp_undef (pfile, "__FAST_MATH__"); - - if (!prev->flag_signaling_nans && cur->flag_signaling_nans) - cpp_define (pfile, "__SUPPORT_SNAN__"); - else if (prev->flag_signaling_nans && !cur->flag_signaling_nans) - cpp_undef (pfile, "__SUPPORT_SNAN__"); - - if (!prev->flag_finite_math_only && cur->flag_finite_math_only) - { - cpp_undef (pfile, "__FINITE_MATH_ONLY__"); - cpp_define (pfile, "__FINITE_MATH_ONLY__=1"); - } - else if (!prev->flag_finite_math_only && cur->flag_finite_math_only) - { - cpp_undef (pfile, "__FINITE_MATH_ONLY__"); - cpp_define (pfile, "__FINITE_MATH_ONLY__=0"); - } -} - - -/* Hook that registers front end and target-specific built-ins. */ -void -c_cpp_builtins (cpp_reader *pfile) -{ - /* -undef turns off target-specific built-ins. */ - if (flag_undef) - return; - - define__GNUC__ (); - - /* For stddef.h. They require macros defined in c-common.c. */ - c_stddef_cpp_builtins (); - - if (c_dialect_cxx ()) - { - if (flag_weak && SUPPORTS_ONE_ONLY) - cpp_define (pfile, "__GXX_WEAK__=1"); - else - cpp_define (pfile, "__GXX_WEAK__=0"); - if (warn_deprecated) - cpp_define (pfile, "__DEPRECATED"); - if (flag_rtti) - cpp_define (pfile, "__GXX_RTTI"); - if (cxx_dialect == cxx0x) - cpp_define (pfile, "__GXX_EXPERIMENTAL_CXX0X__"); - } - /* Note that we define this for C as well, so that we know if - __attribute__((cleanup)) will interface with EH. */ - if (flag_exceptions) - cpp_define (pfile, "__EXCEPTIONS"); - - /* Represents the C++ ABI version, always defined so it can be used while - preprocessing C and assembler. */ - if (flag_abi_version == 0) - /* Use a very large value so that: - - #if __GXX_ABI_VERSION >= - - will work whether the user explicitly says "-fabi-version=x" or - "-fabi-version=0". Do not use INT_MAX because that will be - different from system to system. */ - builtin_define_with_int_value ("__GXX_ABI_VERSION", 999999); - else if (flag_abi_version == 1) - /* Due to a historical accident, this version had the value - "102". */ - builtin_define_with_int_value ("__GXX_ABI_VERSION", 102); - else - /* Newer versions have values 1002, 1003, .... */ - builtin_define_with_int_value ("__GXX_ABI_VERSION", - 1000 + flag_abi_version); - - /* libgcc needs to know this. */ - if (USING_SJLJ_EXCEPTIONS) - cpp_define (pfile, "__USING_SJLJ_EXCEPTIONS__"); - - /* limits.h and stdint.h need to know these. */ - builtin_define_type_max ("__SCHAR_MAX__", signed_char_type_node); - builtin_define_type_max ("__SHRT_MAX__", short_integer_type_node); - builtin_define_type_max ("__INT_MAX__", integer_type_node); - builtin_define_type_max ("__LONG_MAX__", long_integer_type_node); - builtin_define_type_max ("__LONG_LONG_MAX__", long_long_integer_type_node); - builtin_define_type_minmax ("__WCHAR_MIN__", "__WCHAR_MAX__", - underlying_wchar_type_node); - builtin_define_type_minmax ("__WINT_MIN__", "__WINT_MAX__", wint_type_node); - builtin_define_type_max ("__PTRDIFF_MAX__", ptrdiff_type_node); - builtin_define_type_max ("__SIZE_MAX__", size_type_node); - - builtin_define_type_precision ("__CHAR_BIT__", char_type_node); - - /* stdint.h and the testsuite need to know these. */ - builtin_define_stdint_macros (); - - /* float.h needs to know these. */ - - builtin_define_with_int_value ("__FLT_EVAL_METHOD__", - TARGET_FLT_EVAL_METHOD); - - /* And decfloat.h needs this. */ - builtin_define_with_int_value ("__DEC_EVAL_METHOD__", - TARGET_DEC_EVAL_METHOD); - - builtin_define_float_constants ("FLT", "F", "%s", float_type_node); - /* Cast the double precision constants. This is needed when single - precision constants are specified or when pragma FLOAT_CONST_DECIMAL64 - is used. The correct result is computed by the compiler when using - macros that include a cast. */ - builtin_define_float_constants ("DBL", "L", "((double)%s)", double_type_node); - builtin_define_float_constants ("LDBL", "L", "%s", long_double_type_node); - - /* For decfloat.h. */ - builtin_define_decimal_float_constants ("DEC32", "DF", dfloat32_type_node); - builtin_define_decimal_float_constants ("DEC64", "DD", dfloat64_type_node); - builtin_define_decimal_float_constants ("DEC128", "DL", dfloat128_type_node); - - /* For fixed-point fibt, ibit, max, min, and epsilon. */ - if (targetm.fixed_point_supported_p ()) - { - builtin_define_fixed_point_constants ("SFRACT", "HR", - short_fract_type_node); - builtin_define_fixed_point_constants ("USFRACT", "UHR", - unsigned_short_fract_type_node); - builtin_define_fixed_point_constants ("FRACT", "R", - fract_type_node); - builtin_define_fixed_point_constants ("UFRACT", "UR", - unsigned_fract_type_node); - builtin_define_fixed_point_constants ("LFRACT", "LR", - long_fract_type_node); - builtin_define_fixed_point_constants ("ULFRACT", "ULR", - unsigned_long_fract_type_node); - builtin_define_fixed_point_constants ("LLFRACT", "LLR", - long_long_fract_type_node); - builtin_define_fixed_point_constants ("ULLFRACT", "ULLR", - unsigned_long_long_fract_type_node); - builtin_define_fixed_point_constants ("SACCUM", "HK", - short_accum_type_node); - builtin_define_fixed_point_constants ("USACCUM", "UHK", - unsigned_short_accum_type_node); - builtin_define_fixed_point_constants ("ACCUM", "K", - accum_type_node); - builtin_define_fixed_point_constants ("UACCUM", "UK", - unsigned_accum_type_node); - builtin_define_fixed_point_constants ("LACCUM", "LK", - long_accum_type_node); - builtin_define_fixed_point_constants ("ULACCUM", "ULK", - unsigned_long_accum_type_node); - builtin_define_fixed_point_constants ("LLACCUM", "LLK", - long_long_accum_type_node); - builtin_define_fixed_point_constants ("ULLACCUM", "ULLK", - unsigned_long_long_accum_type_node); - - builtin_define_fixed_point_constants ("QQ", "", qq_type_node); - builtin_define_fixed_point_constants ("HQ", "", hq_type_node); - builtin_define_fixed_point_constants ("SQ", "", sq_type_node); - builtin_define_fixed_point_constants ("DQ", "", dq_type_node); - builtin_define_fixed_point_constants ("TQ", "", tq_type_node); - builtin_define_fixed_point_constants ("UQQ", "", uqq_type_node); - builtin_define_fixed_point_constants ("UHQ", "", uhq_type_node); - builtin_define_fixed_point_constants ("USQ", "", usq_type_node); - builtin_define_fixed_point_constants ("UDQ", "", udq_type_node); - builtin_define_fixed_point_constants ("UTQ", "", utq_type_node); - builtin_define_fixed_point_constants ("HA", "", ha_type_node); - builtin_define_fixed_point_constants ("SA", "", sa_type_node); - builtin_define_fixed_point_constants ("DA", "", da_type_node); - builtin_define_fixed_point_constants ("TA", "", ta_type_node); - builtin_define_fixed_point_constants ("UHA", "", uha_type_node); - builtin_define_fixed_point_constants ("USA", "", usa_type_node); - builtin_define_fixed_point_constants ("UDA", "", uda_type_node); - builtin_define_fixed_point_constants ("UTA", "", uta_type_node); - } - - /* For use in assembly language. */ - builtin_define_with_value ("__REGISTER_PREFIX__", REGISTER_PREFIX, 0); - builtin_define_with_value ("__USER_LABEL_PREFIX__", user_label_prefix, 0); - - /* Misc. */ - builtin_define_with_value ("__VERSION__", version_string, 1); - - if (flag_gnu89_inline) - cpp_define (pfile, "__GNUC_GNU_INLINE__"); - else - cpp_define (pfile, "__GNUC_STDC_INLINE__"); - - /* Definitions for LP64 model. */ - if (TYPE_PRECISION (long_integer_type_node) == 64 - && POINTER_SIZE == 64 - && TYPE_PRECISION (integer_type_node) == 32) - { - cpp_define (pfile, "_LP64"); - cpp_define (pfile, "__LP64__"); - } - - /* Other target-independent built-ins determined by command-line - options. */ - if (optimize_size) - cpp_define (pfile, "__OPTIMIZE_SIZE__"); - if (optimize) - cpp_define (pfile, "__OPTIMIZE__"); - - if (fast_math_flags_set_p ()) - cpp_define (pfile, "__FAST_MATH__"); - if (flag_no_inline) - cpp_define (pfile, "__NO_INLINE__"); - if (flag_signaling_nans) - cpp_define (pfile, "__SUPPORT_SNAN__"); - if (flag_finite_math_only) - cpp_define (pfile, "__FINITE_MATH_ONLY__=1"); - else - cpp_define (pfile, "__FINITE_MATH_ONLY__=0"); - if (flag_pic) - { - builtin_define_with_int_value ("__pic__", flag_pic); - builtin_define_with_int_value ("__PIC__", flag_pic); - } - if (flag_pie) - { - builtin_define_with_int_value ("__pie__", flag_pie); - builtin_define_with_int_value ("__PIE__", flag_pie); - } - - if (flag_iso) - cpp_define (pfile, "__STRICT_ANSI__"); - - if (!flag_signed_char) - cpp_define (pfile, "__CHAR_UNSIGNED__"); - - if (c_dialect_cxx () && TYPE_UNSIGNED (wchar_type_node)) - cpp_define (pfile, "__WCHAR_UNSIGNED__"); - - /* Tell source code if the compiler makes sync_compare_and_swap - builtins available. */ -#ifdef HAVE_sync_compare_and_swapqi - if (HAVE_sync_compare_and_swapqi) - cpp_define (pfile, "__GCC_HAVE_SYNC_COMPARE_AND_SWAP_1"); -#endif - -#ifdef HAVE_sync_compare_and_swaphi - if (HAVE_sync_compare_and_swaphi) - cpp_define (pfile, "__GCC_HAVE_SYNC_COMPARE_AND_SWAP_2"); -#endif - -#ifdef HAVE_sync_compare_and_swapsi - if (HAVE_sync_compare_and_swapsi) - cpp_define (pfile, "__GCC_HAVE_SYNC_COMPARE_AND_SWAP_4"); -#endif - -#ifdef HAVE_sync_compare_and_swapdi - if (HAVE_sync_compare_and_swapdi) - cpp_define (pfile, "__GCC_HAVE_SYNC_COMPARE_AND_SWAP_8"); -#endif - -#ifdef HAVE_sync_compare_and_swapti - if (HAVE_sync_compare_and_swapti) - cpp_define (pfile, "__GCC_HAVE_SYNC_COMPARE_AND_SWAP_16"); -#endif - -#ifdef DWARF2_UNWIND_INFO - if (dwarf2out_do_cfi_asm ()) - cpp_define (pfile, "__GCC_HAVE_DWARF2_CFI_ASM"); -#endif - - /* Make the choice of ObjC runtime visible to source code. */ - if (c_dialect_objc () && flag_next_runtime) - cpp_define (pfile, "__NEXT_RUNTIME__"); - - /* Show the availability of some target pragmas. */ - cpp_define (pfile, "__PRAGMA_REDEFINE_EXTNAME"); - - if (targetm.handle_pragma_extern_prefix) - cpp_define (pfile, "__PRAGMA_EXTERN_PREFIX"); - - /* Make the choice of the stack protector runtime visible to source code. - The macro names and values here were chosen for compatibility with an - earlier implementation, i.e. ProPolice. */ - if (flag_stack_protect == 2) - cpp_define (pfile, "__SSP_ALL__=2"); - else if (flag_stack_protect == 1) - cpp_define (pfile, "__SSP__=1"); - - if (flag_openmp) - cpp_define (pfile, "_OPENMP=200805"); - - builtin_define_type_sizeof ("__SIZEOF_INT__", integer_type_node); - builtin_define_type_sizeof ("__SIZEOF_LONG__", long_integer_type_node); - builtin_define_type_sizeof ("__SIZEOF_LONG_LONG__", - long_long_integer_type_node); - if (int128_integer_type_node != NULL_TREE) - builtin_define_type_sizeof ("__SIZEOF_INT128__", - int128_integer_type_node); - builtin_define_type_sizeof ("__SIZEOF_SHORT__", short_integer_type_node); - builtin_define_type_sizeof ("__SIZEOF_FLOAT__", float_type_node); - builtin_define_type_sizeof ("__SIZEOF_DOUBLE__", double_type_node); - builtin_define_type_sizeof ("__SIZEOF_LONG_DOUBLE__", long_double_type_node); - builtin_define_type_sizeof ("__SIZEOF_SIZE_T__", size_type_node); - builtin_define_type_sizeof ("__SIZEOF_WCHAR_T__", wchar_type_node); - builtin_define_type_sizeof ("__SIZEOF_WINT_T__", wint_type_node); - builtin_define_type_sizeof ("__SIZEOF_PTRDIFF_T__", - unsigned_ptrdiff_type_node); - /* ptr_type_node can't be used here since ptr_mode is only set when - toplev calls backend_init which is not done with -E switch. */ - builtin_define_with_int_value ("__SIZEOF_POINTER__", - POINTER_SIZE / BITS_PER_UNIT); - - /* A straightforward target hook doesn't work, because of problems - linking that hook's body when part of non-C front ends. */ -# define preprocessing_asm_p() (cpp_get_options (pfile)->lang == CLK_ASM) -# define preprocessing_trad_p() (cpp_get_options (pfile)->traditional) -# define builtin_define(TXT) cpp_define (pfile, TXT) -# define builtin_assert(TXT) cpp_assert (pfile, TXT) - TARGET_CPU_CPP_BUILTINS (); - TARGET_OS_CPP_BUILTINS (); - TARGET_OBJFMT_CPP_BUILTINS (); - - /* Support the __declspec keyword by turning them into attributes. - Note that the current way we do this may result in a collision - with predefined attributes later on. This can be solved by using - one attribute, say __declspec__, and passing args to it. The - problem with that approach is that args are not accumulated: each - new appearance would clobber any existing args. */ - if (TARGET_DECLSPEC) - builtin_define ("__declspec(x)=__attribute__((x))"); - - /* If decimal floating point is supported, tell the user if the - alternate format (BID) is used instead of the standard (DPD) - format. */ - if (ENABLE_DECIMAL_FLOAT && ENABLE_DECIMAL_BID_FORMAT) - cpp_define (pfile, "__DECIMAL_BID_FORMAT__"); - - builtin_define_with_int_value ("__BIGGEST_ALIGNMENT__", - BIGGEST_ALIGNMENT / BITS_PER_UNIT); -} - -/* Pass an object-like macro. If it doesn't lie in the user's - namespace, defines it unconditionally. Otherwise define a version - with two leading underscores, and another version with two leading - and trailing underscores, and define the original only if an ISO - standard was not nominated. - - e.g. passing "unix" defines "__unix", "__unix__" and possibly - "unix". Passing "_mips" defines "__mips", "__mips__" and possibly - "_mips". */ -void -builtin_define_std (const char *macro) -{ - size_t len = strlen (macro); - char *buff = (char *) alloca (len + 5); - char *p = buff + 2; - char *q = p + len; - - /* prepend __ (or maybe just _) if in user's namespace. */ - memcpy (p, macro, len + 1); - if (!( *p == '_' && (p[1] == '_' || ISUPPER (p[1])))) - { - if (*p != '_') - *--p = '_'; - if (p[1] != '_') - *--p = '_'; - } - cpp_define (parse_in, p); - - /* If it was in user's namespace... */ - if (p != buff + 2) - { - /* Define the macro with leading and following __. */ - if (q[-1] != '_') - *q++ = '_'; - if (q[-2] != '_') - *q++ = '_'; - *q = '\0'; - cpp_define (parse_in, p); - - /* Finally, define the original macro if permitted. */ - if (!flag_iso) - cpp_define (parse_in, macro); - } -} - -/* Pass an object-like macro and a value to define it to. The third - parameter says whether or not to turn the value into a string - constant. */ -void -builtin_define_with_value (const char *macro, const char *expansion, int is_str) -{ - char *buf; - size_t mlen = strlen (macro); - size_t elen = strlen (expansion); - size_t extra = 2; /* space for an = and a NUL */ - - if (is_str) - extra += 2; /* space for two quote marks */ - - buf = (char *) alloca (mlen + elen + extra); - if (is_str) - sprintf (buf, "%s=\"%s\"", macro, expansion); - else - sprintf (buf, "%s=%s", macro, expansion); - - cpp_define (parse_in, buf); -} - - -/* Pass an object-like macro and an integer value to define it to. */ -static void -builtin_define_with_int_value (const char *macro, HOST_WIDE_INT value) -{ - char *buf; - size_t mlen = strlen (macro); - size_t vlen = 18; - size_t extra = 2; /* space for = and NUL. */ - - buf = (char *) alloca (mlen + vlen + extra); - memcpy (buf, macro, mlen); - buf[mlen] = '='; - sprintf (buf + mlen + 1, HOST_WIDE_INT_PRINT_DEC, value); - - cpp_define (parse_in, buf); -} - -/* Pass an object-like macro a hexadecimal floating-point value. */ -static void -builtin_define_with_hex_fp_value (const char *macro, - tree type, int digits, - const char *hex_str, - const char *fp_suffix, - const char *fp_cast) -{ - REAL_VALUE_TYPE real; - char dec_str[64], buf1[256], buf2[256]; - - /* Hex values are really cool and convenient, except that they're - not supported in strict ISO C90 mode. First, the "p-" sequence - is not valid as part of a preprocessor number. Second, we get a - pedwarn from the preprocessor, which has no context, so we can't - suppress the warning with __extension__. - - So instead what we do is construct the number in hex (because - it's easy to get the exact correct value), parse it as a real, - then print it back out as decimal. */ - - real_from_string (&real, hex_str); - real_to_decimal_for_mode (dec_str, &real, sizeof (dec_str), digits, 0, - TYPE_MODE (type)); - - /* Assemble the macro in the following fashion - macro = fp_cast [dec_str fp_suffix] */ - sprintf (buf1, "%s%s", dec_str, fp_suffix); - sprintf (buf2, fp_cast, buf1); - sprintf (buf1, "%s=%s", macro, buf2); - - cpp_define (parse_in, buf1); -} - -/* Return a string constant for the suffix for a value of type TYPE - promoted according to the integer promotions. The type must be one - of the standard integer type nodes. */ - -static const char * -type_suffix (tree type) -{ - static const char *const suffixes[] = { "", "U", "L", "UL", "LL", "ULL" }; - int unsigned_suffix; - int is_long; - - if (type == long_long_integer_type_node - || type == long_long_unsigned_type_node) - is_long = 2; - else if (type == long_integer_type_node - || type == long_unsigned_type_node) - is_long = 1; - else if (type == integer_type_node - || type == unsigned_type_node - || type == short_integer_type_node - || type == short_unsigned_type_node - || type == signed_char_type_node - || type == unsigned_char_type_node - /* ??? "char" is not a signed or unsigned integer type and - so is not permitted for the standard typedefs, but some - systems use it anyway. */ - || type == char_type_node) - is_long = 0; - else - gcc_unreachable (); - - unsigned_suffix = TYPE_UNSIGNED (type); - if (TYPE_PRECISION (type) < TYPE_PRECISION (integer_type_node)) - unsigned_suffix = 0; - return suffixes[is_long * 2 + unsigned_suffix]; -} - -/* Define MACRO as a constant-suffix macro for TYPE. */ -static void -builtin_define_constants (const char *macro, tree type) -{ - const char *suffix; - char *buf; - - suffix = type_suffix (type); - - if (suffix[0] == 0) - { - buf = (char *) alloca (strlen (macro) + 6); - sprintf (buf, "%s(c)=c", macro); - } - else - { - buf = (char *) alloca (strlen (macro) + 9 + strlen (suffix) + 1); - sprintf (buf, "%s(c)=c ## %s", macro, suffix); - } - - cpp_define (parse_in, buf); -} - -/* Define MAX for TYPE based on the precision of the type. */ - -static void -builtin_define_type_max (const char *macro, tree type) -{ - builtin_define_type_minmax (NULL, macro, type); -} - -/* Define MIN_MACRO (if not NULL) and MAX_MACRO for TYPE based on the - precision of the type. */ - -static void -builtin_define_type_minmax (const char *min_macro, const char *max_macro, - tree type) -{ - static const char *const values[] - = { "127", "255", - "32767", "65535", - "2147483647", "4294967295", - "9223372036854775807", "18446744073709551615", - "170141183460469231731687303715884105727", - "340282366920938463463374607431768211455" }; - - const char *value, *suffix; - char *buf; - size_t idx; - - /* Pre-rendering the values mean we don't have to futz with printing a - multi-word decimal value. There are also a very limited number of - precisions that we support, so it's really a waste of time. */ - switch (TYPE_PRECISION (type)) - { - case 8: idx = 0; break; - case 16: idx = 2; break; - case 32: idx = 4; break; - case 64: idx = 6; break; - case 128: idx = 8; break; - default: gcc_unreachable (); - } - - value = values[idx + TYPE_UNSIGNED (type)]; - suffix = type_suffix (type); - - buf = (char *) alloca (strlen (max_macro) + 1 + strlen (value) - + strlen (suffix) + 1); - sprintf (buf, "%s=%s%s", max_macro, value, suffix); - - cpp_define (parse_in, buf); - - if (min_macro) - { - if (TYPE_UNSIGNED (type)) - { - buf = (char *) alloca (strlen (min_macro) + 2 + strlen (suffix) + 1); - sprintf (buf, "%s=0%s", min_macro, suffix); - } - else - { - buf = (char *) alloca (strlen (min_macro) + 3 - + strlen (max_macro) + 6); - sprintf (buf, "%s=(-%s - 1)", min_macro, max_macro); - } - cpp_define (parse_in, buf); - } -} diff --git a/gcc/c-decl.c b/gcc/c-decl.c index cda6ce3ca77..2033a3b1e9f 100644 --- a/gcc/c-decl.c +++ b/gcc/c-decl.c @@ -45,8 +45,8 @@ along with GCC; see the file COPYING3. If not see #include "debug.h" #include "opts.h" #include "timevar.h" -#include "c-common.h" -#include "c-pragma.h" +#include "c-family/c-common.h" +#include "c-family/c-pragma.h" #include "c-lang.h" #include "langhooks.h" #include "tree-mudflap.h" @@ -58,7 +58,7 @@ along with GCC; see the file COPYING3. If not see #include "langhooks-def.h" #include "pointer-set.h" #include "plugin.h" -#include "c-ada-spec.h" +#include "c-family/c-ada-spec.h" /* In grokdeclarator, distinguish syntactic contexts of declarators. */ enum decl_context @@ -590,7 +590,7 @@ bind (tree name, tree decl, struct c_scope *scope, bool invisible, binding_freelist = b->prev; } else - b = GGC_NEW (struct c_binding); + b = ggc_alloc_c_binding (); b->shadowed = 0; b->decl = decl; @@ -704,7 +704,7 @@ void record_inline_static (location_t loc, tree func, tree decl, enum c_inline_static_type type) { - struct c_inline_static *csi = GGC_NEW (struct c_inline_static); + struct c_inline_static *csi = ggc_alloc_c_inline_static (); csi->location = loc; csi->function = func; csi->static_decl = decl; @@ -928,7 +928,7 @@ push_scope (void) scope_freelist = scope->outer; } else - scope = GGC_CNEW (struct c_scope); + scope = ggc_alloc_cleared_c_scope (); /* The FLOAT_CONST_DECIMAL64 pragma applies to nested scopes. */ if (current_scope) @@ -3007,7 +3007,7 @@ make_label (location_t location, tree name, bool defining, DECL_CONTEXT (label) = current_function_decl; DECL_MODE (label) = VOIDmode; - label_vars = GGC_NEW (struct c_label_vars); + label_vars = ggc_alloc_c_label_vars (); label_vars->shadowed = NULL; set_spot_bindings (&label_vars->label_bindings, defining); label_vars->decls_in_scope = make_tree_vector (); @@ -3105,7 +3105,7 @@ lookup_label_for_goto (location_t loc, tree name) { struct c_goto_bindings *g; - g = GGC_NEW (struct c_goto_bindings); + g = ggc_alloc_c_goto_bindings (); g->loc = loc; set_spot_bindings (&g->goto_bindings, true); VEC_safe_push (c_goto_bindings_p, gc, label_vars->gotos, g); @@ -5901,12 +5901,6 @@ grokdeclarator (const struct c_declarator *declarator, pedwarn (loc, OPT_pedantic, "ISO C forbids qualified function types"); - /* GNU C interprets a volatile-qualified function type to indicate - that the function does not return. */ - if ((type_quals & TYPE_QUAL_VOLATILE) - && !VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))) - warning_at (loc, 0, "% function returns non-void value"); - /* Every function declaration is an external reference (DECL_EXTERNAL) except for those which are not at file scope and are explicitly declared "auto". This is @@ -6993,9 +6987,9 @@ finish_struct (location_t loc, tree t, tree fieldlist, tree attributes, ensure that this lives as long as the rest of the struct decl. All decls in an inline function need to be saved. */ - space = GGC_CNEW (struct lang_type); - space2 = GGC_NEWVAR (struct sorted_fields_type, - sizeof (struct sorted_fields_type) + len * sizeof (tree)); + space = ggc_alloc_cleared_lang_type (sizeof (struct lang_type)); + space2 = ggc_alloc_sorted_fields_type + (sizeof (struct sorted_fields_type) + len * sizeof (tree)); len = 0; space->s = space2; @@ -7276,7 +7270,7 @@ finish_enum (tree enumtype, tree values, tree attributes) /* Record the min/max values so that we can warn about bit-field enumerations that are too small for the values. */ - lt = GGC_CNEW (struct lang_type); + lt = ggc_alloc_cleared_lang_type (sizeof (struct lang_type)); lt->enum_min = minnode; lt->enum_max = maxnode; TYPE_LANG_SPECIFIC (enumtype) = lt; @@ -8299,7 +8293,7 @@ void c_push_function_context (void) { struct language_function *p; - p = GGC_NEW (struct language_function); + p = ggc_alloc_language_function (); cfun->language = p; p->base.x_stmt_tree = c_stmt_tree; @@ -9664,11 +9658,6 @@ c_write_global_declarations (void) if (pch_file) return; - /* Don't waste time on further processing if -fsyntax-only. - Continue for warning and errors issued during lowering though. */ - if (flag_syntax_only) - return; - /* Close the external scope. */ ext_block = pop_scope (); external_scope = 0; diff --git a/gcc/c-dump.c b/gcc/c-dump.c deleted file mode 100644 index 71e872e22cb..00000000000 --- a/gcc/c-dump.c +++ /dev/null @@ -1,61 +0,0 @@ -/* Tree-dumping functionality for C-family languages. - Copyright (C) 2002, 2004, 2005, 2007 Free Software Foundation, Inc. - Written by Mark Mitchell - -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 3, 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 COPYING3. If not see -. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "tm.h" -#include "tree.h" -#include "tree-dump.h" -#include "c-common.h" - -/* Dump information common to statements from STMT. */ - -void -dump_stmt (dump_info_p di, const_tree t) -{ - if (EXPR_HAS_LOCATION (t)) - dump_int (di, "line", EXPR_LINENO (t)); -} - -/* Dump any C-specific tree codes and attributes of common codes. */ - -bool -c_dump_tree (void *dump_info, tree t) -{ - enum tree_code code; - dump_info_p di = (dump_info_p) dump_info; - - /* Figure out what kind of node this is. */ - code = TREE_CODE (t); - - switch (code) - { - case FIELD_DECL: - if (DECL_C_BIT_FIELD (t)) - dump_string (di, "bitfield"); - break; - - default: - break; - } - - return false; -} diff --git a/gcc/c-family/ChangeLog b/gcc/c-family/ChangeLog new file mode 100644 index 00000000000..4047ca54176 --- /dev/null +++ b/gcc/c-family/ChangeLog @@ -0,0 +1,162 @@ +2010-06-30 Manuel López-Ibáñez + + * c-gimplify.c: Do not include tree-flow.h + +2010-06-29 Joern Rennecke + + PR other/44034 + * c-common.c: Rename targetm member: + targetm.enum_va_list -> targetm.enum_va_list_p + +2010-06-28 Anatoly Sokolov + + * c-common.c (shorten_compare): Adjust call to force_fit_type_double. + +2010-06-28 Steven Bosscher + + * c-cppbuiltin.c: Do not include except.h. + +2010-06-24 Andi Kleen + + * c-common.c (warn_for_omitted_condop): New. + * c-common.h (warn_for_omitted_condop): Add prototype. + +2010-06-21 Joseph Myers + + * c.opt (lang-objc): Remove. + * c-opts.c (c_common_handle_option): Don't handle OPT_lang_objc. + +2010-06-21 Joern Rennecke + + * c-opts.c: Include "tm_p.h". + +2010-06-20 Joseph Myers + + * c-common.c (parse_optimize_options): Update call to + decode_options. + +2010-06-18 Nathan Froyd + + * c-common.c (record_types_used_by_current_var_decl): Adjust for + new type of types_used_by_cur_var_decl. + +2010-06-17 Joern Rennecke + + PR bootstrap/44512 + * c-cppbuiltin.c (builtin_define_with_hex_fp_value): Add cast + for C++ standard compliance. + +2010-06-16 Jason Merrill + + * c.opt: Add -Wnoexcept. + +2010-06-16 Richard Guenther + + PR c/44555 + * c-common.c (c_common_truthvalue_conversion): Remove + premature and wrong optimization concering ADDR_EXPRs. + +2010-06-15 Arnaud Charlet + + * c-ada-spec.c (dump_sloc): Remove column info. + (is_simple_enum): New function. + (dump_generic_ada_node, print_ada_declaration): Map C enum types to Ada + enum types when relevant. + +2010-06-11 Manuel López-Ibáñez + + * c-common.c (conversion_warning): Warn at expression + location. + +2010-06-10 Joseph Myers + + * c-opts.c (c_common_handle_option): Don't handle + OPT_fshow_column. + +2010-06-08 Laurynas Biveinis + + * c-pragma.c (push_alignment): Use typed GC allocation. + (handle_pragma_push_options): Likewise. + + * c-common.c (parse_optimize_options): Likewise. + + * c-common.h (struct sorted_fields_type): Add variable_size GTY + option. + +2010-06-07 Joseph Myers + + * c-common.c (flag_preprocess_only, flag_undef, flag_no_builtin, + flag_no_nonansi_builtin, flag_short_double, flag_short_wchar, + flag_lax_vector_conversions, flag_ms_extensions, flag_no_asm, + flag_signed_bitfields, warn_strict_null_sentinel, + flag_nil_receivers, flag_zero_link, flag_replace_objc_classes, + flag_gen_declaration, flag_no_gnu_keywords, + flag_implement_inlines, flag_implicit_templates, + flag_implicit_inline_templates, flag_optional_diags, + flag_elide_constructors, flag_default_inline, flag_rtti, + flag_conserve_space, flag_access_control, flag_check_new, + flag_new_for_scope, flag_weak, flag_working_directory, + flag_use_cxa_atexit, flag_use_cxa_get_exception_ptr, + flag_enforce_eh_specs, flag_threadsafe_statics, + flag_pretty_templates): Remove. + * c-common.h (flag_preprocess_only, flag_nil_receivers, + flag_objc_exceptions, flag_objc_sjlj_exceptions, flag_zero_link, + flag_replace_objc_classes, flag_undef, flag_no_builtin, + flag_no_nonansi_builtin, flag_short_double, flag_short_wchar, + flag_lax_vector_conversions, flag_ms_extensions, flag_no_asm, + flag_const_strings, flag_signed_bitfields, flag_gen_declaration, + flag_no_gnu_keywords, flag_implement_inlines, + flag_implicit_templates, flag_implicit_inline_templates, + flag_optional_diags, flag_elide_constructors, flag_default_inline, + flag_rtti, flag_conserve_space, flag_access_control, + flag_check_new, flag_new_for_scope, flag_weak, + flag_working_directory, flag_use_cxa_atexit, + flag_use_cxa_get_exception_ptr, flag_enforce_eh_specs, + flag_threadsafe_statics, flag_pretty_templates, + warn_strict_null_sentinel): Remove. + * c.opt (E, Wstrict-null-sentinel, faccess-control, fasm, + fbuiltin, fcheck-new, fconserve-space, felide-constructors, + fenforce-eh-specs, ffor-scope, fgnu-keywords, fimplement-inlines, + fimplicit-inline-templates, fimplicit-templates, + flax-vector-conversions, fms-extensions, fnil-receivers, + fnonansi-builtins, fpretty-templates, freplace-objc-classes, + frtti, fshort-double, fshort-enums, fshort-wchar, + fsigned-bitfields, fsigned-char, fstats, fthreadsafe-statics, + funsigned-bitfields, funsigned-char, fuse-cxa-atexit, + fuse-cxa-get-exception-ptr, fweak, fworking-directory, fzero-link, + gen-decls, undef): Use Var. + (fdefault-inline, foptional-diags): Document as doing nothing. + * c-opts.c (c_common_handle_option): Remove cases for options now + using Var. Mark ignored options as such. + +2010-06-05 Steven Bosscher + + * c-common.c: Moved to here from parent directory. + * c-common.def: Likewise. + * c-common.h: Likewise. + * c-cppbuiltin.c: Likewise. + * c-dump.c: Likewise. + * c-format.c: Likewise. + * c-format.h : Likewise. + * c-gimplify.c: Likewise. + * c-lex.c: Likewise. + * c-omp.c: Likewise. + * c.opt: Likewise. + * c-opts.c: Likewise. + * c-pch.c: Likewise. + * c-ppoutput.c: Likewise. + * c-pragma.c: Likewise. + * c-pragma.h: Likewise. + * c-pretty-print.c: Likewise. + * c-pretty-print.h: Likewise. + * c-semantics.c: Likewise. + * stub-objc.c: Likewise. + + * c-common.c: Include gt-c-family-c-common.h. + * c-pragma.c: Include gt-c-family-c-pragma.h. + +Copyright (C) 2010 Free Software Foundation, Inc. + +Copying and distribution of this file, with or without modification, +are permitted in any medium without royalty provided the copyright +notice and this notice are preserved. diff --git a/gcc/c-family/c-ada-spec.c b/gcc/c-family/c-ada-spec.c new file mode 100644 index 00000000000..8e914866696 --- /dev/null +++ b/gcc/c-family/c-ada-spec.c @@ -0,0 +1,3292 @@ +/* Print GENERIC declaration (functions, variables, types) trees coming from + the C and C++ front-ends as well as macros in Ada syntax. + Copyright (C) 2010 Free Software Foundation, Inc. + Adapted from tree-pretty-print.c by Arnaud Charlet + +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 3, 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 COPYING3. If not see +. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tm.h" +#include "tree.h" +#include "tree-pass.h" /* For TDI_ada and friends. */ +#include "output.h" +#include "c-ada-spec.h" +#include "cpplib.h" +#include "c-pragma.h" +#include "cpp-id-data.h" + +/* Local functions, macros and variables. */ +static int dump_generic_ada_node (pretty_printer *, tree, tree, + int (*)(tree, cpp_operation), int, int, bool); +static int print_ada_declaration (pretty_printer *, tree, tree, + int (*cpp_check)(tree, cpp_operation), int); +static void print_ada_struct_decl (pretty_printer *, tree, tree, + int (*cpp_check)(tree, cpp_operation), int, + bool); +static void dump_sloc (pretty_printer *buffer, tree node); +static void print_comment (pretty_printer *, const char *); +static void print_generic_ada_decl (pretty_printer *, tree, + int (*)(tree, cpp_operation), const char *); +static char *get_ada_package (const char *); +static void dump_ada_nodes (pretty_printer *, const char *, + int (*)(tree, cpp_operation)); +static void reset_ada_withs (void); +static void dump_ada_withs (FILE *); +static void dump_ads (const char *, void (*)(const char *), + int (*)(tree, cpp_operation)); +static char *to_ada_name (const char *, int *); + +#define LOCATION_COL(LOC) ((expand_location (LOC)).column) + +#define INDENT(SPACE) do { \ + int i; for (i = 0; ifun_like) + { + param_len++; + for (i = 0; i < macro->paramc; i++) + { + cpp_hashnode *param = macro->params[i]; + + *param_len += NODE_LEN (param); + + if (i + 1 < macro->paramc) + { + *param_len += 2; /* ", " */ + } + else if (macro->variadic) + { + *supported = 0; + return; + } + } + *param_len += 2; /* ")\0" */ + } + + for (j = 0; j < macro->count; j++) + { + cpp_token *token = ¯o->exp.tokens[j]; + + if (token->flags & PREV_WHITE) + (*buffer_len)++; + + if (token->flags & STRINGIFY_ARG || token->flags & PASTE_LEFT) + { + *supported = 0; + return; + } + + if (token->type == CPP_MACRO_ARG) + *buffer_len += + NODE_LEN (macro->params[token->val.macro_arg.arg_no - 1]); + else + /* Include enough extra space to handle e.g. special characters. */ + *buffer_len += (cpp_token_len (token) + 1) * 8; + } + + (*buffer_len)++; +} + +/* Dump into PP a set of MAX_ADA_MACROS MACROS (C/C++) as Ada constants when + possible. */ + +static void +print_ada_macros (pretty_printer *pp, cpp_hashnode **macros, int max_ada_macros) +{ + int j, num_macros = 0, prev_line = -1; + + for (j = 0; j < max_ada_macros; j++) + { + cpp_hashnode *node = macros [j]; + const cpp_macro *macro = node->value.macro; + unsigned i; + int supported = 1, prev_is_one = 0, buffer_len, param_len; + int is_string = 0, is_char = 0; + char *ada_name; + unsigned char *s, *params, *buffer, *buf_param, *char_one = NULL; + + macro_length (macro, &supported, &buffer_len, ¶m_len); + s = buffer = XALLOCAVEC (unsigned char, buffer_len); + params = buf_param = XALLOCAVEC (unsigned char, param_len); + + if (supported) + { + if (macro->fun_like) + { + *buf_param++ = '('; + for (i = 0; i < macro->paramc; i++) + { + cpp_hashnode *param = macro->params[i]; + + memcpy (buf_param, NODE_NAME (param), NODE_LEN (param)); + buf_param += NODE_LEN (param); + + if (i + 1 < macro->paramc) + { + *buf_param++ = ','; + *buf_param++ = ' '; + } + else if (macro->variadic) + { + supported = 0; + break; + } + } + *buf_param++ = ')'; + *buf_param = '\0'; + } + + for (i = 0; supported && i < macro->count; i++) + { + cpp_token *token = ¯o->exp.tokens[i]; + int is_one = 0; + + if (token->flags & PREV_WHITE) + *buffer++ = ' '; + + if (token->flags & STRINGIFY_ARG || token->flags & PASTE_LEFT) + { + supported = 0; + break; + } + + switch (token->type) + { + case CPP_MACRO_ARG: + { + cpp_hashnode *param = + macro->params[token->val.macro_arg.arg_no - 1]; + memcpy (buffer, NODE_NAME (param), NODE_LEN (param)); + buffer += NODE_LEN (param); + } + break; + + case CPP_EQ_EQ: *buffer++ = '='; break; + case CPP_GREATER: *buffer++ = '>'; break; + case CPP_LESS: *buffer++ = '<'; break; + case CPP_PLUS: *buffer++ = '+'; break; + case CPP_MINUS: *buffer++ = '-'; break; + case CPP_MULT: *buffer++ = '*'; break; + case CPP_DIV: *buffer++ = '/'; break; + case CPP_COMMA: *buffer++ = ','; break; + case CPP_OPEN_SQUARE: + case CPP_OPEN_PAREN: *buffer++ = '('; break; + case CPP_CLOSE_SQUARE: /* fallthrough */ + case CPP_CLOSE_PAREN: *buffer++ = ')'; break; + case CPP_DEREF: /* fallthrough */ + case CPP_SCOPE: /* fallthrough */ + case CPP_DOT: *buffer++ = '.'; break; + + case CPP_EQ: *buffer++ = ':'; *buffer++ = '='; break; + case CPP_NOT_EQ: *buffer++ = '/'; *buffer++ = '='; break; + case CPP_GREATER_EQ: *buffer++ = '>'; *buffer++ = '='; break; + case CPP_LESS_EQ: *buffer++ = '<'; *buffer++ = '='; break; + + case CPP_NOT: + *buffer++ = 'n'; *buffer++ = 'o'; *buffer++ = 't'; break; + case CPP_MOD: + *buffer++ = 'm'; *buffer++ = 'o'; *buffer++ = 'd'; break; + case CPP_AND: + *buffer++ = 'a'; *buffer++ = 'n'; *buffer++ = 'd'; break; + case CPP_OR: + *buffer++ = 'o'; *buffer++ = 'r'; break; + case CPP_XOR: + *buffer++ = 'x'; *buffer++ = 'o'; *buffer++ = 'r'; break; + case CPP_AND_AND: + strcpy ((char *) buffer, " and then "); + buffer += 10; + break; + case CPP_OR_OR: + strcpy ((char *) buffer, " or else "); + buffer += 9; + break; + + case CPP_PADDING: + *buffer++ = ' '; + is_one = prev_is_one; + break; + + case CPP_COMMENT: break; + + case CPP_WSTRING: + case CPP_STRING16: + case CPP_STRING32: + case CPP_UTF8STRING: + case CPP_WCHAR: + case CPP_CHAR16: + case CPP_CHAR32: + case CPP_NAME: + case CPP_STRING: + case CPP_NUMBER: + if (!macro->fun_like) + supported = 0; + else + buffer = cpp_spell_token (parse_in, token, buffer, false); + break; + + case CPP_CHAR: + is_char = 1; + { + unsigned chars_seen; + int ignored; + cppchar_t c; + + c = cpp_interpret_charconst (parse_in, token, + &chars_seen, &ignored); + if (c >= 32 && c <= 126) + { + *buffer++ = '\''; + *buffer++ = (char) c; + *buffer++ = '\''; + } + else + { + chars_seen = sprintf + ((char *) buffer, "Character'Val (%d)", (int) c); + buffer += chars_seen; + } + } + break; + + case CPP_LSHIFT: + if (prev_is_one) + { + /* Replace "1 << N" by "2 ** N" */ + *char_one = '2'; + *buffer++ = '*'; + *buffer++ = '*'; + break; + } + /* fallthrough */ + + case CPP_RSHIFT: + case CPP_COMPL: + case CPP_QUERY: + case CPP_EOF: + case CPP_PLUS_EQ: + case CPP_MINUS_EQ: + case CPP_MULT_EQ: + case CPP_DIV_EQ: + case CPP_MOD_EQ: + case CPP_AND_EQ: + case CPP_OR_EQ: + case CPP_XOR_EQ: + case CPP_RSHIFT_EQ: + case CPP_LSHIFT_EQ: + case CPP_PRAGMA: + case CPP_PRAGMA_EOL: + case CPP_HASH: + case CPP_PASTE: + case CPP_OPEN_BRACE: + case CPP_CLOSE_BRACE: + case CPP_SEMICOLON: + case CPP_ELLIPSIS: + case CPP_PLUS_PLUS: + case CPP_MINUS_MINUS: + case CPP_DEREF_STAR: + case CPP_DOT_STAR: + case CPP_ATSIGN: + case CPP_HEADER_NAME: + case CPP_AT_NAME: + case CPP_OTHER: + case CPP_OBJC_STRING: + default: + if (!macro->fun_like) + supported = 0; + else + buffer = cpp_spell_token (parse_in, token, buffer, false); + break; + } + + prev_is_one = is_one; + } + + if (supported) + *buffer = '\0'; + } + + if (macro->fun_like && supported) + { + char *start = (char *) s; + int is_function = 0; + + pp_string (pp, " -- arg-macro: "); + + if (*start == '(' && buffer [-1] == ')') + { + start++; + buffer [-1] = '\0'; + is_function = 1; + pp_string (pp, "function "); + } + else + { + pp_string (pp, "procedure "); + } + + pp_string (pp, (const char *) NODE_NAME (node)); + pp_space (pp); + pp_string (pp, (char *) params); + pp_newline (pp); + pp_string (pp, " -- "); + + if (is_function) + { + pp_string (pp, "return "); + pp_string (pp, start); + pp_semicolon (pp); + } + else + pp_string (pp, start); + + pp_newline (pp); + } + else if (supported) + { + expanded_location sloc = expand_location (macro->line); + + if (sloc.line != prev_line + 1) + pp_newline (pp); + + num_macros++; + prev_line = sloc.line; + + pp_string (pp, " "); + ada_name = to_ada_name ((const char *) NODE_NAME (node), NULL); + pp_string (pp, ada_name); + free (ada_name); + pp_string (pp, " : "); + + if (is_string) + pp_string (pp, "aliased constant String"); + else if (is_char) + pp_string (pp, "aliased constant Character"); + else + pp_string (pp, "constant"); + + pp_string (pp, " := "); + pp_string (pp, (char *) s); + + if (is_string) + pp_string (pp, " & ASCII.NUL"); + + pp_string (pp, "; -- "); + pp_string (pp, sloc.file); + pp_character (pp, ':'); + pp_scalar (pp, "%d", sloc.line); + pp_newline (pp); + } + else + { + pp_string (pp, " -- unsupported macro: "); + pp_string (pp, (const char *) cpp_macro_definition (parse_in, node)); + pp_newline (pp); + } + } + + if (num_macros > 0) + pp_newline (pp); +} + +static const char *source_file; +static int max_ada_macros; + +/* Callback used to count the number of relevant macros from + cpp_forall_identifiers. PFILE and V are not used. NODE is the current macro + to consider. */ + +static int +count_ada_macro (cpp_reader *pfile ATTRIBUTE_UNUSED, cpp_hashnode *node, + void *v ATTRIBUTE_UNUSED) +{ + const cpp_macro *macro = node->value.macro; + + if (node->type == NT_MACRO && !(node->flags & NODE_BUILTIN) + && macro->count + && *NODE_NAME (node) != '_' + && LOCATION_FILE (macro->line) == source_file) + max_ada_macros++; + + return 1; +} + +static int store_ada_macro_index; + +/* Callback used to store relevant macros from cpp_forall_identifiers. + PFILE is not used. NODE is the current macro to store if relevant. + MACROS is an array of cpp_hashnode* used to store NODE. */ + +static int +store_ada_macro (cpp_reader *pfile ATTRIBUTE_UNUSED, + cpp_hashnode *node, void *macros) +{ + const cpp_macro *macro = node->value.macro; + + if (node->type == NT_MACRO && !(node->flags & NODE_BUILTIN) + && macro->count + && *NODE_NAME (node) != '_' + && LOCATION_FILE (macro->line) == source_file) + ((cpp_hashnode **) macros)[store_ada_macro_index++] = node; + + return 1; +} + +/* Callback used to compare (during qsort) macros. NODE1 and NODE2 are the + two macro nodes to compare. */ + +static int +compare_macro (const void *node1, const void *node2) +{ + typedef const cpp_hashnode *const_hnode; + + const_hnode n1 = *(const const_hnode *) node1; + const_hnode n2 = *(const const_hnode *) node2; + + return n1->value.macro->line - n2->value.macro->line; +} + +/* Dump in PP all relevant macros appearing in FILE. */ + +static void +dump_ada_macros (pretty_printer *pp, const char* file) +{ + cpp_hashnode **macros; + + /* Initialize file-scope variables. */ + max_ada_macros = 0; + store_ada_macro_index = 0; + source_file = file; + + /* Count all potentially relevant macros, and then sort them by sloc. */ + cpp_forall_identifiers (parse_in, count_ada_macro, NULL); + macros = XALLOCAVEC (cpp_hashnode *, max_ada_macros); + cpp_forall_identifiers (parse_in, store_ada_macro, macros); + qsort (macros, max_ada_macros, sizeof (cpp_hashnode *), compare_macro); + + print_ada_macros (pp, macros, max_ada_macros); +} + +/* Current source file being handled. */ + +static const char *source_file_base; + +/* Compare the declaration (DECL) of struct-like types based on the sloc of + their last field (if LAST is true), so that more nested types collate before + less nested ones. + If ORIG_TYPE is true, also consider struct with a DECL_ORIGINAL_TYPE. */ + +static location_t +decl_sloc_common (const_tree decl, bool last, bool orig_type) +{ + tree type = TREE_TYPE (decl); + + if (TREE_CODE (decl) == TYPE_DECL + && (orig_type || !DECL_ORIGINAL_TYPE (decl)) + && RECORD_OR_UNION_TYPE_P (type) + && TYPE_FIELDS (type)) + { + tree f = TYPE_FIELDS (type); + + if (last) + while (TREE_CHAIN (f)) + f = TREE_CHAIN (f); + + return DECL_SOURCE_LOCATION (f); + } + else + return DECL_SOURCE_LOCATION (decl); +} + +/* Return sloc of DECL, using sloc of last field if LAST is true. */ + +location_t +decl_sloc (const_tree decl, bool last) +{ + return decl_sloc_common (decl, last, false); +} + +/* Compare two declarations (LP and RP) by their source location. */ + +static int +compare_node (const void *lp, const void *rp) +{ + const_tree lhs = *((const tree *) lp); + const_tree rhs = *((const tree *) rp); + + return decl_sloc (lhs, true) - decl_sloc (rhs, true); +} + +/* Compare two comments (LP and RP) by their source location. */ + +static int +compare_comment (const void *lp, const void *rp) +{ + const cpp_comment *lhs = (const cpp_comment *) lp; + const cpp_comment *rhs = (const cpp_comment *) rp; + + if (LOCATION_FILE (lhs->sloc) != LOCATION_FILE (rhs->sloc)) + return strcmp (LOCATION_FILE (lhs->sloc), LOCATION_FILE (rhs->sloc)); + + if (LOCATION_LINE (lhs->sloc) != LOCATION_LINE (rhs->sloc)) + return LOCATION_LINE (lhs->sloc) - LOCATION_LINE (rhs->sloc); + + if (LOCATION_COL (lhs->sloc) != LOCATION_COL (rhs->sloc)) + return LOCATION_COL (lhs->sloc) - LOCATION_COL (rhs->sloc); + + return 0; +} + +static tree *to_dump = NULL; +static int to_dump_count = 0; + +/* Collect a list of declarations from T relevant to SOURCE_FILE to be dumped + by a subsequent call to dump_ada_nodes. */ + +void +collect_ada_nodes (tree t, const char *source_file) +{ + tree n; + int i = to_dump_count; + + /* Count the likely relevant nodes. */ + for (n = t; n; n = TREE_CHAIN (n)) + if (!DECL_IS_BUILTIN (n) + && LOCATION_FILE (decl_sloc (n, false)) == source_file) + to_dump_count++; + + /* Allocate sufficient storage for all nodes. */ + to_dump = XRESIZEVEC (tree, to_dump, to_dump_count); + + /* Store the relevant nodes. */ + for (n = t; n; n = TREE_CHAIN (n)) + if (!DECL_IS_BUILTIN (n) + && LOCATION_FILE (decl_sloc (n, false)) == source_file) + to_dump [i++] = n; +} + +/* Call back for walk_tree to clear the TREE_VISITED flag of TP. */ + +static tree +unmark_visited_r (tree *tp, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data ATTRIBUTE_UNUSED) +{ + if (TREE_VISITED (*tp)) + TREE_VISITED (*tp) = 0; + else + *walk_subtrees = 0; + + return NULL_TREE; +} + +/* Dump nodes into PP relevant to SOURCE_FILE, as collected by previous calls + to collect_ada_nodes. CPP_CHECK is used to perform C++ queries on nodes. */ + +static void +dump_ada_nodes (pretty_printer *pp, const char *source_file, + int (*cpp_check)(tree, cpp_operation)) +{ + int i, j; + cpp_comment_table *comments; + + /* Sort the table of declarations to dump by sloc. */ + qsort (to_dump, to_dump_count, sizeof (tree), compare_node); + + /* Fetch the table of comments. */ + comments = cpp_get_comments (parse_in); + + /* Sort the comments table by sloc. */ + qsort (comments->entries, comments->count, sizeof (cpp_comment), + compare_comment); + + /* Interleave comments and declarations in line number order. */ + i = j = 0; + do + { + /* Advance j until comment j is in this file. */ + while (j != comments->count + && LOCATION_FILE (comments->entries[j].sloc) != source_file) + j++; + + /* Advance j until comment j is not a duplicate. */ + while (j < comments->count - 1 + && !compare_comment (&comments->entries[j], + &comments->entries[j + 1])) + j++; + + /* Write decls until decl i collates after comment j. */ + while (i != to_dump_count) + { + if (j == comments->count + || LOCATION_LINE (decl_sloc (to_dump[i], false)) + < LOCATION_LINE (comments->entries[j].sloc)) + print_generic_ada_decl (pp, to_dump[i++], cpp_check, source_file); + else + break; + } + + /* Write comment j, if there is one. */ + if (j != comments->count) + print_comment (pp, comments->entries[j++].comment); + + } while (i != to_dump_count || j != comments->count); + + /* Clear the TREE_VISITED flag over each subtree we've dumped. */ + for (i = 0; i < to_dump_count; i++) + walk_tree (&to_dump[i], unmark_visited_r, NULL, NULL); + + /* Finalize the to_dump table. */ + if (to_dump) + { + free (to_dump); + to_dump = NULL; + to_dump_count = 0; + } +} + +/* Print a COMMENT to the output stream PP. */ + +static void +print_comment (pretty_printer *pp, const char *comment) +{ + int len = strlen (comment); + char *str = XALLOCAVEC (char, len + 1); + char *tok; + bool extra_newline = false; + + memcpy (str, comment, len + 1); + + /* Trim C/C++ comment indicators. */ + if (str[len - 2] == '*' && str[len - 1] == '/') + { + str[len - 2] = ' '; + str[len - 1] = '\0'; + } + str += 2; + + tok = strtok (str, "\n"); + while (tok) { + pp_string (pp, " --"); + pp_string (pp, tok); + pp_newline (pp); + tok = strtok (NULL, "\n"); + + /* Leave a blank line after multi-line comments. */ + if (tok) + extra_newline = true; + } + + if (extra_newline) + pp_newline (pp); +} + +/* Prints declaration DECL to PP in Ada syntax. The current source file being + handled is SOURCE_FILE, and CPP_CHECK is used to perform C++ queries on + nodes. */ + +static void +print_generic_ada_decl (pretty_printer *pp, tree decl, + int (*cpp_check)(tree, cpp_operation), + const char* source_file) +{ + source_file_base = source_file; + + if (print_ada_declaration (pp, decl, 0, cpp_check, INDENT_INCR)) + { + pp_newline (pp); + pp_newline (pp); + } +} + +/* Dump a newline and indent BUFFER by SPC chars. */ + +static void +newline_and_indent (pretty_printer *buffer, int spc) +{ + pp_newline (buffer); + INDENT (spc); +} + +struct with { char *s; const char *in_file; int limited; }; +static struct with *withs = NULL; +static int withs_max = 4096; +static int with_len = 0; + +/* Record a "with" clause on package S (a limited with if LIMITED_ACCESS is + true), if not already done. */ + +static void +append_withs (const char *s, int limited_access) +{ + int i; + + if (withs == NULL) + withs = XNEWVEC (struct with, withs_max); + + if (with_len == withs_max) + { + withs_max *= 2; + withs = XRESIZEVEC (struct with, withs, withs_max); + } + + for (i = 0; i < with_len; i++) + if (!strcmp (s, withs [i].s) + && source_file_base == withs [i].in_file) + { + withs [i].limited &= limited_access; + return; + } + + withs [with_len].s = xstrdup (s); + withs [with_len].in_file = source_file_base; + withs [with_len].limited = limited_access; + with_len++; +} + +/* Reset "with" clauses. */ + +static void +reset_ada_withs (void) +{ + int i; + + if (!withs) + return; + + for (i = 0; i < with_len; i++) + free (withs [i].s); + free (withs); + withs = NULL; + withs_max = 4096; + with_len = 0; +} + +/* Dump "with" clauses in F. */ + +static void +dump_ada_withs (FILE *f) +{ + int i; + + fprintf (f, "with Interfaces.C; use Interfaces.C;\n"); + + for (i = 0; i < with_len; i++) + fprintf + (f, "%swith %s;\n", withs [i].limited ? "limited " : "", withs [i].s); +} + +/* Return suitable Ada package name from FILE. */ + +static char * +get_ada_package (const char *file) +{ + const char *base; + char *res; + const char *s; + int i; + + s = strstr (file, "/include/"); + if (s) + base = s + 9; + else + base = lbasename (file); + res = XNEWVEC (char, strlen (base) + 1); + + for (i = 0; *base; base++, i++) + switch (*base) + { + case '+': + res [i] = 'p'; + break; + + case '.': + case '-': + case '_': + case '/': + case '\\': + res [i] = (i == 0 || res [i - 1] == '_') ? 'u' : '_'; + break; + + default: + res [i] = *base; + break; + } + res [i] = '\0'; + + return res; +} + +static const char *ada_reserved[] = { + "abort", "abs", "abstract", "accept", "access", "aliased", "all", "and", + "array", "at", "begin", "body", "case", "constant", "declare", "delay", + "delta", "digits", "do", "else", "elsif", "end", "entry", "exception", + "exit", "for", "function", "generic", "goto", "if", "in", "interface", "is", + "limited", "loop", "mod", "new", "not", "null", "others", "out", "of", "or", + "overriding", "package", "pragma", "private", "procedure", "protected", + "raise", "range", "record", "rem", "renames", "requeue", "return", "reverse", + "select", "separate", "subtype", "synchronized", "tagged", "task", + "terminate", "then", "type", "until", "use", "when", "while", "with", "xor", + NULL}; + +/* ??? would be nice to specify this list via a config file, so that users + can create their own dictionary of conflicts. */ +static const char *c_duplicates[] = { + /* system will cause troubles with System.Address. */ + "system", + + /* The following values have other definitions with same name/other + casing. */ + "funmap", + "rl_vi_fWord", + "rl_vi_bWord", + "rl_vi_eWord", + "rl_readline_version", + "_Vx_ushort", + "USHORT", + "XLookupKeysym", + NULL}; + +/* Return a declaration tree corresponding to TYPE. */ + +static tree +get_underlying_decl (tree type) +{ + tree decl = NULL_TREE; + + if (type == NULL_TREE) + return NULL_TREE; + + /* type is a declaration. */ + if (DECL_P (type)) + decl = type; + + /* type is a typedef. */ + if (TYPE_P (type) && TYPE_NAME (type) && DECL_P (TYPE_NAME (type))) + decl = TYPE_NAME (type); + + /* TYPE_STUB_DECL has been set for type. */ + if (TYPE_P (type) && TYPE_STUB_DECL (type) && + DECL_P (TYPE_STUB_DECL (type))) + decl = TYPE_STUB_DECL (type); + + return decl; +} + +/* Return whether TYPE has static fields. */ + +static int +has_static_fields (const_tree type) +{ + tree tmp; + + for (tmp = TYPE_FIELDS (type); tmp; tmp = TREE_CHAIN (tmp)) + { + if (DECL_NAME (tmp) && TREE_STATIC (tmp)) + return true; + } + return false; +} + +/* Return whether TYPE corresponds to an Ada tagged type (has a dispatch + table). */ + +static int +is_tagged_type (const_tree type) +{ + tree tmp; + + if (!type || !RECORD_OR_UNION_TYPE_P (type)) + return false; + + for (tmp = TYPE_METHODS (type); tmp; tmp = TREE_CHAIN (tmp)) + if (DECL_VINDEX (tmp)) + return true; + + return false; +} + +/* Generate a legal Ada name from a C NAME, returning a malloc'd string. + SPACE_FOUND, if not NULL, is used to indicate whether a space was found in + NAME. */ + +static char * +to_ada_name (const char *name, int *space_found) +{ + const char **names; + int len = strlen (name); + int j, len2 = 0; + int found = false; + char *s = XNEWVEC (char, len * 2 + 5); + char c; + + if (space_found) + *space_found = false; + + /* Add trailing "c_" if name is an Ada reserved word. */ + for (names = ada_reserved; *names; names++) + if (!strcasecmp (name, *names)) + { + s [len2++] = 'c'; + s [len2++] = '_'; + found = true; + break; + } + + if (!found) + /* Add trailing "c_" if name is an potential case sensitive duplicate. */ + for (names = c_duplicates; *names; names++) + if (!strcmp (name, *names)) + { + s [len2++] = 'c'; + s [len2++] = '_'; + found = true; + break; + } + + for (j = 0; name [j] == '_'; j++) + s [len2++] = 'u'; + + if (j > 0) + s [len2++] = '_'; + else if (*name == '.' || *name == '$') + { + s [0] = 'a'; + s [1] = 'n'; + s [2] = 'o'; + s [3] = 'n'; + len2 = 4; + j++; + } + + /* Replace unsuitable characters for Ada identifiers. */ + + for (; j < len; j++) + switch (name [j]) + { + case ' ': + if (space_found) + *space_found = true; + s [len2++] = '_'; + break; + + /* ??? missing some C++ operators. */ + case '=': + s [len2++] = '_'; + + if (name [j + 1] == '=') + { + j++; + s [len2++] = 'e'; + s [len2++] = 'q'; + } + else + { + s [len2++] = 'a'; + s [len2++] = 's'; + } + break; + + case '!': + s [len2++] = '_'; + if (name [j + 1] == '=') + { + j++; + s [len2++] = 'n'; + s [len2++] = 'e'; + } + break; + + case '~': + s [len2++] = '_'; + s [len2++] = 't'; + s [len2++] = 'i'; + break; + + case '&': + case '|': + case '^': + s [len2++] = '_'; + s [len2++] = name [j] == '&' ? 'a' : name [j] == '|' ? 'o' : 'x'; + + if (name [j + 1] == '=') + { + j++; + s [len2++] = 'e'; + } + break; + + case '+': + case '-': + case '*': + case '/': + case '(': + case '[': + if (s [len2 - 1] != '_') + s [len2++] = '_'; + + switch (name [j + 1]) { + case '\0': + j++; + switch (name [j - 1]) { + case '+': s [len2++] = 'p'; break; /* + */ + case '-': s [len2++] = 'm'; break; /* - */ + case '*': s [len2++] = 't'; break; /* * */ + case '/': s [len2++] = 'd'; break; /* / */ + } + break; + + case '=': + j++; + switch (name [j - 1]) { + case '+': s [len2++] = 'p'; break; /* += */ + case '-': s [len2++] = 'm'; break; /* -= */ + case '*': s [len2++] = 't'; break; /* *= */ + case '/': s [len2++] = 'd'; break; /* /= */ + } + s [len2++] = 'a'; + break; + + case '-': /* -- */ + j++; + s [len2++] = 'm'; + s [len2++] = 'm'; + break; + + case '+': /* ++ */ + j++; + s [len2++] = 'p'; + s [len2++] = 'p'; + break; + + case ')': /* () */ + j++; + s [len2++] = 'o'; + s [len2++] = 'p'; + break; + + case ']': /* [] */ + j++; + s [len2++] = 'o'; + s [len2++] = 'b'; + break; + } + + break; + + case '<': + case '>': + c = name [j] == '<' ? 'l' : 'g'; + s [len2++] = '_'; + + switch (name [j + 1]) { + case '\0': + s [len2++] = c; + s [len2++] = 't'; + break; + case '=': + j++; + s [len2++] = c; + s [len2++] = 'e'; + break; + case '>': + j++; + s [len2++] = 's'; + s [len2++] = 'r'; + break; + case '<': + j++; + s [len2++] = 's'; + s [len2++] = 'l'; + break; + default: + break; + } + break; + + case '_': + if (len2 && s [len2 - 1] == '_') + s [len2++] = 'u'; + /* fall through */ + + default: + s [len2++] = name [j]; + } + + if (s [len2 - 1] == '_') + s [len2++] = 'u'; + + s [len2] = '\0'; + + return s; +} + +static bool package_prefix = true; + +/* Dump in BUFFER the name of an identifier NODE of type TYPE, following Ada + syntax. LIMITED_ACCESS indicates whether NODE can be accessed via a limited + 'with' clause rather than a regular 'with' clause. */ + +static void +pp_ada_tree_identifier (pretty_printer *buffer, tree node, tree type, + int limited_access) +{ + const char *name = IDENTIFIER_POINTER (node); + int space_found = false; + char *s = to_ada_name (name, &space_found); + tree decl; + + /* If the entity is a type and comes from another file, generate "package" + prefix. */ + + decl = get_underlying_decl (type); + + if (decl) + { + expanded_location xloc = expand_location (decl_sloc (decl, false)); + + if (xloc.file && xloc.line) + { + if (xloc.file != source_file_base) + { + switch (TREE_CODE (type)) + { + case ENUMERAL_TYPE: + case INTEGER_TYPE: + case REAL_TYPE: + case FIXED_POINT_TYPE: + case BOOLEAN_TYPE: + case REFERENCE_TYPE: + case POINTER_TYPE: + case ARRAY_TYPE: + case RECORD_TYPE: + case UNION_TYPE: + case QUAL_UNION_TYPE: + case TYPE_DECL: + { + char *s1 = get_ada_package (xloc.file); + + if (package_prefix) + { + append_withs (s1, limited_access); + pp_string (buffer, s1); + pp_character (buffer, '.'); + } + free (s1); + } + break; + default: + break; + } + } + } + } + + if (space_found) + if (!strcmp (s, "short_int")) + pp_string (buffer, "short"); + else if (!strcmp (s, "short_unsigned_int")) + pp_string (buffer, "unsigned_short"); + else if (!strcmp (s, "unsigned_int")) + pp_string (buffer, "unsigned"); + else if (!strcmp (s, "long_int")) + pp_string (buffer, "long"); + else if (!strcmp (s, "long_unsigned_int")) + pp_string (buffer, "unsigned_long"); + else if (!strcmp (s, "long_long_int")) + pp_string (buffer, "Long_Long_Integer"); + else if (!strcmp (s, "long_long_unsigned_int")) + { + if (package_prefix) + { + append_withs ("Interfaces.C.Extensions", false); + pp_string (buffer, "Extensions.unsigned_long_long"); + } + else + pp_string (buffer, "unsigned_long_long"); + } + else + pp_string(buffer, s); + else + if (!strcmp (s, "bool")) + { + if (package_prefix) + { + append_withs ("Interfaces.C.Extensions", false); + pp_string (buffer, "Extensions.bool"); + } + else + pp_string (buffer, "bool"); + } + else + pp_string(buffer, s); + + free (s); +} + +/* Dump in BUFFER the assembly name of T. */ + +static void +pp_asm_name (pretty_printer *buffer, tree t) +{ + tree name = DECL_ASSEMBLER_NAME (t); + char *ada_name = XALLOCAVEC (char, IDENTIFIER_LENGTH (name) + 1), *s; + const char *ident = IDENTIFIER_POINTER (name); + + for (s = ada_name; *ident; ident++) + { + if (*ident == ' ') + break; + else if (*ident != '*') + *s++ = *ident; + } + + *s = '\0'; + pp_string (buffer, ada_name); +} + +/* Dump in BUFFER the name of a DECL node if set, following Ada syntax. + LIMITED_ACCESS indicates whether NODE can be accessed via a limited + 'with' clause rather than a regular 'with' clause. */ + +static void +dump_ada_decl_name (pretty_printer *buffer, tree decl, int limited_access) +{ + if (DECL_NAME (decl)) + pp_ada_tree_identifier (buffer, DECL_NAME (decl), decl, limited_access); + else + { + tree type_name = TYPE_NAME (TREE_TYPE (decl)); + + if (!type_name) + { + pp_string (buffer, "anon"); + if (TREE_CODE (decl) == FIELD_DECL) + pp_scalar (buffer, "%d", DECL_UID (decl)); + else + pp_scalar (buffer, "%d", TYPE_UID (TREE_TYPE (decl))); + } + else if (TREE_CODE (type_name) == IDENTIFIER_NODE) + pp_ada_tree_identifier (buffer, type_name, decl, limited_access); + } +} + +/* Dump in BUFFER a name based on both T1 and T2, followed by S. */ + +static void +dump_ada_double_name (pretty_printer *buffer, tree t1, tree t2, const char *s) +{ + if (DECL_NAME (t1)) + pp_ada_tree_identifier (buffer, DECL_NAME (t1), t1, false); + else + { + pp_string (buffer, "anon"); + pp_scalar (buffer, "%d", TYPE_UID (TREE_TYPE (t1))); + } + + pp_character (buffer, '_'); + + if (DECL_NAME (t1)) + pp_ada_tree_identifier (buffer, DECL_NAME (t2), t2, false); + else + { + pp_string (buffer, "anon"); + pp_scalar (buffer, "%d", TYPE_UID (TREE_TYPE (t2))); + } + + pp_string (buffer, s); +} + +/* Dump in BUFFER pragma Import C/CPP on a given node T. */ + +static void +dump_ada_import (pretty_printer *buffer, tree t) +{ + const char *name = IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (t)); + int is_stdcall = TREE_CODE (t) == FUNCTION_DECL && + lookup_attribute ("stdcall", TYPE_ATTRIBUTES (TREE_TYPE (t))); + + if (is_stdcall) + pp_string (buffer, "pragma Import (Stdcall, "); + else if (name [0] == '_' && name [1] == 'Z') + pp_string (buffer, "pragma Import (CPP, "); + else + pp_string (buffer, "pragma Import (C, "); + + dump_ada_decl_name (buffer, t, false); + pp_string (buffer, ", \""); + + if (is_stdcall) + pp_string (buffer, IDENTIFIER_POINTER (DECL_NAME (t))); + else + pp_asm_name (buffer, t); + + pp_string (buffer, "\");"); +} + +/* Check whether T and its type have different names, and append "the_" + otherwise in BUFFER. */ + +static void +check_name (pretty_printer *buffer, tree t) +{ + const char *s; + tree tmp = TREE_TYPE (t); + + while (TREE_CODE (tmp) == POINTER_TYPE && !TYPE_NAME (tmp)) + tmp = TREE_TYPE (tmp); + + if (TREE_CODE (tmp) != FUNCTION_TYPE) + { + if (TREE_CODE (tmp) == IDENTIFIER_NODE) + s = IDENTIFIER_POINTER (tmp); + else if (!TYPE_NAME (tmp)) + s = ""; + else if (TREE_CODE (TYPE_NAME (tmp)) == IDENTIFIER_NODE) + s = IDENTIFIER_POINTER (TYPE_NAME (tmp)); + else + s = IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME (tmp))); + + if (!strcasecmp (IDENTIFIER_POINTER (DECL_NAME (t)), s)) + pp_string (buffer, "the_"); + } +} + +/* Dump in BUFFER a function declaration FUNC with Ada syntax. + IS_METHOD indicates whether FUNC is a C++ method. + IS_CONSTRUCTOR whether FUNC is a C++ constructor. + IS_DESTRUCTOR whether FUNC is a C++ destructor. + SPC is the current indentation level. */ + +static int +dump_ada_function_declaration (pretty_printer *buffer, tree func, + int is_method, int is_constructor, + int is_destructor, int spc) +{ + tree arg; + const tree node = TREE_TYPE (func); + char buf [16]; + int num = 0, num_args = 0, have_args = true, have_ellipsis = false; + + /* Compute number of arguments. */ + arg = TYPE_ARG_TYPES (node); + + if (arg) + { + while (TREE_CHAIN (arg) && arg != error_mark_node) + { + num_args++; + arg = TREE_CHAIN (arg); + } + + if (TREE_CODE (TREE_VALUE (arg)) != VOID_TYPE) + { + num_args++; + have_ellipsis = true; + } + } + + if (is_constructor) + num_args--; + + if (is_destructor) + num_args = 1; + + if (num_args > 2) + newline_and_indent (buffer, spc + 1); + + if (num_args > 0) + { + pp_space (buffer); + pp_character (buffer, '('); + } + + if (TREE_CODE (func) == FUNCTION_DECL) + arg = DECL_ARGUMENTS (func); + else + arg = NULL_TREE; + + if (arg == NULL_TREE) + { + have_args = false; + arg = TYPE_ARG_TYPES (node); + + if (arg && TREE_CODE (TREE_VALUE (arg)) == VOID_TYPE) + arg = NULL_TREE; + } + + if (is_constructor) + arg = TREE_CHAIN (arg); + + /* Print the argument names (if available) & types. */ + + for (num = 1; num <= num_args; num++) + { + if (have_args) + { + if (DECL_NAME (arg)) + { + check_name (buffer, arg); + pp_ada_tree_identifier (buffer, DECL_NAME (arg), 0, false); + pp_string (buffer, " : "); + } + else + { + sprintf (buf, "arg%d : ", num); + pp_string (buffer, buf); + } + + dump_generic_ada_node + (buffer, TREE_TYPE (arg), node, NULL, spc, 0, true); + } + else + { + sprintf (buf, "arg%d : ", num); + pp_string (buffer, buf); + dump_generic_ada_node + (buffer, TREE_VALUE (arg), node, NULL, spc, 0, true); + } + + if (TREE_TYPE (arg) && TREE_TYPE (TREE_TYPE (arg)) + && is_tagged_type (TREE_TYPE (TREE_TYPE (arg)))) + { + if (!is_method + || (num != 1 || (!DECL_VINDEX (func) && !is_constructor))) + pp_string (buffer, "'Class"); + } + + arg = TREE_CHAIN (arg); + + if (num < num_args) + { + pp_character (buffer, ';'); + + if (num_args > 2) + newline_and_indent (buffer, spc + INDENT_INCR); + else + pp_space (buffer); + } + } + + if (have_ellipsis) + { + pp_string (buffer, " -- , ..."); + newline_and_indent (buffer, spc + INDENT_INCR); + } + + if (num_args > 0) + pp_character (buffer, ')'); + return num_args; +} + +/* Dump in BUFFER all the domains associated with an array NODE, + using Ada syntax. SPC is the current indentation level. */ + +static void +dump_ada_array_domains (pretty_printer *buffer, tree node, int spc) +{ + int first = 1; + pp_character (buffer, '('); + + for (; TREE_CODE (node) == ARRAY_TYPE; node = TREE_TYPE (node)) + { + tree domain = TYPE_DOMAIN (node); + + if (domain) + { + tree min = TYPE_MIN_VALUE (domain); + tree max = TYPE_MAX_VALUE (domain); + + if (!first) + pp_string (buffer, ", "); + first = 0; + + if (min) + dump_generic_ada_node (buffer, min, NULL_TREE, NULL, spc, 0, true); + pp_string (buffer, " .. "); + + /* If the upper bound is zero, gcc may generate a NULL_TREE + for TYPE_MAX_VALUE rather than an integer_cst. */ + if (max) + dump_generic_ada_node (buffer, max, NULL_TREE, NULL, spc, 0, true); + else + pp_string (buffer, "0"); + } + else + pp_string (buffer, "size_t"); + } + pp_character (buffer, ')'); +} + +/* Dump in BUFFER file:line information related to NODE. */ + +static void +dump_sloc (pretty_printer *buffer, tree node) +{ + expanded_location xloc; + + xloc.file = NULL; + + if (TREE_CODE_CLASS (TREE_CODE (node)) == tcc_declaration) + xloc = expand_location (DECL_SOURCE_LOCATION (node)); + else if (EXPR_HAS_LOCATION (node)) + xloc = expand_location (EXPR_LOCATION (node)); + + if (xloc.file) + { + pp_string (buffer, xloc.file); + pp_string (buffer, ":"); + pp_decimal_int (buffer, xloc.line); + } +} + +/* Return true if T designates a one dimension array of "char". */ + +static bool +is_char_array (tree t) +{ + tree tmp; + int num_dim = 0; + + /* Retrieve array's type. */ + tmp = t; + while (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE) + { + num_dim++; + tmp = TREE_TYPE (tmp); + } + + tmp = TREE_TYPE (tmp); + return num_dim == 1 && TREE_CODE (tmp) == INTEGER_TYPE + && !strcmp (IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME (tmp))), "char"); +} + +/* Dump in BUFFER an array type T in Ada syntax. Assume that the "type" + keyword and name have already been printed. SPC is the indentation + level. */ + +static void +dump_ada_array_type (pretty_printer *buffer, tree t, int spc) +{ + tree tmp; + bool char_array = is_char_array (t); + + /* Special case char arrays. */ + if (char_array) + { + pp_string (buffer, "Interfaces.C.char_array "); + } + else + pp_string (buffer, "array "); + + /* Print the dimensions. */ + dump_ada_array_domains (buffer, TREE_TYPE (t), spc); + + /* Retrieve array's type. */ + tmp = TREE_TYPE (t); + while (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE) + tmp = TREE_TYPE (tmp); + + /* Print array's type. */ + if (!char_array) + { + pp_string (buffer, " of "); + + if (TREE_CODE (TREE_TYPE (tmp)) != POINTER_TYPE) + pp_string (buffer, "aliased "); + + dump_generic_ada_node + (buffer, TREE_TYPE (tmp), TREE_TYPE (t), NULL, spc, false, true); + } +} + +/* Dump in BUFFER type names associated with a template, each prepended with + '_'. TYPES is the TREE_PURPOSE of a DECL_TEMPLATE_INSTANTIATIONS. + CPP_CHECK is used to perform C++ queries on nodes. + SPC is the indentation level. */ + +static void +dump_template_types (pretty_printer *buffer, tree types, + int (*cpp_check)(tree, cpp_operation), int spc) +{ + size_t i; + size_t len = TREE_VEC_LENGTH (types); + + for (i = 0; i < len; i++) + { + tree elem = TREE_VEC_ELT (types, i); + pp_character (buffer, '_'); + if (!dump_generic_ada_node (buffer, elem, 0, cpp_check, spc, false, true)) + { + pp_string (buffer, "unknown"); + pp_scalar (buffer, "%lu", (unsigned long) TREE_HASH (elem)); + } + } +} + +/* Dump in BUFFER the contents of all instantiations associated with a given + template T. CPP_CHECK is used to perform C++ queries on nodes. + SPC is the indentation level. */ + +static int +dump_ada_template (pretty_printer *buffer, tree t, + int (*cpp_check)(tree, cpp_operation), int spc) +{ + tree inst = DECL_VINDEX (t); + /* DECL_VINDEX is DECL_TEMPLATE_INSTANTIATIONS in this context. */ + int num_inst = 0; + + while (inst && inst != error_mark_node) + { + tree types = TREE_PURPOSE (inst); + tree instance = TREE_VALUE (inst); + + if (TREE_VEC_LENGTH (types) == 0) + break; + + if (!TYPE_METHODS (instance)) + break; + + num_inst++; + INDENT (spc); + pp_string (buffer, "package "); + package_prefix = false; + dump_generic_ada_node (buffer, instance, t, cpp_check, spc, false, true); + dump_template_types (buffer, types, cpp_check, spc); + pp_string (buffer, " is"); + spc += INDENT_INCR; + newline_and_indent (buffer, spc); + + pp_string (buffer, "type "); + dump_generic_ada_node (buffer, instance, t, cpp_check, spc, false, true); + package_prefix = true; + + if (is_tagged_type (instance)) + pp_string (buffer, " is tagged limited "); + else + pp_string (buffer, " is limited "); + + dump_generic_ada_node (buffer, instance, t, cpp_check, spc, false, false); + pp_newline (buffer); + spc -= INDENT_INCR; + newline_and_indent (buffer, spc); + + pp_string (buffer, "end;"); + newline_and_indent (buffer, spc); + pp_string (buffer, "use "); + package_prefix = false; + dump_generic_ada_node (buffer, instance, t, cpp_check, spc, false, true); + dump_template_types (buffer, types, cpp_check, spc); + package_prefix = true; + pp_semicolon (buffer); + pp_newline (buffer); + pp_newline (buffer); + + inst = TREE_CHAIN (inst); + } + + return num_inst > 0; +} + +/* Return true if NODE is a simple enum types, that can be mapped to an + Ada enum type directly. */ + +static bool +is_simple_enum (tree node) +{ + unsigned HOST_WIDE_INT count = 0; + tree value; + + for (value = TYPE_VALUES (node); value; value = TREE_CHAIN (value)) + { + tree int_val = TREE_VALUE (value); + + if (TREE_CODE (int_val) != INTEGER_CST) + int_val = DECL_INITIAL (int_val); + + if (!host_integerp (int_val, 0)) + return false; + else if (TREE_INT_CST_LOW (int_val) != count) + return false; + + count++; + } + + return true; +} + +static bool in_function = true; +static bool bitfield_used = false; + +/* Recursively dump in BUFFER Ada declarations corresponding to NODE of type + TYPE. CPP_CHECK is used to perform C++ queries on nodes. SPC is the + indentation level. LIMITED_ACCESS indicates whether NODE can be referenced + via a "limited with" clause. NAME_ONLY indicates whether we should only + dump the name of NODE, instead of its full declaration. */ + +static int +dump_generic_ada_node (pretty_printer *buffer, tree node, tree type, + int (*cpp_check)(tree, cpp_operation), int spc, + int limited_access, bool name_only) +{ + if (node == NULL_TREE) + return 0; + + switch (TREE_CODE (node)) + { + case ERROR_MARK: + pp_string (buffer, "<<< error >>>"); + return 0; + + case IDENTIFIER_NODE: + pp_ada_tree_identifier (buffer, node, type, limited_access); + break; + + case TREE_LIST: + pp_string (buffer, "--- unexpected node: TREE_LIST"); + return 0; + + case TREE_BINFO: + dump_generic_ada_node + (buffer, BINFO_TYPE (node), type, cpp_check, + spc, limited_access, name_only); + + case TREE_VEC: + pp_string (buffer, "--- unexpected node: TREE_VEC"); + return 0; + + case VOID_TYPE: + if (package_prefix) + { + append_withs ("System", false); + pp_string (buffer, "System.Address"); + } + else + pp_string (buffer, "address"); + break; + + case VECTOR_TYPE: + pp_string (buffer, ""); + break; + + case COMPLEX_TYPE: + pp_string (buffer, ""); + break; + + case ENUMERAL_TYPE: + if (name_only) + dump_generic_ada_node + (buffer, TYPE_NAME (node), node, cpp_check, spc, 0, true); + else + { + tree value = TYPE_VALUES (node); + + if (is_simple_enum (node)) + { + bool first = true; + spc += INDENT_INCR; + newline_and_indent (buffer, spc - 1); + pp_string (buffer, "("); + for (; value; value = TREE_CHAIN (value)) + { + if (first) + first = false; + else + { + pp_string (buffer, ","); + newline_and_indent (buffer, spc); + } + + pp_ada_tree_identifier + (buffer, TREE_PURPOSE (value), node, false); + } + pp_string (buffer, ");"); + spc -= INDENT_INCR; + newline_and_indent (buffer, spc); + pp_string (buffer, "pragma Convention (C, "); + dump_generic_ada_node + (buffer, DECL_NAME (type) ? type : TYPE_NAME (node), type, + cpp_check, spc, 0, true); + pp_string (buffer, ")"); + } + else + { + pp_string (buffer, "unsigned"); + for (; value; value = TREE_CHAIN (value)) + { + pp_semicolon (buffer); + newline_and_indent (buffer, spc); + + pp_ada_tree_identifier + (buffer, TREE_PURPOSE (value), node, false); + pp_string (buffer, " : constant "); + + dump_generic_ada_node + (buffer, DECL_NAME (type) ? type : TYPE_NAME (node), type, + cpp_check, spc, 0, true); + + pp_string (buffer, " := "); + dump_generic_ada_node + (buffer, + TREE_CODE (TREE_VALUE (value)) == INTEGER_CST ? + TREE_VALUE (value) : DECL_INITIAL (TREE_VALUE (value)), + node, cpp_check, spc, false, true); + } + } + } + break; + + case INTEGER_TYPE: + case REAL_TYPE: + case FIXED_POINT_TYPE: + case BOOLEAN_TYPE: + { + enum tree_code_class tclass; + + tclass = TREE_CODE_CLASS (TREE_CODE (node)); + + if (tclass == tcc_declaration) + { + if (DECL_NAME (node)) + pp_ada_tree_identifier + (buffer, DECL_NAME (node), 0, limited_access); + else + pp_string (buffer, ""); + } + else if (tclass == tcc_type) + { + if (TYPE_NAME (node)) + { + if (TREE_CODE (TYPE_NAME (node)) == IDENTIFIER_NODE) + pp_ada_tree_identifier (buffer, TYPE_NAME (node), + node, limited_access); + else if (TREE_CODE (TYPE_NAME (node)) == TYPE_DECL + && DECL_NAME (TYPE_NAME (node))) + dump_ada_decl_name (buffer, TYPE_NAME (node), limited_access); + else + pp_string (buffer, ""); + } + else if (TREE_CODE (node) == INTEGER_TYPE) + { + append_withs ("Interfaces.C.Extensions", false); + bitfield_used = true; + + if (TYPE_PRECISION (node) == 1) + pp_string (buffer, "Extensions.Unsigned_1"); + else + { + pp_string (buffer, (TYPE_UNSIGNED (node) + ? "Extensions.Unsigned_" + : "Extensions.Signed_")); + pp_decimal_int (buffer, TYPE_PRECISION (node)); + } + } + else + pp_string (buffer, ""); + } + break; + } + + case POINTER_TYPE: + case REFERENCE_TYPE: + if (TREE_CODE (TREE_TYPE (node)) == FUNCTION_TYPE) + { + tree fnode = TREE_TYPE (node); + bool is_function; + bool prev_in_function = in_function; + + if (VOID_TYPE_P (TREE_TYPE (fnode))) + { + is_function = false; + pp_string (buffer, "access procedure"); + } + else + { + is_function = true; + pp_string (buffer, "access function"); + } + + in_function = is_function; + dump_ada_function_declaration + (buffer, node, false, false, false, spc + INDENT_INCR); + in_function = prev_in_function; + + if (is_function) + { + pp_string (buffer, " return "); + dump_generic_ada_node + (buffer, TREE_TYPE (fnode), type, cpp_check, spc, 0, true); + } + } + else + { + int is_access = false; + unsigned int quals = TYPE_QUALS (TREE_TYPE (node)); + + if (name_only && TYPE_NAME (node)) + dump_generic_ada_node + (buffer, TYPE_NAME (node), node, cpp_check, + spc, limited_access, true); + else if (VOID_TYPE_P (TREE_TYPE (node))) + { + if (!name_only) + pp_string (buffer, "new "); + if (package_prefix) + { + append_withs ("System", false); + pp_string (buffer, "System.Address"); + } + else + pp_string (buffer, "address"); + } + else + { + if (TREE_CODE (node) == POINTER_TYPE + && TREE_CODE (TREE_TYPE (node)) == INTEGER_TYPE + && !strcmp + (IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME + (TREE_TYPE (node)))), "char")) + { + if (!name_only) + pp_string (buffer, "new "); + + if (package_prefix) + { + pp_string (buffer, "Interfaces.C.Strings.chars_ptr"); + append_withs ("Interfaces.C.Strings", false); + } + else + pp_string (buffer, "chars_ptr"); + } + else + { + /* For now, handle all access-to-access or + access-to-unknown-structs as opaque system.address. */ + + tree typ = TYPE_NAME (TREE_TYPE (node)); + const_tree typ2 = !type || + DECL_P (type) ? type : TYPE_NAME (type); + const_tree underlying_type = + get_underlying_decl (TREE_TYPE (node)); + + if (TREE_CODE (TREE_TYPE (node)) == POINTER_TYPE + /* Pointer to pointer. */ + + || (RECORD_OR_UNION_TYPE_P (TREE_TYPE (node)) + && (!underlying_type + || !TYPE_FIELDS (TREE_TYPE (underlying_type)))) + /* Pointer to opaque structure. */ + + || (typ && typ2 + && DECL_P (underlying_type) + && DECL_P (typ2) + && decl_sloc (underlying_type, true) + > decl_sloc (typ2, true) + && DECL_SOURCE_FILE (underlying_type) + == DECL_SOURCE_FILE (typ2))) + { + if (package_prefix) + { + append_withs ("System", false); + if (!name_only) + pp_string (buffer, "new "); + pp_string (buffer, "System.Address"); + } + else + pp_string (buffer, "address"); + return spc; + } + + if (!package_prefix) + pp_string (buffer, "access"); + else if (AGGREGATE_TYPE_P (TREE_TYPE (node))) + { + if (!type || TREE_CODE (type) != FUNCTION_DECL) + { + pp_string (buffer, "access "); + is_access = true; + + if (quals & TYPE_QUAL_CONST) + pp_string (buffer, "constant "); + else if (!name_only) + pp_string (buffer, "all "); + } + else if (quals & TYPE_QUAL_CONST) + pp_string (buffer, "in "); + else if (in_function) + { + is_access = true; + pp_string (buffer, "access "); + } + else + { + is_access = true; + pp_string (buffer, "access "); + /* ??? should be configurable: access or in out. */ + } + } + else + { + is_access = true; + pp_string (buffer, "access "); + + if (!name_only) + pp_string (buffer, "all "); + } + + if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (node)) + && TYPE_NAME (TREE_TYPE (node))) + { + tree name = TYPE_NAME (TREE_TYPE (node)); + tree tmp; + + if (TREE_CODE (name) == TYPE_DECL + && DECL_ORIGINAL_TYPE (name) + && TYPE_STUB_DECL (DECL_ORIGINAL_TYPE (name))) + { + tmp = TYPE_NAME (TREE_TYPE (TYPE_STUB_DECL + (DECL_ORIGINAL_TYPE (name)))); + + if (tmp == NULL_TREE) + tmp = TYPE_NAME (TREE_TYPE (node)); + } + else + tmp = TYPE_NAME (TREE_TYPE (node)); + + dump_generic_ada_node + (buffer, tmp, + TREE_TYPE (node), cpp_check, spc, is_access, true); + } + else + dump_generic_ada_node + (buffer, TREE_TYPE (node), TREE_TYPE (node), + cpp_check, spc, 0, true); + } + } + } + break; + + case ARRAY_TYPE: + if (name_only) + dump_generic_ada_node + (buffer, TYPE_NAME (node), node, cpp_check, + spc, limited_access, true); + else + dump_ada_array_type (buffer, node, spc); + break; + + case RECORD_TYPE: + case UNION_TYPE: + case QUAL_UNION_TYPE: + if (name_only) + { + if (TYPE_NAME (node)) + dump_generic_ada_node + (buffer, TYPE_NAME (node), node, cpp_check, + spc, limited_access, true); + else + { + pp_string (buffer, "anon_"); + pp_scalar (buffer, "%d", TYPE_UID (node)); + } + } + else + print_ada_struct_decl + (buffer, node, type, cpp_check, spc, true); + break; + + case INTEGER_CST: + if (TREE_CODE (TREE_TYPE (node)) == POINTER_TYPE) + { + pp_wide_integer (buffer, TREE_INT_CST_LOW (node)); + pp_string (buffer, "B"); /* pseudo-unit */ + } + else if (!host_integerp (node, 0)) + { + tree val = node; + unsigned HOST_WIDE_INT low = TREE_INT_CST_LOW (val); + HOST_WIDE_INT high = TREE_INT_CST_HIGH (val); + + if (tree_int_cst_sgn (val) < 0) + { + pp_character (buffer, '-'); + high = ~high + !low; + low = -low; + } + sprintf (pp_buffer (buffer)->digit_buffer, + HOST_WIDE_INT_PRINT_DOUBLE_HEX, + (unsigned HOST_WIDE_INT) high, low); + pp_string (buffer, pp_buffer (buffer)->digit_buffer); + } + else + pp_wide_integer (buffer, TREE_INT_CST_LOW (node)); + break; + + case REAL_CST: + case FIXED_CST: + case COMPLEX_CST: + case STRING_CST: + case VECTOR_CST: + return 0; + + case FUNCTION_DECL: + case CONST_DECL: + dump_ada_decl_name (buffer, node, limited_access); + break; + + case TYPE_DECL: + if (DECL_IS_BUILTIN (node)) + { + /* Don't print the declaration of built-in types. */ + + if (name_only) + { + /* If we're in the middle of a declaration, defaults to + System.Address. */ + if (package_prefix) + { + append_withs ("System", false); + pp_string (buffer, "System.Address"); + } + else + pp_string (buffer, "address"); + } + break; + } + + if (name_only) + dump_ada_decl_name (buffer, node, limited_access); + else + { + if (is_tagged_type (TREE_TYPE (node))) + { + tree tmp = TYPE_FIELDS (TREE_TYPE (node)); + int first = 1; + + /* Look for ancestors. */ + for (; tmp; tmp = TREE_CHAIN (tmp)) + { + if (!DECL_NAME (tmp) && is_tagged_type (TREE_TYPE (tmp))) + { + if (first) + { + pp_string (buffer, "limited new "); + first = 0; + } + else + pp_string (buffer, " and "); + + dump_ada_decl_name + (buffer, TYPE_NAME (TREE_TYPE (tmp)), false); + } + } + + pp_string (buffer, first ? "tagged limited " : " with "); + } + else if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (node)) + && TYPE_METHODS (TREE_TYPE (node))) + pp_string (buffer, "limited "); + + dump_generic_ada_node + (buffer, TREE_TYPE (node), type, cpp_check, spc, false, false); + } + break; + + case VAR_DECL: + case PARM_DECL: + case FIELD_DECL: + case NAMESPACE_DECL: + dump_ada_decl_name (buffer, node, false); + break; + + default: + /* Ignore other nodes (e.g. expressions). */ + return 0; + } + + return 1; +} + +/* Dump in BUFFER NODE's methods. CPP_CHECK is used to perform C++ queries on + nodes. SPC is the indentation level. */ + +static void +print_ada_methods (pretty_printer *buffer, tree node, + int (*cpp_check)(tree, cpp_operation), int spc) +{ + tree tmp = TYPE_METHODS (node); + int res = 1; + + if (tmp) + { + pp_semicolon (buffer); + + for (; tmp; tmp = TREE_CHAIN (tmp)) + { + if (res) + { + pp_newline (buffer); + pp_newline (buffer); + } + res = print_ada_declaration (buffer, tmp, node, cpp_check, spc); + } + } +} + +/* Dump in BUFFER anonymous types nested inside T's definition. + PARENT is the parent node of T. CPP_CHECK is used to perform C++ queries on + nodes. SPC is the indentation level. */ + +static void +dump_nested_types (pretty_printer *buffer, tree t, tree parent, + int (*cpp_check)(tree, cpp_operation), int spc) +{ + tree field, outer, decl; + + /* Avoid recursing over the same tree. */ + if (TREE_VISITED (t)) + return; + + /* Find possible anonymous arrays/unions/structs recursively. */ + + outer = TREE_TYPE (t); + + if (outer == NULL_TREE) + return; + + field = TYPE_FIELDS (outer); + while (field) + { + if ((TREE_TYPE (field) != outer + || (TREE_CODE (TREE_TYPE (field)) == POINTER_TYPE + && TREE_TYPE (TREE_TYPE (field)) != outer)) + && (!TYPE_NAME (TREE_TYPE (field)) + || (TREE_CODE (field) == TYPE_DECL + && DECL_NAME (field) != DECL_NAME (t) + && TYPE_NAME (TREE_TYPE (field)) != TYPE_NAME (outer)))) + { + switch (TREE_CODE (TREE_TYPE (field))) + { + case POINTER_TYPE: + decl = TREE_TYPE (TREE_TYPE (field)); + + if (TREE_CODE (decl) == FUNCTION_TYPE) + for (decl = TREE_TYPE (decl); + decl && TREE_CODE (decl) == POINTER_TYPE; + decl = TREE_TYPE (decl)); + + decl = get_underlying_decl (decl); + + if (decl + && DECL_P (decl) + && decl_sloc (decl, true) > decl_sloc (t, true) + && DECL_SOURCE_FILE (decl) == DECL_SOURCE_FILE (t) + && !TREE_VISITED (decl) + && !DECL_IS_BUILTIN (decl) + && (!RECORD_OR_UNION_TYPE_P (TREE_TYPE (decl)) + || TYPE_FIELDS (TREE_TYPE (decl)))) + { + /* Generate forward declaration. */ + + pp_string (buffer, "type "); + dump_generic_ada_node + (buffer, decl, 0, cpp_check, spc, false, true); + pp_semicolon (buffer); + newline_and_indent (buffer, spc); + + /* Ensure we do not generate duplicate forward + declarations for this type. */ + TREE_VISITED (decl) = 1; + } + break; + + case ARRAY_TYPE: + /* Special case char arrays. */ + if (is_char_array (field)) + pp_string (buffer, "sub"); + + pp_string (buffer, "type "); + dump_ada_double_name (buffer, parent, field, "_array is "); + dump_ada_array_type (buffer, field, spc); + pp_semicolon (buffer); + newline_and_indent (buffer, spc); + break; + + case UNION_TYPE: + TREE_VISITED (t) = 1; + dump_nested_types (buffer, field, t, cpp_check, spc); + + pp_string (buffer, "type "); + + if (TYPE_NAME (TREE_TYPE (field))) + { + dump_generic_ada_node + (buffer, TYPE_NAME (TREE_TYPE (field)), 0, cpp_check, + spc, false, true); + pp_string (buffer, " (discr : unsigned := 0) is "); + print_ada_struct_decl + (buffer, TREE_TYPE (field), t, cpp_check, spc, false); + + pp_string (buffer, "pragma Convention (C_Pass_By_Copy, "); + dump_generic_ada_node + (buffer, TREE_TYPE (field), 0, cpp_check, + spc, false, true); + pp_string (buffer, ");"); + newline_and_indent (buffer, spc); + + pp_string (buffer, "pragma Unchecked_Union ("); + dump_generic_ada_node + (buffer, TREE_TYPE (field), 0, cpp_check, + spc, false, true); + pp_string (buffer, ");"); + } + else + { + dump_ada_double_name + (buffer, parent, field, + "_union (discr : unsigned := 0) is "); + print_ada_struct_decl + (buffer, TREE_TYPE (field), t, cpp_check, spc, false); + pp_string (buffer, "pragma Convention (C_Pass_By_Copy, "); + dump_ada_double_name (buffer, parent, field, "_union);"); + newline_and_indent (buffer, spc); + + pp_string (buffer, "pragma Unchecked_Union ("); + dump_ada_double_name (buffer, parent, field, "_union);"); + } + + newline_and_indent (buffer, spc); + break; + + case RECORD_TYPE: + if (TYPE_NAME (TREE_TYPE (t)) && !TREE_VISITED (t)) + { + pp_string (buffer, "type "); + dump_generic_ada_node + (buffer, t, parent, 0, spc, false, true); + pp_semicolon (buffer); + newline_and_indent (buffer, spc); + } + + TREE_VISITED (t) = 1; + dump_nested_types (buffer, field, t, cpp_check, spc); + pp_string (buffer, "type "); + + if (TYPE_NAME (TREE_TYPE (field))) + { + dump_generic_ada_node + (buffer, TREE_TYPE (field), 0, cpp_check, + spc, false, true); + pp_string (buffer, " is "); + print_ada_struct_decl + (buffer, TREE_TYPE (field), t, cpp_check, spc, false); + pp_string (buffer, "pragma Convention (C_Pass_By_Copy, "); + dump_generic_ada_node + (buffer, TREE_TYPE (field), 0, cpp_check, + spc, false, true); + pp_string (buffer, ");"); + } + else + { + dump_ada_double_name + (buffer, parent, field, "_struct is "); + print_ada_struct_decl + (buffer, TREE_TYPE (field), t, cpp_check, spc, false); + pp_string (buffer, "pragma Convention (C_Pass_By_Copy, "); + dump_ada_double_name (buffer, parent, field, "_struct);"); + } + + newline_and_indent (buffer, spc); + break; + + default: + break; + } + } + field = TREE_CHAIN (field); + } +} + +/* Dump in BUFFER destructor spec corresponding to T. */ + +static void +print_destructor (pretty_printer *buffer, tree t) +{ + const char *s = IDENTIFIER_POINTER (DECL_NAME (t)); + + if (*s == '_') + for (s += 2; *s != ' '; s++) + pp_character (buffer, *s); + else + { + pp_string (buffer, "Delete_"); + pp_ada_tree_identifier (buffer, DECL_NAME (t), t, false); + } +} + +/* Return the name of type T. */ + +static const char * +type_name (tree t) +{ + tree n = TYPE_NAME (t); + + if (TREE_CODE (n) == IDENTIFIER_NODE) + return IDENTIFIER_POINTER (n); + else + return IDENTIFIER_POINTER (DECL_NAME (n)); +} + +/* Print in BUFFER the declaration of a variable T of type TYPE in Ada syntax. + CPP_CHECK is used to perform C++ queries on nodes. SPC is the indentation + level. Return 1 if a declaration was printed, 0 otherwise. */ + +static int +print_ada_declaration (pretty_printer *buffer, tree t, tree type, + int (*cpp_check)(tree, cpp_operation), int spc) +{ + int is_var = 0, need_indent = 0; + int is_class = false; + tree name = TYPE_NAME (TREE_TYPE (t)); + tree decl_name = DECL_NAME (t); + bool dump_internal = get_dump_file_info (TDI_ada)->flags & TDF_RAW; + tree orig = NULL_TREE; + + if (cpp_check && cpp_check (t, IS_TEMPLATE)) + return dump_ada_template (buffer, t, cpp_check, spc); + + if (TREE_CODE (t) == CONST_DECL && TREE_CODE (TREE_TYPE (t)) == ENUMERAL_TYPE) + /* Skip enumeral values: will be handled as part of the type itself. */ + return 0; + + if (TREE_CODE (t) == TYPE_DECL) + { + orig = DECL_ORIGINAL_TYPE (t); + + if (orig && TYPE_STUB_DECL (orig)) + { + tree typ = TREE_TYPE (TYPE_STUB_DECL (orig)); + + if (TYPE_NAME (typ)) + { + /* If types have same representation, and same name (ignoring + casing), then ignore the second type. */ + if (type_name (typ) == type_name (TREE_TYPE (t)) + || !strcasecmp (type_name (typ), type_name (TREE_TYPE (t)))) + return 0; + + INDENT (spc); + + if (RECORD_OR_UNION_TYPE_P (typ) && !TYPE_FIELDS (typ)) + { + pp_string (buffer, "-- skipped empty struct "); + dump_generic_ada_node (buffer, t, type, 0, spc, false, true); + } + else + { + pp_string (buffer, "subtype "); + dump_generic_ada_node (buffer, t, type, 0, spc, false, true); + pp_string (buffer, " is "); + dump_generic_ada_node + (buffer, typ, type, 0, spc, false, true); + pp_semicolon (buffer); + } + return 1; + } + } + + /* Skip unnamed or anonymous structs/unions/enum types. */ + if (!orig && !decl_name && !name) + { + tree tmp; + location_t sloc; + + if (cpp_check || TREE_CODE (TREE_TYPE (t)) == ENUMERAL_TYPE) + return 0; + + if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (t))) + { + /* Search next items until finding a named type decl. */ + sloc = decl_sloc_common (t, true, true); + + for (tmp = TREE_CHAIN (t); tmp; tmp = TREE_CHAIN (tmp)) + { + if (TREE_CODE (tmp) == TYPE_DECL + && (DECL_NAME (tmp) || TYPE_NAME (TREE_TYPE (tmp)))) + { + /* If same sloc, it means we can ignore the anonymous + struct. */ + if (decl_sloc_common (tmp, true, true) == sloc) + return 0; + else + break; + } + } + if (tmp == NULL) + return 0; + } + } + + if (!orig + && TREE_CODE (TREE_TYPE (t)) == ENUMERAL_TYPE + && decl_name + && (*IDENTIFIER_POINTER (decl_name) == '.' + || *IDENTIFIER_POINTER (decl_name) == '$')) + /* Skip anonymous enum types (duplicates of real types). */ + return 0; + + INDENT (spc); + + switch (TREE_CODE (TREE_TYPE (t))) + { + case RECORD_TYPE: + case UNION_TYPE: + case QUAL_UNION_TYPE: + /* Skip empty structs (typically forward references to real + structs). */ + if (!TYPE_FIELDS (TREE_TYPE (t))) + { + pp_string (buffer, "-- skipped empty struct "); + dump_generic_ada_node (buffer, t, type, 0, spc, false, true); + return 1; + } + + if (decl_name + && (*IDENTIFIER_POINTER (decl_name) == '.' + || *IDENTIFIER_POINTER (decl_name) == '$')) + { + pp_string (buffer, "-- skipped anonymous struct "); + dump_generic_ada_node (buffer, t, type, 0, spc, false, true); + return 1; + } + + if (orig && TYPE_NAME (orig) && orig != TREE_TYPE (t)) + pp_string (buffer, "subtype "); + else + { + dump_nested_types (buffer, t, t, cpp_check, spc); + + if (TYPE_METHODS (TREE_TYPE (t)) + || has_static_fields (TREE_TYPE (t))) + { + is_class = true; + pp_string (buffer, "package Class_"); + dump_generic_ada_node + (buffer, t, type, 0, spc, false, true); + pp_string (buffer, " is"); + spc += INDENT_INCR; + newline_and_indent (buffer, spc); + } + + pp_string (buffer, "type "); + } + break; + + case ARRAY_TYPE: + case POINTER_TYPE: + case REFERENCE_TYPE: + if ((orig && TYPE_NAME (orig) && orig != TREE_TYPE (t)) + || is_char_array (t)) + pp_string (buffer, "subtype "); + else + pp_string (buffer, "type "); + break; + + case FUNCTION_TYPE: + pp_string (buffer, "-- skipped function type "); + dump_generic_ada_node (buffer, t, type, 0, spc, false, true); + return 1; + break; + + case ENUMERAL_TYPE: + if ((orig && TYPE_NAME (orig) && orig != TREE_TYPE (t)) + || !is_simple_enum (TREE_TYPE (t))) + pp_string (buffer, "subtype "); + else + pp_string (buffer, "type "); + break; + + default: + pp_string (buffer, "subtype "); + } + } + else + { + if (!dump_internal + && TREE_CODE (t) == VAR_DECL + && decl_name + && *IDENTIFIER_POINTER (decl_name) == '_') + return 0; + + need_indent = 1; + } + + /* Print the type and name. */ + if (TREE_CODE (TREE_TYPE (t)) == ARRAY_TYPE) + { + if (need_indent) + INDENT (spc); + + /* Print variable's name. */ + dump_generic_ada_node (buffer, t, type, cpp_check, spc, false, true); + + if (TREE_CODE (t) == TYPE_DECL) + { + pp_string (buffer, " is "); + + if (orig && TYPE_NAME (orig) && orig != TREE_TYPE (t)) + dump_generic_ada_node + (buffer, TYPE_NAME (orig), type, + cpp_check, spc, false, true); + else + dump_ada_array_type (buffer, t, spc); + } + else + { + tree tmp = TYPE_NAME (TREE_TYPE (t)); + + if (spc == INDENT_INCR || TREE_STATIC (t)) + is_var = 1; + + pp_string (buffer, " : "); + + if (tmp) + { + if (TREE_CODE (TREE_TYPE (tmp)) != POINTER_TYPE + && TREE_CODE (tmp) != INTEGER_TYPE) + pp_string (buffer, "aliased "); + + dump_generic_ada_node (buffer, tmp, type, 0, spc, false, true); + } + else + { + pp_string (buffer, "aliased "); + + if (!type) + dump_ada_array_type (buffer, t, spc); + else + dump_ada_double_name (buffer, type, t, "_array"); + } + } + } + else if (TREE_CODE (t) == FUNCTION_DECL) + { + bool is_function = true, is_method, is_abstract_class = false; + tree decl_name = DECL_NAME (t); + int prev_in_function = in_function; + bool is_abstract = false; + bool is_constructor = false; + bool is_destructor = false; + bool is_copy_constructor = false; + + if (!decl_name) + return 0; + + if (cpp_check) + { + is_abstract = cpp_check (t, IS_ABSTRACT); + is_constructor = cpp_check (t, IS_CONSTRUCTOR); + is_destructor = cpp_check (t, IS_DESTRUCTOR); + is_copy_constructor = cpp_check (t, IS_COPY_CONSTRUCTOR); + } + + /* Skip __comp_dtor destructor which is redundant with the '~class()' + destructor. */ + if (is_destructor + && !strncmp (IDENTIFIER_POINTER (decl_name), "__comp", 6)) + return 0; + + /* Skip copy constructors: some are internal only, and those that are + not cannot be called easily from Ada anyway. */ + if (is_copy_constructor) + return 0; + + /* If this function has an entry in the dispatch table, we cannot + omit it. */ + if (!dump_internal && !DECL_VINDEX (t) + && *IDENTIFIER_POINTER (decl_name) == '_') + { + if (IDENTIFIER_POINTER (decl_name)[1] == '_') + return 0; + + INDENT (spc); + pp_string (buffer, "-- skipped func "); + pp_string (buffer, IDENTIFIER_POINTER (decl_name)); + return 1; + } + + if (need_indent) + INDENT (spc); + + if (is_constructor) + pp_string (buffer, "function New_"); + else if (VOID_TYPE_P (TREE_TYPE (TREE_TYPE (t)))) + { + is_function = false; + pp_string (buffer, "procedure "); + } + else + pp_string (buffer, "function "); + + in_function = is_function; + is_method = TREE_CODE (TREE_TYPE (t)) == METHOD_TYPE; + + if (is_destructor) + print_destructor (buffer, t); + else + dump_ada_decl_name (buffer, t, false); + + dump_ada_function_declaration + (buffer, t, is_method, is_constructor, is_destructor, spc); + in_function = prev_in_function; + + if (is_function) + { + pp_string (buffer, " return "); + + if (is_constructor) + { + dump_ada_decl_name (buffer, t, false); + } + else + { + dump_generic_ada_node + (buffer, TREE_TYPE (TREE_TYPE (t)), type, cpp_check, + spc, false, true); + } + } + + if (is_constructor && cpp_check && type + && AGGREGATE_TYPE_P (type) + && TYPE_METHODS (type)) + { + tree tmp = TYPE_METHODS (type); + + for (; tmp; tmp = TREE_CHAIN (tmp)) + if (cpp_check (tmp, IS_ABSTRACT)) + { + is_abstract_class = 1; + break; + } + } + + if (is_abstract || is_abstract_class) + pp_string (buffer, " is abstract"); + + pp_semicolon (buffer); + pp_string (buffer, " -- "); + dump_sloc (buffer, t); + + if (is_abstract) + return 1; + + newline_and_indent (buffer, spc); + + if (is_constructor) + { + pp_string (buffer, "pragma CPP_Constructor (New_"); + dump_ada_decl_name (buffer, t, false); + pp_string (buffer, ", \""); + pp_asm_name (buffer, t); + pp_string (buffer, "\");"); + } + else if (is_destructor) + { + pp_string (buffer, "pragma Import (CPP, "); + print_destructor (buffer, t); + pp_string (buffer, ", \""); + pp_asm_name (buffer, t); + pp_string (buffer, "\");"); + } + else + { + dump_ada_import (buffer, t); + } + + return 1; + } + else if (TREE_CODE (t) == TYPE_DECL && !DECL_ORIGINAL_TYPE (t)) + { + int is_interface = 0; + int is_abstract_record = 0; + + if (need_indent) + INDENT (spc); + + /* Anonymous structs/unions */ + dump_generic_ada_node + (buffer, TREE_TYPE (t), t, cpp_check, spc, false, true); + + if (TREE_CODE (TREE_TYPE (t)) == UNION_TYPE + || TREE_CODE (TREE_TYPE (t)) == QUAL_UNION_TYPE) + { + pp_string (buffer, " (discr : unsigned := 0)"); + } + + pp_string (buffer, " is "); + + /* Check whether we have an Ada interface compatible class. */ + if (cpp_check && AGGREGATE_TYPE_P (TREE_TYPE (t)) + && TYPE_METHODS (TREE_TYPE (t))) + { + int num_fields = 0; + tree tmp = TYPE_FIELDS (TREE_TYPE (t)); + + /* Check that there are no fields other than the virtual table. */ + for (; tmp; tmp = TREE_CHAIN (tmp)) + { + if (TREE_CODE (tmp) == TYPE_DECL) + continue; + num_fields++; + } + + if (num_fields == 1) + is_interface = 1; + + /* Also check that there are only virtual methods. */ + for (tmp = TYPE_METHODS (TREE_TYPE (t)); tmp; tmp = TREE_CHAIN (tmp)) + { + if (cpp_check (tmp, IS_ABSTRACT)) + is_abstract_record = 1; + else + is_interface = 0; + } + } + + if (is_interface) + { + pp_string (buffer, "limited interface; -- "); + dump_sloc (buffer, t); + newline_and_indent (buffer, spc); + pp_string (buffer, "pragma Import (CPP, "); + dump_generic_ada_node + (buffer, TYPE_NAME (TREE_TYPE (t)), type, cpp_check, + spc, false, true); + pp_character (buffer, ')'); + + print_ada_methods (buffer, TREE_TYPE (t), cpp_check, spc); + } + else + { + if (is_abstract_record) + pp_string (buffer, "abstract "); + dump_generic_ada_node (buffer, t, t, cpp_check, spc, false, false); + } + } + else + { + if (need_indent) + INDENT (spc); + + if (TREE_CODE (t) == FIELD_DECL && DECL_NAME (t)) + check_name (buffer, t); + + /* Print variable/type's name. */ + dump_generic_ada_node (buffer, t, t, cpp_check, spc, false, true); + + if (TREE_CODE (t) == TYPE_DECL) + { + tree orig = DECL_ORIGINAL_TYPE (t); + int is_subtype = orig && TYPE_NAME (orig) && orig != TREE_TYPE (t); + + if (!is_subtype + && (TREE_CODE (TREE_TYPE (t)) == UNION_TYPE + || TREE_CODE (TREE_TYPE (t)) == QUAL_UNION_TYPE)) + pp_string (buffer, " (discr : unsigned := 0)"); + + pp_string (buffer, " is "); + + dump_generic_ada_node + (buffer, orig, t, cpp_check, spc, false, is_subtype); + } + else + { + if (spc == INDENT_INCR || TREE_STATIC (t)) + is_var = 1; + + pp_string (buffer, " : "); + + /* Print type declaration. */ + + if (TREE_CODE (TREE_TYPE (t)) == UNION_TYPE + && !TYPE_NAME (TREE_TYPE (t))) + { + dump_ada_double_name (buffer, type, t, "_union"); + } + else if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (t))) + { + if (TREE_CODE (TREE_TYPE (t)) == RECORD_TYPE) + pp_string (buffer, "aliased "); + + dump_generic_ada_node + (buffer, TREE_TYPE (t), t, cpp_check, spc, false, true); + } + else + { + if (TREE_CODE (TREE_TYPE (t)) != POINTER_TYPE + && (TYPE_NAME (TREE_TYPE (t)) + || TREE_CODE (TREE_TYPE (t)) != INTEGER_TYPE)) + pp_string (buffer, "aliased "); + + dump_generic_ada_node + (buffer, TREE_TYPE (t), TREE_TYPE (t), cpp_check, + spc, false, true); + } + } + } + + if (is_class) + { + spc -= 3; + newline_and_indent (buffer, spc); + pp_string (buffer, "end;"); + newline_and_indent (buffer, spc); + pp_string (buffer, "use Class_"); + dump_generic_ada_node (buffer, t, type, 0, spc, false, true); + pp_semicolon (buffer); + pp_newline (buffer); + + /* All needed indentation/newline performed already, so return 0. */ + return 0; + } + else + { + pp_string (buffer, "; -- "); + dump_sloc (buffer, t); + } + + if (is_var) + { + newline_and_indent (buffer, spc); + dump_ada_import (buffer, t); + } + + return 1; +} + +/* Prints in BUFFER a structure NODE of type TYPE: name, fields, and methods + with Ada syntax. CPP_CHECK is used to perform C++ queries on nodes. SPC + is the indentation level. If DISPLAY_CONVENTION is true, also print the + pragma Convention for NODE. */ + +static void +print_ada_struct_decl (pretty_printer *buffer, tree node, tree type, + int (*cpp_check)(tree, cpp_operation), int spc, + bool display_convention) +{ + tree tmp; + int is_union = + TREE_CODE (node) == UNION_TYPE || TREE_CODE (node) == QUAL_UNION_TYPE; + char buf [16]; + int field_num = 0; + int field_spc = spc + INDENT_INCR; + int need_semicolon; + + bitfield_used = false; + + if (!TYPE_FIELDS (node)) + pp_string (buffer, "null record;"); + else + { + pp_string (buffer, "record"); + + /* Print the contents of the structure. */ + + if (is_union) + { + newline_and_indent (buffer, spc + INDENT_INCR); + pp_string (buffer, "case discr is"); + field_spc = spc + INDENT_INCR * 3; + } + + pp_newline (buffer); + + /* Print the non-static fields of the structure. */ + for (tmp = TYPE_FIELDS (node); tmp; tmp = TREE_CHAIN (tmp)) + { + /* Add parent field if needed. */ + if (!DECL_NAME (tmp)) + { + if (!is_tagged_type (TREE_TYPE (tmp))) + { + if (!TYPE_NAME (TREE_TYPE (tmp))) + print_ada_declaration + (buffer, tmp, type, cpp_check, field_spc); + else + { + INDENT (field_spc); + + if (field_num == 0) + pp_string (buffer, "parent : "); + else + { + sprintf (buf, "field_%d : ", field_num + 1); + pp_string (buffer, buf); + } + dump_ada_decl_name + (buffer, TYPE_NAME (TREE_TYPE (tmp)), false); + pp_semicolon (buffer); + } + pp_newline (buffer); + field_num++; + } + } + /* Avoid printing the structure recursively. */ + else if ((TREE_TYPE (tmp) != node + || (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE + && TREE_TYPE (TREE_TYPE (tmp)) != node)) + && TREE_CODE (tmp) != TYPE_DECL + && !TREE_STATIC (tmp)) + { + /* Skip internal virtual table field. */ + if (strncmp (IDENTIFIER_POINTER (DECL_NAME (tmp)), "_vptr", 5)) + { + if (is_union) + { + if (TREE_CHAIN (tmp) + && TREE_TYPE (TREE_CHAIN (tmp)) != node + && TREE_CODE (TREE_CHAIN (tmp)) != TYPE_DECL) + sprintf (buf, "when %d =>", field_num); + else + sprintf (buf, "when others =>"); + + INDENT (spc + INDENT_INCR * 2); + pp_string (buffer, buf); + pp_newline (buffer); + } + + if (print_ada_declaration (buffer, + tmp, type, cpp_check, field_spc)) + { + pp_newline (buffer); + field_num++; + } + } + } + } + + if (is_union) + { + INDENT (spc + INDENT_INCR); + pp_string (buffer, "end case;"); + pp_newline (buffer); + } + + if (field_num == 0) + { + INDENT (spc + INDENT_INCR); + pp_string (buffer, "null;"); + pp_newline (buffer); + } + + INDENT (spc); + pp_string (buffer, "end record;"); + } + + newline_and_indent (buffer, spc); + + if (!display_convention) + return; + + if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (type))) + { + if (TYPE_METHODS (TREE_TYPE (type))) + pp_string (buffer, "pragma Import (CPP, "); + else + pp_string (buffer, "pragma Convention (C_Pass_By_Copy, "); + } + else + pp_string (buffer, "pragma Convention (C, "); + + package_prefix = false; + dump_generic_ada_node + (buffer, TREE_TYPE (type), type, cpp_check, spc, false, true); + package_prefix = true; + pp_character (buffer, ')'); + + if (is_union) + { + pp_semicolon (buffer); + newline_and_indent (buffer, spc); + pp_string (buffer, "pragma Unchecked_Union ("); + + dump_generic_ada_node + (buffer, TREE_TYPE (type), type, cpp_check, spc, false, true); + pp_character (buffer, ')'); + } + + if (bitfield_used) + { + pp_semicolon (buffer); + newline_and_indent (buffer, spc); + pp_string (buffer, "pragma Pack ("); + dump_generic_ada_node + (buffer, TREE_TYPE (type), type, cpp_check, spc, false, true); + pp_character (buffer, ')'); + bitfield_used = false; + } + + print_ada_methods (buffer, node, cpp_check, spc); + + /* Print the static fields of the structure, if any. */ + need_semicolon = TYPE_METHODS (node) == NULL_TREE; + for (tmp = TYPE_FIELDS (node); tmp; tmp = TREE_CHAIN (tmp)) + { + if (DECL_NAME (tmp) && TREE_STATIC (tmp)) + { + if (need_semicolon) + { + need_semicolon = false; + pp_semicolon (buffer); + } + pp_newline (buffer); + pp_newline (buffer); + print_ada_declaration (buffer, tmp, type, cpp_check, spc); + } + } +} + +/* Dump all the declarations in SOURCE_FILE to an Ada spec. + COLLECT_ALL_REFS is a front-end callback used to collect all relevant + nodes for SOURCE_FILE. CPP_CHECK is used to perform C++ queries on + nodes. */ + +static void +dump_ads (const char *source_file, + void (*collect_all_refs)(const char *), + int (*cpp_check)(tree, cpp_operation)) +{ + char *ads_name; + char *pkg_name; + char *s; + FILE *f; + + pkg_name = get_ada_package (source_file); + + /* Construct the the .ads filename and package name. */ + ads_name = xstrdup (pkg_name); + + for (s = ads_name; *s; s++) + *s = TOLOWER (*s); + + ads_name = reconcat (ads_name, ads_name, ".ads", NULL); + + /* Write out the .ads file. */ + f = fopen (ads_name, "w"); + if (f) + { + pretty_printer pp; + + pp_construct (&pp, NULL, 0); + pp_needs_newline (&pp) = true; + pp.buffer->stream = f; + + /* Dump all relevant macros. */ + dump_ada_macros (&pp, source_file); + + /* Reset the table of withs for this file. */ + reset_ada_withs (); + + (*collect_all_refs) (source_file); + + /* Dump all references. */ + dump_ada_nodes (&pp, source_file, cpp_check); + + /* Dump withs. */ + dump_ada_withs (f); + + fprintf (f, "\npackage %s is\n\n", pkg_name); + pp_write_text_to_stream (&pp); + /* ??? need to free pp */ + fprintf (f, "end %s;\n", pkg_name); + fclose (f); + } + + free (ads_name); + free (pkg_name); +} + +static const char **source_refs = NULL; +static int source_refs_used = 0; +static int source_refs_allocd = 0; + +/* Add an entry for FILENAME to the table SOURCE_REFS. */ + +void +collect_source_ref (const char *filename) +{ + int i; + + if (!filename) + return; + + if (source_refs_allocd == 0) + { + source_refs_allocd = 1024; + source_refs = XNEWVEC (const char *, source_refs_allocd); + } + + for (i = 0; i < source_refs_used; i++) + if (filename == source_refs [i]) + return; + + if (source_refs_used == source_refs_allocd) + { + source_refs_allocd *= 2; + source_refs = XRESIZEVEC (const char *, source_refs, source_refs_allocd); + } + + source_refs [source_refs_used++] = filename; +} + +/* Main entry point: dump all Ada specs corresponding to SOURCE_REFS + using callbacks COLLECT_ALL_REFS and CPP_CHECK. + COLLECT_ALL_REFS is a front-end callback used to collect all relevant + nodes for a given source file. + CPP_CHECK is used to perform C++ queries on nodes, or NULL for the C + front-end. */ + +void +dump_ada_specs (void (*collect_all_refs)(const char *), + int (*cpp_check)(tree, cpp_operation)) +{ + int i; + + /* Iterate over the list of files to dump specs for */ + for (i = 0; i < source_refs_used; i++) + dump_ads (source_refs [i], collect_all_refs, cpp_check); + + /* Free files table. */ + free (source_refs); +} diff --git a/gcc/c-family/c-ada-spec.h b/gcc/c-family/c-ada-spec.h new file mode 100644 index 00000000000..8aed158678c --- /dev/null +++ b/gcc/c-family/c-ada-spec.h @@ -0,0 +1,41 @@ +/* Interface for -fdump-ada-spec capability. + Copyright (C) 2010, 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 3, 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 COPYING3. If not see +. */ + +#ifndef C_ADA_SPEC_H +#define C_ADA_SPEC_H + +#include "pretty-print.h" + +/* In c-ada-spec.c */ + +typedef enum { + IS_ABSTRACT, + IS_CONSTRUCTOR, + IS_DESTRUCTOR, + IS_COPY_CONSTRUCTOR, + IS_TEMPLATE +} cpp_operation; + +extern location_t decl_sloc (const_tree, bool); +extern void collect_ada_nodes (tree, const char *); +extern void collect_source_ref (const char *); +extern void dump_ada_specs (void (*)(const char *), + int (*)(tree, cpp_operation)); + +#endif /* ! C_ADA_SPEC_H */ diff --git a/gcc/c-family/c-common.c b/gcc/c-family/c-common.c new file mode 100644 index 00000000000..324c28aa114 --- /dev/null +++ b/gcc/c-family/c-common.c @@ -0,0 +1,9280 @@ +/* Subroutines shared by all languages that are variants of C. + Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, + 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 + 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 3, 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 COPYING3. If not see +. */ + +/* FIXME: Still need to include rtl.h here (via expr.h) in a front-end file. + Pretend this is a back-end file. */ +#undef IN_GCC_FRONTEND + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tm.h" +#include "intl.h" +#include "tree.h" +#include "flags.h" +#include "output.h" +#include "c-pragma.h" +#include "ggc.h" +#include "c-common.h" +#include "tm_p.h" +#include "obstack.h" +#include "cpplib.h" +#include "target.h" +#include "langhooks.h" +#include "tree-inline.h" +#include "toplev.h" +#include "diagnostic.h" +#include "tree-iterator.h" +#include "hashtab.h" +#include "tree-mudflap.h" +#include "opts.h" +#include "cgraph.h" +#include "target-def.h" +#include "libfuncs.h" + +#include "expr.h" /* For vector_mode_valid_p */ + +cpp_reader *parse_in; /* Declared in c-pragma.h. */ + +/* The following symbols are subsumed in the c_global_trees array, and + listed here individually for documentation purposes. + + INTEGER_TYPE and REAL_TYPE nodes for the standard data types. + + tree short_integer_type_node; + tree long_integer_type_node; + tree long_long_integer_type_node; + tree int128_integer_type_node; + + tree short_unsigned_type_node; + tree long_unsigned_type_node; + tree long_long_unsigned_type_node; + tree int128_unsigned_type_node; + + tree truthvalue_type_node; + tree truthvalue_false_node; + tree truthvalue_true_node; + + tree ptrdiff_type_node; + + tree unsigned_char_type_node; + tree signed_char_type_node; + tree wchar_type_node; + + tree char16_type_node; + tree char32_type_node; + + tree float_type_node; + tree double_type_node; + tree long_double_type_node; + + tree complex_integer_type_node; + tree complex_float_type_node; + tree complex_double_type_node; + tree complex_long_double_type_node; + + tree dfloat32_type_node; + tree dfloat64_type_node; + tree_dfloat128_type_node; + + tree intQI_type_node; + tree intHI_type_node; + tree intSI_type_node; + tree intDI_type_node; + tree intTI_type_node; + + tree unsigned_intQI_type_node; + tree unsigned_intHI_type_node; + tree unsigned_intSI_type_node; + tree unsigned_intDI_type_node; + tree unsigned_intTI_type_node; + + tree widest_integer_literal_type_node; + tree widest_unsigned_literal_type_node; + + Nodes for types `void *' and `const void *'. + + tree ptr_type_node, const_ptr_type_node; + + Nodes for types `char *' and `const char *'. + + tree string_type_node, const_string_type_node; + + Type `char[SOMENUMBER]'. + Used when an array of char is needed and the size is irrelevant. + + tree char_array_type_node; + + Type `int[SOMENUMBER]' or something like it. + Used when an array of int needed and the size is irrelevant. + + tree int_array_type_node; + + Type `wchar_t[SOMENUMBER]' or something like it. + Used when a wide string literal is created. + + tree wchar_array_type_node; + + Type `char16_t[SOMENUMBER]' or something like it. + Used when a UTF-16 string literal is created. + + tree char16_array_type_node; + + Type `char32_t[SOMENUMBER]' or something like it. + Used when a UTF-32 string literal is created. + + tree char32_array_type_node; + + Type `int ()' -- used for implicit declaration of functions. + + tree default_function_type; + + A VOID_TYPE node, packaged in a TREE_LIST. + + tree void_list_node; + + The lazily created VAR_DECLs for __FUNCTION__, __PRETTY_FUNCTION__, + and __func__. (C doesn't generate __FUNCTION__ and__PRETTY_FUNCTION__ + VAR_DECLS, but C++ does.) + + tree function_name_decl_node; + tree pretty_function_name_decl_node; + tree c99_function_name_decl_node; + + Stack of nested function name VAR_DECLs. + + tree saved_function_name_decls; + +*/ + +tree c_global_trees[CTI_MAX]; + +/* Switches common to the C front ends. */ + +/* Nonzero means don't output line number information. */ + +char flag_no_line_commands; + +/* Nonzero causes -E output not to be done, but directives such as + #define that have side effects are still obeyed. */ + +char flag_no_output; + +/* Nonzero means dump macros in some fashion. */ + +char flag_dump_macros; + +/* Nonzero means pass #include lines through to the output. */ + +char flag_dump_includes; + +/* Nonzero means process PCH files while preprocessing. */ + +bool flag_pch_preprocess; + +/* The file name to which we should write a precompiled header, or + NULL if no header will be written in this compile. */ + +const char *pch_file; + +/* Nonzero if an ISO standard was selected. It rejects macros in the + user's namespace. */ +int flag_iso; + +/* Warn about #pragma directives that are not recognized. */ + +int warn_unknown_pragmas; /* Tri state variable. */ + +/* Warn about format/argument anomalies in calls to formatted I/O functions + (*printf, *scanf, strftime, strfmon, etc.). */ + +int warn_format; + +/* C/ObjC language option variables. */ + + +/* Nonzero means allow type mismatches in conditional expressions; + just make their values `void'. */ + +int flag_cond_mismatch; + +/* Nonzero means enable C89 Amendment 1 features. */ + +int flag_isoc94; + +/* Nonzero means use the ISO C99 (or C1X) dialect of C. */ + +int flag_isoc99; + +/* Nonzero means use the ISO C1X dialect of C. */ + +int flag_isoc1x; + +/* Nonzero means that we have builtin functions, and main is an int. */ + +int flag_hosted = 1; + + +/* ObjC language option variables. */ + + +/* Tells the compiler that this is a special run. Do not perform any + compiling, instead we are to test some platform dependent features + and output a C header file with appropriate definitions. */ + +int print_struct_values; + +/* Tells the compiler what is the constant string class for ObjC. */ + +const char *constant_string_class_name; + + +/* C++ language option variables. */ + + +/* Nonzero means generate separate instantiation control files and + juggle them at link time. */ + +int flag_use_repository; + +/* The C++ dialect being used. C++98 is the default. */ + +enum cxx_dialect cxx_dialect = cxx98; + +/* Maximum template instantiation depth. This limit exists to limit the + time it takes to notice infinite template instantiations; the default + value of 1024 is likely to be in the next C++ standard. */ + +int max_tinst_depth = 1024; + + + +/* The elements of `ridpointers' are identifier nodes for the reserved + type names and storage classes. It is indexed by a RID_... value. */ +tree *ridpointers; + +tree (*make_fname_decl) (location_t, tree, int); + +/* Nonzero means don't warn about problems that occur when the code is + executed. */ +int c_inhibit_evaluation_warnings; + +/* Whether lexing has been completed, so subsequent preprocessor + errors should use the compiler's input_location. */ +bool done_lexing = false; + +/* Information about how a function name is generated. */ +struct fname_var_t +{ + tree *const decl; /* pointer to the VAR_DECL. */ + const unsigned rid; /* RID number for the identifier. */ + const int pretty; /* How pretty is it? */ +}; + +/* The three ways of getting then name of the current function. */ + +const struct fname_var_t fname_vars[] = +{ + /* C99 compliant __func__, must be first. */ + {&c99_function_name_decl_node, RID_C99_FUNCTION_NAME, 0}, + /* GCC __FUNCTION__ compliant. */ + {&function_name_decl_node, RID_FUNCTION_NAME, 0}, + /* GCC __PRETTY_FUNCTION__ compliant. */ + {&pretty_function_name_decl_node, RID_PRETTY_FUNCTION_NAME, 1}, + {NULL, 0, 0}, +}; + +static tree c_fully_fold_internal (tree expr, bool, bool *, bool *); +static tree check_case_value (tree); +static bool check_case_bounds (tree, tree, tree *, tree *); + +static tree handle_packed_attribute (tree *, tree, tree, int, bool *); +static tree handle_nocommon_attribute (tree *, tree, tree, int, bool *); +static tree handle_common_attribute (tree *, tree, tree, int, bool *); +static tree handle_noreturn_attribute (tree *, tree, tree, int, bool *); +static tree handle_hot_attribute (tree *, tree, tree, int, bool *); +static tree handle_cold_attribute (tree *, tree, tree, int, bool *); +static tree handle_noinline_attribute (tree *, tree, tree, int, bool *); +static tree handle_noclone_attribute (tree *, tree, tree, int, bool *); +static tree handle_always_inline_attribute (tree *, tree, tree, int, + bool *); +static tree handle_gnu_inline_attribute (tree *, tree, tree, int, bool *); +static tree handle_artificial_attribute (tree *, tree, tree, int, bool *); +static tree handle_flatten_attribute (tree *, tree, tree, int, bool *); +static tree handle_error_attribute (tree *, tree, tree, int, bool *); +static tree handle_used_attribute (tree *, tree, tree, int, bool *); +static tree handle_unused_attribute (tree *, tree, tree, int, bool *); +static tree handle_externally_visible_attribute (tree *, tree, tree, int, + bool *); +static tree handle_const_attribute (tree *, tree, tree, int, bool *); +static tree handle_transparent_union_attribute (tree *, tree, tree, + int, bool *); +static tree handle_constructor_attribute (tree *, tree, tree, int, bool *); +static tree handle_destructor_attribute (tree *, tree, tree, int, bool *); +static tree handle_mode_attribute (tree *, tree, tree, int, bool *); +static tree handle_section_attribute (tree *, tree, tree, int, bool *); +static tree handle_aligned_attribute (tree *, tree, tree, int, bool *); +static tree handle_weak_attribute (tree *, tree, tree, int, bool *) ; +static tree handle_alias_attribute (tree *, tree, tree, int, bool *); +static tree handle_weakref_attribute (tree *, tree, tree, int, bool *) ; +static tree handle_visibility_attribute (tree *, tree, tree, int, + bool *); +static tree handle_tls_model_attribute (tree *, tree, tree, int, + bool *); +static tree handle_no_instrument_function_attribute (tree *, tree, + tree, int, bool *); +static tree handle_malloc_attribute (tree *, tree, tree, int, bool *); +static tree handle_returns_twice_attribute (tree *, tree, tree, int, bool *); +static tree handle_no_limit_stack_attribute (tree *, tree, tree, int, + bool *); +static tree handle_pure_attribute (tree *, tree, tree, int, bool *); +static tree handle_novops_attribute (tree *, tree, tree, int, bool *); +static tree handle_deprecated_attribute (tree *, tree, tree, int, + bool *); +static tree handle_vector_size_attribute (tree *, tree, tree, int, + bool *); +static tree handle_nonnull_attribute (tree *, tree, tree, int, bool *); +static tree handle_nothrow_attribute (tree *, tree, tree, int, bool *); +static tree handle_cleanup_attribute (tree *, tree, tree, int, bool *); +static tree handle_warn_unused_result_attribute (tree *, tree, tree, int, + bool *); +static tree handle_sentinel_attribute (tree *, tree, tree, int, bool *); +static tree handle_type_generic_attribute (tree *, tree, tree, int, bool *); +static tree handle_alloc_size_attribute (tree *, tree, tree, int, bool *); +static tree handle_target_attribute (tree *, tree, tree, int, bool *); +static tree handle_optimize_attribute (tree *, tree, tree, int, bool *); +static tree handle_fnspec_attribute (tree *, tree, tree, int, bool *); + +static void check_function_nonnull (tree, int, tree *); +static void check_nonnull_arg (void *, tree, unsigned HOST_WIDE_INT); +static bool nonnull_check_p (tree, unsigned HOST_WIDE_INT); +static bool get_nonnull_operand (tree, unsigned HOST_WIDE_INT *); +static int resort_field_decl_cmp (const void *, const void *); + +/* Reserved words. The third field is a mask: keywords are disabled + if they match the mask. + + Masks for languages: + C --std=c89: D_C99 | D_CXXONLY | D_OBJC | D_CXX_OBJC + C --std=c99: D_CXXONLY | D_OBJC + ObjC is like C except that D_OBJC and D_CXX_OBJC are not set + C++ --std=c98: D_CONLY | D_CXXOX | D_OBJC + C++ --std=c0x: D_CONLY | D_OBJC + ObjC++ is like C++ except that D_OBJC is not set + + If -fno-asm is used, D_ASM is added to the mask. If + -fno-gnu-keywords is used, D_EXT is added. If -fno-asm and C in + C89 mode, D_EXT89 is added for both -fno-asm and -fno-gnu-keywords. + In C with -Wc++-compat, we warn if D_CXXWARN is set. */ + +const struct c_common_resword c_common_reswords[] = +{ + { "_Bool", RID_BOOL, D_CONLY }, + { "_Complex", RID_COMPLEX, 0 }, + { "_Imaginary", RID_IMAGINARY, D_CONLY }, + { "_Decimal32", RID_DFLOAT32, D_CONLY | D_EXT }, + { "_Decimal64", RID_DFLOAT64, D_CONLY | D_EXT }, + { "_Decimal128", RID_DFLOAT128, D_CONLY | D_EXT }, + { "_Fract", RID_FRACT, D_CONLY | D_EXT }, + { "_Accum", RID_ACCUM, D_CONLY | D_EXT }, + { "_Sat", RID_SAT, D_CONLY | D_EXT }, + { "_Static_assert", RID_STATIC_ASSERT, D_CONLY }, + { "__FUNCTION__", RID_FUNCTION_NAME, 0 }, + { "__PRETTY_FUNCTION__", RID_PRETTY_FUNCTION_NAME, 0 }, + { "__alignof", RID_ALIGNOF, 0 }, + { "__alignof__", RID_ALIGNOF, 0 }, + { "__asm", RID_ASM, 0 }, + { "__asm__", RID_ASM, 0 }, + { "__attribute", RID_ATTRIBUTE, 0 }, + { "__attribute__", RID_ATTRIBUTE, 0 }, + { "__builtin_choose_expr", RID_CHOOSE_EXPR, D_CONLY }, + { "__builtin_offsetof", RID_OFFSETOF, 0 }, + { "__builtin_types_compatible_p", RID_TYPES_COMPATIBLE_P, D_CONLY }, + { "__builtin_va_arg", RID_VA_ARG, 0 }, + { "__complex", RID_COMPLEX, 0 }, + { "__complex__", RID_COMPLEX, 0 }, + { "__const", RID_CONST, 0 }, + { "__const__", RID_CONST, 0 }, + { "__decltype", RID_DECLTYPE, D_CXXONLY }, + { "__extension__", RID_EXTENSION, 0 }, + { "__func__", RID_C99_FUNCTION_NAME, 0 }, + { "__has_nothrow_assign", RID_HAS_NOTHROW_ASSIGN, D_CXXONLY }, + { "__has_nothrow_constructor", RID_HAS_NOTHROW_CONSTRUCTOR, D_CXXONLY }, + { "__has_nothrow_copy", RID_HAS_NOTHROW_COPY, D_CXXONLY }, + { "__has_trivial_assign", RID_HAS_TRIVIAL_ASSIGN, D_CXXONLY }, + { "__has_trivial_constructor", RID_HAS_TRIVIAL_CONSTRUCTOR, D_CXXONLY }, + { "__has_trivial_copy", RID_HAS_TRIVIAL_COPY, D_CXXONLY }, + { "__has_trivial_destructor", RID_HAS_TRIVIAL_DESTRUCTOR, D_CXXONLY }, + { "__has_virtual_destructor", RID_HAS_VIRTUAL_DESTRUCTOR, D_CXXONLY }, + { "__int128", RID_INT128, 0 }, + { "__is_abstract", RID_IS_ABSTRACT, D_CXXONLY }, + { "__is_base_of", RID_IS_BASE_OF, D_CXXONLY }, + { "__is_class", RID_IS_CLASS, D_CXXONLY }, + { "__is_convertible_to", RID_IS_CONVERTIBLE_TO, D_CXXONLY }, + { "__is_empty", RID_IS_EMPTY, D_CXXONLY }, + { "__is_enum", RID_IS_ENUM, D_CXXONLY }, + { "__is_pod", RID_IS_POD, D_CXXONLY }, + { "__is_polymorphic", RID_IS_POLYMORPHIC, D_CXXONLY }, + { "__is_standard_layout", RID_IS_STD_LAYOUT, D_CXXONLY }, + { "__is_trivial", RID_IS_TRIVIAL, D_CXXONLY }, + { "__is_union", RID_IS_UNION, D_CXXONLY }, + { "__imag", RID_IMAGPART, 0 }, + { "__imag__", RID_IMAGPART, 0 }, + { "__inline", RID_INLINE, 0 }, + { "__inline__", RID_INLINE, 0 }, + { "__label__", RID_LABEL, 0 }, + { "__null", RID_NULL, 0 }, + { "__real", RID_REALPART, 0 }, + { "__real__", RID_REALPART, 0 }, + { "__restrict", RID_RESTRICT, 0 }, + { "__restrict__", RID_RESTRICT, 0 }, + { "__signed", RID_SIGNED, 0 }, + { "__signed__", RID_SIGNED, 0 }, + { "__thread", RID_THREAD, 0 }, + { "__typeof", RID_TYPEOF, 0 }, + { "__typeof__", RID_TYPEOF, 0 }, + { "__volatile", RID_VOLATILE, 0 }, + { "__volatile__", RID_VOLATILE, 0 }, + { "alignof", RID_ALIGNOF, D_CXXONLY | D_CXX0X | D_CXXWARN }, + { "asm", RID_ASM, D_ASM }, + { "auto", RID_AUTO, 0 }, + { "bool", RID_BOOL, D_CXXONLY | D_CXXWARN }, + { "break", RID_BREAK, 0 }, + { "case", RID_CASE, 0 }, + { "catch", RID_CATCH, D_CXX_OBJC | D_CXXWARN }, + { "char", RID_CHAR, 0 }, + { "char16_t", RID_CHAR16, D_CXXONLY | D_CXX0X | D_CXXWARN }, + { "char32_t", RID_CHAR32, D_CXXONLY | D_CXX0X | D_CXXWARN }, + { "class", RID_CLASS, D_CXX_OBJC | D_CXXWARN }, + { "const", RID_CONST, 0 }, + { "constexpr", RID_CONSTEXPR, D_CXXONLY | D_CXX0X | D_CXXWARN }, + { "const_cast", RID_CONSTCAST, D_CXXONLY | D_CXXWARN }, + { "continue", RID_CONTINUE, 0 }, + { "decltype", RID_DECLTYPE, D_CXXONLY | D_CXX0X | D_CXXWARN }, + { "default", RID_DEFAULT, 0 }, + { "delete", RID_DELETE, D_CXXONLY | D_CXXWARN }, + { "do", RID_DO, 0 }, + { "double", RID_DOUBLE, 0 }, + { "dynamic_cast", RID_DYNCAST, D_CXXONLY | D_CXXWARN }, + { "else", RID_ELSE, 0 }, + { "enum", RID_ENUM, 0 }, + { "explicit", RID_EXPLICIT, D_CXXONLY | D_CXXWARN }, + { "export", RID_EXPORT, D_CXXONLY | D_CXXWARN }, + { "extern", RID_EXTERN, 0 }, + { "false", RID_FALSE, D_CXXONLY | D_CXXWARN }, + { "float", RID_FLOAT, 0 }, + { "for", RID_FOR, 0 }, + { "friend", RID_FRIEND, D_CXXONLY | D_CXXWARN }, + { "goto", RID_GOTO, 0 }, + { "if", RID_IF, 0 }, + { "inline", RID_INLINE, D_EXT89 }, + { "int", RID_INT, 0 }, + { "long", RID_LONG, 0 }, + { "mutable", RID_MUTABLE, D_CXXONLY | D_CXXWARN }, + { "namespace", RID_NAMESPACE, D_CXXONLY | D_CXXWARN }, + { "new", RID_NEW, D_CXXONLY | D_CXXWARN }, + { "noexcept", RID_NOEXCEPT, D_CXXONLY | D_CXX0X | D_CXXWARN }, + { "nullptr", RID_NULLPTR, D_CXXONLY | D_CXX0X | D_CXXWARN }, + { "operator", RID_OPERATOR, D_CXXONLY | D_CXXWARN }, + { "private", RID_PRIVATE, D_CXX_OBJC | D_CXXWARN }, + { "protected", RID_PROTECTED, D_CXX_OBJC | D_CXXWARN }, + { "public", RID_PUBLIC, D_CXX_OBJC | D_CXXWARN }, + { "register", RID_REGISTER, 0 }, + { "reinterpret_cast", RID_REINTCAST, D_CXXONLY | D_CXXWARN }, + { "restrict", RID_RESTRICT, D_CONLY | D_C99 }, + { "return", RID_RETURN, 0 }, + { "short", RID_SHORT, 0 }, + { "signed", RID_SIGNED, 0 }, + { "sizeof", RID_SIZEOF, 0 }, + { "static", RID_STATIC, 0 }, + { "static_assert", RID_STATIC_ASSERT, D_CXXONLY | D_CXX0X | D_CXXWARN }, + { "static_cast", RID_STATCAST, D_CXXONLY | D_CXXWARN }, + { "struct", RID_STRUCT, 0 }, + { "switch", RID_SWITCH, 0 }, + { "template", RID_TEMPLATE, D_CXXONLY | D_CXXWARN }, + { "this", RID_THIS, D_CXXONLY | D_CXXWARN }, + { "throw", RID_THROW, D_CXX_OBJC | D_CXXWARN }, + { "true", RID_TRUE, D_CXXONLY | D_CXXWARN }, + { "try", RID_TRY, D_CXX_OBJC | D_CXXWARN }, + { "typedef", RID_TYPEDEF, 0 }, + { "typename", RID_TYPENAME, D_CXXONLY | D_CXXWARN }, + { "typeid", RID_TYPEID, D_CXXONLY | D_CXXWARN }, + { "typeof", RID_TYPEOF, D_ASM | D_EXT }, + { "union", RID_UNION, 0 }, + { "unsigned", RID_UNSIGNED, 0 }, + { "using", RID_USING, D_CXXONLY | D_CXXWARN }, + { "virtual", RID_VIRTUAL, D_CXXONLY | D_CXXWARN }, + { "void", RID_VOID, 0 }, + { "volatile", RID_VOLATILE, 0 }, + { "wchar_t", RID_WCHAR, D_CXXONLY }, + { "while", RID_WHILE, 0 }, + /* These Objective-C keywords are recognized only immediately after + an '@'. */ + { "compatibility_alias", RID_AT_ALIAS, D_OBJC }, + { "defs", RID_AT_DEFS, D_OBJC }, + { "encode", RID_AT_ENCODE, D_OBJC }, + { "end", RID_AT_END, D_OBJC }, + { "implementation", RID_AT_IMPLEMENTATION, D_OBJC }, + { "interface", RID_AT_INTERFACE, D_OBJC }, + { "protocol", RID_AT_PROTOCOL, D_OBJC }, + { "selector", RID_AT_SELECTOR, D_OBJC }, + { "finally", RID_AT_FINALLY, D_OBJC }, + { "synchronized", RID_AT_SYNCHRONIZED, D_OBJC }, + /* These are recognized only in protocol-qualifier context + (see above) */ + { "bycopy", RID_BYCOPY, D_OBJC }, + { "byref", RID_BYREF, D_OBJC }, + { "in", RID_IN, D_OBJC }, + { "inout", RID_INOUT, D_OBJC }, + { "oneway", RID_ONEWAY, D_OBJC }, + { "out", RID_OUT, D_OBJC }, +}; + +const unsigned int num_c_common_reswords = + sizeof c_common_reswords / sizeof (struct c_common_resword); + +/* Table of machine-independent attributes common to all C-like languages. */ +const struct attribute_spec c_common_attribute_table[] = +{ + /* { name, min_len, max_len, decl_req, type_req, fn_type_req, handler } */ + { "packed", 0, 0, false, false, false, + handle_packed_attribute }, + { "nocommon", 0, 0, true, false, false, + handle_nocommon_attribute }, + { "common", 0, 0, true, false, false, + handle_common_attribute }, + /* FIXME: logically, noreturn attributes should be listed as + "false, true, true" and apply to function types. But implementing this + would require all the places in the compiler that use TREE_THIS_VOLATILE + on a decl to identify non-returning functions to be located and fixed + to check the function type instead. */ + { "noreturn", 0, 0, true, false, false, + handle_noreturn_attribute }, + { "volatile", 0, 0, true, false, false, + handle_noreturn_attribute }, + { "noinline", 0, 0, true, false, false, + handle_noinline_attribute }, + { "noclone", 0, 0, true, false, false, + handle_noclone_attribute }, + { "always_inline", 0, 0, true, false, false, + handle_always_inline_attribute }, + { "gnu_inline", 0, 0, true, false, false, + handle_gnu_inline_attribute }, + { "artificial", 0, 0, true, false, false, + handle_artificial_attribute }, + { "flatten", 0, 0, true, false, false, + handle_flatten_attribute }, + { "used", 0, 0, true, false, false, + handle_used_attribute }, + { "unused", 0, 0, false, false, false, + handle_unused_attribute }, + { "externally_visible", 0, 0, true, false, false, + handle_externally_visible_attribute }, + /* The same comments as for noreturn attributes apply to const ones. */ + { "const", 0, 0, true, false, false, + handle_const_attribute }, + { "transparent_union", 0, 0, false, false, false, + handle_transparent_union_attribute }, + { "constructor", 0, 1, true, false, false, + handle_constructor_attribute }, + { "destructor", 0, 1, true, false, false, + handle_destructor_attribute }, + { "mode", 1, 1, false, true, false, + handle_mode_attribute }, + { "section", 1, 1, true, false, false, + handle_section_attribute }, + { "aligned", 0, 1, false, false, false, + handle_aligned_attribute }, + { "weak", 0, 0, true, false, false, + handle_weak_attribute }, + { "alias", 1, 1, true, false, false, + handle_alias_attribute }, + { "weakref", 0, 1, true, false, false, + handle_weakref_attribute }, + { "no_instrument_function", 0, 0, true, false, false, + handle_no_instrument_function_attribute }, + { "malloc", 0, 0, true, false, false, + handle_malloc_attribute }, + { "returns_twice", 0, 0, true, false, false, + handle_returns_twice_attribute }, + { "no_stack_limit", 0, 0, true, false, false, + handle_no_limit_stack_attribute }, + { "pure", 0, 0, true, false, false, + handle_pure_attribute }, + /* For internal use (marking of builtins) only. The name contains space + to prevent its usage in source code. */ + { "no vops", 0, 0, true, false, false, + handle_novops_attribute }, + { "deprecated", 0, 1, false, false, false, + handle_deprecated_attribute }, + { "vector_size", 1, 1, false, true, false, + handle_vector_size_attribute }, + { "visibility", 1, 1, false, false, false, + handle_visibility_attribute }, + { "tls_model", 1, 1, true, false, false, + handle_tls_model_attribute }, + { "nonnull", 0, -1, false, true, true, + handle_nonnull_attribute }, + { "nothrow", 0, 0, true, false, false, + handle_nothrow_attribute }, + { "may_alias", 0, 0, false, true, false, NULL }, + { "cleanup", 1, 1, true, false, false, + handle_cleanup_attribute }, + { "warn_unused_result", 0, 0, false, true, true, + handle_warn_unused_result_attribute }, + { "sentinel", 0, 1, false, true, true, + handle_sentinel_attribute }, + /* For internal use (marking of builtins) only. The name contains space + to prevent its usage in source code. */ + { "type generic", 0, 0, false, true, true, + handle_type_generic_attribute }, + { "alloc_size", 1, 2, false, true, true, + handle_alloc_size_attribute }, + { "cold", 0, 0, true, false, false, + handle_cold_attribute }, + { "hot", 0, 0, true, false, false, + handle_hot_attribute }, + { "warning", 1, 1, true, false, false, + handle_error_attribute }, + { "error", 1, 1, true, false, false, + handle_error_attribute }, + { "target", 1, -1, true, false, false, + handle_target_attribute }, + { "optimize", 1, -1, true, false, false, + handle_optimize_attribute }, + /* For internal use (marking of builtins and runtime functions) only. + The name contains space to prevent its usage in source code. */ + { "fn spec", 1, 1, false, true, true, + handle_fnspec_attribute }, + { NULL, 0, 0, false, false, false, NULL } +}; + +/* Give the specifications for the format attributes, used by C and all + descendants. */ + +const struct attribute_spec c_common_format_attribute_table[] = +{ + /* { name, min_len, max_len, decl_req, type_req, fn_type_req, handler } */ + { "format", 3, 3, false, true, true, + handle_format_attribute }, + { "format_arg", 1, 1, false, true, true, + handle_format_arg_attribute }, + { NULL, 0, 0, false, false, false, NULL } +}; + +/* Return identifier for address space AS. */ + +const char * +c_addr_space_name (addr_space_t as) +{ + int rid = RID_FIRST_ADDR_SPACE + as; + gcc_assert (ridpointers [rid]); + return IDENTIFIER_POINTER (ridpointers [rid]); +} + +/* Push current bindings for the function name VAR_DECLS. */ + +void +start_fname_decls (void) +{ + unsigned ix; + tree saved = NULL_TREE; + + for (ix = 0; fname_vars[ix].decl; ix++) + { + tree decl = *fname_vars[ix].decl; + + if (decl) + { + saved = tree_cons (decl, build_int_cst (NULL_TREE, ix), saved); + *fname_vars[ix].decl = NULL_TREE; + } + } + if (saved || saved_function_name_decls) + /* Normally they'll have been NULL, so only push if we've got a + stack, or they are non-NULL. */ + saved_function_name_decls = tree_cons (saved, NULL_TREE, + saved_function_name_decls); +} + +/* Finish up the current bindings, adding them into the current function's + statement tree. This must be done _before_ finish_stmt_tree is called. + If there is no current function, we must be at file scope and no statements + are involved. Pop the previous bindings. */ + +void +finish_fname_decls (void) +{ + unsigned ix; + tree stmts = NULL_TREE; + tree stack = saved_function_name_decls; + + for (; stack && TREE_VALUE (stack); stack = TREE_CHAIN (stack)) + append_to_statement_list (TREE_VALUE (stack), &stmts); + + if (stmts) + { + tree *bodyp = &DECL_SAVED_TREE (current_function_decl); + + if (TREE_CODE (*bodyp) == BIND_EXPR) + bodyp = &BIND_EXPR_BODY (*bodyp); + + append_to_statement_list_force (*bodyp, &stmts); + *bodyp = stmts; + } + + for (ix = 0; fname_vars[ix].decl; ix++) + *fname_vars[ix].decl = NULL_TREE; + + if (stack) + { + /* We had saved values, restore them. */ + tree saved; + + for (saved = TREE_PURPOSE (stack); saved; saved = TREE_CHAIN (saved)) + { + tree decl = TREE_PURPOSE (saved); + unsigned ix = TREE_INT_CST_LOW (TREE_VALUE (saved)); + + *fname_vars[ix].decl = decl; + } + stack = TREE_CHAIN (stack); + } + saved_function_name_decls = stack; +} + +/* Return the text name of the current function, suitably prettified + by PRETTY_P. Return string must be freed by caller. */ + +const char * +fname_as_string (int pretty_p) +{ + const char *name = "top level"; + char *namep; + int vrb = 2, len; + cpp_string cstr = { 0, 0 }, strname; + + if (!pretty_p) + { + name = ""; + vrb = 0; + } + + if (current_function_decl) + name = lang_hooks.decl_printable_name (current_function_decl, vrb); + + len = strlen (name) + 3; /* Two for '"'s. One for NULL. */ + + namep = XNEWVEC (char, len); + snprintf (namep, len, "\"%s\"", name); + strname.text = (unsigned char *) namep; + strname.len = len - 1; + + if (cpp_interpret_string (parse_in, &strname, 1, &cstr, CPP_STRING)) + { + XDELETEVEC (namep); + return (const char *) cstr.text; + } + + return namep; +} + +/* Return the VAR_DECL for a const char array naming the current + function. If the VAR_DECL has not yet been created, create it + now. RID indicates how it should be formatted and IDENTIFIER_NODE + ID is its name (unfortunately C and C++ hold the RID values of + keywords in different places, so we can't derive RID from ID in + this language independent code. LOC is the location of the + function. */ + +tree +fname_decl (location_t loc, unsigned int rid, tree id) +{ + unsigned ix; + tree decl = NULL_TREE; + + for (ix = 0; fname_vars[ix].decl; ix++) + if (fname_vars[ix].rid == rid) + break; + + decl = *fname_vars[ix].decl; + if (!decl) + { + /* If a tree is built here, it would normally have the lineno of + the current statement. Later this tree will be moved to the + beginning of the function and this line number will be wrong. + To avoid this problem set the lineno to 0 here; that prevents + it from appearing in the RTL. */ + tree stmts; + location_t saved_location = input_location; + input_location = UNKNOWN_LOCATION; + + stmts = push_stmt_list (); + decl = (*make_fname_decl) (loc, id, fname_vars[ix].pretty); + stmts = pop_stmt_list (stmts); + if (!IS_EMPTY_STMT (stmts)) + saved_function_name_decls + = tree_cons (decl, stmts, saved_function_name_decls); + *fname_vars[ix].decl = decl; + input_location = saved_location; + } + if (!ix && !current_function_decl) + pedwarn (loc, 0, "%qD is not defined outside of function scope", decl); + + return decl; +} + +/* Given a STRING_CST, give it a suitable array-of-chars data type. */ + +tree +fix_string_type (tree value) +{ + int length = TREE_STRING_LENGTH (value); + int nchars; + tree e_type, i_type, a_type; + + /* Compute the number of elements, for the array type. */ + if (TREE_TYPE (value) == char_array_type_node || !TREE_TYPE (value)) + { + nchars = length; + e_type = char_type_node; + } + else if (TREE_TYPE (value) == char16_array_type_node) + { + nchars = length / (TYPE_PRECISION (char16_type_node) / BITS_PER_UNIT); + e_type = char16_type_node; + } + else if (TREE_TYPE (value) == char32_array_type_node) + { + nchars = length / (TYPE_PRECISION (char32_type_node) / BITS_PER_UNIT); + e_type = char32_type_node; + } + else + { + nchars = length / (TYPE_PRECISION (wchar_type_node) / BITS_PER_UNIT); + e_type = wchar_type_node; + } + + /* C89 2.2.4.1, C99 5.2.4.1 (Translation limits). The analogous + limit in C++98 Annex B is very large (65536) and is not normative, + so we do not diagnose it (warn_overlength_strings is forced off + in c_common_post_options). */ + if (warn_overlength_strings) + { + const int nchars_max = flag_isoc99 ? 4095 : 509; + const int relevant_std = flag_isoc99 ? 99 : 90; + if (nchars - 1 > nchars_max) + /* Translators: The %d after 'ISO C' will be 90 or 99. Do not + separate the %d from the 'C'. 'ISO' should not be + translated, but it may be moved after 'C%d' in languages + where modifiers follow nouns. */ + pedwarn (input_location, OPT_Woverlength_strings, + "string length %qd is greater than the length %qd " + "ISO C%d compilers are required to support", + nchars - 1, nchars_max, relevant_std); + } + + /* Create the array type for the string constant. The ISO C++ + standard says that a string literal has type `const char[N]' or + `const wchar_t[N]'. We use the same logic when invoked as a C + front-end with -Wwrite-strings. + ??? We should change the type of an expression depending on the + state of a warning flag. We should just be warning -- see how + this is handled in the C++ front-end for the deprecated implicit + conversion from string literals to `char*' or `wchar_t*'. + + The C++ front end relies on TYPE_MAIN_VARIANT of a cv-qualified + array type being the unqualified version of that type. + Therefore, if we are constructing an array of const char, we must + construct the matching unqualified array type first. The C front + end does not require this, but it does no harm, so we do it + unconditionally. */ + i_type = build_index_type (build_int_cst (NULL_TREE, nchars - 1)); + a_type = build_array_type (e_type, i_type); + if (c_dialect_cxx() || warn_write_strings) + a_type = c_build_qualified_type (a_type, TYPE_QUAL_CONST); + + TREE_TYPE (value) = a_type; + TREE_CONSTANT (value) = 1; + TREE_READONLY (value) = 1; + TREE_STATIC (value) = 1; + return value; +} + +/* Fully fold EXPR, an expression that was not folded (beyond integer + constant expressions and null pointer constants) when being built + up. If IN_INIT, this is in a static initializer and certain + changes are made to the folding done. Clear *MAYBE_CONST if + MAYBE_CONST is not NULL and EXPR is definitely not a constant + expression because it contains an evaluated operator (in C99) or an + operator outside of sizeof returning an integer constant (in C90) + not permitted in constant expressions, or because it contains an + evaluated arithmetic overflow. (*MAYBE_CONST should typically be + set to true by callers before calling this function.) Return the + folded expression. Function arguments have already been folded + before calling this function, as have the contents of SAVE_EXPR, + TARGET_EXPR, BIND_EXPR, VA_ARG_EXPR, OBJ_TYPE_REF and + C_MAYBE_CONST_EXPR. */ + +tree +c_fully_fold (tree expr, bool in_init, bool *maybe_const) +{ + tree ret; + tree eptype = NULL_TREE; + bool dummy = true; + bool maybe_const_itself = true; + location_t loc = EXPR_LOCATION (expr); + + /* This function is not relevant to C++ because C++ folds while + parsing, and may need changes to be correct for C++ when C++ + stops folding while parsing. */ + if (c_dialect_cxx ()) + gcc_unreachable (); + + if (!maybe_const) + maybe_const = &dummy; + if (TREE_CODE (expr) == EXCESS_PRECISION_EXPR) + { + eptype = TREE_TYPE (expr); + expr = TREE_OPERAND (expr, 0); + } + ret = c_fully_fold_internal (expr, in_init, maybe_const, + &maybe_const_itself); + if (eptype) + ret = fold_convert_loc (loc, eptype, ret); + *maybe_const &= maybe_const_itself; + return ret; +} + +/* Internal helper for c_fully_fold. EXPR and IN_INIT are as for + c_fully_fold. *MAYBE_CONST_OPERANDS is cleared because of operands + not permitted, while *MAYBE_CONST_ITSELF is cleared because of + arithmetic overflow (for C90, *MAYBE_CONST_OPERANDS is carried from + both evaluated and unevaluated subexpressions while + *MAYBE_CONST_ITSELF is carried from only evaluated + subexpressions). */ + +static tree +c_fully_fold_internal (tree expr, bool in_init, bool *maybe_const_operands, + bool *maybe_const_itself) +{ + tree ret = expr; + enum tree_code code = TREE_CODE (expr); + enum tree_code_class kind = TREE_CODE_CLASS (code); + location_t loc = EXPR_LOCATION (expr); + tree op0, op1, op2, op3; + tree orig_op0, orig_op1, orig_op2; + bool op0_const = true, op1_const = true, op2_const = true; + bool op0_const_self = true, op1_const_self = true, op2_const_self = true; + bool nowarning = TREE_NO_WARNING (expr); + int unused_p; + + /* This function is not relevant to C++ because C++ folds while + parsing, and may need changes to be correct for C++ when C++ + stops folding while parsing. */ + if (c_dialect_cxx ()) + gcc_unreachable (); + + /* Constants, declarations, statements, errors, SAVE_EXPRs and + anything else not counted as an expression cannot usefully be + folded further at this point. */ + if (!IS_EXPR_CODE_CLASS (kind) + || kind == tcc_statement + || code == SAVE_EXPR) + return expr; + + /* Operands of variable-length expressions (function calls) have + already been folded, as have __builtin_* function calls, and such + expressions cannot occur in constant expressions. */ + if (kind == tcc_vl_exp) + { + *maybe_const_operands = false; + ret = fold (expr); + goto out; + } + + if (code == C_MAYBE_CONST_EXPR) + { + tree pre = C_MAYBE_CONST_EXPR_PRE (expr); + tree inner = C_MAYBE_CONST_EXPR_EXPR (expr); + if (C_MAYBE_CONST_EXPR_NON_CONST (expr)) + *maybe_const_operands = false; + if (C_MAYBE_CONST_EXPR_INT_OPERANDS (expr)) + *maybe_const_itself = false; + if (pre && !in_init) + ret = build2 (COMPOUND_EXPR, TREE_TYPE (expr), pre, inner); + else + ret = inner; + goto out; + } + + /* Assignment, increment, decrement, function call and comma + operators, and statement expressions, cannot occur in constant + expressions if evaluated / outside of sizeof. (Function calls + were handled above, though VA_ARG_EXPR is treated like a function + call here, and statement expressions are handled through + C_MAYBE_CONST_EXPR to avoid folding inside them.) */ + switch (code) + { + case MODIFY_EXPR: + case PREDECREMENT_EXPR: + case PREINCREMENT_EXPR: + case POSTDECREMENT_EXPR: + case POSTINCREMENT_EXPR: + case COMPOUND_EXPR: + *maybe_const_operands = false; + break; + + case VA_ARG_EXPR: + case TARGET_EXPR: + case BIND_EXPR: + case OBJ_TYPE_REF: + *maybe_const_operands = false; + ret = fold (expr); + goto out; + + default: + break; + } + + /* Fold individual tree codes as appropriate. */ + switch (code) + { + case COMPOUND_LITERAL_EXPR: + /* Any non-constancy will have been marked in a containing + C_MAYBE_CONST_EXPR; there is no more folding to do here. */ + goto out; + + case COMPONENT_REF: + orig_op0 = op0 = TREE_OPERAND (expr, 0); + op1 = TREE_OPERAND (expr, 1); + op2 = TREE_OPERAND (expr, 2); + op0 = c_fully_fold_internal (op0, in_init, maybe_const_operands, + maybe_const_itself); + STRIP_TYPE_NOPS (op0); + if (op0 != orig_op0) + ret = build3 (COMPONENT_REF, TREE_TYPE (expr), op0, op1, op2); + if (ret != expr) + { + TREE_READONLY (ret) = TREE_READONLY (expr); + TREE_THIS_VOLATILE (ret) = TREE_THIS_VOLATILE (expr); + } + goto out; + + case ARRAY_REF: + orig_op0 = op0 = TREE_OPERAND (expr, 0); + orig_op1 = op1 = TREE_OPERAND (expr, 1); + op2 = TREE_OPERAND (expr, 2); + op3 = TREE_OPERAND (expr, 3); + op0 = c_fully_fold_internal (op0, in_init, maybe_const_operands, + maybe_const_itself); + STRIP_TYPE_NOPS (op0); + op1 = c_fully_fold_internal (op1, in_init, maybe_const_operands, + maybe_const_itself); + STRIP_TYPE_NOPS (op1); + op1 = decl_constant_value_for_optimization (op1); + if (op0 != orig_op0 || op1 != orig_op1) + ret = build4 (ARRAY_REF, TREE_TYPE (expr), op0, op1, op2, op3); + if (ret != expr) + { + TREE_READONLY (ret) = TREE_READONLY (expr); + TREE_SIDE_EFFECTS (ret) = TREE_SIDE_EFFECTS (expr); + TREE_THIS_VOLATILE (ret) = TREE_THIS_VOLATILE (expr); + } + ret = fold (ret); + goto out; + + case COMPOUND_EXPR: + case MODIFY_EXPR: + case PREDECREMENT_EXPR: + case PREINCREMENT_EXPR: + case POSTDECREMENT_EXPR: + case POSTINCREMENT_EXPR: + case PLUS_EXPR: + case MINUS_EXPR: + case MULT_EXPR: + case POINTER_PLUS_EXPR: + case TRUNC_DIV_EXPR: + case CEIL_DIV_EXPR: + case FLOOR_DIV_EXPR: + case TRUNC_MOD_EXPR: + case RDIV_EXPR: + case EXACT_DIV_EXPR: + case LSHIFT_EXPR: + case RSHIFT_EXPR: + case BIT_IOR_EXPR: + case BIT_XOR_EXPR: + case BIT_AND_EXPR: + case LT_EXPR: + case LE_EXPR: + case GT_EXPR: + case GE_EXPR: + case EQ_EXPR: + case NE_EXPR: + case COMPLEX_EXPR: + case TRUTH_AND_EXPR: + case TRUTH_OR_EXPR: + case TRUTH_XOR_EXPR: + case UNORDERED_EXPR: + case ORDERED_EXPR: + case UNLT_EXPR: + case UNLE_EXPR: + case UNGT_EXPR: + case UNGE_EXPR: + case UNEQ_EXPR: + /* Binary operations evaluating both arguments (increment and + decrement are binary internally in GCC). */ + orig_op0 = op0 = TREE_OPERAND (expr, 0); + orig_op1 = op1 = TREE_OPERAND (expr, 1); + op0 = c_fully_fold_internal (op0, in_init, maybe_const_operands, + maybe_const_itself); + STRIP_TYPE_NOPS (op0); + if (code != MODIFY_EXPR + && code != PREDECREMENT_EXPR + && code != PREINCREMENT_EXPR + && code != POSTDECREMENT_EXPR + && code != POSTINCREMENT_EXPR) + op0 = decl_constant_value_for_optimization (op0); + /* The RHS of a MODIFY_EXPR was fully folded when building that + expression for the sake of conversion warnings. */ + if (code != MODIFY_EXPR) + op1 = c_fully_fold_internal (op1, in_init, maybe_const_operands, + maybe_const_itself); + STRIP_TYPE_NOPS (op1); + op1 = decl_constant_value_for_optimization (op1); + if (op0 != orig_op0 || op1 != orig_op1 || in_init) + ret = in_init + ? fold_build2_initializer_loc (loc, code, TREE_TYPE (expr), op0, op1) + : fold_build2_loc (loc, code, TREE_TYPE (expr), op0, op1); + else + ret = fold (expr); + if (TREE_OVERFLOW_P (ret) + && !TREE_OVERFLOW_P (op0) + && !TREE_OVERFLOW_P (op1)) + overflow_warning (EXPR_LOCATION (expr), ret); + goto out; + + case INDIRECT_REF: + case FIX_TRUNC_EXPR: + case FLOAT_EXPR: + CASE_CONVERT: + case NON_LVALUE_EXPR: + case NEGATE_EXPR: + case BIT_NOT_EXPR: + case TRUTH_NOT_EXPR: + case ADDR_EXPR: + case CONJ_EXPR: + case REALPART_EXPR: + case IMAGPART_EXPR: + /* Unary operations. */ + orig_op0 = op0 = TREE_OPERAND (expr, 0); + op0 = c_fully_fold_internal (op0, in_init, maybe_const_operands, + maybe_const_itself); + STRIP_TYPE_NOPS (op0); + if (code != ADDR_EXPR && code != REALPART_EXPR && code != IMAGPART_EXPR) + op0 = decl_constant_value_for_optimization (op0); + if (op0 != orig_op0 || in_init) + ret = in_init + ? fold_build1_initializer_loc (loc, code, TREE_TYPE (expr), op0) + : fold_build1_loc (loc, code, TREE_TYPE (expr), op0); + else + ret = fold (expr); + if (code == INDIRECT_REF + && ret != expr + && TREE_CODE (ret) == INDIRECT_REF) + { + TREE_READONLY (ret) = TREE_READONLY (expr); + TREE_SIDE_EFFECTS (ret) = TREE_SIDE_EFFECTS (expr); + TREE_THIS_VOLATILE (ret) = TREE_THIS_VOLATILE (expr); + } + switch (code) + { + case FIX_TRUNC_EXPR: + case FLOAT_EXPR: + CASE_CONVERT: + /* Don't warn about explicit conversions. We will already + have warned about suspect implicit conversions. */ + break; + + default: + if (TREE_OVERFLOW_P (ret) && !TREE_OVERFLOW_P (op0)) + overflow_warning (EXPR_LOCATION (expr), ret); + break; + } + goto out; + + case TRUTH_ANDIF_EXPR: + case TRUTH_ORIF_EXPR: + /* Binary operations not necessarily evaluating both + arguments. */ + orig_op0 = op0 = TREE_OPERAND (expr, 0); + orig_op1 = op1 = TREE_OPERAND (expr, 1); + op0 = c_fully_fold_internal (op0, in_init, &op0_const, &op0_const_self); + STRIP_TYPE_NOPS (op0); + + unused_p = (op0 == (code == TRUTH_ANDIF_EXPR + ? truthvalue_false_node + : truthvalue_true_node)); + c_inhibit_evaluation_warnings += unused_p; + op1 = c_fully_fold_internal (op1, in_init, &op1_const, &op1_const_self); + STRIP_TYPE_NOPS (op1); + c_inhibit_evaluation_warnings -= unused_p; + + if (op0 != orig_op0 || op1 != orig_op1 || in_init) + ret = in_init + ? fold_build2_initializer_loc (loc, code, TREE_TYPE (expr), op0, op1) + : fold_build2_loc (loc, code, TREE_TYPE (expr), op0, op1); + else + ret = fold (expr); + *maybe_const_operands &= op0_const; + *maybe_const_itself &= op0_const_self; + if (!(flag_isoc99 + && op0_const + && op0_const_self + && (code == TRUTH_ANDIF_EXPR + ? op0 == truthvalue_false_node + : op0 == truthvalue_true_node))) + *maybe_const_operands &= op1_const; + if (!(op0_const + && op0_const_self + && (code == TRUTH_ANDIF_EXPR + ? op0 == truthvalue_false_node + : op0 == truthvalue_true_node))) + *maybe_const_itself &= op1_const_self; + goto out; + + case COND_EXPR: + orig_op0 = op0 = TREE_OPERAND (expr, 0); + orig_op1 = op1 = TREE_OPERAND (expr, 1); + orig_op2 = op2 = TREE_OPERAND (expr, 2); + op0 = c_fully_fold_internal (op0, in_init, &op0_const, &op0_const_self); + + STRIP_TYPE_NOPS (op0); + c_inhibit_evaluation_warnings += (op0 == truthvalue_false_node); + op1 = c_fully_fold_internal (op1, in_init, &op1_const, &op1_const_self); + STRIP_TYPE_NOPS (op1); + c_inhibit_evaluation_warnings -= (op0 == truthvalue_false_node); + + c_inhibit_evaluation_warnings += (op0 == truthvalue_true_node); + op2 = c_fully_fold_internal (op2, in_init, &op2_const, &op2_const_self); + STRIP_TYPE_NOPS (op2); + c_inhibit_evaluation_warnings -= (op0 == truthvalue_true_node); + + if (op0 != orig_op0 || op1 != orig_op1 || op2 != orig_op2) + ret = fold_build3_loc (loc, code, TREE_TYPE (expr), op0, op1, op2); + else + ret = fold (expr); + *maybe_const_operands &= op0_const; + *maybe_const_itself &= op0_const_self; + if (!(flag_isoc99 + && op0_const + && op0_const_self + && op0 == truthvalue_false_node)) + *maybe_const_operands &= op1_const; + if (!(op0_const + && op0_const_self + && op0 == truthvalue_false_node)) + *maybe_const_itself &= op1_const_self; + if (!(flag_isoc99 + && op0_const + && op0_const_self + && op0 == truthvalue_true_node)) + *maybe_const_operands &= op2_const; + if (!(op0_const + && op0_const_self + && op0 == truthvalue_true_node)) + *maybe_const_itself &= op2_const_self; + goto out; + + case EXCESS_PRECISION_EXPR: + /* Each case where an operand with excess precision may be + encountered must remove the EXCESS_PRECISION_EXPR around + inner operands and possibly put one around the whole + expression or possibly convert to the semantic type (which + c_fully_fold does); we cannot tell at this stage which is + appropriate in any particular case. */ + gcc_unreachable (); + + default: + /* Various codes may appear through folding built-in functions + and their arguments. */ + goto out; + } + + out: + /* Some folding may introduce NON_LVALUE_EXPRs; all lvalue checks + have been done by this point, so remove them again. */ + nowarning |= TREE_NO_WARNING (ret); + STRIP_TYPE_NOPS (ret); + if (nowarning && !TREE_NO_WARNING (ret)) + { + if (!CAN_HAVE_LOCATION_P (ret)) + ret = build1 (NOP_EXPR, TREE_TYPE (ret), ret); + TREE_NO_WARNING (ret) = 1; + } + if (ret != expr) + protected_set_expr_location (ret, loc); + return ret; +} + +/* If not optimizing, EXP is not a VAR_DECL, or EXP has array type, + return EXP. Otherwise, return either EXP or its known constant + value (if it has one), but return EXP if EXP has mode BLKmode. ??? + Is the BLKmode test appropriate? */ + +tree +decl_constant_value_for_optimization (tree exp) +{ + tree ret; + + /* This function is only used by C, for c_fully_fold and other + optimization, and may not be correct for C++. */ + if (c_dialect_cxx ()) + gcc_unreachable (); + + if (!optimize + || TREE_CODE (exp) != VAR_DECL + || TREE_CODE (TREE_TYPE (exp)) == ARRAY_TYPE + || DECL_MODE (exp) == BLKmode) + return exp; + + ret = decl_constant_value (exp); + /* Avoid unwanted tree sharing between the initializer and current + function's body where the tree can be modified e.g. by the + gimplifier. */ + if (ret != exp && TREE_STATIC (exp)) + ret = unshare_expr (ret); + return ret; +} + +/* Print a warning if a constant expression had overflow in folding. + Invoke this function on every expression that the language + requires to be a constant expression. + Note the ANSI C standard says it is erroneous for a + constant expression to overflow. */ + +void +constant_expression_warning (tree value) +{ + if (warn_overflow && pedantic + && (TREE_CODE (value) == INTEGER_CST || TREE_CODE (value) == REAL_CST + || TREE_CODE (value) == FIXED_CST + || TREE_CODE (value) == VECTOR_CST + || TREE_CODE (value) == COMPLEX_CST) + && TREE_OVERFLOW (value)) + pedwarn (input_location, OPT_Woverflow, "overflow in constant expression"); +} + +/* The same as above but print an unconditional error. */ +void +constant_expression_error (tree value) +{ + if ((TREE_CODE (value) == INTEGER_CST || TREE_CODE (value) == REAL_CST + || TREE_CODE (value) == FIXED_CST + || TREE_CODE (value) == VECTOR_CST + || TREE_CODE (value) == COMPLEX_CST) + && TREE_OVERFLOW (value)) + error ("overflow in constant expression"); +} + +/* Print a warning if an expression had overflow in folding and its + operands hadn't. + + Invoke this function on every expression that + (1) appears in the source code, and + (2) is a constant expression that overflowed, and + (3) is not already checked by convert_and_check; + however, do not invoke this function on operands of explicit casts + or when the expression is the result of an operator and any operand + already overflowed. */ + +void +overflow_warning (location_t loc, tree value) +{ + if (c_inhibit_evaluation_warnings != 0) + return; + + switch (TREE_CODE (value)) + { + case INTEGER_CST: + warning_at (loc, OPT_Woverflow, "integer overflow in expression"); + break; + + case REAL_CST: + warning_at (loc, OPT_Woverflow, + "floating point overflow in expression"); + break; + + case FIXED_CST: + warning_at (loc, OPT_Woverflow, "fixed-point overflow in expression"); + break; + + case VECTOR_CST: + warning_at (loc, OPT_Woverflow, "vector overflow in expression"); + break; + + case COMPLEX_CST: + if (TREE_CODE (TREE_REALPART (value)) == INTEGER_CST) + warning_at (loc, OPT_Woverflow, + "complex integer overflow in expression"); + else if (TREE_CODE (TREE_REALPART (value)) == REAL_CST) + warning_at (loc, OPT_Woverflow, + "complex floating point overflow in expression"); + break; + + default: + break; + } +} + +/* Warn about uses of logical || / && operator in a context where it + is likely that the bitwise equivalent was intended by the + programmer. We have seen an expression in which CODE is a binary + operator used to combine expressions OP_LEFT and OP_RIGHT, which before folding + had CODE_LEFT and CODE_RIGHT, into an expression of type TYPE. */ +void +warn_logical_operator (location_t location, enum tree_code code, tree type, + enum tree_code code_left, tree op_left, + enum tree_code ARG_UNUSED (code_right), tree op_right) +{ + int or_op = (code == TRUTH_ORIF_EXPR || code == TRUTH_OR_EXPR); + int in0_p, in1_p, in_p; + tree low0, low1, low, high0, high1, high, lhs, rhs, tem; + bool strict_overflow_p = false; + + if (code != TRUTH_ANDIF_EXPR + && code != TRUTH_AND_EXPR + && code != TRUTH_ORIF_EXPR + && code != TRUTH_OR_EXPR) + return; + + /* Warn if &&/|| are being used in a context where it is + likely that the bitwise equivalent was intended by the + programmer. That is, an expression such as op && MASK + where op should not be any boolean expression, nor a + constant, and mask seems to be a non-boolean integer constant. */ + if (!truth_value_p (code_left) + && INTEGRAL_TYPE_P (TREE_TYPE (op_left)) + && !CONSTANT_CLASS_P (op_left) + && !TREE_NO_WARNING (op_left) + && TREE_CODE (op_right) == INTEGER_CST + && !integer_zerop (op_right) + && !integer_onep (op_right)) + { + if (or_op) + warning_at (location, OPT_Wlogical_op, "logical %" + " applied to non-boolean constant"); + else + warning_at (location, OPT_Wlogical_op, "logical %" + " applied to non-boolean constant"); + TREE_NO_WARNING (op_left) = true; + return; + } + + /* We do not warn for constants because they are typical of macro + expansions that test for features. */ + if (CONSTANT_CLASS_P (op_left) || CONSTANT_CLASS_P (op_right)) + return; + + /* This warning only makes sense with logical operands. */ + if (!(truth_value_p (TREE_CODE (op_left)) + || INTEGRAL_TYPE_P (TREE_TYPE (op_left))) + || !(truth_value_p (TREE_CODE (op_right)) + || INTEGRAL_TYPE_P (TREE_TYPE (op_right)))) + return; + + lhs = make_range (op_left, &in0_p, &low0, &high0, &strict_overflow_p); + rhs = make_range (op_right, &in1_p, &low1, &high1, &strict_overflow_p); + + if (lhs && TREE_CODE (lhs) == C_MAYBE_CONST_EXPR) + lhs = C_MAYBE_CONST_EXPR_EXPR (lhs); + + if (rhs && TREE_CODE (rhs) == C_MAYBE_CONST_EXPR) + rhs = C_MAYBE_CONST_EXPR_EXPR (rhs); + + /* If this is an OR operation, invert both sides; we will invert + again at the end. */ + if (or_op) + in0_p = !in0_p, in1_p = !in1_p; + + /* If both expressions are the same, if we can merge the ranges, and we + can build the range test, return it or it inverted. */ + if (lhs && rhs && operand_equal_p (lhs, rhs, 0) + && merge_ranges (&in_p, &low, &high, in0_p, low0, high0, + in1_p, low1, high1) + && 0 != (tem = build_range_check (UNKNOWN_LOCATION, + type, lhs, in_p, low, high))) + { + if (TREE_CODE (tem) != INTEGER_CST) + return; + + if (or_op) + warning_at (location, OPT_Wlogical_op, + "logical % " + "of collectively exhaustive tests is always true"); + else + warning_at (location, OPT_Wlogical_op, + "logical % " + "of mutually exclusive tests is always false"); + } +} + + +/* Print a warning about casts that might indicate violation + of strict aliasing rules if -Wstrict-aliasing is used and + strict aliasing mode is in effect. OTYPE is the original + TREE_TYPE of EXPR, and TYPE the type we're casting to. */ + +bool +strict_aliasing_warning (tree otype, tree type, tree expr) +{ + /* Strip pointer conversion chains and get to the correct original type. */ + STRIP_NOPS (expr); + otype = TREE_TYPE (expr); + + if (!(flag_strict_aliasing + && POINTER_TYPE_P (type) + && POINTER_TYPE_P (otype) + && !VOID_TYPE_P (TREE_TYPE (type))) + /* If the type we are casting to is a ref-all pointer + dereferencing it is always valid. */ + || TYPE_REF_CAN_ALIAS_ALL (type)) + return false; + + if ((warn_strict_aliasing > 1) && TREE_CODE (expr) == ADDR_EXPR + && (DECL_P (TREE_OPERAND (expr, 0)) + || handled_component_p (TREE_OPERAND (expr, 0)))) + { + /* Casting the address of an object to non void pointer. Warn + if the cast breaks type based aliasing. */ + if (!COMPLETE_TYPE_P (TREE_TYPE (type)) && warn_strict_aliasing == 2) + { + warning (OPT_Wstrict_aliasing, "type-punning to incomplete type " + "might break strict-aliasing rules"); + return true; + } + else + { + /* warn_strict_aliasing >= 3. This includes the default (3). + Only warn if the cast is dereferenced immediately. */ + alias_set_type set1 = + get_alias_set (TREE_TYPE (TREE_OPERAND (expr, 0))); + alias_set_type set2 = get_alias_set (TREE_TYPE (type)); + + if (set1 != set2 && set2 != 0 + && (set1 == 0 || !alias_sets_conflict_p (set1, set2))) + { + warning (OPT_Wstrict_aliasing, "dereferencing type-punned " + "pointer will break strict-aliasing rules"); + return true; + } + else if (warn_strict_aliasing == 2 + && !alias_sets_must_conflict_p (set1, set2)) + { + warning (OPT_Wstrict_aliasing, "dereferencing type-punned " + "pointer might break strict-aliasing rules"); + return true; + } + } + } + else + if ((warn_strict_aliasing == 1) && !VOID_TYPE_P (TREE_TYPE (otype))) + { + /* At this level, warn for any conversions, even if an address is + not taken in the same statement. This will likely produce many + false positives, but could be useful to pinpoint problems that + are not revealed at higher levels. */ + alias_set_type set1 = get_alias_set (TREE_TYPE (otype)); + alias_set_type set2 = get_alias_set (TREE_TYPE (type)); + if (!COMPLETE_TYPE_P (type) + || !alias_sets_must_conflict_p (set1, set2)) + { + warning (OPT_Wstrict_aliasing, "dereferencing type-punned " + "pointer might break strict-aliasing rules"); + return true; + } + } + + return false; +} + +/* Warn for unlikely, improbable, or stupid DECL declarations + of `main'. */ + +void +check_main_parameter_types (tree decl) +{ + tree args; + int argct = 0; + + for (args = TYPE_ARG_TYPES (TREE_TYPE (decl)); args; + args = TREE_CHAIN (args)) + { + tree type = args ? TREE_VALUE (args) : 0; + + if (type == void_type_node || type == error_mark_node ) + break; + + ++argct; + switch (argct) + { + case 1: + if (TYPE_MAIN_VARIANT (type) != integer_type_node) + pedwarn (input_location, OPT_Wmain, "first argument of %q+D should be %", + decl); + break; + + case 2: + if (TREE_CODE (type) != POINTER_TYPE + || TREE_CODE (TREE_TYPE (type)) != POINTER_TYPE + || (TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (type))) + != char_type_node)) + pedwarn (input_location, OPT_Wmain, "second argument of %q+D should be %", + decl); + break; + + case 3: + if (TREE_CODE (type) != POINTER_TYPE + || TREE_CODE (TREE_TYPE (type)) != POINTER_TYPE + || (TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (type))) + != char_type_node)) + pedwarn (input_location, OPT_Wmain, "third argument of %q+D should probably be " + "%", decl); + break; + } + } + + /* It is intentional that this message does not mention the third + argument because it's only mentioned in an appendix of the + standard. */ + if (argct > 0 && (argct < 2 || argct > 3)) + pedwarn (input_location, OPT_Wmain, "%q+D takes only zero or two arguments", decl); +} + +/* True if pointers to distinct types T1 and T2 can be converted to + each other without an explicit cast. Only returns true for opaque + vector types. */ +bool +vector_targets_convertible_p (const_tree t1, const_tree t2) +{ + if (TREE_CODE (t1) == VECTOR_TYPE && TREE_CODE (t2) == VECTOR_TYPE + && (TYPE_VECTOR_OPAQUE (t1) || TYPE_VECTOR_OPAQUE (t2)) + && tree_int_cst_equal (TYPE_SIZE (t1), TYPE_SIZE (t2))) + return true; + + return false; +} + +/* True if vector types T1 and T2 can be converted to each other + without an explicit cast. If EMIT_LAX_NOTE is true, and T1 and T2 + can only be converted with -flax-vector-conversions yet that is not + in effect, emit a note telling the user about that option if such + a note has not previously been emitted. */ +bool +vector_types_convertible_p (const_tree t1, const_tree t2, bool emit_lax_note) +{ + static bool emitted_lax_note = false; + bool convertible_lax; + + if ((TYPE_VECTOR_OPAQUE (t1) || TYPE_VECTOR_OPAQUE (t2)) + && tree_int_cst_equal (TYPE_SIZE (t1), TYPE_SIZE (t2))) + return true; + + convertible_lax = + (tree_int_cst_equal (TYPE_SIZE (t1), TYPE_SIZE (t2)) + && (TREE_CODE (TREE_TYPE (t1)) != REAL_TYPE || + TYPE_PRECISION (t1) == TYPE_PRECISION (t2)) + && (INTEGRAL_TYPE_P (TREE_TYPE (t1)) + == INTEGRAL_TYPE_P (TREE_TYPE (t2)))); + + if (!convertible_lax || flag_lax_vector_conversions) + return convertible_lax; + + if (TYPE_VECTOR_SUBPARTS (t1) == TYPE_VECTOR_SUBPARTS (t2) + && lang_hooks.types_compatible_p (TREE_TYPE (t1), TREE_TYPE (t2))) + return true; + + if (emit_lax_note && !emitted_lax_note) + { + emitted_lax_note = true; + inform (input_location, "use -flax-vector-conversions to permit " + "conversions between vectors with differing " + "element types or numbers of subparts"); + } + + return false; +} + +/* This is a helper function of build_binary_op. + + For certain operations if both args were extended from the same + smaller type, do the arithmetic in that type and then extend. + + BITWISE indicates a bitwise operation. + For them, this optimization is safe only if + both args are zero-extended or both are sign-extended. + Otherwise, we might change the result. + Eg, (short)-1 | (unsigned short)-1 is (int)-1 + but calculated in (unsigned short) it would be (unsigned short)-1. +*/ +tree shorten_binary_op (tree result_type, tree op0, tree op1, bool bitwise) +{ + int unsigned0, unsigned1; + tree arg0, arg1; + int uns; + tree type; + + /* Cast OP0 and OP1 to RESULT_TYPE. Doing so prevents + excessive narrowing when we call get_narrower below. For + example, suppose that OP0 is of unsigned int extended + from signed char and that RESULT_TYPE is long long int. + If we explicitly cast OP0 to RESULT_TYPE, OP0 would look + like + + (long long int) (unsigned int) signed_char + + which get_narrower would narrow down to + + (unsigned int) signed char + + If we do not cast OP0 first, get_narrower would return + signed_char, which is inconsistent with the case of the + explicit cast. */ + op0 = convert (result_type, op0); + op1 = convert (result_type, op1); + + arg0 = get_narrower (op0, &unsigned0); + arg1 = get_narrower (op1, &unsigned1); + + /* UNS is 1 if the operation to be done is an unsigned one. */ + uns = TYPE_UNSIGNED (result_type); + + /* Handle the case that OP0 (or OP1) does not *contain* a conversion + but it *requires* conversion to FINAL_TYPE. */ + + if ((TYPE_PRECISION (TREE_TYPE (op0)) + == TYPE_PRECISION (TREE_TYPE (arg0))) + && TREE_TYPE (op0) != result_type) + unsigned0 = TYPE_UNSIGNED (TREE_TYPE (op0)); + if ((TYPE_PRECISION (TREE_TYPE (op1)) + == TYPE_PRECISION (TREE_TYPE (arg1))) + && TREE_TYPE (op1) != result_type) + unsigned1 = TYPE_UNSIGNED (TREE_TYPE (op1)); + + /* Now UNSIGNED0 is 1 if ARG0 zero-extends to FINAL_TYPE. */ + + /* For bitwise operations, signedness of nominal type + does not matter. Consider only how operands were extended. */ + if (bitwise) + uns = unsigned0; + + /* Note that in all three cases below we refrain from optimizing + an unsigned operation on sign-extended args. + That would not be valid. */ + + /* Both args variable: if both extended in same way + from same width, do it in that width. + Do it unsigned if args were zero-extended. */ + if ((TYPE_PRECISION (TREE_TYPE (arg0)) + < TYPE_PRECISION (result_type)) + && (TYPE_PRECISION (TREE_TYPE (arg1)) + == TYPE_PRECISION (TREE_TYPE (arg0))) + && unsigned0 == unsigned1 + && (unsigned0 || !uns)) + return c_common_signed_or_unsigned_type + (unsigned0, common_type (TREE_TYPE (arg0), TREE_TYPE (arg1))); + + else if (TREE_CODE (arg0) == INTEGER_CST + && (unsigned1 || !uns) + && (TYPE_PRECISION (TREE_TYPE (arg1)) + < TYPE_PRECISION (result_type)) + && (type + = c_common_signed_or_unsigned_type (unsigned1, + TREE_TYPE (arg1))) + && !POINTER_TYPE_P (type) + && int_fits_type_p (arg0, type)) + return type; + + else if (TREE_CODE (arg1) == INTEGER_CST + && (unsigned0 || !uns) + && (TYPE_PRECISION (TREE_TYPE (arg0)) + < TYPE_PRECISION (result_type)) + && (type + = c_common_signed_or_unsigned_type (unsigned0, + TREE_TYPE (arg0))) + && !POINTER_TYPE_P (type) + && int_fits_type_p (arg1, type)) + return type; + + return result_type; +} + +/* Warns if the conversion of EXPR to TYPE may alter a value. + This is a helper function for warnings_for_convert_and_check. */ + +static void +conversion_warning (tree type, tree expr) +{ + bool give_warning = false; + + int i; + const int expr_num_operands = TREE_OPERAND_LENGTH (expr); + tree expr_type = TREE_TYPE (expr); + location_t loc = EXPR_HAS_LOCATION (expr) + ? EXPR_LOCATION (expr) : input_location; + + if (!warn_conversion && !warn_sign_conversion) + return; + + /* If any operand is artificial, then this expression was generated + by the compiler and we do not warn. */ + for (i = 0; i < expr_num_operands; i++) + { + tree op = TREE_OPERAND (expr, i); + if (op && DECL_P (op) && DECL_ARTIFICIAL (op)) + return; + } + + switch (TREE_CODE (expr)) + { + case EQ_EXPR: + 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: + case TRUTH_NOT_EXPR: + /* Conversion from boolean to a signed:1 bit-field (which only + can hold the values 0 and -1) doesn't lose information - but + it does change the value. */ + if (TYPE_PRECISION (type) == 1 && !TYPE_UNSIGNED (type)) + warning_at (loc, OPT_Wconversion, + "conversion to %qT from boolean expression", type); + return; + + case REAL_CST: + case INTEGER_CST: + + /* Warn for real constant that is not an exact integer converted + to integer type. */ + if (TREE_CODE (expr_type) == REAL_TYPE + && TREE_CODE (type) == INTEGER_TYPE) + { + if (!real_isinteger (TREE_REAL_CST_PTR (expr), TYPE_MODE (expr_type))) + give_warning = true; + } + /* Warn for an integer constant that does not fit into integer type. */ + else if (TREE_CODE (expr_type) == INTEGER_TYPE + && TREE_CODE (type) == INTEGER_TYPE + && !int_fits_type_p (expr, type)) + { + if (TYPE_UNSIGNED (type) && !TYPE_UNSIGNED (expr_type) + && tree_int_cst_sgn (expr) < 0) + warning_at (loc, OPT_Wsign_conversion, "negative integer" + " implicitly converted to unsigned type"); + else if (!TYPE_UNSIGNED (type) && TYPE_UNSIGNED (expr_type)) + warning_at (loc, OPT_Wsign_conversion, "conversion of unsigned" + " constant value to negative integer"); + else + give_warning = true; + } + else if (TREE_CODE (type) == REAL_TYPE) + { + /* Warn for an integer constant that does not fit into real type. */ + if (TREE_CODE (expr_type) == INTEGER_TYPE) + { + REAL_VALUE_TYPE a = real_value_from_int_cst (0, expr); + if (!exact_real_truncate (TYPE_MODE (type), &a)) + give_warning = true; + } + /* Warn for a real constant that does not fit into a smaller + real type. */ + else if (TREE_CODE (expr_type) == REAL_TYPE + && TYPE_PRECISION (type) < TYPE_PRECISION (expr_type)) + { + REAL_VALUE_TYPE a = TREE_REAL_CST (expr); + if (!exact_real_truncate (TYPE_MODE (type), &a)) + give_warning = true; + } + } + + if (give_warning) + warning_at (loc, OPT_Wconversion, + "conversion to %qT alters %qT constant value", + type, expr_type); + + return; + + case COND_EXPR: + { + /* In case of COND_EXPR, if both operands are constants or + COND_EXPR, then we do not care about the type of COND_EXPR, + only about the conversion of each operand. */ + tree op1 = TREE_OPERAND (expr, 1); + tree op2 = TREE_OPERAND (expr, 2); + + if ((TREE_CODE (op1) == REAL_CST || TREE_CODE (op1) == INTEGER_CST + || TREE_CODE (op1) == COND_EXPR) + && (TREE_CODE (op2) == REAL_CST || TREE_CODE (op2) == INTEGER_CST + || TREE_CODE (op2) == COND_EXPR)) + { + conversion_warning (type, op1); + conversion_warning (type, op2); + return; + } + /* Fall through. */ + } + + default: /* 'expr' is not a constant. */ + + /* Warn for real types converted to integer types. */ + if (TREE_CODE (expr_type) == REAL_TYPE + && TREE_CODE (type) == INTEGER_TYPE) + give_warning = true; + + else if (TREE_CODE (expr_type) == INTEGER_TYPE + && TREE_CODE (type) == INTEGER_TYPE) + { + /* Don't warn about unsigned char y = 0xff, x = (int) y; */ + expr = get_unwidened (expr, 0); + expr_type = TREE_TYPE (expr); + + /* Don't warn for short y; short x = ((int)y & 0xff); */ + if (TREE_CODE (expr) == BIT_AND_EXPR + || TREE_CODE (expr) == BIT_IOR_EXPR + || TREE_CODE (expr) == BIT_XOR_EXPR) + { + /* If both args were extended from a shortest type, + use that type if that is safe. */ + expr_type = shorten_binary_op (expr_type, + TREE_OPERAND (expr, 0), + TREE_OPERAND (expr, 1), + /* bitwise */1); + + if (TREE_CODE (expr) == BIT_AND_EXPR) + { + tree op0 = TREE_OPERAND (expr, 0); + tree op1 = TREE_OPERAND (expr, 1); + bool unsigned0 = TYPE_UNSIGNED (TREE_TYPE (op0)); + bool unsigned1 = TYPE_UNSIGNED (TREE_TYPE (op1)); + + /* If one of the operands is a non-negative constant + that fits in the target type, then the type of the + other operand does not matter. */ + if ((TREE_CODE (op0) == INTEGER_CST + && int_fits_type_p (op0, c_common_signed_type (type)) + && int_fits_type_p (op0, c_common_unsigned_type (type))) + || (TREE_CODE (op1) == INTEGER_CST + && int_fits_type_p (op1, c_common_signed_type (type)) + && int_fits_type_p (op1, + c_common_unsigned_type (type)))) + return; + /* If constant is unsigned and fits in the target + type, then the result will also fit. */ + else if ((TREE_CODE (op0) == INTEGER_CST + && unsigned0 + && int_fits_type_p (op0, type)) + || (TREE_CODE (op1) == INTEGER_CST + && unsigned1 + && int_fits_type_p (op1, type))) + return; + } + } + /* Warn for integer types converted to smaller integer types. */ + if (TYPE_PRECISION (type) < TYPE_PRECISION (expr_type)) + give_warning = true; + + /* When they are the same width but different signedness, + then the value may change. */ + else if ((TYPE_PRECISION (type) == TYPE_PRECISION (expr_type) + && TYPE_UNSIGNED (expr_type) != TYPE_UNSIGNED (type)) + /* Even when converted to a bigger type, if the type is + unsigned but expr is signed, then negative values + will be changed. */ + || (TYPE_UNSIGNED (type) && !TYPE_UNSIGNED (expr_type))) + warning_at (loc, OPT_Wsign_conversion, "conversion to %qT from %qT " + "may change the sign of the result", + type, expr_type); + } + + /* Warn for integer types converted to real types if and only if + all the range of values of the integer type cannot be + represented by the real type. */ + else if (TREE_CODE (expr_type) == INTEGER_TYPE + && TREE_CODE (type) == REAL_TYPE) + { + tree type_low_bound, type_high_bound; + REAL_VALUE_TYPE real_low_bound, real_high_bound; + + /* Don't warn about char y = 0xff; float x = (int) y; */ + expr = get_unwidened (expr, 0); + expr_type = TREE_TYPE (expr); + + type_low_bound = TYPE_MIN_VALUE (expr_type); + type_high_bound = TYPE_MAX_VALUE (expr_type); + real_low_bound = real_value_from_int_cst (0, type_low_bound); + real_high_bound = real_value_from_int_cst (0, type_high_bound); + + if (!exact_real_truncate (TYPE_MODE (type), &real_low_bound) + || !exact_real_truncate (TYPE_MODE (type), &real_high_bound)) + give_warning = true; + } + + /* Warn for real types converted to smaller real types. */ + else if (TREE_CODE (expr_type) == REAL_TYPE + && TREE_CODE (type) == REAL_TYPE + && TYPE_PRECISION (type) < TYPE_PRECISION (expr_type)) + give_warning = true; + + + if (give_warning) + warning_at (loc, OPT_Wconversion, + "conversion to %qT from %qT may alter its value", + type, expr_type); + } +} + +/* Produce warnings after a conversion. RESULT is the result of + converting EXPR to TYPE. This is a helper function for + convert_and_check and cp_convert_and_check. */ + +void +warnings_for_convert_and_check (tree type, tree expr, tree result) +{ + if (TREE_CODE (expr) == INTEGER_CST + && (TREE_CODE (type) == INTEGER_TYPE + || TREE_CODE (type) == ENUMERAL_TYPE) + && !int_fits_type_p (expr, type)) + { + /* Do not diagnose overflow in a constant expression merely + because a conversion overflowed. */ + if (TREE_OVERFLOW (result)) + TREE_OVERFLOW (result) = TREE_OVERFLOW (expr); + + if (TYPE_UNSIGNED (type)) + { + /* This detects cases like converting -129 or 256 to + unsigned char. */ + if (!int_fits_type_p (expr, c_common_signed_type (type))) + warning (OPT_Woverflow, + "large integer implicitly truncated to unsigned type"); + else + conversion_warning (type, expr); + } + else if (!int_fits_type_p (expr, c_common_unsigned_type (type))) + warning (OPT_Woverflow, + "overflow in implicit constant conversion"); + /* No warning for converting 0x80000000 to int. */ + else if (pedantic + && (TREE_CODE (TREE_TYPE (expr)) != INTEGER_TYPE + || TYPE_PRECISION (TREE_TYPE (expr)) + != TYPE_PRECISION (type))) + warning (OPT_Woverflow, + "overflow in implicit constant conversion"); + + else + conversion_warning (type, expr); + } + else if ((TREE_CODE (result) == INTEGER_CST + || TREE_CODE (result) == FIXED_CST) && TREE_OVERFLOW (result)) + warning (OPT_Woverflow, + "overflow in implicit constant conversion"); + else + conversion_warning (type, expr); +} + + +/* Convert EXPR to TYPE, warning about conversion problems with constants. + Invoke this function on every expression that is converted implicitly, + i.e. because of language rules and not because of an explicit cast. */ + +tree +convert_and_check (tree type, tree expr) +{ + tree result; + tree expr_for_warning; + + /* Convert from a value with possible excess precision rather than + via the semantic type, but do not warn about values not fitting + exactly in the semantic type. */ + if (TREE_CODE (expr) == EXCESS_PRECISION_EXPR) + { + tree orig_type = TREE_TYPE (expr); + expr = TREE_OPERAND (expr, 0); + expr_for_warning = convert (orig_type, expr); + if (orig_type == type) + return expr_for_warning; + } + else + expr_for_warning = expr; + + if (TREE_TYPE (expr) == type) + return expr; + + result = convert (type, expr); + + if (c_inhibit_evaluation_warnings == 0 + && !TREE_OVERFLOW_P (expr) + && result != error_mark_node) + warnings_for_convert_and_check (type, expr_for_warning, result); + + return result; +} + +/* A node in a list that describes references to variables (EXPR), which are + either read accesses if WRITER is zero, or write accesses, in which case + WRITER is the parent of EXPR. */ +struct tlist +{ + struct tlist *next; + tree expr, writer; +}; + +/* Used to implement a cache the results of a call to verify_tree. We only + use this for SAVE_EXPRs. */ +struct tlist_cache +{ + struct tlist_cache *next; + struct tlist *cache_before_sp; + struct tlist *cache_after_sp; + tree expr; +}; + +/* Obstack to use when allocating tlist structures, and corresponding + firstobj. */ +static struct obstack tlist_obstack; +static char *tlist_firstobj = 0; + +/* Keep track of the identifiers we've warned about, so we can avoid duplicate + warnings. */ +static struct tlist *warned_ids; +/* SAVE_EXPRs need special treatment. We process them only once and then + cache the results. */ +static struct tlist_cache *save_expr_cache; + +static void add_tlist (struct tlist **, struct tlist *, tree, int); +static void merge_tlist (struct tlist **, struct tlist *, int); +static void verify_tree (tree, struct tlist **, struct tlist **, tree); +static int warning_candidate_p (tree); +static bool candidate_equal_p (const_tree, const_tree); +static void warn_for_collisions (struct tlist *); +static void warn_for_collisions_1 (tree, tree, struct tlist *, int); +static struct tlist *new_tlist (struct tlist *, tree, tree); + +/* Create a new struct tlist and fill in its fields. */ +static struct tlist * +new_tlist (struct tlist *next, tree t, tree writer) +{ + struct tlist *l; + l = XOBNEW (&tlist_obstack, struct tlist); + l->next = next; + l->expr = t; + l->writer = writer; + return l; +} + +/* Add duplicates of the nodes found in ADD to the list *TO. If EXCLUDE_WRITER + is nonnull, we ignore any node we find which has a writer equal to it. */ + +static void +add_tlist (struct tlist **to, struct tlist *add, tree exclude_writer, int copy) +{ + while (add) + { + struct tlist *next = add->next; + if (!copy) + add->next = *to; + if (!exclude_writer || !candidate_equal_p (add->writer, exclude_writer)) + *to = copy ? new_tlist (*to, add->expr, add->writer) : add; + add = next; + } +} + +/* Merge the nodes of ADD into TO. This merging process is done so that for + each variable that already exists in TO, no new node is added; however if + there is a write access recorded in ADD, and an occurrence on TO is only + a read access, then the occurrence in TO will be modified to record the + write. */ + +static void +merge_tlist (struct tlist **to, struct tlist *add, int copy) +{ + struct tlist **end = to; + + while (*end) + end = &(*end)->next; + + while (add) + { + int found = 0; + struct tlist *tmp2; + struct tlist *next = add->next; + + for (tmp2 = *to; tmp2; tmp2 = tmp2->next) + if (candidate_equal_p (tmp2->expr, add->expr)) + { + found = 1; + if (!tmp2->writer) + tmp2->writer = add->writer; + } + if (!found) + { + *end = copy ? add : new_tlist (NULL, add->expr, add->writer); + end = &(*end)->next; + *end = 0; + } + add = next; + } +} + +/* WRITTEN is a variable, WRITER is its parent. Warn if any of the variable + references in list LIST conflict with it, excluding reads if ONLY writers + is nonzero. */ + +static void +warn_for_collisions_1 (tree written, tree writer, struct tlist *list, + int only_writes) +{ + struct tlist *tmp; + + /* Avoid duplicate warnings. */ + for (tmp = warned_ids; tmp; tmp = tmp->next) + if (candidate_equal_p (tmp->expr, written)) + return; + + while (list) + { + if (candidate_equal_p (list->expr, written) + && !candidate_equal_p (list->writer, writer) + && (!only_writes || list->writer)) + { + warned_ids = new_tlist (warned_ids, written, NULL_TREE); + warning_at (EXPR_HAS_LOCATION (writer) + ? EXPR_LOCATION (writer) : input_location, + OPT_Wsequence_point, "operation on %qE may be undefined", + list->expr); + } + list = list->next; + } +} + +/* Given a list LIST of references to variables, find whether any of these + can cause conflicts due to missing sequence points. */ + +static void +warn_for_collisions (struct tlist *list) +{ + struct tlist *tmp; + + for (tmp = list; tmp; tmp = tmp->next) + { + if (tmp->writer) + warn_for_collisions_1 (tmp->expr, tmp->writer, list, 0); + } +} + +/* Return nonzero if X is a tree that can be verified by the sequence point + warnings. */ +static int +warning_candidate_p (tree x) +{ + /* !VOID_TYPE_P (TREE_TYPE (x)) is workaround for cp/tree.c + (lvalue_p) crash on TRY/CATCH. */ + return !(DECL_P (x) && DECL_ARTIFICIAL (x)) + && TREE_TYPE (x) && !VOID_TYPE_P (TREE_TYPE (x)) && lvalue_p (x); +} + +/* Return nonzero if X and Y appear to be the same candidate (or NULL) */ +static bool +candidate_equal_p (const_tree x, const_tree y) +{ + return (x == y) || (x && y && operand_equal_p (x, y, 0)); +} + +/* Walk the tree X, and record accesses to variables. If X is written by the + parent tree, WRITER is the parent. + We store accesses in one of the two lists: PBEFORE_SP, and PNO_SP. If this + expression or its only operand forces a sequence point, then everything up + to the sequence point is stored in PBEFORE_SP. Everything else gets stored + in PNO_SP. + Once we return, we will have emitted warnings if any subexpression before + such a sequence point could be undefined. On a higher level, however, the + sequence point may not be relevant, and we'll merge the two lists. + + Example: (b++, a) + b; + The call that processes the COMPOUND_EXPR will store the increment of B + in PBEFORE_SP, and the use of A in PNO_SP. The higher-level call that + processes the PLUS_EXPR will need to merge the two lists so that + eventually, all accesses end up on the same list (and we'll warn about the + unordered subexpressions b++ and b. + + A note on merging. If we modify the former example so that our expression + becomes + (b++, b) + a + care must be taken not simply to add all three expressions into the final + PNO_SP list. The function merge_tlist takes care of that by merging the + before-SP list of the COMPOUND_EXPR into its after-SP list in a special + way, so that no more than one access to B is recorded. */ + +static void +verify_tree (tree x, struct tlist **pbefore_sp, struct tlist **pno_sp, + tree writer) +{ + struct tlist *tmp_before, *tmp_nosp, *tmp_list2, *tmp_list3; + enum tree_code code; + enum tree_code_class cl; + + /* X may be NULL if it is the operand of an empty statement expression + ({ }). */ + if (x == NULL) + return; + + restart: + code = TREE_CODE (x); + cl = TREE_CODE_CLASS (code); + + if (warning_candidate_p (x)) + *pno_sp = new_tlist (*pno_sp, x, writer); + + switch (code) + { + case CONSTRUCTOR: + return; + + case COMPOUND_EXPR: + case TRUTH_ANDIF_EXPR: + case TRUTH_ORIF_EXPR: + tmp_before = tmp_nosp = tmp_list3 = 0; + verify_tree (TREE_OPERAND (x, 0), &tmp_before, &tmp_nosp, NULL_TREE); + warn_for_collisions (tmp_nosp); + merge_tlist (pbefore_sp, tmp_before, 0); + merge_tlist (pbefore_sp, tmp_nosp, 0); + verify_tree (TREE_OPERAND (x, 1), &tmp_list3, pno_sp, NULL_TREE); + merge_tlist (pbefore_sp, tmp_list3, 0); + return; + + case COND_EXPR: + tmp_before = tmp_list2 = 0; + verify_tree (TREE_OPERAND (x, 0), &tmp_before, &tmp_list2, NULL_TREE); + warn_for_collisions (tmp_list2); + merge_tlist (pbefore_sp, tmp_before, 0); + merge_tlist (pbefore_sp, tmp_list2, 1); + + tmp_list3 = tmp_nosp = 0; + verify_tree (TREE_OPERAND (x, 1), &tmp_list3, &tmp_nosp, NULL_TREE); + warn_for_collisions (tmp_nosp); + merge_tlist (pbefore_sp, tmp_list3, 0); + + tmp_list3 = tmp_list2 = 0; + verify_tree (TREE_OPERAND (x, 2), &tmp_list3, &tmp_list2, NULL_TREE); + warn_for_collisions (tmp_list2); + merge_tlist (pbefore_sp, tmp_list3, 0); + /* Rather than add both tmp_nosp and tmp_list2, we have to merge the + two first, to avoid warning for (a ? b++ : b++). */ + merge_tlist (&tmp_nosp, tmp_list2, 0); + add_tlist (pno_sp, tmp_nosp, NULL_TREE, 0); + return; + + case PREDECREMENT_EXPR: + case PREINCREMENT_EXPR: + case POSTDECREMENT_EXPR: + case POSTINCREMENT_EXPR: + verify_tree (TREE_OPERAND (x, 0), pno_sp, pno_sp, x); + return; + + case MODIFY_EXPR: + tmp_before = tmp_nosp = tmp_list3 = 0; + verify_tree (TREE_OPERAND (x, 1), &tmp_before, &tmp_nosp, NULL_TREE); + verify_tree (TREE_OPERAND (x, 0), &tmp_list3, &tmp_list3, x); + /* Expressions inside the LHS are not ordered wrt. the sequence points + in the RHS. Example: + *a = (a++, 2) + Despite the fact that the modification of "a" is in the before_sp + list (tmp_before), it conflicts with the use of "a" in the LHS. + We can handle this by adding the contents of tmp_list3 + to those of tmp_before, and redoing the collision warnings for that + list. */ + add_tlist (&tmp_before, tmp_list3, x, 1); + warn_for_collisions (tmp_before); + /* Exclude the LHS itself here; we first have to merge it into the + tmp_nosp list. This is done to avoid warning for "a = a"; if we + didn't exclude the LHS, we'd get it twice, once as a read and once + as a write. */ + add_tlist (pno_sp, tmp_list3, x, 0); + warn_for_collisions_1 (TREE_OPERAND (x, 0), x, tmp_nosp, 1); + + merge_tlist (pbefore_sp, tmp_before, 0); + if (warning_candidate_p (TREE_OPERAND (x, 0))) + merge_tlist (&tmp_nosp, new_tlist (NULL, TREE_OPERAND (x, 0), x), 0); + add_tlist (pno_sp, tmp_nosp, NULL_TREE, 1); + return; + + case CALL_EXPR: + /* We need to warn about conflicts among arguments and conflicts between + args and the function address. Side effects of the function address, + however, are not ordered by the sequence point of the call. */ + { + call_expr_arg_iterator iter; + tree arg; + tmp_before = tmp_nosp = 0; + verify_tree (CALL_EXPR_FN (x), &tmp_before, &tmp_nosp, NULL_TREE); + FOR_EACH_CALL_EXPR_ARG (arg, iter, x) + { + tmp_list2 = tmp_list3 = 0; + verify_tree (arg, &tmp_list2, &tmp_list3, NULL_TREE); + merge_tlist (&tmp_list3, tmp_list2, 0); + add_tlist (&tmp_before, tmp_list3, NULL_TREE, 0); + } + add_tlist (&tmp_before, tmp_nosp, NULL_TREE, 0); + warn_for_collisions (tmp_before); + add_tlist (pbefore_sp, tmp_before, NULL_TREE, 0); + return; + } + + case TREE_LIST: + /* Scan all the list, e.g. indices of multi dimensional array. */ + while (x) + { + tmp_before = tmp_nosp = 0; + verify_tree (TREE_VALUE (x), &tmp_before, &tmp_nosp, NULL_TREE); + merge_tlist (&tmp_nosp, tmp_before, 0); + add_tlist (pno_sp, tmp_nosp, NULL_TREE, 0); + x = TREE_CHAIN (x); + } + return; + + case SAVE_EXPR: + { + struct tlist_cache *t; + for (t = save_expr_cache; t; t = t->next) + if (candidate_equal_p (t->expr, x)) + break; + + if (!t) + { + t = XOBNEW (&tlist_obstack, struct tlist_cache); + t->next = save_expr_cache; + t->expr = x; + save_expr_cache = t; + + tmp_before = tmp_nosp = 0; + verify_tree (TREE_OPERAND (x, 0), &tmp_before, &tmp_nosp, NULL_TREE); + warn_for_collisions (tmp_nosp); + + tmp_list3 = 0; + while (tmp_nosp) + { + struct tlist *t = tmp_nosp; + tmp_nosp = t->next; + merge_tlist (&tmp_list3, t, 0); + } + t->cache_before_sp = tmp_before; + t->cache_after_sp = tmp_list3; + } + merge_tlist (pbefore_sp, t->cache_before_sp, 1); + add_tlist (pno_sp, t->cache_after_sp, NULL_TREE, 1); + return; + } + + case ADDR_EXPR: + x = TREE_OPERAND (x, 0); + if (DECL_P (x)) + return; + writer = 0; + goto restart; + + default: + /* For other expressions, simply recurse on their operands. + Manual tail recursion for unary expressions. + Other non-expressions need not be processed. */ + if (cl == tcc_unary) + { + x = TREE_OPERAND (x, 0); + writer = 0; + goto restart; + } + else if (IS_EXPR_CODE_CLASS (cl)) + { + int lp; + int max = TREE_OPERAND_LENGTH (x); + for (lp = 0; lp < max; lp++) + { + tmp_before = tmp_nosp = 0; + verify_tree (TREE_OPERAND (x, lp), &tmp_before, &tmp_nosp, 0); + merge_tlist (&tmp_nosp, tmp_before, 0); + add_tlist (pno_sp, tmp_nosp, NULL_TREE, 0); + } + } + return; + } +} + +/* Try to warn for undefined behavior in EXPR due to missing sequence + points. */ + +DEBUG_FUNCTION void +verify_sequence_points (tree expr) +{ + struct tlist *before_sp = 0, *after_sp = 0; + + warned_ids = 0; + save_expr_cache = 0; + if (tlist_firstobj == 0) + { + gcc_obstack_init (&tlist_obstack); + tlist_firstobj = (char *) obstack_alloc (&tlist_obstack, 0); + } + + verify_tree (expr, &before_sp, &after_sp, 0); + warn_for_collisions (after_sp); + obstack_free (&tlist_obstack, tlist_firstobj); +} + +/* Validate the expression after `case' and apply default promotions. */ + +static tree +check_case_value (tree value) +{ + if (value == NULL_TREE) + return value; + + /* ??? Can we ever get nops here for a valid case value? We + shouldn't for C. */ + STRIP_TYPE_NOPS (value); + /* In C++, the following is allowed: + + const int i = 3; + switch (...) { case i: ... } + + So, we try to reduce the VALUE to a constant that way. */ + if (c_dialect_cxx ()) + { + value = decl_constant_value (value); + STRIP_TYPE_NOPS (value); + value = fold (value); + } + + if (TREE_CODE (value) == INTEGER_CST) + /* Promote char or short to int. */ + value = perform_integral_promotions (value); + else if (value != error_mark_node) + { + error ("case label does not reduce to an integer constant"); + value = error_mark_node; + } + + constant_expression_warning (value); + + return value; +} + +/* See if the case values LOW and HIGH are in the range of the original + type (i.e. before the default conversion to int) of the switch testing + expression. + TYPE is the promoted type of the testing expression, and ORIG_TYPE is + the type before promoting it. CASE_LOW_P is a pointer to the lower + bound of the case label, and CASE_HIGH_P is the upper bound or NULL + if the case is not a case range. + The caller has to make sure that we are not called with NULL for + CASE_LOW_P (i.e. the default case). + Returns true if the case label is in range of ORIG_TYPE (saturated or + untouched) or false if the label is out of range. */ + +static bool +check_case_bounds (tree type, tree orig_type, + tree *case_low_p, tree *case_high_p) +{ + tree min_value, max_value; + tree case_low = *case_low_p; + tree case_high = case_high_p ? *case_high_p : case_low; + + /* If there was a problem with the original type, do nothing. */ + if (orig_type == error_mark_node) + return true; + + min_value = TYPE_MIN_VALUE (orig_type); + max_value = TYPE_MAX_VALUE (orig_type); + + /* Case label is less than minimum for type. */ + if (tree_int_cst_compare (case_low, min_value) < 0 + && tree_int_cst_compare (case_high, min_value) < 0) + { + warning (0, "case label value is less than minimum value for type"); + return false; + } + + /* Case value is greater than maximum for type. */ + if (tree_int_cst_compare (case_low, max_value) > 0 + && tree_int_cst_compare (case_high, max_value) > 0) + { + warning (0, "case label value exceeds maximum value for type"); + return false; + } + + /* Saturate lower case label value to minimum. */ + if (tree_int_cst_compare (case_high, min_value) >= 0 + && tree_int_cst_compare (case_low, min_value) < 0) + { + warning (0, "lower value in case label range" + " less than minimum value for type"); + case_low = min_value; + } + + /* Saturate upper case label value to maximum. */ + if (tree_int_cst_compare (case_low, max_value) <= 0 + && tree_int_cst_compare (case_high, max_value) > 0) + { + warning (0, "upper value in case label range" + " exceeds maximum value for type"); + case_high = max_value; + } + + if (*case_low_p != case_low) + *case_low_p = convert (type, case_low); + if (case_high_p && *case_high_p != case_high) + *case_high_p = convert (type, case_high); + + return true; +} + +/* Return an integer type with BITS bits of precision, + that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */ + +tree +c_common_type_for_size (unsigned int bits, int unsignedp) +{ + 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); + + if (int128_integer_type_node + && bits == TYPE_PRECISION (int128_integer_type_node)) + return (unsignedp ? int128_unsigned_type_node + : int128_integer_type_node); + + if (bits == TYPE_PRECISION (widest_integer_literal_type_node)) + return (unsignedp ? widest_unsigned_literal_type_node + : widest_integer_literal_type_node); + + if (bits <= TYPE_PRECISION (intQI_type_node)) + return unsignedp ? unsigned_intQI_type_node : intQI_type_node; + + if (bits <= TYPE_PRECISION (intHI_type_node)) + return unsignedp ? unsigned_intHI_type_node : intHI_type_node; + + if (bits <= TYPE_PRECISION (intSI_type_node)) + return unsignedp ? unsigned_intSI_type_node : intSI_type_node; + + if (bits <= TYPE_PRECISION (intDI_type_node)) + return unsignedp ? unsigned_intDI_type_node : intDI_type_node; + + return 0; +} + +/* Return a fixed-point type that has at least IBIT ibits and FBIT fbits + that is unsigned if UNSIGNEDP is nonzero, otherwise signed; + and saturating if SATP is nonzero, otherwise not saturating. */ + +tree +c_common_fixed_point_type_for_size (unsigned int ibit, unsigned int fbit, + int unsignedp, int satp) +{ + enum machine_mode mode; + if (ibit == 0) + mode = unsignedp ? UQQmode : QQmode; + else + mode = unsignedp ? UHAmode : HAmode; + + for (; mode != VOIDmode; mode = GET_MODE_WIDER_MODE (mode)) + if (GET_MODE_IBIT (mode) >= ibit && GET_MODE_FBIT (mode) >= fbit) + break; + + if (mode == VOIDmode || !targetm.scalar_mode_supported_p (mode)) + { + sorry ("GCC cannot support operators with integer types and " + "fixed-point types that have too many integral and " + "fractional bits together"); + return 0; + } + + return c_common_type_for_mode (mode, satp); +} + +/* Used for communication between c_common_type_for_mode and + c_register_builtin_type. */ +static GTY(()) tree registered_builtin_types; + +/* Return a data type that has machine mode MODE. + If the mode is an integer, + then UNSIGNEDP selects between signed and unsigned types. + If the mode is a fixed-point mode, + then UNSIGNEDP selects between saturating and nonsaturating types. */ + +tree +c_common_type_for_mode (enum machine_mode mode, int unsignedp) +{ + 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 (int128_integer_type_node + && mode == TYPE_MODE (int128_integer_type_node)) + return unsignedp ? int128_unsigned_type_node : int128_integer_type_node; + + if (mode == TYPE_MODE (widest_integer_literal_type_node)) + return unsignedp ? widest_unsigned_literal_type_node + : widest_integer_literal_type_node; + + if (mode == QImode) + return unsignedp ? unsigned_intQI_type_node : intQI_type_node; + + if (mode == HImode) + return unsignedp ? unsigned_intHI_type_node : intHI_type_node; + + if (mode == SImode) + return unsignedp ? unsigned_intSI_type_node : intSI_type_node; + + if (mode == DImode) + return unsignedp ? unsigned_intDI_type_node : intDI_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 (void_type_node)) + return void_type_node; + + if (mode == TYPE_MODE (build_pointer_type (char_type_node))) + return (unsignedp + ? make_unsigned_type (GET_MODE_PRECISION (mode)) + : make_signed_type (GET_MODE_PRECISION (mode))); + + if (mode == TYPE_MODE (build_pointer_type (integer_type_node))) + return (unsignedp + ? make_unsigned_type (GET_MODE_PRECISION (mode)) + : make_signed_type (GET_MODE_PRECISION (mode))); + + if (COMPLEX_MODE_P (mode)) + { + enum machine_mode inner_mode; + tree inner_type; + + if (mode == TYPE_MODE (complex_float_type_node)) + return complex_float_type_node; + if (mode == TYPE_MODE (complex_double_type_node)) + return complex_double_type_node; + if (mode == TYPE_MODE (complex_long_double_type_node)) + return complex_long_double_type_node; + + if (mode == TYPE_MODE (complex_integer_type_node) && !unsignedp) + return complex_integer_type_node; + + inner_mode = GET_MODE_INNER (mode); + inner_type = c_common_type_for_mode (inner_mode, unsignedp); + if (inner_type != NULL_TREE) + return build_complex_type (inner_type); + } + else if (VECTOR_MODE_P (mode)) + { + enum machine_mode inner_mode = GET_MODE_INNER (mode); + tree inner_type = c_common_type_for_mode (inner_mode, unsignedp); + if (inner_type != NULL_TREE) + return build_vector_type_for_mode (inner_type, mode); + } + + if (mode == TYPE_MODE (dfloat32_type_node)) + return dfloat32_type_node; + if (mode == TYPE_MODE (dfloat64_type_node)) + return dfloat64_type_node; + if (mode == TYPE_MODE (dfloat128_type_node)) + return dfloat128_type_node; + + if (ALL_SCALAR_FIXED_POINT_MODE_P (mode)) + { + if (mode == TYPE_MODE (short_fract_type_node)) + return unsignedp ? sat_short_fract_type_node : short_fract_type_node; + if (mode == TYPE_MODE (fract_type_node)) + return unsignedp ? sat_fract_type_node : fract_type_node; + if (mode == TYPE_MODE (long_fract_type_node)) + return unsignedp ? sat_long_fract_type_node : long_fract_type_node; + if (mode == TYPE_MODE (long_long_fract_type_node)) + return unsignedp ? sat_long_long_fract_type_node + : long_long_fract_type_node; + + if (mode == TYPE_MODE (unsigned_short_fract_type_node)) + return unsignedp ? sat_unsigned_short_fract_type_node + : unsigned_short_fract_type_node; + if (mode == TYPE_MODE (unsigned_fract_type_node)) + return unsignedp ? sat_unsigned_fract_type_node + : unsigned_fract_type_node; + if (mode == TYPE_MODE (unsigned_long_fract_type_node)) + return unsignedp ? sat_unsigned_long_fract_type_node + : unsigned_long_fract_type_node; + if (mode == TYPE_MODE (unsigned_long_long_fract_type_node)) + return unsignedp ? sat_unsigned_long_long_fract_type_node + : unsigned_long_long_fract_type_node; + + if (mode == TYPE_MODE (short_accum_type_node)) + return unsignedp ? sat_short_accum_type_node : short_accum_type_node; + if (mode == TYPE_MODE (accum_type_node)) + return unsignedp ? sat_accum_type_node : accum_type_node; + if (mode == TYPE_MODE (long_accum_type_node)) + return unsignedp ? sat_long_accum_type_node : long_accum_type_node; + if (mode == TYPE_MODE (long_long_accum_type_node)) + return unsignedp ? sat_long_long_accum_type_node + : long_long_accum_type_node; + + if (mode == TYPE_MODE (unsigned_short_accum_type_node)) + return unsignedp ? sat_unsigned_short_accum_type_node + : unsigned_short_accum_type_node; + if (mode == TYPE_MODE (unsigned_accum_type_node)) + return unsignedp ? sat_unsigned_accum_type_node + : unsigned_accum_type_node; + if (mode == TYPE_MODE (unsigned_long_accum_type_node)) + return unsignedp ? sat_unsigned_long_accum_type_node + : unsigned_long_accum_type_node; + if (mode == TYPE_MODE (unsigned_long_long_accum_type_node)) + return unsignedp ? sat_unsigned_long_long_accum_type_node + : unsigned_long_long_accum_type_node; + + if (mode == QQmode) + return unsignedp ? sat_qq_type_node : qq_type_node; + if (mode == HQmode) + return unsignedp ? sat_hq_type_node : hq_type_node; + if (mode == SQmode) + return unsignedp ? sat_sq_type_node : sq_type_node; + if (mode == DQmode) + return unsignedp ? sat_dq_type_node : dq_type_node; + if (mode == TQmode) + return unsignedp ? sat_tq_type_node : tq_type_node; + + if (mode == UQQmode) + return unsignedp ? sat_uqq_type_node : uqq_type_node; + if (mode == UHQmode) + return unsignedp ? sat_uhq_type_node : uhq_type_node; + if (mode == USQmode) + return unsignedp ? sat_usq_type_node : usq_type_node; + if (mode == UDQmode) + return unsignedp ? sat_udq_type_node : udq_type_node; + if (mode == UTQmode) + return unsignedp ? sat_utq_type_node : utq_type_node; + + if (mode == HAmode) + return unsignedp ? sat_ha_type_node : ha_type_node; + if (mode == SAmode) + return unsignedp ? sat_sa_type_node : sa_type_node; + if (mode == DAmode) + return unsignedp ? sat_da_type_node : da_type_node; + if (mode == TAmode) + return unsignedp ? sat_ta_type_node : ta_type_node; + + if (mode == UHAmode) + return unsignedp ? sat_uha_type_node : uha_type_node; + if (mode == USAmode) + return unsignedp ? sat_usa_type_node : usa_type_node; + if (mode == UDAmode) + return unsignedp ? sat_uda_type_node : uda_type_node; + if (mode == UTAmode) + return unsignedp ? sat_uta_type_node : uta_type_node; + } + + for (t = registered_builtin_types; t; t = TREE_CHAIN (t)) + if (TYPE_MODE (TREE_VALUE (t)) == mode) + return TREE_VALUE (t); + + return 0; +} + +tree +c_common_unsigned_type (tree type) +{ + return c_common_signed_or_unsigned_type (1, type); +} + +/* Return a signed type the same as TYPE in other respects. */ + +tree +c_common_signed_type (tree type) +{ + return c_common_signed_or_unsigned_type (0, type); +} + +/* Return a type the same as TYPE except unsigned or + signed according to UNSIGNEDP. */ + +tree +c_common_signed_or_unsigned_type (int unsignedp, tree type) +{ + tree type1; + + /* This block of code emulates the behavior of the old + c_common_unsigned_type. In particular, it returns + long_unsigned_type_node if passed a long, even when a int would + have the same size. This is necessary for warnings to work + correctly in archs where sizeof(int) == sizeof(long) */ + + type1 = TYPE_MAIN_VARIANT (type); + if (type1 == signed_char_type_node || type1 == char_type_node || type1 == unsigned_char_type_node) + return unsignedp ? unsigned_char_type_node : signed_char_type_node; + if (type1 == integer_type_node || type1 == unsigned_type_node) + return unsignedp ? unsigned_type_node : integer_type_node; + if (type1 == short_integer_type_node || type1 == short_unsigned_type_node) + return unsignedp ? short_unsigned_type_node : short_integer_type_node; + if (type1 == long_integer_type_node || type1 == long_unsigned_type_node) + return unsignedp ? long_unsigned_type_node : long_integer_type_node; + if (type1 == long_long_integer_type_node || type1 == long_long_unsigned_type_node) + return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node; + if (int128_integer_type_node + && (type1 == int128_integer_type_node + || type1 == int128_unsigned_type_node)) + return unsignedp ? int128_unsigned_type_node : int128_integer_type_node; + if (type1 == widest_integer_literal_type_node || type1 == widest_unsigned_literal_type_node) + return unsignedp ? widest_unsigned_literal_type_node : widest_integer_literal_type_node; +#if HOST_BITS_PER_WIDE_INT >= 64 + if (type1 == intTI_type_node || type1 == unsigned_intTI_type_node) + return unsignedp ? unsigned_intTI_type_node : intTI_type_node; +#endif + if (type1 == intDI_type_node || type1 == unsigned_intDI_type_node) + return unsignedp ? unsigned_intDI_type_node : intDI_type_node; + if (type1 == intSI_type_node || type1 == unsigned_intSI_type_node) + return unsignedp ? unsigned_intSI_type_node : intSI_type_node; + if (type1 == intHI_type_node || type1 == unsigned_intHI_type_node) + return unsignedp ? unsigned_intHI_type_node : intHI_type_node; + if (type1 == intQI_type_node || type1 == unsigned_intQI_type_node) + return unsignedp ? unsigned_intQI_type_node : intQI_type_node; + +#define C_COMMON_FIXED_TYPES(NAME) \ + if (type1 == short_ ## NAME ## _type_node \ + || type1 == unsigned_short_ ## NAME ## _type_node) \ + return unsignedp ? unsigned_short_ ## NAME ## _type_node \ + : short_ ## NAME ## _type_node; \ + if (type1 == NAME ## _type_node \ + || type1 == unsigned_ ## NAME ## _type_node) \ + return unsignedp ? unsigned_ ## NAME ## _type_node \ + : NAME ## _type_node; \ + if (type1 == long_ ## NAME ## _type_node \ + || type1 == unsigned_long_ ## NAME ## _type_node) \ + return unsignedp ? unsigned_long_ ## NAME ## _type_node \ + : long_ ## NAME ## _type_node; \ + if (type1 == long_long_ ## NAME ## _type_node \ + || type1 == unsigned_long_long_ ## NAME ## _type_node) \ + return unsignedp ? unsigned_long_long_ ## NAME ## _type_node \ + : long_long_ ## NAME ## _type_node; + +#define C_COMMON_FIXED_MODE_TYPES(NAME) \ + if (type1 == NAME ## _type_node \ + || type1 == u ## NAME ## _type_node) \ + return unsignedp ? u ## NAME ## _type_node \ + : NAME ## _type_node; + +#define C_COMMON_FIXED_TYPES_SAT(NAME) \ + if (type1 == sat_ ## short_ ## NAME ## _type_node \ + || type1 == sat_ ## unsigned_short_ ## NAME ## _type_node) \ + return unsignedp ? sat_ ## unsigned_short_ ## NAME ## _type_node \ + : sat_ ## short_ ## NAME ## _type_node; \ + if (type1 == sat_ ## NAME ## _type_node \ + || type1 == sat_ ## unsigned_ ## NAME ## _type_node) \ + return unsignedp ? sat_ ## unsigned_ ## NAME ## _type_node \ + : sat_ ## NAME ## _type_node; \ + if (type1 == sat_ ## long_ ## NAME ## _type_node \ + || type1 == sat_ ## unsigned_long_ ## NAME ## _type_node) \ + return unsignedp ? sat_ ## unsigned_long_ ## NAME ## _type_node \ + : sat_ ## long_ ## NAME ## _type_node; \ + if (type1 == sat_ ## long_long_ ## NAME ## _type_node \ + || type1 == sat_ ## unsigned_long_long_ ## NAME ## _type_node) \ + return unsignedp ? sat_ ## unsigned_long_long_ ## NAME ## _type_node \ + : sat_ ## long_long_ ## NAME ## _type_node; + +#define C_COMMON_FIXED_MODE_TYPES_SAT(NAME) \ + if (type1 == sat_ ## NAME ## _type_node \ + || type1 == sat_ ## u ## NAME ## _type_node) \ + return unsignedp ? sat_ ## u ## NAME ## _type_node \ + : sat_ ## NAME ## _type_node; + + C_COMMON_FIXED_TYPES (fract); + C_COMMON_FIXED_TYPES_SAT (fract); + C_COMMON_FIXED_TYPES (accum); + C_COMMON_FIXED_TYPES_SAT (accum); + + C_COMMON_FIXED_MODE_TYPES (qq); + C_COMMON_FIXED_MODE_TYPES (hq); + C_COMMON_FIXED_MODE_TYPES (sq); + C_COMMON_FIXED_MODE_TYPES (dq); + C_COMMON_FIXED_MODE_TYPES (tq); + C_COMMON_FIXED_MODE_TYPES_SAT (qq); + C_COMMON_FIXED_MODE_TYPES_SAT (hq); + C_COMMON_FIXED_MODE_TYPES_SAT (sq); + C_COMMON_FIXED_MODE_TYPES_SAT (dq); + C_COMMON_FIXED_MODE_TYPES_SAT (tq); + C_COMMON_FIXED_MODE_TYPES (ha); + C_COMMON_FIXED_MODE_TYPES (sa); + C_COMMON_FIXED_MODE_TYPES (da); + C_COMMON_FIXED_MODE_TYPES (ta); + C_COMMON_FIXED_MODE_TYPES_SAT (ha); + C_COMMON_FIXED_MODE_TYPES_SAT (sa); + C_COMMON_FIXED_MODE_TYPES_SAT (da); + C_COMMON_FIXED_MODE_TYPES_SAT (ta); + + /* For ENUMERAL_TYPEs in C++, must check the mode of the types, not + the precision; they have precision set to match their range, but + may use a wider mode to match an ABI. If we change modes, we may + wind up with bad conversions. For INTEGER_TYPEs in C, must check + the precision as well, so as to yield correct results for + bit-field types. C++ does not have these separate bit-field + types, and producing a signed or unsigned variant of an + ENUMERAL_TYPE may cause other problems as well. */ + + if (!INTEGRAL_TYPE_P (type) + || TYPE_UNSIGNED (type) == unsignedp) + return type; + +#define TYPE_OK(node) \ + (TYPE_MODE (type) == TYPE_MODE (node) \ + && TYPE_PRECISION (type) == TYPE_PRECISION (node)) + if (TYPE_OK (signed_char_type_node)) + return unsignedp ? unsigned_char_type_node : signed_char_type_node; + if (TYPE_OK (integer_type_node)) + return unsignedp ? unsigned_type_node : integer_type_node; + if (TYPE_OK (short_integer_type_node)) + return unsignedp ? short_unsigned_type_node : short_integer_type_node; + if (TYPE_OK (long_integer_type_node)) + return unsignedp ? long_unsigned_type_node : long_integer_type_node; + if (TYPE_OK (long_long_integer_type_node)) + return (unsignedp ? long_long_unsigned_type_node + : long_long_integer_type_node); + if (int128_integer_type_node && TYPE_OK (int128_integer_type_node)) + return (unsignedp ? int128_unsigned_type_node + : int128_integer_type_node); + if (TYPE_OK (widest_integer_literal_type_node)) + return (unsignedp ? widest_unsigned_literal_type_node + : widest_integer_literal_type_node); + +#if HOST_BITS_PER_WIDE_INT >= 64 + if (TYPE_OK (intTI_type_node)) + return unsignedp ? unsigned_intTI_type_node : intTI_type_node; +#endif + if (TYPE_OK (intDI_type_node)) + return unsignedp ? unsigned_intDI_type_node : intDI_type_node; + if (TYPE_OK (intSI_type_node)) + return unsignedp ? unsigned_intSI_type_node : intSI_type_node; + if (TYPE_OK (intHI_type_node)) + return unsignedp ? unsigned_intHI_type_node : intHI_type_node; + if (TYPE_OK (intQI_type_node)) + return unsignedp ? unsigned_intQI_type_node : intQI_type_node; +#undef TYPE_OK + + return build_nonstandard_integer_type (TYPE_PRECISION (type), unsignedp); +} + +/* Build a bit-field integer type for the given WIDTH and UNSIGNEDP. */ + +tree +c_build_bitfield_integer_type (unsigned HOST_WIDE_INT width, int unsignedp) +{ + /* Extended integer types of the same width as a standard type have + lesser rank, so those of the same width as int promote to int or + unsigned int and are valid for printf formats expecting int or + unsigned int. To avoid such special cases, avoid creating + extended integer types for bit-fields if a standard integer type + is available. */ + if (width == TYPE_PRECISION (integer_type_node)) + return unsignedp ? unsigned_type_node : integer_type_node; + if (width == TYPE_PRECISION (signed_char_type_node)) + return unsignedp ? unsigned_char_type_node : signed_char_type_node; + if (width == TYPE_PRECISION (short_integer_type_node)) + return unsignedp ? short_unsigned_type_node : short_integer_type_node; + if (width == TYPE_PRECISION (long_integer_type_node)) + return unsignedp ? long_unsigned_type_node : long_integer_type_node; + if (width == TYPE_PRECISION (long_long_integer_type_node)) + return (unsignedp ? long_long_unsigned_type_node + : long_long_integer_type_node); + if (int128_integer_type_node + && width == TYPE_PRECISION (int128_integer_type_node)) + return (unsignedp ? int128_unsigned_type_node + : int128_integer_type_node); + return build_nonstandard_integer_type (width, unsignedp); +} + +/* The C version of the register_builtin_type langhook. */ + +void +c_register_builtin_type (tree type, const char* name) +{ + tree decl; + + decl = build_decl (UNKNOWN_LOCATION, + TYPE_DECL, get_identifier (name), type); + DECL_ARTIFICIAL (decl) = 1; + if (!TYPE_NAME (type)) + TYPE_NAME (type) = decl; + pushdecl (decl); + + registered_builtin_types = tree_cons (0, type, registered_builtin_types); +} + +/* Print an error message for invalid operands to arith operation + CODE with TYPE0 for operand 0, and TYPE1 for operand 1. + LOCATION is the location of the message. */ + +void +binary_op_error (location_t location, enum tree_code code, + tree type0, tree type1) +{ + const char *opname; + + switch (code) + { + case PLUS_EXPR: + opname = "+"; break; + case MINUS_EXPR: + opname = "-"; break; + case MULT_EXPR: + opname = "*"; break; + case MAX_EXPR: + opname = "max"; break; + case MIN_EXPR: + opname = "min"; break; + case EQ_EXPR: + opname = "=="; break; + case NE_EXPR: + opname = "!="; break; + case LE_EXPR: + opname = "<="; break; + case GE_EXPR: + opname = ">="; break; + case LT_EXPR: + opname = "<"; break; + case GT_EXPR: + opname = ">"; break; + case LSHIFT_EXPR: + opname = "<<"; break; + case RSHIFT_EXPR: + opname = ">>"; break; + case TRUNC_MOD_EXPR: + case FLOOR_MOD_EXPR: + opname = "%"; break; + case TRUNC_DIV_EXPR: + case FLOOR_DIV_EXPR: + opname = "/"; break; + case BIT_AND_EXPR: + opname = "&"; break; + case BIT_IOR_EXPR: + opname = "|"; break; + case TRUTH_ANDIF_EXPR: + opname = "&&"; break; + case TRUTH_ORIF_EXPR: + opname = "||"; break; + case BIT_XOR_EXPR: + opname = "^"; break; + default: + gcc_unreachable (); + } + error_at (location, + "invalid operands to binary %s (have %qT and %qT)", opname, + type0, type1); +} + +/* Subroutine of build_binary_op, used for comparison operations. + See if the operands have both been converted from subword integer types + and, if so, perhaps change them both back to their original type. + This function is also responsible for converting the two operands + to the proper common type for comparison. + + The arguments of this function are all pointers to local variables + of build_binary_op: OP0_PTR is &OP0, OP1_PTR is &OP1, + RESTYPE_PTR is &RESULT_TYPE and RESCODE_PTR is &RESULTCODE. + + If this function returns nonzero, it means that the comparison has + a constant value. What this function returns is an expression for + that value. */ + +tree +shorten_compare (tree *op0_ptr, tree *op1_ptr, tree *restype_ptr, + enum tree_code *rescode_ptr) +{ + tree type; + tree op0 = *op0_ptr; + tree op1 = *op1_ptr; + int unsignedp0, unsignedp1; + int real1, real2; + tree primop0, primop1; + enum tree_code code = *rescode_ptr; + + /* Throw away any conversions to wider types + already present in the operands. */ + + primop0 = get_narrower (op0, &unsignedp0); + primop1 = get_narrower (op1, &unsignedp1); + + /* Handle the case that OP0 does not *contain* a conversion + but it *requires* conversion to FINAL_TYPE. */ + + if (op0 == primop0 && TREE_TYPE (op0) != *restype_ptr) + unsignedp0 = TYPE_UNSIGNED (TREE_TYPE (op0)); + if (op1 == primop1 && TREE_TYPE (op1) != *restype_ptr) + unsignedp1 = TYPE_UNSIGNED (TREE_TYPE (op1)); + + /* If one of the operands must be floated, we cannot optimize. */ + real1 = TREE_CODE (TREE_TYPE (primop0)) == REAL_TYPE; + real2 = TREE_CODE (TREE_TYPE (primop1)) == REAL_TYPE; + + /* If first arg is constant, swap the args (changing operation + so value is preserved), for canonicalization. Don't do this if + the second arg is 0. */ + + if (TREE_CONSTANT (primop0) + && !integer_zerop (primop1) && !real_zerop (primop1) + && !fixed_zerop (primop1)) + { + tree tem = primop0; + int temi = unsignedp0; + primop0 = primop1; + primop1 = tem; + tem = op0; + op0 = op1; + op1 = tem; + *op0_ptr = op0; + *op1_ptr = op1; + unsignedp0 = unsignedp1; + unsignedp1 = temi; + temi = real1; + real1 = real2; + real2 = temi; + + switch (code) + { + case LT_EXPR: + code = GT_EXPR; + break; + case GT_EXPR: + code = LT_EXPR; + break; + case LE_EXPR: + code = GE_EXPR; + break; + case GE_EXPR: + code = LE_EXPR; + break; + default: + break; + } + *rescode_ptr = code; + } + + /* If comparing an integer against a constant more bits wide, + maybe we can deduce a value of 1 or 0 independent of the data. + Or else truncate the constant now + rather than extend the variable at run time. + + This is only interesting if the constant is the wider arg. + Also, it is not safe if the constant is unsigned and the + variable arg is signed, since in this case the variable + would be sign-extended and then regarded as unsigned. + Our technique fails in this case because the lowest/highest + possible unsigned results don't follow naturally from the + lowest/highest possible values of the variable operand. + For just EQ_EXPR and NE_EXPR there is another technique that + could be used: see if the constant can be faithfully represented + in the other operand's type, by truncating it and reextending it + and see if that preserves the constant's value. */ + + if (!real1 && !real2 + && TREE_CODE (TREE_TYPE (primop0)) != FIXED_POINT_TYPE + && TREE_CODE (primop1) == INTEGER_CST + && TYPE_PRECISION (TREE_TYPE (primop0)) < TYPE_PRECISION (*restype_ptr)) + { + int min_gt, max_gt, min_lt, max_lt; + tree maxval, minval; + /* 1 if comparison is nominally unsigned. */ + int unsignedp = TYPE_UNSIGNED (*restype_ptr); + tree val; + + type = c_common_signed_or_unsigned_type (unsignedp0, + TREE_TYPE (primop0)); + + maxval = TYPE_MAX_VALUE (type); + minval = TYPE_MIN_VALUE (type); + + if (unsignedp && !unsignedp0) + *restype_ptr = c_common_signed_type (*restype_ptr); + + if (TREE_TYPE (primop1) != *restype_ptr) + { + /* Convert primop1 to target type, but do not introduce + additional overflow. We know primop1 is an int_cst. */ + primop1 = force_fit_type_double (*restype_ptr, + tree_to_double_int (primop1), + 0, TREE_OVERFLOW (primop1)); + } + if (type != *restype_ptr) + { + minval = convert (*restype_ptr, minval); + maxval = convert (*restype_ptr, maxval); + } + + if (unsignedp && unsignedp0) + { + min_gt = INT_CST_LT_UNSIGNED (primop1, minval); + max_gt = INT_CST_LT_UNSIGNED (primop1, maxval); + min_lt = INT_CST_LT_UNSIGNED (minval, primop1); + max_lt = INT_CST_LT_UNSIGNED (maxval, primop1); + } + else + { + min_gt = INT_CST_LT (primop1, minval); + max_gt = INT_CST_LT (primop1, maxval); + min_lt = INT_CST_LT (minval, primop1); + max_lt = INT_CST_LT (maxval, primop1); + } + + val = 0; + /* This used to be a switch, but Genix compiler can't handle that. */ + if (code == NE_EXPR) + { + if (max_lt || min_gt) + val = truthvalue_true_node; + } + else if (code == EQ_EXPR) + { + if (max_lt || min_gt) + val = truthvalue_false_node; + } + else if (code == LT_EXPR) + { + if (max_lt) + val = truthvalue_true_node; + if (!min_lt) + val = truthvalue_false_node; + } + else if (code == GT_EXPR) + { + if (min_gt) + val = truthvalue_true_node; + if (!max_gt) + val = truthvalue_false_node; + } + else if (code == LE_EXPR) + { + if (!max_gt) + val = truthvalue_true_node; + if (min_gt) + val = truthvalue_false_node; + } + else if (code == GE_EXPR) + { + if (!min_lt) + val = truthvalue_true_node; + if (max_lt) + val = truthvalue_false_node; + } + + /* If primop0 was sign-extended and unsigned comparison specd, + we did a signed comparison above using the signed type bounds. + But the comparison we output must be unsigned. + + Also, for inequalities, VAL is no good; but if the signed + comparison had *any* fixed result, it follows that the + unsigned comparison just tests the sign in reverse + (positive values are LE, negative ones GE). + So we can generate an unsigned comparison + against an extreme value of the signed type. */ + + if (unsignedp && !unsignedp0) + { + if (val != 0) + switch (code) + { + case LT_EXPR: + case GE_EXPR: + primop1 = TYPE_MIN_VALUE (type); + val = 0; + break; + + case LE_EXPR: + case GT_EXPR: + primop1 = TYPE_MAX_VALUE (type); + val = 0; + break; + + default: + break; + } + type = c_common_unsigned_type (type); + } + + if (TREE_CODE (primop0) != INTEGER_CST) + { + if (val == truthvalue_false_node) + warning (OPT_Wtype_limits, "comparison is always false due to limited range of data type"); + if (val == truthvalue_true_node) + warning (OPT_Wtype_limits, "comparison is always true due to limited range of data type"); + } + + if (val != 0) + { + /* Don't forget to evaluate PRIMOP0 if it has side effects. */ + if (TREE_SIDE_EFFECTS (primop0)) + return build2 (COMPOUND_EXPR, TREE_TYPE (val), primop0, val); + return val; + } + + /* Value is not predetermined, but do the comparison + in the type of the operand that is not constant. + TYPE is already properly set. */ + } + + /* If either arg is decimal float and the other is float, find the + proper common type to use for comparison. */ + else if (real1 && real2 + && (DECIMAL_FLOAT_MODE_P (TYPE_MODE (TREE_TYPE (primop0))) + || DECIMAL_FLOAT_MODE_P (TYPE_MODE (TREE_TYPE (primop1))))) + type = common_type (TREE_TYPE (primop0), TREE_TYPE (primop1)); + + else if (real1 && real2 + && (TYPE_PRECISION (TREE_TYPE (primop0)) + == TYPE_PRECISION (TREE_TYPE (primop1)))) + type = TREE_TYPE (primop0); + + /* If args' natural types are both narrower than nominal type + and both extend in the same manner, compare them + in the type of the wider arg. + Otherwise must actually extend both to the nominal + common type lest different ways of extending + alter the result. + (eg, (short)-1 == (unsigned short)-1 should be 0.) */ + + else if (unsignedp0 == unsignedp1 && real1 == real2 + && TYPE_PRECISION (TREE_TYPE (primop0)) < TYPE_PRECISION (*restype_ptr) + && TYPE_PRECISION (TREE_TYPE (primop1)) < TYPE_PRECISION (*restype_ptr)) + { + type = common_type (TREE_TYPE (primop0), TREE_TYPE (primop1)); + type = c_common_signed_or_unsigned_type (unsignedp0 + || TYPE_UNSIGNED (*restype_ptr), + type); + /* Make sure shorter operand is extended the right way + to match the longer operand. */ + primop0 + = convert (c_common_signed_or_unsigned_type (unsignedp0, + TREE_TYPE (primop0)), + primop0); + primop1 + = convert (c_common_signed_or_unsigned_type (unsignedp1, + TREE_TYPE (primop1)), + primop1); + } + else + { + /* Here we must do the comparison on the nominal type + using the args exactly as we received them. */ + type = *restype_ptr; + primop0 = op0; + primop1 = op1; + + if (!real1 && !real2 && integer_zerop (primop1) + && TYPE_UNSIGNED (*restype_ptr)) + { + tree value = 0; + switch (code) + { + case GE_EXPR: + /* All unsigned values are >= 0, so we warn. However, + if OP0 is a constant that is >= 0, the signedness of + the comparison isn't an issue, so suppress the + warning. */ + if (warn_type_limits && !in_system_header + && !(TREE_CODE (primop0) == INTEGER_CST + && !TREE_OVERFLOW (convert (c_common_signed_type (type), + primop0)))) + warning (OPT_Wtype_limits, + "comparison of unsigned expression >= 0 is always true"); + value = truthvalue_true_node; + break; + + case LT_EXPR: + if (warn_type_limits && !in_system_header + && !(TREE_CODE (primop0) == INTEGER_CST + && !TREE_OVERFLOW (convert (c_common_signed_type (type), + primop0)))) + warning (OPT_Wtype_limits, + "comparison of unsigned expression < 0 is always false"); + value = truthvalue_false_node; + break; + + default: + break; + } + + if (value != 0) + { + /* Don't forget to evaluate PRIMOP0 if it has side effects. */ + if (TREE_SIDE_EFFECTS (primop0)) + return build2 (COMPOUND_EXPR, TREE_TYPE (value), + primop0, value); + return value; + } + } + } + + *op0_ptr = convert (type, primop0); + *op1_ptr = convert (type, primop1); + + *restype_ptr = truthvalue_type_node; + + return 0; +} + +/* Return a tree for the sum or difference (RESULTCODE says which) + of pointer PTROP and integer INTOP. */ + +tree +pointer_int_sum (location_t loc, enum tree_code resultcode, + tree ptrop, tree intop) +{ + tree size_exp, ret; + + /* The result is a pointer of the same type that is being added. */ + tree result_type = TREE_TYPE (ptrop); + + if (TREE_CODE (TREE_TYPE (result_type)) == VOID_TYPE) + { + pedwarn (loc, pedantic ? OPT_pedantic : OPT_Wpointer_arith, + "pointer of type % used in arithmetic"); + size_exp = integer_one_node; + } + else if (TREE_CODE (TREE_TYPE (result_type)) == FUNCTION_TYPE) + { + pedwarn (loc, pedantic ? OPT_pedantic : OPT_Wpointer_arith, + "pointer to a function used in arithmetic"); + size_exp = integer_one_node; + } + else if (TREE_CODE (TREE_TYPE (result_type)) == METHOD_TYPE) + { + pedwarn (loc, pedantic ? OPT_pedantic : OPT_Wpointer_arith, + "pointer to member function used in arithmetic"); + size_exp = integer_one_node; + } + else + size_exp = size_in_bytes (TREE_TYPE (result_type)); + + /* We are manipulating pointer values, so we don't need to warn + about relying on undefined signed overflow. We disable the + warning here because we use integer types so fold won't know that + they are really pointers. */ + fold_defer_overflow_warnings (); + + /* If what we are about to multiply by the size of the elements + contains a constant term, apply distributive law + and multiply that constant term separately. + This helps produce common subexpressions. */ + if ((TREE_CODE (intop) == PLUS_EXPR || TREE_CODE (intop) == MINUS_EXPR) + && !TREE_CONSTANT (intop) + && TREE_CONSTANT (TREE_OPERAND (intop, 1)) + && TREE_CONSTANT (size_exp) + /* If the constant comes from pointer subtraction, + skip this optimization--it would cause an error. */ + && TREE_CODE (TREE_TYPE (TREE_OPERAND (intop, 0))) == INTEGER_TYPE + /* If the constant is unsigned, and smaller than the pointer size, + then we must skip this optimization. This is because it could cause + an overflow error if the constant is negative but INTOP is not. */ + && (!TYPE_UNSIGNED (TREE_TYPE (intop)) + || (TYPE_PRECISION (TREE_TYPE (intop)) + == TYPE_PRECISION (TREE_TYPE (ptrop))))) + { + enum tree_code subcode = resultcode; + tree int_type = TREE_TYPE (intop); + if (TREE_CODE (intop) == MINUS_EXPR) + subcode = (subcode == PLUS_EXPR ? MINUS_EXPR : PLUS_EXPR); + /* Convert both subexpression types to the type of intop, + because weird cases involving pointer arithmetic + can result in a sum or difference with different type args. */ + ptrop = build_binary_op (EXPR_LOCATION (TREE_OPERAND (intop, 1)), + subcode, ptrop, + convert (int_type, TREE_OPERAND (intop, 1)), 1); + intop = convert (int_type, TREE_OPERAND (intop, 0)); + } + + /* Convert the integer argument to a type the same size as sizetype + so the multiply won't overflow spuriously. */ + if (TYPE_PRECISION (TREE_TYPE (intop)) != TYPE_PRECISION (sizetype) + || TYPE_UNSIGNED (TREE_TYPE (intop)) != TYPE_UNSIGNED (sizetype)) + intop = convert (c_common_type_for_size (TYPE_PRECISION (sizetype), + TYPE_UNSIGNED (sizetype)), intop); + + /* Replace the integer argument with a suitable product by the object size. + Do this multiplication as signed, then convert to the appropriate type + for the pointer operation and disregard an overflow that occured only + because of the sign-extension change in the latter conversion. */ + { + tree t = build_binary_op (loc, + MULT_EXPR, intop, + convert (TREE_TYPE (intop), size_exp), 1); + intop = convert (sizetype, t); + if (TREE_OVERFLOW_P (intop) && !TREE_OVERFLOW (t)) + intop = build_int_cst_wide (TREE_TYPE (intop), TREE_INT_CST_LOW (intop), + TREE_INT_CST_HIGH (intop)); + } + + /* Create the sum or difference. */ + if (resultcode == MINUS_EXPR) + intop = fold_build1_loc (loc, NEGATE_EXPR, sizetype, intop); + + ret = fold_build2_loc (loc, POINTER_PLUS_EXPR, result_type, ptrop, intop); + + fold_undefer_and_ignore_overflow_warnings (); + + return ret; +} + +/* Wrap a C_MAYBE_CONST_EXPR around an expression that is fully folded + and if NON_CONST is known not to be permitted in an evaluated part + of a constant expression. */ + +tree +c_wrap_maybe_const (tree expr, bool non_const) +{ + bool nowarning = TREE_NO_WARNING (expr); + location_t loc = EXPR_LOCATION (expr); + + /* This should never be called for C++. */ + if (c_dialect_cxx ()) + gcc_unreachable (); + + /* The result of folding may have a NOP_EXPR to set TREE_NO_WARNING. */ + STRIP_TYPE_NOPS (expr); + expr = build2 (C_MAYBE_CONST_EXPR, TREE_TYPE (expr), NULL, expr); + C_MAYBE_CONST_EXPR_NON_CONST (expr) = non_const; + if (nowarning) + TREE_NO_WARNING (expr) = 1; + protected_set_expr_location (expr, loc); + + return expr; +} + +/* Wrap a SAVE_EXPR around EXPR, if appropriate. Like save_expr, but + for C folds the inside expression and wraps a C_MAYBE_CONST_EXPR + around the SAVE_EXPR if needed so that c_fully_fold does not need + to look inside SAVE_EXPRs. */ + +tree +c_save_expr (tree expr) +{ + bool maybe_const = true; + if (c_dialect_cxx ()) + return save_expr (expr); + expr = c_fully_fold (expr, false, &maybe_const); + expr = save_expr (expr); + if (!maybe_const) + expr = c_wrap_maybe_const (expr, true); + return expr; +} + +/* Return whether EXPR is a declaration whose address can never be + NULL. */ + +bool +decl_with_nonnull_addr_p (const_tree expr) +{ + return (DECL_P (expr) + && (TREE_CODE (expr) == PARM_DECL + || TREE_CODE (expr) == LABEL_DECL + || !DECL_WEAK (expr))); +} + +/* Prepare expr to be an argument of a TRUTH_NOT_EXPR, + or for an `if' or `while' statement or ?..: exp. It should already + have been validated to be of suitable type; otherwise, a bad + diagnostic may result. + + The EXPR is located at LOCATION. + + 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, truthvalue_false_node, 1), + but we optimize comparisons, &&, ||, and !. + + The resulting type should always be `truthvalue_type_node'. */ + +tree +c_common_truthvalue_conversion (location_t location, tree expr) +{ + switch (TREE_CODE (expr)) + { + case EQ_EXPR: case NE_EXPR: case UNEQ_EXPR: case LTGT_EXPR: + case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR: + case UNLE_EXPR: case UNGE_EXPR: case UNLT_EXPR: case UNGT_EXPR: + case ORDERED_EXPR: case UNORDERED_EXPR: + if (TREE_TYPE (expr) == truthvalue_type_node) + return expr; + expr = build2 (TREE_CODE (expr), truthvalue_type_node, + TREE_OPERAND (expr, 0), TREE_OPERAND (expr, 1)); + goto ret; + + case TRUTH_ANDIF_EXPR: + case TRUTH_ORIF_EXPR: + case TRUTH_AND_EXPR: + case TRUTH_OR_EXPR: + case TRUTH_XOR_EXPR: + if (TREE_TYPE (expr) == truthvalue_type_node) + return expr; + expr = build2 (TREE_CODE (expr), truthvalue_type_node, + c_common_truthvalue_conversion (location, + TREE_OPERAND (expr, 0)), + c_common_truthvalue_conversion (location, + TREE_OPERAND (expr, 1))); + goto ret; + + case TRUTH_NOT_EXPR: + if (TREE_TYPE (expr) == truthvalue_type_node) + return expr; + expr = build1 (TREE_CODE (expr), truthvalue_type_node, + c_common_truthvalue_conversion (location, + TREE_OPERAND (expr, 0))); + goto ret; + + case ERROR_MARK: + return expr; + + case INTEGER_CST: + return integer_zerop (expr) ? truthvalue_false_node + : truthvalue_true_node; + + case REAL_CST: + return real_compare (NE_EXPR, &TREE_REAL_CST (expr), &dconst0) + ? truthvalue_true_node + : truthvalue_false_node; + + case FIXED_CST: + return fixed_compare (NE_EXPR, &TREE_FIXED_CST (expr), + &FCONST0 (TYPE_MODE (TREE_TYPE (expr)))) + ? truthvalue_true_node + : truthvalue_false_node; + + case FUNCTION_DECL: + expr = build_unary_op (location, ADDR_EXPR, expr, 0); + /* Fall through. */ + + case ADDR_EXPR: + { + tree inner = TREE_OPERAND (expr, 0); + if (decl_with_nonnull_addr_p (inner)) + { + /* Common Ada/Pascal programmer's mistake. */ + warning_at (location, + OPT_Waddress, + "the address of %qD will always evaluate as %", + inner); + return truthvalue_true_node; + } + break; + } + + case COMPLEX_EXPR: + expr = build_binary_op (EXPR_LOCATION (expr), + (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)) + ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR), + c_common_truthvalue_conversion (location, + TREE_OPERAND (expr, 0)), + c_common_truthvalue_conversion (location, + TREE_OPERAND (expr, 1)), + 0); + goto ret; + + case NEGATE_EXPR: + case ABS_EXPR: + case FLOAT_EXPR: + case EXCESS_PRECISION_EXPR: + /* These don't change whether an object is nonzero or zero. */ + return c_common_truthvalue_conversion (location, 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))) + { + expr = build2 (COMPOUND_EXPR, truthvalue_type_node, + TREE_OPERAND (expr, 1), + c_common_truthvalue_conversion + (location, TREE_OPERAND (expr, 0))); + goto ret; + } + else + return c_common_truthvalue_conversion (location, + TREE_OPERAND (expr, 0)); + + case COND_EXPR: + /* Distribute the conversion into the arms of a COND_EXPR. */ + if (c_dialect_cxx ()) + { + expr = fold_build3_loc (location, COND_EXPR, truthvalue_type_node, + TREE_OPERAND (expr, 0), + c_common_truthvalue_conversion (location, + TREE_OPERAND (expr, + 1)), + c_common_truthvalue_conversion (location, + TREE_OPERAND (expr, + 2))); + goto ret; + } + else + { + /* Folding will happen later for C. */ + expr = build3 (COND_EXPR, truthvalue_type_node, + TREE_OPERAND (expr, 0), + c_common_truthvalue_conversion (location, + TREE_OPERAND (expr, 1)), + c_common_truthvalue_conversion (location, + TREE_OPERAND (expr, 2))); + goto ret; + } + + CASE_CONVERT: + /* 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; + /* 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 c_common_truthvalue_conversion (location, + TREE_OPERAND (expr, 0)); + break; + + case MODIFY_EXPR: + if (!TREE_NO_WARNING (expr) + && warn_parentheses) + { + warning (OPT_Wparentheses, + "suggest parentheses around assignment used as truth value"); + TREE_NO_WARNING (expr) = 1; + } + break; + + default: + break; + } + + if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE) + { + tree t = c_save_expr (expr); + expr = (build_binary_op + (EXPR_LOCATION (expr), + (TREE_SIDE_EFFECTS (expr) + ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR), + c_common_truthvalue_conversion + (location, + build_unary_op (location, REALPART_EXPR, t, 0)), + c_common_truthvalue_conversion + (location, + build_unary_op (location, IMAGPART_EXPR, t, 0)), + 0)); + goto ret; + } + + if (TREE_CODE (TREE_TYPE (expr)) == FIXED_POINT_TYPE) + { + tree fixed_zero_node = build_fixed (TREE_TYPE (expr), + FCONST0 (TYPE_MODE + (TREE_TYPE (expr)))); + return build_binary_op (location, NE_EXPR, expr, fixed_zero_node, 1); + } + else + return build_binary_op (location, NE_EXPR, expr, integer_zero_node, 1); + + ret: + protected_set_expr_location (expr, location); + return expr; +} + +static void def_builtin_1 (enum built_in_function fncode, + const char *name, + enum built_in_class fnclass, + tree fntype, tree libtype, + bool both_p, bool fallback_p, bool nonansi_p, + tree fnattrs, bool implicit_p); + + +/* Apply the TYPE_QUALS to the new DECL. */ + +void +c_apply_type_quals_to_decl (int type_quals, tree decl) +{ + tree type = TREE_TYPE (decl); + + if (type == error_mark_node) + return; + + if (((type_quals & TYPE_QUAL_CONST) + || (type && TREE_CODE (type) == REFERENCE_TYPE)) + /* An object declared 'const' is only readonly after it is + initialized. We don't have any way of expressing this currently, + so we need to be conservative and unset TREE_READONLY for types + with constructors. Otherwise aliasing code will ignore stores in + an inline constructor. */ + && !(type && TYPE_NEEDS_CONSTRUCTING (type))) + TREE_READONLY (decl) = 1; + if (type_quals & TYPE_QUAL_VOLATILE) + { + TREE_SIDE_EFFECTS (decl) = 1; + TREE_THIS_VOLATILE (decl) = 1; + } + if (type_quals & TYPE_QUAL_RESTRICT) + { + while (type && TREE_CODE (type) == ARRAY_TYPE) + /* Allow 'restrict' on arrays of pointers. + FIXME currently we just ignore it. */ + type = TREE_TYPE (type); + if (!type + || !POINTER_TYPE_P (type) + || !C_TYPE_OBJECT_OR_INCOMPLETE_P (TREE_TYPE (type))) + error ("invalid use of %"); + } +} + +/* Hash function for the problem of multiple type definitions in + different files. This must hash all types that will compare + equal via comptypes to the same value. In practice it hashes + on some of the simple stuff and leaves the details to comptypes. */ + +static hashval_t +c_type_hash (const void *p) +{ + int i = 0; + int shift, size; + const_tree const t = (const_tree) p; + tree t2; + switch (TREE_CODE (t)) + { + /* For pointers, hash on pointee type plus some swizzling. */ + case POINTER_TYPE: + return c_type_hash (TREE_TYPE (t)) ^ 0x3003003; + /* Hash on number of elements and total size. */ + case ENUMERAL_TYPE: + shift = 3; + t2 = TYPE_VALUES (t); + break; + case RECORD_TYPE: + shift = 0; + t2 = TYPE_FIELDS (t); + break; + case QUAL_UNION_TYPE: + shift = 1; + t2 = TYPE_FIELDS (t); + break; + case UNION_TYPE: + shift = 2; + t2 = TYPE_FIELDS (t); + break; + default: + gcc_unreachable (); + } + for (; t2; t2 = TREE_CHAIN (t2)) + i++; + /* We might have a VLA here. */ + if (TREE_CODE (TYPE_SIZE (t)) != INTEGER_CST) + size = 0; + else + size = TREE_INT_CST_LOW (TYPE_SIZE (t)); + return ((size << 24) | (i << shift)); +} + +static GTY((param_is (union tree_node))) htab_t type_hash_table; + +/* Return the typed-based alias set for T, which may be an expression + or a type. Return -1 if we don't do anything special. */ + +alias_set_type +c_common_get_alias_set (tree t) +{ + tree u; + PTR *slot; + + /* For VLAs, use the alias set of the element type rather than the + default of alias set 0 for types compared structurally. */ + if (TYPE_P (t) && TYPE_STRUCTURAL_EQUALITY_P (t)) + { + if (TREE_CODE (t) == ARRAY_TYPE) + return get_alias_set (TREE_TYPE (t)); + return -1; + } + + /* Permit type-punning when accessing a union, provided the access + is directly through the union. For example, this code does not + permit taking the address of a union member and then storing + through it. Even the type-punning allowed here is a GCC + extension, albeit a common and useful one; the C standard says + that such accesses have implementation-defined behavior. */ + for (u = t; + TREE_CODE (u) == COMPONENT_REF || TREE_CODE (u) == ARRAY_REF; + u = TREE_OPERAND (u, 0)) + if (TREE_CODE (u) == COMPONENT_REF + && TREE_CODE (TREE_TYPE (TREE_OPERAND (u, 0))) == UNION_TYPE) + return 0; + + /* That's all the expressions we handle specially. */ + if (!TYPE_P (t)) + return -1; + + /* The C standard guarantees that any object may be accessed via an + lvalue that has character type. */ + if (t == char_type_node + || t == signed_char_type_node + || t == unsigned_char_type_node) + return 0; + + /* The C standard specifically allows aliasing between signed and + unsigned variants of the same type. We treat the signed + variant as canonical. */ + if (TREE_CODE (t) == INTEGER_TYPE && TYPE_UNSIGNED (t)) + { + tree t1 = c_common_signed_type (t); + + /* t1 == t can happen for boolean nodes which are always unsigned. */ + if (t1 != t) + return get_alias_set (t1); + } + else if (POINTER_TYPE_P (t)) + { + tree t1; + + /* Unfortunately, there is no canonical form of a pointer type. + In particular, if we have `typedef int I', then `int *', and + `I *' are different types. So, we have to pick a canonical + representative. We do this below. + + Technically, this approach is actually more conservative that + it needs to be. In particular, `const int *' and `int *' + should be in different alias sets, according to the C and C++ + standard, since their types are not the same, and so, + technically, an `int **' and `const int **' cannot point at + the same thing. + + But, the standard is wrong. In particular, this code is + legal C++: + + int *ip; + int **ipp = &ip; + const int* const* cipp = ipp; + + And, it doesn't make sense for that to be legal unless you + can dereference IPP and CIPP. So, we ignore cv-qualifiers on + the pointed-to types. This issue has been reported to the + C++ committee. */ + t1 = build_type_no_quals (t); + if (t1 != t) + return get_alias_set (t1); + } + + /* Handle the case of multiple type nodes referring to "the same" type, + which occurs with IMA. These share an alias set. FIXME: Currently only + C90 is handled. (In C99 type compatibility is not transitive, which + complicates things mightily. The alias set splay trees can theoretically + represent this, but insertion is tricky when you consider all the + different orders things might arrive in.) */ + + if (c_language != clk_c || flag_isoc99) + return -1; + + /* Save time if there's only one input file. */ + if (num_in_fnames == 1) + return -1; + + /* Pointers need special handling if they point to any type that + needs special handling (below). */ + if (TREE_CODE (t) == POINTER_TYPE) + { + tree t2; + /* Find bottom type under any nested POINTERs. */ + for (t2 = TREE_TYPE (t); + TREE_CODE (t2) == POINTER_TYPE; + t2 = TREE_TYPE (t2)) + ; + if (TREE_CODE (t2) != RECORD_TYPE + && TREE_CODE (t2) != ENUMERAL_TYPE + && TREE_CODE (t2) != QUAL_UNION_TYPE + && TREE_CODE (t2) != UNION_TYPE) + return -1; + if (TYPE_SIZE (t2) == 0) + return -1; + } + /* These are the only cases that need special handling. */ + if (TREE_CODE (t) != RECORD_TYPE + && TREE_CODE (t) != ENUMERAL_TYPE + && TREE_CODE (t) != QUAL_UNION_TYPE + && TREE_CODE (t) != UNION_TYPE + && TREE_CODE (t) != POINTER_TYPE) + return -1; + /* Undefined? */ + if (TYPE_SIZE (t) == 0) + return -1; + + /* Look up t in hash table. Only one of the compatible types within each + alias set is recorded in the table. */ + if (!type_hash_table) + type_hash_table = htab_create_ggc (1021, c_type_hash, + (htab_eq) lang_hooks.types_compatible_p, + NULL); + slot = htab_find_slot (type_hash_table, t, INSERT); + if (*slot != NULL) + { + TYPE_ALIAS_SET (t) = TYPE_ALIAS_SET ((tree)*slot); + return TYPE_ALIAS_SET ((tree)*slot); + } + else + /* Our caller will assign and record (in t) a new alias set; all we need + to do is remember t in the hash table. */ + *slot = t; + + return -1; +} + +/* Compute the value of 'sizeof (TYPE)' or '__alignof__ (TYPE)', where + the second parameter indicates which OPERATOR is being applied. + The COMPLAIN flag controls whether we should diagnose possibly + ill-formed constructs or not. LOC is the location of the SIZEOF or + TYPEOF operator. */ + +tree +c_sizeof_or_alignof_type (location_t loc, + tree type, bool is_sizeof, int complain) +{ + const char *op_name; + tree value = NULL; + enum tree_code type_code = TREE_CODE (type); + + op_name = is_sizeof ? "sizeof" : "__alignof__"; + + if (type_code == FUNCTION_TYPE) + { + if (is_sizeof) + { + if (complain && (pedantic || warn_pointer_arith)) + pedwarn (loc, pedantic ? OPT_pedantic : OPT_Wpointer_arith, + "invalid application of % to a function type"); + else if (!complain) + return error_mark_node; + value = size_one_node; + } + else + value = size_int (FUNCTION_BOUNDARY / BITS_PER_UNIT); + } + else if (type_code == VOID_TYPE || type_code == ERROR_MARK) + { + if (type_code == VOID_TYPE + && complain && (pedantic || warn_pointer_arith)) + pedwarn (loc, pedantic ? OPT_pedantic : OPT_Wpointer_arith, + "invalid application of %qs to a void type", op_name); + else if (!complain) + return error_mark_node; + value = size_one_node; + } + else if (!COMPLETE_TYPE_P (type)) + { + if (complain) + error_at (loc, "invalid application of %qs to incomplete type %qT ", + op_name, type); + return error_mark_node; + } + else + { + if (is_sizeof) + /* Convert in case a char is more than one unit. */ + value = size_binop_loc (loc, CEIL_DIV_EXPR, TYPE_SIZE_UNIT (type), + size_int (TYPE_PRECISION (char_type_node) + / BITS_PER_UNIT)); + else + value = size_int (TYPE_ALIGN_UNIT (type)); + } + + /* VALUE will have an integer type with TYPE_IS_SIZETYPE set. + TYPE_IS_SIZETYPE means that certain things (like overflow) will + never happen. However, this node should really have type + `size_t', which is just a typedef for an ordinary integer type. */ + value = fold_convert_loc (loc, size_type_node, value); + gcc_assert (!TYPE_IS_SIZETYPE (TREE_TYPE (value))); + + return value; +} + +/* Implement the __alignof keyword: Return the minimum required + alignment of EXPR, measured in bytes. For VAR_DECLs, + FUNCTION_DECLs and FIELD_DECLs return DECL_ALIGN (which can be set + from an "aligned" __attribute__ specification). LOC is the + location of the ALIGNOF operator. */ + +tree +c_alignof_expr (location_t loc, tree expr) +{ + tree t; + + if (VAR_OR_FUNCTION_DECL_P (expr)) + t = size_int (DECL_ALIGN_UNIT (expr)); + + else if (TREE_CODE (expr) == COMPONENT_REF + && DECL_C_BIT_FIELD (TREE_OPERAND (expr, 1))) + { + error_at (loc, "%<__alignof%> applied to a bit-field"); + t = size_one_node; + } + else if (TREE_CODE (expr) == COMPONENT_REF + && TREE_CODE (TREE_OPERAND (expr, 1)) == FIELD_DECL) + t = size_int (DECL_ALIGN_UNIT (TREE_OPERAND (expr, 1))); + + else if (TREE_CODE (expr) == INDIRECT_REF) + { + tree t = TREE_OPERAND (expr, 0); + tree best = t; + int bestalign = TYPE_ALIGN (TREE_TYPE (TREE_TYPE (t))); + + while (CONVERT_EXPR_P (t) + && TREE_CODE (TREE_TYPE (TREE_OPERAND (t, 0))) == POINTER_TYPE) + { + int thisalign; + + t = TREE_OPERAND (t, 0); + thisalign = TYPE_ALIGN (TREE_TYPE (TREE_TYPE (t))); + if (thisalign > bestalign) + best = t, bestalign = thisalign; + } + return c_alignof (loc, TREE_TYPE (TREE_TYPE (best))); + } + else + return c_alignof (loc, TREE_TYPE (expr)); + + return fold_convert_loc (loc, size_type_node, t); +} + +/* Handle C and C++ default attributes. */ + +enum built_in_attribute +{ +#define DEF_ATTR_NULL_TREE(ENUM) ENUM, +#define DEF_ATTR_INT(ENUM, VALUE) ENUM, +#define DEF_ATTR_IDENT(ENUM, STRING) ENUM, +#define DEF_ATTR_TREE_LIST(ENUM, PURPOSE, VALUE, CHAIN) ENUM, +#include "builtin-attrs.def" +#undef DEF_ATTR_NULL_TREE +#undef DEF_ATTR_INT +#undef DEF_ATTR_IDENT +#undef DEF_ATTR_TREE_LIST + ATTR_LAST +}; + +static GTY(()) tree built_in_attributes[(int) ATTR_LAST]; + +static void c_init_attributes (void); + +enum c_builtin_type +{ +#define DEF_PRIMITIVE_TYPE(NAME, VALUE) NAME, +#define DEF_FUNCTION_TYPE_0(NAME, RETURN) NAME, +#define DEF_FUNCTION_TYPE_1(NAME, RETURN, ARG1) NAME, +#define DEF_FUNCTION_TYPE_2(NAME, RETURN, ARG1, ARG2) NAME, +#define DEF_FUNCTION_TYPE_3(NAME, RETURN, ARG1, ARG2, ARG3) NAME, +#define DEF_FUNCTION_TYPE_4(NAME, RETURN, ARG1, ARG2, ARG3, ARG4) NAME, +#define DEF_FUNCTION_TYPE_5(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) NAME, +#define DEF_FUNCTION_TYPE_6(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6) NAME, +#define DEF_FUNCTION_TYPE_7(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, ARG7) NAME, +#define DEF_FUNCTION_TYPE_VAR_0(NAME, RETURN) NAME, +#define DEF_FUNCTION_TYPE_VAR_1(NAME, RETURN, ARG1) NAME, +#define DEF_FUNCTION_TYPE_VAR_2(NAME, RETURN, ARG1, ARG2) NAME, +#define DEF_FUNCTION_TYPE_VAR_3(NAME, RETURN, ARG1, ARG2, ARG3) NAME, +#define DEF_FUNCTION_TYPE_VAR_4(NAME, RETURN, ARG1, ARG2, ARG3, ARG4) NAME, +#define DEF_FUNCTION_TYPE_VAR_5(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG6) \ + NAME, +#define DEF_POINTER_TYPE(NAME, TYPE) NAME, +#include "builtin-types.def" +#undef DEF_PRIMITIVE_TYPE +#undef DEF_FUNCTION_TYPE_0 +#undef DEF_FUNCTION_TYPE_1 +#undef DEF_FUNCTION_TYPE_2 +#undef DEF_FUNCTION_TYPE_3 +#undef DEF_FUNCTION_TYPE_4 +#undef DEF_FUNCTION_TYPE_5 +#undef DEF_FUNCTION_TYPE_6 +#undef DEF_FUNCTION_TYPE_7 +#undef DEF_FUNCTION_TYPE_VAR_0 +#undef DEF_FUNCTION_TYPE_VAR_1 +#undef DEF_FUNCTION_TYPE_VAR_2 +#undef DEF_FUNCTION_TYPE_VAR_3 +#undef DEF_FUNCTION_TYPE_VAR_4 +#undef DEF_FUNCTION_TYPE_VAR_5 +#undef DEF_POINTER_TYPE + BT_LAST +}; + +typedef enum c_builtin_type builtin_type; + +/* A temporary array for c_common_nodes_and_builtins. Used in + communication with def_fn_type. */ +static tree builtin_types[(int) BT_LAST + 1]; + +/* A helper function for c_common_nodes_and_builtins. Build function type + for DEF with return type RET and N arguments. If VAR is true, then the + function should be variadic after those N arguments. + + Takes special care not to ICE if any of the types involved are + error_mark_node, which indicates that said type is not in fact available + (see builtin_type_for_size). In which case the function type as a whole + should be error_mark_node. */ + +static void +def_fn_type (builtin_type def, builtin_type ret, bool var, int n, ...) +{ + tree args = NULL, t; + va_list list; + int i; + + va_start (list, n); + for (i = 0; i < n; ++i) + { + builtin_type a = (builtin_type) va_arg (list, int); + t = builtin_types[a]; + if (t == error_mark_node) + goto egress; + args = tree_cons (NULL_TREE, t, args); + } + va_end (list); + + args = nreverse (args); + if (!var) + args = chainon (args, void_list_node); + + t = builtin_types[ret]; + if (t == error_mark_node) + goto egress; + t = build_function_type (t, args); + + egress: + builtin_types[def] = t; +} + +/* Build builtin functions common to both C and C++ language + frontends. */ + +static void +c_define_builtins (tree va_list_ref_type_node, tree va_list_arg_type_node) +{ +#define DEF_PRIMITIVE_TYPE(ENUM, VALUE) \ + builtin_types[ENUM] = VALUE; +#define DEF_FUNCTION_TYPE_0(ENUM, RETURN) \ + def_fn_type (ENUM, RETURN, 0, 0); +#define DEF_FUNCTION_TYPE_1(ENUM, RETURN, ARG1) \ + def_fn_type (ENUM, RETURN, 0, 1, ARG1); +#define DEF_FUNCTION_TYPE_2(ENUM, RETURN, ARG1, ARG2) \ + def_fn_type (ENUM, RETURN, 0, 2, ARG1, ARG2); +#define DEF_FUNCTION_TYPE_3(ENUM, RETURN, ARG1, ARG2, ARG3) \ + def_fn_type (ENUM, RETURN, 0, 3, ARG1, ARG2, ARG3); +#define DEF_FUNCTION_TYPE_4(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4) \ + def_fn_type (ENUM, RETURN, 0, 4, ARG1, ARG2, ARG3, ARG4); +#define DEF_FUNCTION_TYPE_5(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) \ + def_fn_type (ENUM, RETURN, 0, 5, ARG1, ARG2, ARG3, ARG4, ARG5); +#define DEF_FUNCTION_TYPE_6(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ + ARG6) \ + def_fn_type (ENUM, RETURN, 0, 6, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6); +#define DEF_FUNCTION_TYPE_7(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ + ARG6, ARG7) \ + def_fn_type (ENUM, RETURN, 0, 7, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, ARG7); +#define DEF_FUNCTION_TYPE_VAR_0(ENUM, RETURN) \ + def_fn_type (ENUM, RETURN, 1, 0); +#define DEF_FUNCTION_TYPE_VAR_1(ENUM, RETURN, ARG1) \ + def_fn_type (ENUM, RETURN, 1, 1, ARG1); +#define DEF_FUNCTION_TYPE_VAR_2(ENUM, RETURN, ARG1, ARG2) \ + def_fn_type (ENUM, RETURN, 1, 2, ARG1, ARG2); +#define DEF_FUNCTION_TYPE_VAR_3(ENUM, RETURN, ARG1, ARG2, ARG3) \ + def_fn_type (ENUM, RETURN, 1, 3, ARG1, ARG2, ARG3); +#define DEF_FUNCTION_TYPE_VAR_4(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4) \ + def_fn_type (ENUM, RETURN, 1, 4, ARG1, ARG2, ARG3, ARG4); +#define DEF_FUNCTION_TYPE_VAR_5(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) \ + def_fn_type (ENUM, RETURN, 1, 5, ARG1, ARG2, ARG3, ARG4, ARG5); +#define DEF_POINTER_TYPE(ENUM, TYPE) \ + builtin_types[(int) ENUM] = build_pointer_type (builtin_types[(int) TYPE]); + +#include "builtin-types.def" + +#undef DEF_PRIMITIVE_TYPE +#undef DEF_FUNCTION_TYPE_1 +#undef DEF_FUNCTION_TYPE_2 +#undef DEF_FUNCTION_TYPE_3 +#undef DEF_FUNCTION_TYPE_4 +#undef DEF_FUNCTION_TYPE_5 +#undef DEF_FUNCTION_TYPE_6 +#undef DEF_FUNCTION_TYPE_VAR_0 +#undef DEF_FUNCTION_TYPE_VAR_1 +#undef DEF_FUNCTION_TYPE_VAR_2 +#undef DEF_FUNCTION_TYPE_VAR_3 +#undef DEF_FUNCTION_TYPE_VAR_4 +#undef DEF_FUNCTION_TYPE_VAR_5 +#undef DEF_POINTER_TYPE + builtin_types[(int) BT_LAST] = NULL_TREE; + + c_init_attributes (); + +#define DEF_BUILTIN(ENUM, NAME, CLASS, TYPE, LIBTYPE, BOTH_P, FALLBACK_P, \ + NONANSI_P, ATTRS, IMPLICIT, COND) \ + if (NAME && COND) \ + def_builtin_1 (ENUM, NAME, CLASS, \ + builtin_types[(int) TYPE], \ + builtin_types[(int) LIBTYPE], \ + BOTH_P, FALLBACK_P, NONANSI_P, \ + built_in_attributes[(int) ATTRS], IMPLICIT); +#include "builtins.def" +#undef DEF_BUILTIN + + targetm.init_builtins (); + + build_common_builtin_nodes (); + + if (flag_mudflap) + mudflap_init (); +} + +/* Like get_identifier, but avoid warnings about null arguments when + the argument may be NULL for targets where GCC lacks stdint.h type + information. */ + +static inline tree +c_get_ident (const char *id) +{ + return get_identifier (id); +} + +/* Build tree nodes and builtin functions common to both C and C++ language + frontends. */ + +void +c_common_nodes_and_builtins (void) +{ + int char16_type_size; + int char32_type_size; + int wchar_type_size; + tree array_domain_type; + tree va_list_ref_type_node; + tree va_list_arg_type_node; + + /* Define `int' and `char' first so that dbx will output them first. */ + record_builtin_type (RID_INT, NULL, integer_type_node); + record_builtin_type (RID_CHAR, "char", char_type_node); + + /* `signed' is the same as `int'. FIXME: the declarations of "signed", + "unsigned long", "long long unsigned" and "unsigned short" were in C++ + but not C. Are the conditionals here needed? */ + if (c_dialect_cxx ()) + record_builtin_type (RID_SIGNED, NULL, integer_type_node); + record_builtin_type (RID_LONG, "long int", long_integer_type_node); + record_builtin_type (RID_UNSIGNED, "unsigned int", unsigned_type_node); + record_builtin_type (RID_MAX, "long unsigned int", + long_unsigned_type_node); + if (int128_integer_type_node != NULL_TREE) + { + record_builtin_type (RID_INT128, "__int128", + int128_integer_type_node); + record_builtin_type (RID_MAX, "__int128 unsigned", + int128_unsigned_type_node); + } + if (c_dialect_cxx ()) + record_builtin_type (RID_MAX, "unsigned long", long_unsigned_type_node); + record_builtin_type (RID_MAX, "long long int", + long_long_integer_type_node); + record_builtin_type (RID_MAX, "long long unsigned int", + long_long_unsigned_type_node); + if (c_dialect_cxx ()) + record_builtin_type (RID_MAX, "long long unsigned", + long_long_unsigned_type_node); + record_builtin_type (RID_SHORT, "short int", short_integer_type_node); + record_builtin_type (RID_MAX, "short unsigned int", + short_unsigned_type_node); + if (c_dialect_cxx ()) + record_builtin_type (RID_MAX, "unsigned short", + short_unsigned_type_node); + + /* Define both `signed char' and `unsigned char'. */ + record_builtin_type (RID_MAX, "signed char", signed_char_type_node); + record_builtin_type (RID_MAX, "unsigned char", unsigned_char_type_node); + + /* These are types that c_common_type_for_size and + c_common_type_for_mode use. */ + lang_hooks.decls.pushdecl (build_decl (UNKNOWN_LOCATION, + TYPE_DECL, NULL_TREE, + intQI_type_node)); + lang_hooks.decls.pushdecl (build_decl (UNKNOWN_LOCATION, + TYPE_DECL, NULL_TREE, + intHI_type_node)); + lang_hooks.decls.pushdecl (build_decl (UNKNOWN_LOCATION, + TYPE_DECL, NULL_TREE, + intSI_type_node)); + lang_hooks.decls.pushdecl (build_decl (UNKNOWN_LOCATION, + TYPE_DECL, NULL_TREE, + intDI_type_node)); +#if HOST_BITS_PER_WIDE_INT >= 64 + if (targetm.scalar_mode_supported_p (TImode)) + lang_hooks.decls.pushdecl (build_decl (UNKNOWN_LOCATION, + TYPE_DECL, + get_identifier ("__int128_t"), + intTI_type_node)); +#endif + lang_hooks.decls.pushdecl (build_decl (UNKNOWN_LOCATION, + TYPE_DECL, NULL_TREE, + unsigned_intQI_type_node)); + lang_hooks.decls.pushdecl (build_decl (UNKNOWN_LOCATION, + TYPE_DECL, NULL_TREE, + unsigned_intHI_type_node)); + lang_hooks.decls.pushdecl (build_decl (UNKNOWN_LOCATION, + TYPE_DECL, NULL_TREE, + unsigned_intSI_type_node)); + lang_hooks.decls.pushdecl (build_decl (UNKNOWN_LOCATION, + TYPE_DECL, NULL_TREE, + unsigned_intDI_type_node)); +#if HOST_BITS_PER_WIDE_INT >= 64 + if (targetm.scalar_mode_supported_p (TImode)) + lang_hooks.decls.pushdecl (build_decl (UNKNOWN_LOCATION, + TYPE_DECL, + get_identifier ("__uint128_t"), + unsigned_intTI_type_node)); +#endif + + /* Create the widest literal types. */ + widest_integer_literal_type_node + = make_signed_type (HOST_BITS_PER_WIDE_INT * 2); + lang_hooks.decls.pushdecl (build_decl (UNKNOWN_LOCATION, + TYPE_DECL, NULL_TREE, + widest_integer_literal_type_node)); + + widest_unsigned_literal_type_node + = make_unsigned_type (HOST_BITS_PER_WIDE_INT * 2); + lang_hooks.decls.pushdecl (build_decl (UNKNOWN_LOCATION, + TYPE_DECL, NULL_TREE, + widest_unsigned_literal_type_node)); + + /* `unsigned long' is the standard type for sizeof. + Note that stddef.h uses `unsigned long', + and this must agree, even if long and int are the same size. */ + size_type_node = + TREE_TYPE (identifier_global_value (get_identifier (SIZE_TYPE))); + signed_size_type_node = c_common_signed_type (size_type_node); + set_sizetype (size_type_node); + + pid_type_node = + TREE_TYPE (identifier_global_value (get_identifier (PID_TYPE))); + + build_common_tree_nodes_2 (flag_short_double); + + record_builtin_type (RID_FLOAT, NULL, float_type_node); + record_builtin_type (RID_DOUBLE, NULL, double_type_node); + record_builtin_type (RID_MAX, "long double", long_double_type_node); + + /* Only supported decimal floating point extension if the target + actually supports underlying modes. */ + if (targetm.scalar_mode_supported_p (SDmode) + && targetm.scalar_mode_supported_p (DDmode) + && targetm.scalar_mode_supported_p (TDmode)) + { + record_builtin_type (RID_DFLOAT32, NULL, dfloat32_type_node); + record_builtin_type (RID_DFLOAT64, NULL, dfloat64_type_node); + record_builtin_type (RID_DFLOAT128, NULL, dfloat128_type_node); + } + + if (targetm.fixed_point_supported_p ()) + { + record_builtin_type (RID_MAX, "short _Fract", short_fract_type_node); + record_builtin_type (RID_FRACT, NULL, fract_type_node); + record_builtin_type (RID_MAX, "long _Fract", long_fract_type_node); + record_builtin_type (RID_MAX, "long long _Fract", + long_long_fract_type_node); + record_builtin_type (RID_MAX, "unsigned short _Fract", + unsigned_short_fract_type_node); + record_builtin_type (RID_MAX, "unsigned _Fract", + unsigned_fract_type_node); + record_builtin_type (RID_MAX, "unsigned long _Fract", + unsigned_long_fract_type_node); + record_builtin_type (RID_MAX, "unsigned long long _Fract", + unsigned_long_long_fract_type_node); + record_builtin_type (RID_MAX, "_Sat short _Fract", + sat_short_fract_type_node); + record_builtin_type (RID_MAX, "_Sat _Fract", sat_fract_type_node); + record_builtin_type (RID_MAX, "_Sat long _Fract", + sat_long_fract_type_node); + record_builtin_type (RID_MAX, "_Sat long long _Fract", + sat_long_long_fract_type_node); + record_builtin_type (RID_MAX, "_Sat unsigned short _Fract", + sat_unsigned_short_fract_type_node); + record_builtin_type (RID_MAX, "_Sat unsigned _Fract", + sat_unsigned_fract_type_node); + record_builtin_type (RID_MAX, "_Sat unsigned long _Fract", + sat_unsigned_long_fract_type_node); + record_builtin_type (RID_MAX, "_Sat unsigned long long _Fract", + sat_unsigned_long_long_fract_type_node); + record_builtin_type (RID_MAX, "short _Accum", short_accum_type_node); + record_builtin_type (RID_ACCUM, NULL, accum_type_node); + record_builtin_type (RID_MAX, "long _Accum", long_accum_type_node); + record_builtin_type (RID_MAX, "long long _Accum", + long_long_accum_type_node); + record_builtin_type (RID_MAX, "unsigned short _Accum", + unsigned_short_accum_type_node); + record_builtin_type (RID_MAX, "unsigned _Accum", + unsigned_accum_type_node); + record_builtin_type (RID_MAX, "unsigned long _Accum", + unsigned_long_accum_type_node); + record_builtin_type (RID_MAX, "unsigned long long _Accum", + unsigned_long_long_accum_type_node); + record_builtin_type (RID_MAX, "_Sat short _Accum", + sat_short_accum_type_node); + record_builtin_type (RID_MAX, "_Sat _Accum", sat_accum_type_node); + record_builtin_type (RID_MAX, "_Sat long _Accum", + sat_long_accum_type_node); + record_builtin_type (RID_MAX, "_Sat long long _Accum", + sat_long_long_accum_type_node); + record_builtin_type (RID_MAX, "_Sat unsigned short _Accum", + sat_unsigned_short_accum_type_node); + record_builtin_type (RID_MAX, "_Sat unsigned _Accum", + sat_unsigned_accum_type_node); + record_builtin_type (RID_MAX, "_Sat unsigned long _Accum", + sat_unsigned_long_accum_type_node); + record_builtin_type (RID_MAX, "_Sat unsigned long long _Accum", + sat_unsigned_long_long_accum_type_node); + + } + + lang_hooks.decls.pushdecl (build_decl (UNKNOWN_LOCATION, + TYPE_DECL, + get_identifier ("complex int"), + complex_integer_type_node)); + lang_hooks.decls.pushdecl (build_decl (UNKNOWN_LOCATION, + TYPE_DECL, + get_identifier ("complex float"), + complex_float_type_node)); + lang_hooks.decls.pushdecl (build_decl (UNKNOWN_LOCATION, + TYPE_DECL, + get_identifier ("complex double"), + complex_double_type_node)); + lang_hooks.decls.pushdecl + (build_decl (UNKNOWN_LOCATION, + TYPE_DECL, get_identifier ("complex long double"), + complex_long_double_type_node)); + + if (c_dialect_cxx ()) + /* For C++, make fileptr_type_node a distinct void * type until + FILE type is defined. */ + fileptr_type_node = build_variant_type_copy (ptr_type_node); + + record_builtin_type (RID_VOID, NULL, void_type_node); + + /* Set the TYPE_NAME for any variants that were built before + record_builtin_type gave names to the built-in types. */ + { + tree void_name = TYPE_NAME (void_type_node); + TYPE_NAME (void_type_node) = NULL_TREE; + TYPE_NAME (build_qualified_type (void_type_node, TYPE_QUAL_CONST)) + = void_name; + TYPE_NAME (void_type_node) = void_name; + } + + /* This node must not be shared. */ + void_zero_node = make_node (INTEGER_CST); + TREE_TYPE (void_zero_node) = void_type_node; + + void_list_node = build_void_list_node (); + + /* Make a type to be the domain of a few array types + whose domains don't really matter. + 200 is small enough that it always fits in size_t + and large enough that it can hold most function names for the + initializations of __FUNCTION__ and __PRETTY_FUNCTION__. */ + array_domain_type = build_index_type (size_int (200)); + + /* Make a type for arrays of characters. + With luck nothing will ever really depend on the length of this + array type. */ + char_array_type_node + = build_array_type (char_type_node, array_domain_type); + + /* Likewise for arrays of ints. */ + int_array_type_node + = build_array_type (integer_type_node, array_domain_type); + + string_type_node = build_pointer_type (char_type_node); + const_string_type_node + = build_pointer_type (build_qualified_type + (char_type_node, TYPE_QUAL_CONST)); + + /* This is special for C++ so functions can be overloaded. */ + wchar_type_node = get_identifier (MODIFIED_WCHAR_TYPE); + wchar_type_node = TREE_TYPE (identifier_global_value (wchar_type_node)); + wchar_type_size = TYPE_PRECISION (wchar_type_node); + underlying_wchar_type_node = wchar_type_node; + if (c_dialect_cxx ()) + { + if (TYPE_UNSIGNED (wchar_type_node)) + wchar_type_node = make_unsigned_type (wchar_type_size); + else + wchar_type_node = make_signed_type (wchar_type_size); + record_builtin_type (RID_WCHAR, "wchar_t", wchar_type_node); + } + + /* This is for wide string constants. */ + wchar_array_type_node + = build_array_type (wchar_type_node, array_domain_type); + + /* Define 'char16_t'. */ + char16_type_node = get_identifier (CHAR16_TYPE); + char16_type_node = TREE_TYPE (identifier_global_value (char16_type_node)); + char16_type_size = TYPE_PRECISION (char16_type_node); + if (c_dialect_cxx ()) + { + char16_type_node = make_unsigned_type (char16_type_size); + + if (cxx_dialect == cxx0x) + record_builtin_type (RID_CHAR16, "char16_t", char16_type_node); + } + + /* This is for UTF-16 string constants. */ + char16_array_type_node + = build_array_type (char16_type_node, array_domain_type); + + /* Define 'char32_t'. */ + char32_type_node = get_identifier (CHAR32_TYPE); + char32_type_node = TREE_TYPE (identifier_global_value (char32_type_node)); + char32_type_size = TYPE_PRECISION (char32_type_node); + if (c_dialect_cxx ()) + { + char32_type_node = make_unsigned_type (char32_type_size); + + if (cxx_dialect == cxx0x) + record_builtin_type (RID_CHAR32, "char32_t", char32_type_node); + } + + /* This is for UTF-32 string constants. */ + char32_array_type_node + = build_array_type (char32_type_node, array_domain_type); + + wint_type_node = + TREE_TYPE (identifier_global_value (get_identifier (WINT_TYPE))); + + intmax_type_node = + TREE_TYPE (identifier_global_value (get_identifier (INTMAX_TYPE))); + uintmax_type_node = + TREE_TYPE (identifier_global_value (get_identifier (UINTMAX_TYPE))); + + if (SIG_ATOMIC_TYPE) + sig_atomic_type_node = + TREE_TYPE (identifier_global_value (c_get_ident (SIG_ATOMIC_TYPE))); + if (INT8_TYPE) + int8_type_node = + TREE_TYPE (identifier_global_value (c_get_ident (INT8_TYPE))); + if (INT16_TYPE) + int16_type_node = + TREE_TYPE (identifier_global_value (c_get_ident (INT16_TYPE))); + if (INT32_TYPE) + int32_type_node = + TREE_TYPE (identifier_global_value (c_get_ident (INT32_TYPE))); + if (INT64_TYPE) + int64_type_node = + TREE_TYPE (identifier_global_value (c_get_ident (INT64_TYPE))); + if (UINT8_TYPE) + uint8_type_node = + TREE_TYPE (identifier_global_value (c_get_ident (UINT8_TYPE))); + if (UINT16_TYPE) + uint16_type_node = + TREE_TYPE (identifier_global_value (c_get_ident (UINT16_TYPE))); + if (UINT32_TYPE) + c_uint32_type_node = + TREE_TYPE (identifier_global_value (c_get_ident (UINT32_TYPE))); + if (UINT64_TYPE) + c_uint64_type_node = + TREE_TYPE (identifier_global_value (c_get_ident (UINT64_TYPE))); + if (INT_LEAST8_TYPE) + int_least8_type_node = + TREE_TYPE (identifier_global_value (c_get_ident (INT_LEAST8_TYPE))); + if (INT_LEAST16_TYPE) + int_least16_type_node = + TREE_TYPE (identifier_global_value (c_get_ident (INT_LEAST16_TYPE))); + if (INT_LEAST32_TYPE) + int_least32_type_node = + TREE_TYPE (identifier_global_value (c_get_ident (INT_LEAST32_TYPE))); + if (INT_LEAST64_TYPE) + int_least64_type_node = + TREE_TYPE (identifier_global_value (c_get_ident (INT_LEAST64_TYPE))); + if (UINT_LEAST8_TYPE) + uint_least8_type_node = + TREE_TYPE (identifier_global_value (c_get_ident (UINT_LEAST8_TYPE))); + if (UINT_LEAST16_TYPE) + uint_least16_type_node = + TREE_TYPE (identifier_global_value (c_get_ident (UINT_LEAST16_TYPE))); + if (UINT_LEAST32_TYPE) + uint_least32_type_node = + TREE_TYPE (identifier_global_value (c_get_ident (UINT_LEAST32_TYPE))); + if (UINT_LEAST64_TYPE) + uint_least64_type_node = + TREE_TYPE (identifier_global_value (c_get_ident (UINT_LEAST64_TYPE))); + if (INT_FAST8_TYPE) + int_fast8_type_node = + TREE_TYPE (identifier_global_value (c_get_ident (INT_FAST8_TYPE))); + if (INT_FAST16_TYPE) + int_fast16_type_node = + TREE_TYPE (identifier_global_value (c_get_ident (INT_FAST16_TYPE))); + if (INT_FAST32_TYPE) + int_fast32_type_node = + TREE_TYPE (identifier_global_value (c_get_ident (INT_FAST32_TYPE))); + if (INT_FAST64_TYPE) + int_fast64_type_node = + TREE_TYPE (identifier_global_value (c_get_ident (INT_FAST64_TYPE))); + if (UINT_FAST8_TYPE) + uint_fast8_type_node = + TREE_TYPE (identifier_global_value (c_get_ident (UINT_FAST8_TYPE))); + if (UINT_FAST16_TYPE) + uint_fast16_type_node = + TREE_TYPE (identifier_global_value (c_get_ident (UINT_FAST16_TYPE))); + if (UINT_FAST32_TYPE) + uint_fast32_type_node = + TREE_TYPE (identifier_global_value (c_get_ident (UINT_FAST32_TYPE))); + if (UINT_FAST64_TYPE) + uint_fast64_type_node = + TREE_TYPE (identifier_global_value (c_get_ident (UINT_FAST64_TYPE))); + if (INTPTR_TYPE) + intptr_type_node = + TREE_TYPE (identifier_global_value (c_get_ident (INTPTR_TYPE))); + if (UINTPTR_TYPE) + uintptr_type_node = + TREE_TYPE (identifier_global_value (c_get_ident (UINTPTR_TYPE))); + + default_function_type = build_function_type (integer_type_node, NULL_TREE); + ptrdiff_type_node + = TREE_TYPE (identifier_global_value (get_identifier (PTRDIFF_TYPE))); + unsigned_ptrdiff_type_node = c_common_unsigned_type (ptrdiff_type_node); + + lang_hooks.decls.pushdecl + (build_decl (UNKNOWN_LOCATION, + TYPE_DECL, get_identifier ("__builtin_va_list"), + va_list_type_node)); + if (targetm.enum_va_list_p) + { + int l; + const char *pname; + tree ptype; + + for (l = 0; targetm.enum_va_list_p (l, &pname, &ptype); ++l) + { + lang_hooks.decls.pushdecl + (build_decl (UNKNOWN_LOCATION, + TYPE_DECL, get_identifier (pname), + ptype)); + + } + } + + if (TREE_CODE (va_list_type_node) == ARRAY_TYPE) + { + va_list_arg_type_node = va_list_ref_type_node = + build_pointer_type (TREE_TYPE (va_list_type_node)); + } + else + { + va_list_arg_type_node = va_list_type_node; + va_list_ref_type_node = build_reference_type (va_list_type_node); + } + + if (!flag_preprocess_only) + c_define_builtins (va_list_ref_type_node, va_list_arg_type_node); + + main_identifier_node = get_identifier ("main"); + + /* Create the built-in __null node. It is important that this is + not shared. */ + null_node = make_node (INTEGER_CST); + TREE_TYPE (null_node) = c_common_type_for_size (POINTER_SIZE, 0); + + /* Since builtin_types isn't gc'ed, don't export these nodes. */ + memset (builtin_types, 0, sizeof (builtin_types)); +} + +/* The number of named compound-literals generated thus far. */ +static GTY(()) int compound_literal_number; + +/* Set DECL_NAME for DECL, a VAR_DECL for a compound-literal. */ + +void +set_compound_literal_name (tree decl) +{ + char *name; + ASM_FORMAT_PRIVATE_NAME (name, "__compound_literal", + compound_literal_number); + compound_literal_number++; + DECL_NAME (decl) = get_identifier (name); +} + +tree +build_va_arg (location_t loc, tree expr, tree type) +{ + expr = build1 (VA_ARG_EXPR, type, expr); + SET_EXPR_LOCATION (expr, loc); + return expr; +} + + +/* Linked list of disabled built-in functions. */ + +typedef struct disabled_builtin +{ + const char *name; + struct disabled_builtin *next; +} disabled_builtin; +static disabled_builtin *disabled_builtins = NULL; + +static bool builtin_function_disabled_p (const char *); + +/* Disable a built-in function specified by -fno-builtin-NAME. If NAME + begins with "__builtin_", give an error. */ + +void +disable_builtin_function (const char *name) +{ + if (strncmp (name, "__builtin_", strlen ("__builtin_")) == 0) + error ("cannot disable built-in function %qs", name); + else + { + disabled_builtin *new_disabled_builtin = XNEW (disabled_builtin); + new_disabled_builtin->name = name; + new_disabled_builtin->next = disabled_builtins; + disabled_builtins = new_disabled_builtin; + } +} + + +/* Return true if the built-in function NAME has been disabled, false + otherwise. */ + +static bool +builtin_function_disabled_p (const char *name) +{ + disabled_builtin *p; + for (p = disabled_builtins; p != NULL; p = p->next) + { + if (strcmp (name, p->name) == 0) + return true; + } + return false; +} + + +/* Worker for DEF_BUILTIN. + Possibly define a builtin function with one or two names. + Does not declare a non-__builtin_ function if flag_no_builtin, or if + nonansi_p and flag_no_nonansi_builtin. */ + +static void +def_builtin_1 (enum built_in_function fncode, + const char *name, + enum built_in_class fnclass, + tree fntype, tree libtype, + bool both_p, bool fallback_p, bool nonansi_p, + tree fnattrs, bool implicit_p) +{ + tree decl; + const char *libname; + + if (fntype == error_mark_node) + return; + + gcc_assert ((!both_p && !fallback_p) + || !strncmp (name, "__builtin_", + strlen ("__builtin_"))); + + libname = name + strlen ("__builtin_"); + decl = add_builtin_function (name, fntype, fncode, fnclass, + (fallback_p ? libname : NULL), + fnattrs); + if (both_p + && !flag_no_builtin && !builtin_function_disabled_p (libname) + && !(nonansi_p && flag_no_nonansi_builtin)) + add_builtin_function (libname, libtype, fncode, fnclass, + NULL, fnattrs); + + built_in_decls[(int) fncode] = decl; + if (implicit_p) + implicit_built_in_decls[(int) fncode] = decl; +} + +/* Nonzero if the type T promotes to int. This is (nearly) the + integral promotions defined in ISO C99 6.3.1.1/2. */ + +bool +c_promoting_integer_type_p (const_tree t) +{ + switch (TREE_CODE (t)) + { + case INTEGER_TYPE: + return (TYPE_MAIN_VARIANT (t) == char_type_node + || TYPE_MAIN_VARIANT (t) == signed_char_type_node + || TYPE_MAIN_VARIANT (t) == unsigned_char_type_node + || TYPE_MAIN_VARIANT (t) == short_integer_type_node + || TYPE_MAIN_VARIANT (t) == short_unsigned_type_node + || TYPE_PRECISION (t) < TYPE_PRECISION (integer_type_node)); + + case ENUMERAL_TYPE: + /* ??? Technically all enumerations not larger than an int + promote to an int. But this is used along code paths + that only want to notice a size change. */ + return TYPE_PRECISION (t) < TYPE_PRECISION (integer_type_node); + + case BOOLEAN_TYPE: + return 1; + + default: + return 0; + } +} + +/* Return 1 if PARMS specifies a fixed number of parameters + and none of their types is affected by default promotions. */ + +int +self_promoting_args_p (const_tree parms) +{ + const_tree t; + for (t = parms; t; t = TREE_CHAIN (t)) + { + tree type = TREE_VALUE (t); + + if (type == error_mark_node) + continue; + + if (TREE_CHAIN (t) == 0 && type != void_type_node) + return 0; + + if (type == 0) + return 0; + + if (TYPE_MAIN_VARIANT (type) == float_type_node) + return 0; + + if (c_promoting_integer_type_p (type)) + return 0; + } + return 1; +} + +/* Recursively remove any '*' or '&' operator from TYPE. */ +tree +strip_pointer_operator (tree t) +{ + while (POINTER_TYPE_P (t)) + t = TREE_TYPE (t); + return t; +} + +/* Recursively remove pointer or array type from TYPE. */ +tree +strip_pointer_or_array_types (tree t) +{ + while (TREE_CODE (t) == ARRAY_TYPE || POINTER_TYPE_P (t)) + t = TREE_TYPE (t); + return t; +} + +/* Used to compare case labels. K1 and K2 are actually tree nodes + representing case labels, or NULL_TREE for a `default' label. + Returns -1 if K1 is ordered before K2, -1 if K1 is ordered after + K2, and 0 if K1 and K2 are equal. */ + +int +case_compare (splay_tree_key k1, splay_tree_key k2) +{ + /* Consider a NULL key (such as arises with a `default' label) to be + smaller than anything else. */ + if (!k1) + return k2 ? -1 : 0; + else if (!k2) + return k1 ? 1 : 0; + + return tree_int_cst_compare ((tree) k1, (tree) k2); +} + +/* Process a case label, located at LOC, for the range LOW_VALUE + ... HIGH_VALUE. If LOW_VALUE and HIGH_VALUE are both NULL_TREE + then this case label is actually a `default' label. If only + HIGH_VALUE is NULL_TREE, then case label was declared using the + usual C/C++ syntax, rather than the GNU case range extension. + CASES is a tree containing all the case ranges processed so far; + COND is the condition for the switch-statement itself. Returns the + CASE_LABEL_EXPR created, or ERROR_MARK_NODE if no CASE_LABEL_EXPR + is created. */ + +tree +c_add_case_label (location_t loc, splay_tree cases, tree cond, tree orig_type, + tree low_value, tree high_value) +{ + tree type; + tree label; + tree case_label; + splay_tree_node node; + + /* Create the LABEL_DECL itself. */ + label = create_artificial_label (loc); + + /* If there was an error processing the switch condition, bail now + before we get more confused. */ + if (!cond || cond == error_mark_node) + goto error_out; + + if ((low_value && TREE_TYPE (low_value) + && POINTER_TYPE_P (TREE_TYPE (low_value))) + || (high_value && TREE_TYPE (high_value) + && POINTER_TYPE_P (TREE_TYPE (high_value)))) + { + error_at (loc, "pointers are not permitted as case values"); + goto error_out; + } + + /* Case ranges are a GNU extension. */ + if (high_value) + pedwarn (loc, OPT_pedantic, + "range expressions in switch statements are non-standard"); + + type = TREE_TYPE (cond); + if (low_value) + { + low_value = check_case_value (low_value); + low_value = convert_and_check (type, low_value); + if (low_value == error_mark_node) + goto error_out; + } + if (high_value) + { + high_value = check_case_value (high_value); + high_value = convert_and_check (type, high_value); + if (high_value == error_mark_node) + goto error_out; + } + + if (low_value && high_value) + { + /* If the LOW_VALUE and HIGH_VALUE are the same, then this isn't + really a case range, even though it was written that way. + Remove the HIGH_VALUE to simplify later processing. */ + if (tree_int_cst_equal (low_value, high_value)) + high_value = NULL_TREE; + else if (!tree_int_cst_lt (low_value, high_value)) + warning_at (loc, 0, "empty range specified"); + } + + /* See if the case is in range of the type of the original testing + expression. If both low_value and high_value are out of range, + don't insert the case label and return NULL_TREE. */ + if (low_value + && !check_case_bounds (type, orig_type, + &low_value, high_value ? &high_value : NULL)) + return NULL_TREE; + + /* Look up the LOW_VALUE in the table of case labels we already + have. */ + node = splay_tree_lookup (cases, (splay_tree_key) low_value); + /* If there was not an exact match, check for overlapping ranges. + There's no need to do this if there's no LOW_VALUE or HIGH_VALUE; + that's a `default' label and the only overlap is an exact match. */ + if (!node && (low_value || high_value)) + { + splay_tree_node low_bound; + splay_tree_node high_bound; + + /* Even though there wasn't an exact match, there might be an + overlap between this case range and another case range. + Since we've (inductively) not allowed any overlapping case + ranges, we simply need to find the greatest low case label + that is smaller that LOW_VALUE, and the smallest low case + label that is greater than LOW_VALUE. If there is an overlap + it will occur in one of these two ranges. */ + low_bound = splay_tree_predecessor (cases, + (splay_tree_key) low_value); + high_bound = splay_tree_successor (cases, + (splay_tree_key) low_value); + + /* Check to see if the LOW_BOUND overlaps. It is smaller than + the LOW_VALUE, so there is no need to check unless the + LOW_BOUND is in fact itself a case range. */ + if (low_bound + && CASE_HIGH ((tree) low_bound->value) + && tree_int_cst_compare (CASE_HIGH ((tree) low_bound->value), + low_value) >= 0) + node = low_bound; + /* Check to see if the HIGH_BOUND overlaps. The low end of that + range is bigger than the low end of the current range, so we + are only interested if the current range is a real range, and + not an ordinary case label. */ + else if (high_bound + && high_value + && (tree_int_cst_compare ((tree) high_bound->key, + high_value) + <= 0)) + node = high_bound; + } + /* If there was an overlap, issue an error. */ + if (node) + { + tree duplicate = CASE_LABEL ((tree) node->value); + + if (high_value) + { + error_at (loc, "duplicate (or overlapping) case value"); + error_at (DECL_SOURCE_LOCATION (duplicate), + "this is the first entry overlapping that value"); + } + else if (low_value) + { + error_at (loc, "duplicate case value") ; + error_at (DECL_SOURCE_LOCATION (duplicate), "previously used here"); + } + else + { + error_at (loc, "multiple default labels in one switch"); + error_at (DECL_SOURCE_LOCATION (duplicate), + "this is the first default label"); + } + goto error_out; + } + + /* Add a CASE_LABEL to the statement-tree. */ + case_label = add_stmt (build_case_label (loc, low_value, high_value, label)); + /* Register this case label in the splay tree. */ + splay_tree_insert (cases, + (splay_tree_key) low_value, + (splay_tree_value) case_label); + + return case_label; + + error_out: + /* Add a label so that the back-end doesn't think that the beginning of + the switch is unreachable. Note that we do not add a case label, as + that just leads to duplicates and thence to failure later on. */ + if (!cases->root) + { + tree t = create_artificial_label (loc); + add_stmt (build_stmt (loc, LABEL_EXPR, t)); + } + return error_mark_node; +} + +/* Subroutines of c_do_switch_warnings, called via splay_tree_foreach. + Used to verify that case values match up with enumerator values. */ + +static void +match_case_to_enum_1 (tree key, tree type, tree label) +{ + char buf[2 + 2*HOST_BITS_PER_WIDE_INT/4 + 1]; + + /* ??? Not working too hard to print the double-word value. + Should perhaps be done with %lwd in the diagnostic routines? */ + if (TREE_INT_CST_HIGH (key) == 0) + snprintf (buf, sizeof (buf), HOST_WIDE_INT_PRINT_UNSIGNED, + TREE_INT_CST_LOW (key)); + else if (!TYPE_UNSIGNED (type) + && TREE_INT_CST_HIGH (key) == -1 + && TREE_INT_CST_LOW (key) != 0) + snprintf (buf, sizeof (buf), "-" HOST_WIDE_INT_PRINT_UNSIGNED, + -TREE_INT_CST_LOW (key)); + else + snprintf (buf, sizeof (buf), HOST_WIDE_INT_PRINT_DOUBLE_HEX, + (unsigned HOST_WIDE_INT) TREE_INT_CST_HIGH (key), + (unsigned HOST_WIDE_INT) TREE_INT_CST_LOW (key)); + + if (TYPE_NAME (type) == 0) + warning_at (DECL_SOURCE_LOCATION (CASE_LABEL (label)), + warn_switch ? OPT_Wswitch : OPT_Wswitch_enum, + "case value %qs not in enumerated type", + buf); + else + warning_at (DECL_SOURCE_LOCATION (CASE_LABEL (label)), + warn_switch ? OPT_Wswitch : OPT_Wswitch_enum, + "case value %qs not in enumerated type %qT", + buf, type); +} + +/* Subroutine of c_do_switch_warnings, called via splay_tree_foreach. + Used to verify that case values match up with enumerator values. */ + +static int +match_case_to_enum (splay_tree_node node, void *data) +{ + tree label = (tree) node->value; + tree type = (tree) data; + + /* Skip default case. */ + if (!CASE_LOW (label)) + return 0; + + /* If CASE_LOW_SEEN is not set, that means CASE_LOW did not appear + when we did our enum->case scan. Reset our scratch bit after. */ + if (!CASE_LOW_SEEN (label)) + match_case_to_enum_1 (CASE_LOW (label), type, label); + else + CASE_LOW_SEEN (label) = 0; + + /* If CASE_HIGH is non-null, we have a range. If CASE_HIGH_SEEN is + not set, that means that CASE_HIGH did not appear when we did our + enum->case scan. Reset our scratch bit after. */ + if (CASE_HIGH (label)) + { + if (!CASE_HIGH_SEEN (label)) + match_case_to_enum_1 (CASE_HIGH (label), type, label); + else + CASE_HIGH_SEEN (label) = 0; + } + + return 0; +} + +/* Handle -Wswitch*. Called from the front end after parsing the + switch construct. */ +/* ??? Should probably be somewhere generic, since other languages + besides C and C++ would want this. At the moment, however, C/C++ + are the only tree-ssa languages that support enumerations at all, + so the point is moot. */ + +void +c_do_switch_warnings (splay_tree cases, location_t switch_location, + tree type, tree cond) +{ + splay_tree_node default_node; + splay_tree_node node; + tree chain; + + if (!warn_switch && !warn_switch_enum && !warn_switch_default) + return; + + default_node = splay_tree_lookup (cases, (splay_tree_key) NULL); + if (!default_node) + warning_at (switch_location, OPT_Wswitch_default, + "switch missing default case"); + + /* From here on, we only care about about enumerated types. */ + if (!type || TREE_CODE (type) != ENUMERAL_TYPE) + return; + + /* From here on, we only care about -Wswitch and -Wswitch-enum. */ + if (!warn_switch_enum && !warn_switch) + return; + + /* Check the cases. Warn about case values which are not members of + the enumerated type. For -Wswitch-enum, or for -Wswitch when + there is no default case, check that exactly all enumeration + literals are covered by the cases. */ + + /* Clearing COND if it is not an integer constant simplifies + the tests inside the loop below. */ + if (TREE_CODE (cond) != INTEGER_CST) + cond = NULL_TREE; + + /* The time complexity here is O(N*lg(N)) worst case, but for the + common case of monotonically increasing enumerators, it is + O(N), since the nature of the splay tree will keep the next + element adjacent to the root at all times. */ + + for (chain = TYPE_VALUES (type); chain; chain = TREE_CHAIN (chain)) + { + tree value = TREE_VALUE (chain); + if (TREE_CODE (value) == CONST_DECL) + value = DECL_INITIAL (value); + node = splay_tree_lookup (cases, (splay_tree_key) value); + if (node) + { + /* Mark the CASE_LOW part of the case entry as seen. */ + tree label = (tree) node->value; + CASE_LOW_SEEN (label) = 1; + continue; + } + + /* Even though there wasn't an exact match, there might be a + case range which includes the enumerator's value. */ + node = splay_tree_predecessor (cases, (splay_tree_key) value); + if (node && CASE_HIGH ((tree) node->value)) + { + tree label = (tree) node->value; + int cmp = tree_int_cst_compare (CASE_HIGH (label), value); + if (cmp >= 0) + { + /* If we match the upper bound exactly, mark the CASE_HIGH + part of the case entry as seen. */ + if (cmp == 0) + CASE_HIGH_SEEN (label) = 1; + continue; + } + } + + /* We've now determined that this enumerated literal isn't + handled by the case labels of the switch statement. */ + + /* If the switch expression is a constant, we only really care + about whether that constant is handled by the switch. */ + if (cond && tree_int_cst_compare (cond, value)) + continue; + + /* If there is a default_node, the only relevant option is + Wswitch-enum. Otherwise, if both are enabled then we prefer + to warn using -Wswitch because -Wswitch is enabled by -Wall + while -Wswitch-enum is explicit. */ + warning_at (switch_location, + (default_node || !warn_switch + ? OPT_Wswitch_enum + : OPT_Wswitch), + "enumeration value %qE not handled in switch", + TREE_PURPOSE (chain)); + } + + /* Warn if there are case expressions that don't correspond to + enumerators. This can occur since C and C++ don't enforce + type-checking of assignments to enumeration variables. + + The time complexity here is now always O(N) worst case, since + we should have marked both the lower bound and upper bound of + every disjoint case label, with CASE_LOW_SEEN and CASE_HIGH_SEEN + above. This scan also resets those fields. */ + + splay_tree_foreach (cases, match_case_to_enum, type); +} + +/* Finish an expression taking the address of LABEL (an + IDENTIFIER_NODE). Returns an expression for the address. + + LOC is the location for the expression returned. */ + +tree +finish_label_address_expr (tree label, location_t loc) +{ + tree result; + + pedwarn (input_location, OPT_pedantic, "taking the address of a label is non-standard"); + + if (label == error_mark_node) + return error_mark_node; + + label = lookup_label (label); + if (label == NULL_TREE) + result = null_pointer_node; + else + { + TREE_USED (label) = 1; + result = build1 (ADDR_EXPR, ptr_type_node, label); + /* The current function is not necessarily uninlinable. + Computed gotos are incompatible with inlining, but the value + here could be used only in a diagnostic, for example. */ + protected_set_expr_location (result, loc); + } + + return result; +} + + +/* Given a boolean expression ARG, return a tree representing an increment + or decrement (as indicated by CODE) of ARG. The front end must check for + invalid cases (e.g., decrement in C++). */ +tree +boolean_increment (enum tree_code code, tree arg) +{ + tree val; + tree true_res = build_int_cst (TREE_TYPE (arg), 1); + + arg = stabilize_reference (arg); + switch (code) + { + case PREINCREMENT_EXPR: + val = build2 (MODIFY_EXPR, TREE_TYPE (arg), arg, true_res); + break; + case POSTINCREMENT_EXPR: + val = build2 (MODIFY_EXPR, TREE_TYPE (arg), arg, true_res); + arg = save_expr (arg); + val = build2 (COMPOUND_EXPR, TREE_TYPE (arg), val, arg); + val = build2 (COMPOUND_EXPR, TREE_TYPE (arg), arg, val); + break; + case PREDECREMENT_EXPR: + val = build2 (MODIFY_EXPR, TREE_TYPE (arg), arg, + invert_truthvalue_loc (input_location, arg)); + break; + case POSTDECREMENT_EXPR: + val = build2 (MODIFY_EXPR, TREE_TYPE (arg), arg, + invert_truthvalue_loc (input_location, arg)); + arg = save_expr (arg); + val = build2 (COMPOUND_EXPR, TREE_TYPE (arg), val, arg); + val = build2 (COMPOUND_EXPR, TREE_TYPE (arg), arg, val); + break; + default: + gcc_unreachable (); + } + TREE_SIDE_EFFECTS (val) = 1; + return val; +} + +/* Built-in macros for stddef.h and stdint.h, that require macros + defined in this file. */ +void +c_stddef_cpp_builtins(void) +{ + builtin_define_with_value ("__SIZE_TYPE__", SIZE_TYPE, 0); + builtin_define_with_value ("__PTRDIFF_TYPE__", PTRDIFF_TYPE, 0); + builtin_define_with_value ("__WCHAR_TYPE__", MODIFIED_WCHAR_TYPE, 0); + builtin_define_with_value ("__WINT_TYPE__", WINT_TYPE, 0); + builtin_define_with_value ("__INTMAX_TYPE__", INTMAX_TYPE, 0); + builtin_define_with_value ("__UINTMAX_TYPE__", UINTMAX_TYPE, 0); + builtin_define_with_value ("__CHAR16_TYPE__", CHAR16_TYPE, 0); + builtin_define_with_value ("__CHAR32_TYPE__", CHAR32_TYPE, 0); + if (SIG_ATOMIC_TYPE) + builtin_define_with_value ("__SIG_ATOMIC_TYPE__", SIG_ATOMIC_TYPE, 0); + if (INT8_TYPE) + builtin_define_with_value ("__INT8_TYPE__", INT8_TYPE, 0); + if (INT16_TYPE) + builtin_define_with_value ("__INT16_TYPE__", INT16_TYPE, 0); + if (INT32_TYPE) + builtin_define_with_value ("__INT32_TYPE__", INT32_TYPE, 0); + if (INT64_TYPE) + builtin_define_with_value ("__INT64_TYPE__", INT64_TYPE, 0); + if (UINT8_TYPE) + builtin_define_with_value ("__UINT8_TYPE__", UINT8_TYPE, 0); + if (UINT16_TYPE) + builtin_define_with_value ("__UINT16_TYPE__", UINT16_TYPE, 0); + if (UINT32_TYPE) + builtin_define_with_value ("__UINT32_TYPE__", UINT32_TYPE, 0); + if (UINT64_TYPE) + builtin_define_with_value ("__UINT64_TYPE__", UINT64_TYPE, 0); + if (INT_LEAST8_TYPE) + builtin_define_with_value ("__INT_LEAST8_TYPE__", INT_LEAST8_TYPE, 0); + if (INT_LEAST16_TYPE) + builtin_define_with_value ("__INT_LEAST16_TYPE__", INT_LEAST16_TYPE, 0); + if (INT_LEAST32_TYPE) + builtin_define_with_value ("__INT_LEAST32_TYPE__", INT_LEAST32_TYPE, 0); + if (INT_LEAST64_TYPE) + builtin_define_with_value ("__INT_LEAST64_TYPE__", INT_LEAST64_TYPE, 0); + if (UINT_LEAST8_TYPE) + builtin_define_with_value ("__UINT_LEAST8_TYPE__", UINT_LEAST8_TYPE, 0); + if (UINT_LEAST16_TYPE) + builtin_define_with_value ("__UINT_LEAST16_TYPE__", UINT_LEAST16_TYPE, 0); + if (UINT_LEAST32_TYPE) + builtin_define_with_value ("__UINT_LEAST32_TYPE__", UINT_LEAST32_TYPE, 0); + if (UINT_LEAST64_TYPE) + builtin_define_with_value ("__UINT_LEAST64_TYPE__", UINT_LEAST64_TYPE, 0); + if (INT_FAST8_TYPE) + builtin_define_with_value ("__INT_FAST8_TYPE__", INT_FAST8_TYPE, 0); + if (INT_FAST16_TYPE) + builtin_define_with_value ("__INT_FAST16_TYPE__", INT_FAST16_TYPE, 0); + if (INT_FAST32_TYPE) + builtin_define_with_value ("__INT_FAST32_TYPE__", INT_FAST32_TYPE, 0); + if (INT_FAST64_TYPE) + builtin_define_with_value ("__INT_FAST64_TYPE__", INT_FAST64_TYPE, 0); + if (UINT_FAST8_TYPE) + builtin_define_with_value ("__UINT_FAST8_TYPE__", UINT_FAST8_TYPE, 0); + if (UINT_FAST16_TYPE) + builtin_define_with_value ("__UINT_FAST16_TYPE__", UINT_FAST16_TYPE, 0); + if (UINT_FAST32_TYPE) + builtin_define_with_value ("__UINT_FAST32_TYPE__", UINT_FAST32_TYPE, 0); + if (UINT_FAST64_TYPE) + builtin_define_with_value ("__UINT_FAST64_TYPE__", UINT_FAST64_TYPE, 0); + if (INTPTR_TYPE) + builtin_define_with_value ("__INTPTR_TYPE__", INTPTR_TYPE, 0); + if (UINTPTR_TYPE) + builtin_define_with_value ("__UINTPTR_TYPE__", UINTPTR_TYPE, 0); +} + +static void +c_init_attributes (void) +{ + /* Fill in the built_in_attributes array. */ +#define DEF_ATTR_NULL_TREE(ENUM) \ + built_in_attributes[(int) ENUM] = NULL_TREE; +#define DEF_ATTR_INT(ENUM, VALUE) \ + built_in_attributes[(int) ENUM] = build_int_cst (NULL_TREE, VALUE); +#define DEF_ATTR_IDENT(ENUM, STRING) \ + built_in_attributes[(int) ENUM] = get_identifier (STRING); +#define DEF_ATTR_TREE_LIST(ENUM, PURPOSE, VALUE, CHAIN) \ + built_in_attributes[(int) ENUM] \ + = tree_cons (built_in_attributes[(int) PURPOSE], \ + built_in_attributes[(int) VALUE], \ + built_in_attributes[(int) CHAIN]); +#include "builtin-attrs.def" +#undef DEF_ATTR_NULL_TREE +#undef DEF_ATTR_INT +#undef DEF_ATTR_IDENT +#undef DEF_ATTR_TREE_LIST +} + +/* Returns TRUE iff the attribute indicated by ATTR_ID takes a plain + identifier as an argument, so the front end shouldn't look it up. */ + +bool +attribute_takes_identifier_p (const_tree attr_id) +{ + if (is_attribute_p ("mode", attr_id) + || is_attribute_p ("format", attr_id) + || is_attribute_p ("cleanup", attr_id)) + return true; + else + return targetm.attribute_takes_identifier_p (attr_id); +} + +/* Attribute handlers common to C front ends. */ + +/* Handle a "packed" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_packed_attribute (tree *node, tree name, tree ARG_UNUSED (args), + int flags, bool *no_add_attrs) +{ + if (TYPE_P (*node)) + { + if (!(flags & (int) ATTR_FLAG_TYPE_IN_PLACE)) + *node = build_variant_type_copy (*node); + TYPE_PACKED (*node) = 1; + } + else if (TREE_CODE (*node) == FIELD_DECL) + { + if (TYPE_ALIGN (TREE_TYPE (*node)) <= BITS_PER_UNIT + /* Still pack bitfields. */ + && ! DECL_INITIAL (*node)) + warning (OPT_Wattributes, + "%qE attribute ignored for field of type %qT", + name, TREE_TYPE (*node)); + else + DECL_PACKED (*node) = 1; + } + /* We can't set DECL_PACKED for a VAR_DECL, because the bit is + used for DECL_REGISTER. It wouldn't mean anything anyway. + We can't set DECL_PACKED on the type of a TYPE_DECL, because + that changes what the typedef is typing. */ + else + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + + return NULL_TREE; +} + +/* Handle a "nocommon" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_nocommon_attribute (tree *node, tree name, + tree ARG_UNUSED (args), + int ARG_UNUSED (flags), bool *no_add_attrs) +{ + if (TREE_CODE (*node) == VAR_DECL) + DECL_COMMON (*node) = 0; + else + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + + return NULL_TREE; +} + +/* Handle a "common" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_common_attribute (tree *node, tree name, tree ARG_UNUSED (args), + int ARG_UNUSED (flags), bool *no_add_attrs) +{ + if (TREE_CODE (*node) == VAR_DECL) + DECL_COMMON (*node) = 1; + else + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + + return NULL_TREE; +} + +/* Handle a "noreturn" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_noreturn_attribute (tree *node, tree name, tree ARG_UNUSED (args), + int ARG_UNUSED (flags), bool *no_add_attrs) +{ + tree type = TREE_TYPE (*node); + + /* See FIXME comment in c_common_attribute_table. */ + if (TREE_CODE (*node) == FUNCTION_DECL) + TREE_THIS_VOLATILE (*node) = 1; + else if (TREE_CODE (type) == POINTER_TYPE + && TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE) + TREE_TYPE (*node) + = build_pointer_type + (build_type_variant (TREE_TYPE (type), + TYPE_READONLY (TREE_TYPE (type)), 1)); + else + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + + return NULL_TREE; +} + +/* Handle a "hot" and attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_hot_attribute (tree *node, tree name, tree ARG_UNUSED (args), + int ARG_UNUSED (flags), bool *no_add_attrs) +{ + if (TREE_CODE (*node) == FUNCTION_DECL) + { + if (lookup_attribute ("cold", DECL_ATTRIBUTES (*node)) != NULL) + { + warning (OPT_Wattributes, "%qE attribute conflicts with attribute %s", + name, "cold"); + *no_add_attrs = true; + } + /* Most of the rest of the hot processing is done later with + lookup_attribute. */ + } + else + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + + return NULL_TREE; +} +/* Handle a "cold" and attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_cold_attribute (tree *node, tree name, tree ARG_UNUSED (args), + int ARG_UNUSED (flags), bool *no_add_attrs) +{ + if (TREE_CODE (*node) == FUNCTION_DECL) + { + if (lookup_attribute ("hot", DECL_ATTRIBUTES (*node)) != NULL) + { + warning (OPT_Wattributes, "%qE attribute conflicts with attribute %s", + name, "hot"); + *no_add_attrs = true; + } + /* Most of the rest of the cold processing is done later with + lookup_attribute. */ + } + else + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + + return NULL_TREE; +} + +/* Handle a "noinline" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_noinline_attribute (tree *node, tree name, + tree ARG_UNUSED (args), + int ARG_UNUSED (flags), bool *no_add_attrs) +{ + if (TREE_CODE (*node) == FUNCTION_DECL) + DECL_UNINLINABLE (*node) = 1; + else + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + + return NULL_TREE; +} + +/* Handle a "noclone" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_noclone_attribute (tree *node, tree name, + tree ARG_UNUSED (args), + int ARG_UNUSED (flags), bool *no_add_attrs) +{ + if (TREE_CODE (*node) != FUNCTION_DECL) + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + + return NULL_TREE; +} + +/* Handle a "always_inline" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_always_inline_attribute (tree *node, tree name, + tree ARG_UNUSED (args), + int ARG_UNUSED (flags), + bool *no_add_attrs) +{ + if (TREE_CODE (*node) == FUNCTION_DECL) + { + /* Set the attribute and mark it for disregarding inline + limits. */ + DECL_DISREGARD_INLINE_LIMITS (*node) = 1; + } + else + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + + return NULL_TREE; +} + +/* Handle a "gnu_inline" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_gnu_inline_attribute (tree *node, tree name, + tree ARG_UNUSED (args), + int ARG_UNUSED (flags), + bool *no_add_attrs) +{ + if (TREE_CODE (*node) == FUNCTION_DECL && DECL_DECLARED_INLINE_P (*node)) + { + /* Do nothing else, just set the attribute. We'll get at + it later with lookup_attribute. */ + } + else + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + + return NULL_TREE; +} + +/* Handle an "artificial" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_artificial_attribute (tree *node, tree name, + tree ARG_UNUSED (args), + int ARG_UNUSED (flags), + bool *no_add_attrs) +{ + if (TREE_CODE (*node) == FUNCTION_DECL && DECL_DECLARED_INLINE_P (*node)) + { + /* Do nothing else, just set the attribute. We'll get at + it later with lookup_attribute. */ + } + else + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + + return NULL_TREE; +} + +/* Handle a "flatten" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_flatten_attribute (tree *node, tree name, + tree args ATTRIBUTE_UNUSED, + int flags ATTRIBUTE_UNUSED, bool *no_add_attrs) +{ + if (TREE_CODE (*node) == FUNCTION_DECL) + /* Do nothing else, just set the attribute. We'll get at + it later with lookup_attribute. */ + ; + else + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + + return NULL_TREE; +} + +/* Handle a "warning" or "error" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_error_attribute (tree *node, tree name, tree args, + int ARG_UNUSED (flags), bool *no_add_attrs) +{ + if (TREE_CODE (*node) == FUNCTION_DECL + || TREE_CODE (TREE_VALUE (args)) == STRING_CST) + /* Do nothing else, just set the attribute. We'll get at + it later with lookup_attribute. */ + ; + else + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + + return NULL_TREE; +} + +/* Handle a "used" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_used_attribute (tree *pnode, tree name, tree ARG_UNUSED (args), + int ARG_UNUSED (flags), bool *no_add_attrs) +{ + tree node = *pnode; + + if (TREE_CODE (node) == FUNCTION_DECL + || (TREE_CODE (node) == VAR_DECL && TREE_STATIC (node))) + { + TREE_USED (node) = 1; + DECL_PRESERVE_P (node) = 1; + if (TREE_CODE (node) == VAR_DECL) + DECL_READ_P (node) = 1; + } + else + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + + return NULL_TREE; +} + +/* Handle a "unused" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_unused_attribute (tree *node, tree name, tree ARG_UNUSED (args), + int flags, bool *no_add_attrs) +{ + if (DECL_P (*node)) + { + tree decl = *node; + + if (TREE_CODE (decl) == PARM_DECL + || TREE_CODE (decl) == VAR_DECL + || TREE_CODE (decl) == FUNCTION_DECL + || TREE_CODE (decl) == LABEL_DECL + || TREE_CODE (decl) == TYPE_DECL) + { + TREE_USED (decl) = 1; + if (TREE_CODE (decl) == VAR_DECL + || TREE_CODE (decl) == PARM_DECL) + DECL_READ_P (decl) = 1; + } + else + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + } + else + { + if (!(flags & (int) ATTR_FLAG_TYPE_IN_PLACE)) + *node = build_variant_type_copy (*node); + TREE_USED (*node) = 1; + } + + return NULL_TREE; +} + +/* Handle a "externally_visible" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_externally_visible_attribute (tree *pnode, tree name, + tree ARG_UNUSED (args), + int ARG_UNUSED (flags), + bool *no_add_attrs) +{ + tree node = *pnode; + + if (TREE_CODE (node) == FUNCTION_DECL || TREE_CODE (node) == VAR_DECL) + { + if ((!TREE_STATIC (node) && TREE_CODE (node) != FUNCTION_DECL + && !DECL_EXTERNAL (node)) || !TREE_PUBLIC (node)) + { + warning (OPT_Wattributes, + "%qE attribute have effect only on public objects", name); + *no_add_attrs = true; + } + } + else + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + + return NULL_TREE; +} + +/* Handle a "const" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_const_attribute (tree *node, tree name, tree ARG_UNUSED (args), + int ARG_UNUSED (flags), bool *no_add_attrs) +{ + tree type = TREE_TYPE (*node); + + /* See FIXME comment on noreturn in c_common_attribute_table. */ + if (TREE_CODE (*node) == FUNCTION_DECL) + TREE_READONLY (*node) = 1; + else if (TREE_CODE (type) == POINTER_TYPE + && TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE) + TREE_TYPE (*node) + = build_pointer_type + (build_type_variant (TREE_TYPE (type), 1, + TREE_THIS_VOLATILE (TREE_TYPE (type)))); + else + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + + return NULL_TREE; +} + +/* Handle a "transparent_union" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_transparent_union_attribute (tree *node, tree name, + tree ARG_UNUSED (args), int flags, + bool *no_add_attrs) +{ + tree type; + + *no_add_attrs = true; + + if (TREE_CODE (*node) == TYPE_DECL) + node = &TREE_TYPE (*node); + type = *node; + + if (TREE_CODE (type) == UNION_TYPE) + { + /* When IN_PLACE is set, leave the check for FIELDS and MODE to + the code in finish_struct. */ + if (!(flags & (int) ATTR_FLAG_TYPE_IN_PLACE)) + { + if (TYPE_FIELDS (type) == NULL_TREE + || TYPE_MODE (type) != DECL_MODE (TYPE_FIELDS (type))) + goto ignored; + + /* A type variant isn't good enough, since we don't a cast + to such a type removed as a no-op. */ + *node = type = build_duplicate_type (type); + } + + TYPE_TRANSPARENT_AGGR (type) = 1; + return NULL_TREE; + } + + ignored: + warning (OPT_Wattributes, "%qE attribute ignored", name); + return NULL_TREE; +} + +/* Subroutine of handle_{con,de}structor_attribute. Evaluate ARGS to + get the requested priority for a constructor or destructor, + possibly issuing diagnostics for invalid or reserved + priorities. */ + +static priority_type +get_priority (tree args, bool is_destructor) +{ + HOST_WIDE_INT pri; + tree arg; + + if (!args) + return DEFAULT_INIT_PRIORITY; + + if (!SUPPORTS_INIT_PRIORITY) + { + if (is_destructor) + error ("destructor priorities are not supported"); + else + error ("constructor priorities are not supported"); + return DEFAULT_INIT_PRIORITY; + } + + arg = TREE_VALUE (args); + if (!host_integerp (arg, /*pos=*/0) + || !INTEGRAL_TYPE_P (TREE_TYPE (arg))) + goto invalid; + + pri = tree_low_cst (TREE_VALUE (args), /*pos=*/0); + if (pri < 0 || pri > MAX_INIT_PRIORITY) + goto invalid; + + if (pri <= MAX_RESERVED_INIT_PRIORITY) + { + if (is_destructor) + warning (0, + "destructor priorities from 0 to %d are reserved " + "for the implementation", + MAX_RESERVED_INIT_PRIORITY); + else + warning (0, + "constructor priorities from 0 to %d are reserved " + "for the implementation", + MAX_RESERVED_INIT_PRIORITY); + } + return pri; + + invalid: + if (is_destructor) + error ("destructor priorities must be integers from 0 to %d inclusive", + MAX_INIT_PRIORITY); + else + error ("constructor priorities must be integers from 0 to %d inclusive", + MAX_INIT_PRIORITY); + return DEFAULT_INIT_PRIORITY; +} + +/* Handle a "constructor" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_constructor_attribute (tree *node, tree name, tree args, + int ARG_UNUSED (flags), + bool *no_add_attrs) +{ + tree decl = *node; + tree type = TREE_TYPE (decl); + + if (TREE_CODE (decl) == FUNCTION_DECL + && TREE_CODE (type) == FUNCTION_TYPE + && decl_function_context (decl) == 0) + { + priority_type priority; + DECL_STATIC_CONSTRUCTOR (decl) = 1; + priority = get_priority (args, /*is_destructor=*/false); + SET_DECL_INIT_PRIORITY (decl, priority); + TREE_USED (decl) = 1; + } + else + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + + return NULL_TREE; +} + +/* Handle a "destructor" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_destructor_attribute (tree *node, tree name, tree args, + int ARG_UNUSED (flags), + bool *no_add_attrs) +{ + tree decl = *node; + tree type = TREE_TYPE (decl); + + if (TREE_CODE (decl) == FUNCTION_DECL + && TREE_CODE (type) == FUNCTION_TYPE + && decl_function_context (decl) == 0) + { + priority_type priority; + DECL_STATIC_DESTRUCTOR (decl) = 1; + priority = get_priority (args, /*is_destructor=*/true); + SET_DECL_FINI_PRIORITY (decl, priority); + TREE_USED (decl) = 1; + } + else + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + + return NULL_TREE; +} + +/* Handle a "mode" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_mode_attribute (tree *node, tree name, tree args, + int ARG_UNUSED (flags), bool *no_add_attrs) +{ + tree type = *node; + tree ident = TREE_VALUE (args); + + *no_add_attrs = true; + + if (TREE_CODE (ident) != IDENTIFIER_NODE) + warning (OPT_Wattributes, "%qE attribute ignored", name); + else + { + int j; + const char *p = IDENTIFIER_POINTER (ident); + int len = strlen (p); + enum machine_mode mode = VOIDmode; + tree typefm; + bool valid_mode; + + if (len > 4 && p[0] == '_' && p[1] == '_' + && p[len - 1] == '_' && p[len - 2] == '_') + { + char *newp = (char *) alloca (len - 1); + + strcpy (newp, &p[2]); + newp[len - 4] = '\0'; + p = newp; + } + + /* Change this type to have a type with the specified mode. + First check for the special modes. */ + if (!strcmp (p, "byte")) + mode = byte_mode; + else if (!strcmp (p, "word")) + mode = word_mode; + else if (!strcmp (p, "pointer")) + mode = ptr_mode; + else if (!strcmp (p, "libgcc_cmp_return")) + mode = targetm.libgcc_cmp_return_mode (); + else if (!strcmp (p, "libgcc_shift_count")) + mode = targetm.libgcc_shift_count_mode (); + else if (!strcmp (p, "unwind_word")) + mode = targetm.unwind_word_mode (); + else + for (j = 0; j < NUM_MACHINE_MODES; j++) + if (!strcmp (p, GET_MODE_NAME (j))) + { + mode = (enum machine_mode) j; + break; + } + + if (mode == VOIDmode) + { + error ("unknown machine mode %qE", ident); + return NULL_TREE; + } + + valid_mode = false; + switch (GET_MODE_CLASS (mode)) + { + case MODE_INT: + case MODE_PARTIAL_INT: + case MODE_FLOAT: + case MODE_DECIMAL_FLOAT: + case MODE_FRACT: + case MODE_UFRACT: + case MODE_ACCUM: + case MODE_UACCUM: + valid_mode = targetm.scalar_mode_supported_p (mode); + break; + + case MODE_COMPLEX_INT: + case MODE_COMPLEX_FLOAT: + valid_mode = targetm.scalar_mode_supported_p (GET_MODE_INNER (mode)); + break; + + case MODE_VECTOR_INT: + case MODE_VECTOR_FLOAT: + case MODE_VECTOR_FRACT: + case MODE_VECTOR_UFRACT: + case MODE_VECTOR_ACCUM: + case MODE_VECTOR_UACCUM: + warning (OPT_Wattributes, "specifying vector types with " + "__attribute__ ((mode)) is deprecated"); + warning (OPT_Wattributes, + "use __attribute__ ((vector_size)) instead"); + valid_mode = vector_mode_valid_p (mode); + break; + + default: + break; + } + if (!valid_mode) + { + error ("unable to emulate %qs", p); + return NULL_TREE; + } + + if (POINTER_TYPE_P (type)) + { + addr_space_t as = TYPE_ADDR_SPACE (TREE_TYPE (type)); + tree (*fn)(tree, enum machine_mode, bool); + + if (!targetm.addr_space.valid_pointer_mode (mode, as)) + { + error ("invalid pointer mode %qs", p); + return NULL_TREE; + } + + if (TREE_CODE (type) == POINTER_TYPE) + fn = build_pointer_type_for_mode; + else + fn = build_reference_type_for_mode; + typefm = fn (TREE_TYPE (type), mode, false); + } + else + { + /* For fixed-point modes, we need to test if the signness of type + and the machine mode are consistent. */ + if (ALL_FIXED_POINT_MODE_P (mode) + && TYPE_UNSIGNED (type) != UNSIGNED_FIXED_POINT_MODE_P (mode)) + { + error ("signness of type and machine mode %qs don't match", p); + return NULL_TREE; + } + /* For fixed-point modes, we need to pass saturating info. */ + typefm = lang_hooks.types.type_for_mode (mode, + ALL_FIXED_POINT_MODE_P (mode) ? TYPE_SATURATING (type) + : TYPE_UNSIGNED (type)); + } + + if (typefm == NULL_TREE) + { + error ("no data type for mode %qs", p); + return NULL_TREE; + } + else if (TREE_CODE (type) == ENUMERAL_TYPE) + { + /* For enumeral types, copy the precision from the integer + type returned above. If not an INTEGER_TYPE, we can't use + this mode for this type. */ + if (TREE_CODE (typefm) != INTEGER_TYPE) + { + error ("cannot use mode %qs for enumeral types", p); + return NULL_TREE; + } + + if (flags & ATTR_FLAG_TYPE_IN_PLACE) + { + TYPE_PRECISION (type) = TYPE_PRECISION (typefm); + typefm = type; + } + else + { + /* We cannot build a type variant, as there's code that assumes + that TYPE_MAIN_VARIANT has the same mode. This includes the + debug generators. Instead, create a subrange type. This + results in all of the enumeral values being emitted only once + in the original, and the subtype gets them by reference. */ + if (TYPE_UNSIGNED (type)) + typefm = make_unsigned_type (TYPE_PRECISION (typefm)); + else + typefm = make_signed_type (TYPE_PRECISION (typefm)); + TREE_TYPE (typefm) = type; + } + } + else if (VECTOR_MODE_P (mode) + ? TREE_CODE (type) != TREE_CODE (TREE_TYPE (typefm)) + : TREE_CODE (type) != TREE_CODE (typefm)) + { + error ("mode %qs applied to inappropriate type", p); + return NULL_TREE; + } + + *node = typefm; + } + + return NULL_TREE; +} + +/* Handle a "section" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_section_attribute (tree *node, tree ARG_UNUSED (name), tree args, + int ARG_UNUSED (flags), bool *no_add_attrs) +{ + tree decl = *node; + + if (targetm.have_named_sections) + { + user_defined_section_attribute = true; + + if ((TREE_CODE (decl) == FUNCTION_DECL + || TREE_CODE (decl) == VAR_DECL) + && TREE_CODE (TREE_VALUE (args)) == STRING_CST) + { + if (TREE_CODE (decl) == VAR_DECL + && current_function_decl != NULL_TREE + && !TREE_STATIC (decl)) + { + error_at (DECL_SOURCE_LOCATION (decl), + "section attribute cannot be specified for " + "local variables"); + *no_add_attrs = true; + } + + /* The decl may have already been given a section attribute + from a previous declaration. Ensure they match. */ + else if (DECL_SECTION_NAME (decl) != NULL_TREE + && strcmp (TREE_STRING_POINTER (DECL_SECTION_NAME (decl)), + TREE_STRING_POINTER (TREE_VALUE (args))) != 0) + { + error ("section of %q+D conflicts with previous declaration", + *node); + *no_add_attrs = true; + } + else if (TREE_CODE (decl) == VAR_DECL + && !targetm.have_tls && targetm.emutls.tmpl_section + && DECL_THREAD_LOCAL_P (decl)) + { + error ("section of %q+D cannot be overridden", *node); + *no_add_attrs = true; + } + else + DECL_SECTION_NAME (decl) = TREE_VALUE (args); + } + else + { + error ("section attribute not allowed for %q+D", *node); + *no_add_attrs = true; + } + } + else + { + error_at (DECL_SOURCE_LOCATION (*node), + "section attributes are not supported for this target"); + *no_add_attrs = true; + } + + return NULL_TREE; +} + +/* Handle a "aligned" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_aligned_attribute (tree *node, tree ARG_UNUSED (name), tree args, + int flags, bool *no_add_attrs) +{ + tree decl = NULL_TREE; + tree *type = NULL; + int is_type = 0; + tree align_expr = (args ? TREE_VALUE (args) + : size_int (ATTRIBUTE_ALIGNED_VALUE / BITS_PER_UNIT)); + int i; + + if (DECL_P (*node)) + { + decl = *node; + type = &TREE_TYPE (decl); + is_type = TREE_CODE (*node) == TYPE_DECL; + } + else if (TYPE_P (*node)) + type = node, is_type = 1; + + if (TREE_CODE (align_expr) != INTEGER_CST) + { + error ("requested alignment is not a constant"); + *no_add_attrs = true; + } + else if ((i = tree_log2 (align_expr)) == -1) + { + error ("requested alignment is not a power of 2"); + *no_add_attrs = true; + } + else if (i >= HOST_BITS_PER_INT - BITS_PER_UNIT_LOG) + { + error ("requested alignment is too large"); + *no_add_attrs = true; + } + else if (is_type) + { + if ((flags & (int) ATTR_FLAG_TYPE_IN_PLACE)) + /* OK, modify the type in place. */; + /* If we have a TYPE_DECL, then copy the type, so that we + don't accidentally modify a builtin type. See pushdecl. */ + else if (decl && TREE_TYPE (decl) != error_mark_node + && DECL_ORIGINAL_TYPE (decl) == NULL_TREE) + { + tree tt = TREE_TYPE (decl); + *type = build_variant_type_copy (*type); + DECL_ORIGINAL_TYPE (decl) = tt; + TYPE_NAME (*type) = decl; + TREE_USED (*type) = TREE_USED (decl); + TREE_TYPE (decl) = *type; + } + else + *type = build_variant_type_copy (*type); + + TYPE_ALIGN (*type) = (1U << i) * BITS_PER_UNIT; + TYPE_USER_ALIGN (*type) = 1; + } + else if (! VAR_OR_FUNCTION_DECL_P (decl) + && TREE_CODE (decl) != FIELD_DECL) + { + error ("alignment may not be specified for %q+D", decl); + *no_add_attrs = true; + } + else if (TREE_CODE (decl) == FUNCTION_DECL + && DECL_ALIGN (decl) > (1U << i) * BITS_PER_UNIT) + { + if (DECL_USER_ALIGN (decl)) + error ("alignment for %q+D was previously specified as %d " + "and may not be decreased", decl, + DECL_ALIGN (decl) / BITS_PER_UNIT); + else + error ("alignment for %q+D must be at least %d", decl, + DECL_ALIGN (decl) / BITS_PER_UNIT); + *no_add_attrs = true; + } + else + { + DECL_ALIGN (decl) = (1U << i) * BITS_PER_UNIT; + DECL_USER_ALIGN (decl) = 1; + } + + return NULL_TREE; +} + +/* Handle a "weak" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_weak_attribute (tree *node, tree name, + tree ARG_UNUSED (args), + int ARG_UNUSED (flags), + bool * ARG_UNUSED (no_add_attrs)) +{ + if (TREE_CODE (*node) == FUNCTION_DECL + && DECL_DECLARED_INLINE_P (*node)) + { + error ("inline function %q+D cannot be declared weak", *node); + *no_add_attrs = true; + } + else if (TREE_CODE (*node) == FUNCTION_DECL + || TREE_CODE (*node) == VAR_DECL) + declare_weak (*node); + else + warning (OPT_Wattributes, "%qE attribute ignored", name); + + return NULL_TREE; +} + +/* Handle an "alias" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_alias_attribute (tree *node, tree name, tree args, + int ARG_UNUSED (flags), bool *no_add_attrs) +{ + tree decl = *node; + + if (TREE_CODE (decl) != FUNCTION_DECL && TREE_CODE (decl) != VAR_DECL) + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + else if ((TREE_CODE (decl) == FUNCTION_DECL && DECL_INITIAL (decl)) + || (TREE_CODE (decl) != FUNCTION_DECL + && TREE_PUBLIC (decl) && !DECL_EXTERNAL (decl)) + /* A static variable declaration is always a tentative definition, + but the alias is a non-tentative definition which overrides. */ + || (TREE_CODE (decl) != FUNCTION_DECL + && ! TREE_PUBLIC (decl) && DECL_INITIAL (decl))) + { + error ("%q+D defined both normally and as an alias", decl); + *no_add_attrs = true; + } + + /* Note that the very first time we process a nested declaration, + decl_function_context will not be set. Indeed, *would* never + be set except for the DECL_INITIAL/DECL_EXTERNAL frobbery that + we do below. After such frobbery, pushdecl would set the context. + In any case, this is never what we want. */ + else if (decl_function_context (decl) == 0 && current_function_decl == NULL) + { + tree id; + + id = TREE_VALUE (args); + if (TREE_CODE (id) != STRING_CST) + { + error ("alias argument not a string"); + *no_add_attrs = true; + return NULL_TREE; + } + id = get_identifier (TREE_STRING_POINTER (id)); + /* This counts as a use of the object pointed to. */ + TREE_USED (id) = 1; + + if (TREE_CODE (decl) == FUNCTION_DECL) + DECL_INITIAL (decl) = error_mark_node; + else + { + if (lookup_attribute ("weakref", DECL_ATTRIBUTES (decl))) + DECL_EXTERNAL (decl) = 1; + else + DECL_EXTERNAL (decl) = 0; + TREE_STATIC (decl) = 1; + } + } + else + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + + return NULL_TREE; +} + +/* Handle a "weakref" attribute; arguments as in struct + attribute_spec.handler. */ + +static tree +handle_weakref_attribute (tree *node, tree ARG_UNUSED (name), tree args, + int flags, bool *no_add_attrs) +{ + tree attr = NULL_TREE; + + /* We must ignore the attribute when it is associated with + local-scoped decls, since attribute alias is ignored and many + such symbols do not even have a DECL_WEAK field. */ + if (decl_function_context (*node) + || current_function_decl + || (TREE_CODE (*node) != VAR_DECL && TREE_CODE (*node) != FUNCTION_DECL)) + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + return NULL_TREE; + } + + /* The idea here is that `weakref("name")' mutates into `weakref, + alias("name")', and weakref without arguments, in turn, + implicitly adds weak. */ + + if (args) + { + attr = tree_cons (get_identifier ("alias"), args, attr); + attr = tree_cons (get_identifier ("weakref"), NULL_TREE, attr); + + *no_add_attrs = true; + + decl_attributes (node, attr, flags); + } + else + { + if (lookup_attribute ("alias", DECL_ATTRIBUTES (*node))) + error_at (DECL_SOURCE_LOCATION (*node), + "weakref attribute must appear before alias attribute"); + + /* Can't call declare_weak because it wants this to be TREE_PUBLIC, + and that isn't supported; and because it wants to add it to + the list of weak decls, which isn't helpful. */ + DECL_WEAK (*node) = 1; + } + + return NULL_TREE; +} + +/* Handle an "visibility" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_visibility_attribute (tree *node, tree name, tree args, + int ARG_UNUSED (flags), + bool *ARG_UNUSED (no_add_attrs)) +{ + tree decl = *node; + tree id = TREE_VALUE (args); + enum symbol_visibility vis; + + if (TYPE_P (*node)) + { + if (TREE_CODE (*node) == ENUMERAL_TYPE) + /* OK */; + else if (TREE_CODE (*node) != RECORD_TYPE && TREE_CODE (*node) != UNION_TYPE) + { + warning (OPT_Wattributes, "%qE attribute ignored on non-class types", + name); + return NULL_TREE; + } + else if (TYPE_FIELDS (*node)) + { + error ("%qE attribute ignored because %qT is already defined", + name, *node); + return NULL_TREE; + } + } + else if (decl_function_context (decl) != 0 || !TREE_PUBLIC (decl)) + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + return NULL_TREE; + } + + if (TREE_CODE (id) != STRING_CST) + { + error ("visibility argument not a string"); + return NULL_TREE; + } + + /* If this is a type, set the visibility on the type decl. */ + if (TYPE_P (decl)) + { + decl = TYPE_NAME (decl); + if (!decl) + return NULL_TREE; + if (TREE_CODE (decl) == IDENTIFIER_NODE) + { + warning (OPT_Wattributes, "%qE attribute ignored on types", + name); + return NULL_TREE; + } + } + + if (strcmp (TREE_STRING_POINTER (id), "default") == 0) + vis = VISIBILITY_DEFAULT; + else if (strcmp (TREE_STRING_POINTER (id), "internal") == 0) + vis = VISIBILITY_INTERNAL; + else if (strcmp (TREE_STRING_POINTER (id), "hidden") == 0) + vis = VISIBILITY_HIDDEN; + else if (strcmp (TREE_STRING_POINTER (id), "protected") == 0) + vis = VISIBILITY_PROTECTED; + else + { + error ("visibility argument must be one of \"default\", \"hidden\", \"protected\" or \"internal\""); + vis = VISIBILITY_DEFAULT; + } + + if (DECL_VISIBILITY_SPECIFIED (decl) + && vis != DECL_VISIBILITY (decl)) + { + tree attributes = (TYPE_P (*node) + ? TYPE_ATTRIBUTES (*node) + : DECL_ATTRIBUTES (decl)); + if (lookup_attribute ("visibility", attributes)) + error ("%qD redeclared with different visibility", decl); + else if (TARGET_DLLIMPORT_DECL_ATTRIBUTES + && lookup_attribute ("dllimport", attributes)) + error ("%qD was declared %qs which implies default visibility", + decl, "dllimport"); + else if (TARGET_DLLIMPORT_DECL_ATTRIBUTES + && lookup_attribute ("dllexport", attributes)) + error ("%qD was declared %qs which implies default visibility", + decl, "dllexport"); + } + + DECL_VISIBILITY (decl) = vis; + DECL_VISIBILITY_SPECIFIED (decl) = 1; + + /* Go ahead and attach the attribute to the node as well. This is needed + so we can determine whether we have VISIBILITY_DEFAULT because the + visibility was not specified, or because it was explicitly overridden + from the containing scope. */ + + return NULL_TREE; +} + +/* Determine the ELF symbol visibility for DECL, which is either a + variable or a function. It is an error to use this function if a + definition of DECL is not available in this translation unit. + Returns true if the final visibility has been determined by this + function; false if the caller is free to make additional + modifications. */ + +bool +c_determine_visibility (tree decl) +{ + gcc_assert (TREE_CODE (decl) == VAR_DECL + || TREE_CODE (decl) == FUNCTION_DECL); + + /* If the user explicitly specified the visibility with an + attribute, honor that. DECL_VISIBILITY will have been set during + the processing of the attribute. We check for an explicit + attribute, rather than just checking DECL_VISIBILITY_SPECIFIED, + to distinguish the use of an attribute from the use of a "#pragma + GCC visibility push(...)"; in the latter case we still want other + considerations to be able to overrule the #pragma. */ + if (lookup_attribute ("visibility", DECL_ATTRIBUTES (decl)) + || (TARGET_DLLIMPORT_DECL_ATTRIBUTES + && (lookup_attribute ("dllimport", DECL_ATTRIBUTES (decl)) + || lookup_attribute ("dllexport", DECL_ATTRIBUTES (decl))))) + return true; + + /* Set default visibility to whatever the user supplied with + visibility_specified depending on #pragma GCC visibility. */ + if (!DECL_VISIBILITY_SPECIFIED (decl)) + { + if (visibility_options.inpragma + || DECL_VISIBILITY (decl) != default_visibility) + { + DECL_VISIBILITY (decl) = default_visibility; + DECL_VISIBILITY_SPECIFIED (decl) = visibility_options.inpragma; + /* If visibility changed and DECL already has DECL_RTL, ensure + symbol flags are updated. */ + if (((TREE_CODE (decl) == VAR_DECL && TREE_STATIC (decl)) + || TREE_CODE (decl) == FUNCTION_DECL) + && DECL_RTL_SET_P (decl)) + make_decl_rtl (decl); + } + } + return false; +} + +/* Handle an "tls_model" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_tls_model_attribute (tree *node, tree name, tree args, + int ARG_UNUSED (flags), bool *no_add_attrs) +{ + tree id; + tree decl = *node; + enum tls_model kind; + + *no_add_attrs = true; + + if (TREE_CODE (decl) != VAR_DECL || !DECL_THREAD_LOCAL_P (decl)) + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + return NULL_TREE; + } + + kind = DECL_TLS_MODEL (decl); + id = TREE_VALUE (args); + if (TREE_CODE (id) != STRING_CST) + { + error ("tls_model argument not a string"); + return NULL_TREE; + } + + if (!strcmp (TREE_STRING_POINTER (id), "local-exec")) + kind = TLS_MODEL_LOCAL_EXEC; + else if (!strcmp (TREE_STRING_POINTER (id), "initial-exec")) + kind = TLS_MODEL_INITIAL_EXEC; + else if (!strcmp (TREE_STRING_POINTER (id), "local-dynamic")) + kind = optimize ? TLS_MODEL_LOCAL_DYNAMIC : TLS_MODEL_GLOBAL_DYNAMIC; + else if (!strcmp (TREE_STRING_POINTER (id), "global-dynamic")) + kind = TLS_MODEL_GLOBAL_DYNAMIC; + else + error ("tls_model argument must be one of \"local-exec\", \"initial-exec\", \"local-dynamic\" or \"global-dynamic\""); + + DECL_TLS_MODEL (decl) = kind; + return NULL_TREE; +} + +/* Handle a "no_instrument_function" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_no_instrument_function_attribute (tree *node, tree name, + tree ARG_UNUSED (args), + int ARG_UNUSED (flags), + bool *no_add_attrs) +{ + tree decl = *node; + + if (TREE_CODE (decl) != FUNCTION_DECL) + { + error_at (DECL_SOURCE_LOCATION (decl), + "%qE attribute applies only to functions", name); + *no_add_attrs = true; + } + else if (DECL_INITIAL (decl)) + { + error_at (DECL_SOURCE_LOCATION (decl), + "can%'t set %qE attribute after definition", name); + *no_add_attrs = true; + } + else + DECL_NO_INSTRUMENT_FUNCTION_ENTRY_EXIT (decl) = 1; + + return NULL_TREE; +} + +/* Handle a "malloc" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_malloc_attribute (tree *node, tree name, tree ARG_UNUSED (args), + int ARG_UNUSED (flags), bool *no_add_attrs) +{ + if (TREE_CODE (*node) == FUNCTION_DECL + && POINTER_TYPE_P (TREE_TYPE (TREE_TYPE (*node)))) + DECL_IS_MALLOC (*node) = 1; + else + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + + return NULL_TREE; +} + +/* Handle a "alloc_size" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_alloc_size_attribute (tree *node, tree ARG_UNUSED (name), tree args, + int ARG_UNUSED (flags), bool *no_add_attrs) +{ + unsigned arg_count = type_num_arguments (*node); + for (; args; args = TREE_CHAIN (args)) + { + tree position = TREE_VALUE (args); + + if (TREE_CODE (position) != INTEGER_CST + || TREE_INT_CST_HIGH (position) + || TREE_INT_CST_LOW (position) < 1 + || TREE_INT_CST_LOW (position) > arg_count ) + { + warning (OPT_Wattributes, + "alloc_size parameter outside range"); + *no_add_attrs = true; + return NULL_TREE; + } + } + return NULL_TREE; +} + +/* Handle a "fn spec" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_fnspec_attribute (tree *node ATTRIBUTE_UNUSED, tree ARG_UNUSED (name), + tree args, int ARG_UNUSED (flags), + bool *no_add_attrs ATTRIBUTE_UNUSED) +{ + gcc_assert (args + && TREE_CODE (TREE_VALUE (args)) == STRING_CST + && !TREE_CHAIN (args)); + return NULL_TREE; +} + +/* Handle a "returns_twice" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_returns_twice_attribute (tree *node, tree name, tree ARG_UNUSED (args), + int ARG_UNUSED (flags), bool *no_add_attrs) +{ + if (TREE_CODE (*node) == FUNCTION_DECL) + DECL_IS_RETURNS_TWICE (*node) = 1; + else + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + + return NULL_TREE; +} + +/* Handle a "no_limit_stack" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_no_limit_stack_attribute (tree *node, tree name, + tree ARG_UNUSED (args), + int ARG_UNUSED (flags), + bool *no_add_attrs) +{ + tree decl = *node; + + if (TREE_CODE (decl) != FUNCTION_DECL) + { + error_at (DECL_SOURCE_LOCATION (decl), + "%qE attribute applies only to functions", name); + *no_add_attrs = true; + } + else if (DECL_INITIAL (decl)) + { + error_at (DECL_SOURCE_LOCATION (decl), + "can%'t set %qE attribute after definition", name); + *no_add_attrs = true; + } + else + DECL_NO_LIMIT_STACK (decl) = 1; + + return NULL_TREE; +} + +/* Handle a "pure" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_pure_attribute (tree *node, tree name, tree ARG_UNUSED (args), + int ARG_UNUSED (flags), bool *no_add_attrs) +{ + if (TREE_CODE (*node) == FUNCTION_DECL) + DECL_PURE_P (*node) = 1; + /* ??? TODO: Support types. */ + else + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + + return NULL_TREE; +} + +/* Handle a "no vops" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_novops_attribute (tree *node, tree ARG_UNUSED (name), + tree ARG_UNUSED (args), int ARG_UNUSED (flags), + bool *ARG_UNUSED (no_add_attrs)) +{ + gcc_assert (TREE_CODE (*node) == FUNCTION_DECL); + DECL_IS_NOVOPS (*node) = 1; + return NULL_TREE; +} + +/* Handle a "deprecated" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_deprecated_attribute (tree *node, tree name, + tree args, int flags, + bool *no_add_attrs) +{ + tree type = NULL_TREE; + int warn = 0; + tree what = NULL_TREE; + + if (!args) + *no_add_attrs = true; + else if (TREE_CODE (TREE_VALUE (args)) != STRING_CST) + { + error ("deprecated message is not a string"); + *no_add_attrs = true; + } + + if (DECL_P (*node)) + { + tree decl = *node; + type = TREE_TYPE (decl); + + if (TREE_CODE (decl) == TYPE_DECL + || TREE_CODE (decl) == PARM_DECL + || TREE_CODE (decl) == VAR_DECL + || TREE_CODE (decl) == FUNCTION_DECL + || TREE_CODE (decl) == FIELD_DECL) + TREE_DEPRECATED (decl) = 1; + else + warn = 1; + } + else if (TYPE_P (*node)) + { + if (!(flags & (int) ATTR_FLAG_TYPE_IN_PLACE)) + *node = build_variant_type_copy (*node); + TREE_DEPRECATED (*node) = 1; + type = *node; + } + else + warn = 1; + + if (warn) + { + *no_add_attrs = true; + if (type && TYPE_NAME (type)) + { + if (TREE_CODE (TYPE_NAME (type)) == IDENTIFIER_NODE) + what = TYPE_NAME (*node); + else if (TREE_CODE (TYPE_NAME (type)) == TYPE_DECL + && DECL_NAME (TYPE_NAME (type))) + what = DECL_NAME (TYPE_NAME (type)); + } + if (what) + warning (OPT_Wattributes, "%qE attribute ignored for %qE", name, what); + else + warning (OPT_Wattributes, "%qE attribute ignored", name); + } + + return NULL_TREE; +} + +/* Handle a "vector_size" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_vector_size_attribute (tree *node, tree name, tree args, + int ARG_UNUSED (flags), + bool *no_add_attrs) +{ + unsigned HOST_WIDE_INT vecsize, nunits; + enum machine_mode orig_mode; + tree type = *node, new_type, size; + + *no_add_attrs = true; + + size = TREE_VALUE (args); + + if (!host_integerp (size, 1)) + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + return NULL_TREE; + } + + /* Get the vector size (in bytes). */ + vecsize = tree_low_cst (size, 1); + + /* We need to provide for vector pointers, vector arrays, and + functions returning vectors. For example: + + __attribute__((vector_size(16))) short *foo; + + In this case, the mode is SI, but the type being modified is + HI, so we need to look further. */ + + while (POINTER_TYPE_P (type) + || TREE_CODE (type) == FUNCTION_TYPE + || TREE_CODE (type) == METHOD_TYPE + || TREE_CODE (type) == ARRAY_TYPE + || TREE_CODE (type) == OFFSET_TYPE) + type = TREE_TYPE (type); + + /* Get the mode of the type being modified. */ + orig_mode = TYPE_MODE (type); + + if ((!INTEGRAL_TYPE_P (type) + && !SCALAR_FLOAT_TYPE_P (type) + && !FIXED_POINT_TYPE_P (type)) + || (!SCALAR_FLOAT_MODE_P (orig_mode) + && GET_MODE_CLASS (orig_mode) != MODE_INT + && !ALL_SCALAR_FIXED_POINT_MODE_P (orig_mode)) + || !host_integerp (TYPE_SIZE_UNIT (type), 1) + || TREE_CODE (type) == BOOLEAN_TYPE) + { + error ("invalid vector type for attribute %qE", name); + return NULL_TREE; + } + + if (vecsize % tree_low_cst (TYPE_SIZE_UNIT (type), 1)) + { + error ("vector size not an integral multiple of component size"); + return NULL; + } + + if (vecsize == 0) + { + error ("zero vector size"); + return NULL; + } + + /* Calculate how many units fit in the vector. */ + nunits = vecsize / tree_low_cst (TYPE_SIZE_UNIT (type), 1); + if (nunits & (nunits - 1)) + { + error ("number of components of the vector not a power of two"); + return NULL_TREE; + } + + new_type = build_vector_type (type, nunits); + + /* Build back pointers if needed. */ + *node = lang_hooks.types.reconstruct_complex_type (*node, new_type); + + return NULL_TREE; +} + +/* Handle the "nonnull" attribute. */ +static tree +handle_nonnull_attribute (tree *node, tree ARG_UNUSED (name), + tree args, int ARG_UNUSED (flags), + bool *no_add_attrs) +{ + tree type = *node; + unsigned HOST_WIDE_INT attr_arg_num; + + /* If no arguments are specified, all pointer arguments should be + non-null. Verify a full prototype is given so that the arguments + will have the correct types when we actually check them later. */ + if (!args) + { + if (!TYPE_ARG_TYPES (type)) + { + error ("nonnull attribute without arguments on a non-prototype"); + *no_add_attrs = true; + } + return NULL_TREE; + } + + /* Argument list specified. Verify that each argument number references + a pointer argument. */ + for (attr_arg_num = 1; args; args = TREE_CHAIN (args)) + { + tree argument; + unsigned HOST_WIDE_INT arg_num = 0, ck_num; + + if (!get_nonnull_operand (TREE_VALUE (args), &arg_num)) + { + error ("nonnull argument has invalid operand number (argument %lu)", + (unsigned long) attr_arg_num); + *no_add_attrs = true; + return NULL_TREE; + } + + argument = TYPE_ARG_TYPES (type); + if (argument) + { + for (ck_num = 1; ; ck_num++) + { + if (!argument || ck_num == arg_num) + break; + argument = TREE_CHAIN (argument); + } + + if (!argument + || TREE_CODE (TREE_VALUE (argument)) == VOID_TYPE) + { + error ("nonnull argument with out-of-range operand number (argument %lu, operand %lu)", + (unsigned long) attr_arg_num, (unsigned long) arg_num); + *no_add_attrs = true; + return NULL_TREE; + } + + if (TREE_CODE (TREE_VALUE (argument)) != POINTER_TYPE) + { + error ("nonnull argument references non-pointer operand (argument %lu, operand %lu)", + (unsigned long) attr_arg_num, (unsigned long) arg_num); + *no_add_attrs = true; + return NULL_TREE; + } + } + } + + return NULL_TREE; +} + +/* Check the argument list of a function call for null in argument slots + that are marked as requiring a non-null pointer argument. The NARGS + arguments are passed in the array ARGARRAY. +*/ + +static void +check_function_nonnull (tree attrs, int nargs, tree *argarray) +{ + tree a, args; + int i; + + for (a = attrs; a; a = TREE_CHAIN (a)) + { + if (is_attribute_p ("nonnull", TREE_PURPOSE (a))) + { + args = TREE_VALUE (a); + + /* Walk the argument list. If we encounter an argument number we + should check for non-null, do it. If the attribute has no args, + then every pointer argument is checked (in which case the check + for pointer type is done in check_nonnull_arg). */ + for (i = 0; i < nargs; i++) + { + if (!args || nonnull_check_p (args, i + 1)) + check_function_arguments_recurse (check_nonnull_arg, NULL, + argarray[i], + i + 1); + } + } + } +} + +/* Check that the Nth argument of a function call (counting backwards + from the end) is a (pointer)0. The NARGS arguments are passed in the + array ARGARRAY. */ + +static void +check_function_sentinel (tree attrs, int nargs, tree *argarray, tree typelist) +{ + tree attr = lookup_attribute ("sentinel", attrs); + + if (attr) + { + int len = 0; + int pos = 0; + tree sentinel; + + /* Skip over the named arguments. */ + while (typelist && len < nargs) + { + typelist = TREE_CHAIN (typelist); + len++; + } + + if (TREE_VALUE (attr)) + { + tree p = TREE_VALUE (TREE_VALUE (attr)); + pos = TREE_INT_CST_LOW (p); + } + + /* The sentinel must be one of the varargs, i.e. + in position >= the number of fixed arguments. */ + if ((nargs - 1 - pos) < len) + { + warning (OPT_Wformat, + "not enough variable arguments to fit a sentinel"); + return; + } + + /* Validate the sentinel. */ + sentinel = argarray[nargs - 1 - pos]; + if ((!POINTER_TYPE_P (TREE_TYPE (sentinel)) + || !integer_zerop (sentinel)) + /* Although __null (in C++) is only an integer we allow it + nevertheless, as we are guaranteed that it's exactly + as wide as a pointer, and we don't want to force + users to cast the NULL they have written there. + We warn with -Wstrict-null-sentinel, though. */ + && (warn_strict_null_sentinel || null_node != sentinel)) + warning (OPT_Wformat, "missing sentinel in function call"); + } +} + +/* Helper for check_function_nonnull; given a list of operands which + must be non-null in ARGS, determine if operand PARAM_NUM should be + checked. */ + +static bool +nonnull_check_p (tree args, unsigned HOST_WIDE_INT param_num) +{ + unsigned HOST_WIDE_INT arg_num = 0; + + for (; args; args = TREE_CHAIN (args)) + { + bool found = get_nonnull_operand (TREE_VALUE (args), &arg_num); + + gcc_assert (found); + + if (arg_num == param_num) + return true; + } + return false; +} + +/* Check that the function argument PARAM (which is operand number + PARAM_NUM) is non-null. This is called by check_function_nonnull + via check_function_arguments_recurse. */ + +static void +check_nonnull_arg (void * ARG_UNUSED (ctx), tree param, + unsigned HOST_WIDE_INT param_num) +{ + /* Just skip checking the argument if it's not a pointer. This can + happen if the "nonnull" attribute was given without an operand + list (which means to check every pointer argument). */ + + if (TREE_CODE (TREE_TYPE (param)) != POINTER_TYPE) + return; + + if (integer_zerop (param)) + warning (OPT_Wnonnull, "null argument where non-null required " + "(argument %lu)", (unsigned long) param_num); +} + +/* Helper for nonnull attribute handling; fetch the operand number + from the attribute argument list. */ + +static bool +get_nonnull_operand (tree arg_num_expr, unsigned HOST_WIDE_INT *valp) +{ + /* Verify the arg number is a constant. */ + if (TREE_CODE (arg_num_expr) != INTEGER_CST + || TREE_INT_CST_HIGH (arg_num_expr) != 0) + return false; + + *valp = TREE_INT_CST_LOW (arg_num_expr); + return true; +} + +/* Handle a "nothrow" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_nothrow_attribute (tree *node, tree name, tree ARG_UNUSED (args), + int ARG_UNUSED (flags), bool *no_add_attrs) +{ + if (TREE_CODE (*node) == FUNCTION_DECL) + TREE_NOTHROW (*node) = 1; + /* ??? TODO: Support types. */ + else + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + + return NULL_TREE; +} + +/* Handle a "cleanup" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_cleanup_attribute (tree *node, tree name, tree args, + int ARG_UNUSED (flags), bool *no_add_attrs) +{ + tree decl = *node; + tree cleanup_id, cleanup_decl; + + /* ??? Could perhaps support cleanups on TREE_STATIC, much like we do + for global destructors in C++. This requires infrastructure that + we don't have generically at the moment. It's also not a feature + we'd be missing too much, since we do have attribute constructor. */ + if (TREE_CODE (decl) != VAR_DECL || TREE_STATIC (decl)) + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + return NULL_TREE; + } + + /* Verify that the argument is a function in scope. */ + /* ??? We could support pointers to functions here as well, if + that was considered desirable. */ + cleanup_id = TREE_VALUE (args); + if (TREE_CODE (cleanup_id) != IDENTIFIER_NODE) + { + error ("cleanup argument not an identifier"); + *no_add_attrs = true; + return NULL_TREE; + } + cleanup_decl = lookup_name (cleanup_id); + if (!cleanup_decl || TREE_CODE (cleanup_decl) != FUNCTION_DECL) + { + error ("cleanup argument not a function"); + *no_add_attrs = true; + return NULL_TREE; + } + + /* That the function has proper type is checked with the + eventual call to build_function_call. */ + + return NULL_TREE; +} + +/* Handle a "warn_unused_result" attribute. No special handling. */ + +static tree +handle_warn_unused_result_attribute (tree *node, tree name, + tree ARG_UNUSED (args), + int ARG_UNUSED (flags), bool *no_add_attrs) +{ + /* Ignore the attribute for functions not returning any value. */ + if (VOID_TYPE_P (TREE_TYPE (*node))) + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + + return NULL_TREE; +} + +/* Handle a "sentinel" attribute. */ + +static tree +handle_sentinel_attribute (tree *node, tree name, tree args, + int ARG_UNUSED (flags), bool *no_add_attrs) +{ + tree params = TYPE_ARG_TYPES (*node); + + if (!params) + { + warning (OPT_Wattributes, + "%qE attribute requires prototypes with named arguments", name); + *no_add_attrs = true; + } + else + { + while (TREE_CHAIN (params)) + params = TREE_CHAIN (params); + + if (VOID_TYPE_P (TREE_VALUE (params))) + { + warning (OPT_Wattributes, + "%qE attribute only applies to variadic functions", name); + *no_add_attrs = true; + } + } + + if (args) + { + tree position = TREE_VALUE (args); + + if (TREE_CODE (position) != INTEGER_CST) + { + warning (OPT_Wattributes, + "requested position is not an integer constant"); + *no_add_attrs = true; + } + else + { + if (tree_int_cst_lt (position, integer_zero_node)) + { + warning (OPT_Wattributes, + "requested position is less than zero"); + *no_add_attrs = true; + } + } + } + + return NULL_TREE; +} + +/* Handle a "type_generic" attribute. */ + +static tree +handle_type_generic_attribute (tree *node, tree ARG_UNUSED (name), + tree ARG_UNUSED (args), int ARG_UNUSED (flags), + bool * ARG_UNUSED (no_add_attrs)) +{ + tree params; + + /* Ensure we have a function type. */ + gcc_assert (TREE_CODE (*node) == FUNCTION_TYPE); + + params = TYPE_ARG_TYPES (*node); + while (params && ! VOID_TYPE_P (TREE_VALUE (params))) + params = TREE_CHAIN (params); + + /* Ensure we have a variadic function. */ + gcc_assert (!params); + + return NULL_TREE; +} + +/* Handle a "target" attribute. */ + +static tree +handle_target_attribute (tree *node, tree name, tree args, int flags, + bool *no_add_attrs) +{ + /* Ensure we have a function type. */ + if (TREE_CODE (*node) != FUNCTION_DECL) + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + else if (! targetm.target_option.valid_attribute_p (*node, name, args, + flags)) + *no_add_attrs = true; + + return NULL_TREE; +} + +/* Arguments being collected for optimization. */ +typedef const char *const_char_p; /* For DEF_VEC_P. */ +DEF_VEC_P(const_char_p); +DEF_VEC_ALLOC_P(const_char_p, gc); +static GTY(()) VEC(const_char_p, gc) *optimize_args; + + +/* Inner function to convert a TREE_LIST to argv string to parse the optimize + options in ARGS. ATTR_P is true if this is for attribute(optimize), and + false for #pragma GCC optimize. */ + +bool +parse_optimize_options (tree args, bool attr_p) +{ + bool ret = true; + unsigned opt_argc; + unsigned i; + int saved_flag_strict_aliasing; + const char **opt_argv; + struct cl_decoded_option *decoded_options; + unsigned int decoded_options_count; + tree ap; + + /* Build up argv vector. Just in case the string is stored away, use garbage + collected strings. */ + VEC_truncate (const_char_p, optimize_args, 0); + VEC_safe_push (const_char_p, gc, optimize_args, NULL); + + for (ap = args; ap != NULL_TREE; ap = TREE_CHAIN (ap)) + { + tree value = TREE_VALUE (ap); + + if (TREE_CODE (value) == INTEGER_CST) + { + char buffer[20]; + sprintf (buffer, "-O%ld", (long) TREE_INT_CST_LOW (value)); + VEC_safe_push (const_char_p, gc, optimize_args, ggc_strdup (buffer)); + } + + else if (TREE_CODE (value) == STRING_CST) + { + /* Split string into multiple substrings. */ + size_t len = TREE_STRING_LENGTH (value); + char *p = ASTRDUP (TREE_STRING_POINTER (value)); + char *end = p + len; + char *comma; + char *next_p = p; + + while (next_p != NULL) + { + size_t len2; + char *q, *r; + + p = next_p; + comma = strchr (p, ','); + if (comma) + { + len2 = comma - p; + *comma = '\0'; + next_p = comma+1; + } + else + { + len2 = end - p; + next_p = NULL; + } + + r = q = (char *) ggc_alloc_atomic (len2 + 3); + + /* If the user supplied -Oxxx or -fxxx, only allow -Oxxx or -fxxx + options. */ + if (*p == '-' && p[1] != 'O' && p[1] != 'f') + { + ret = false; + if (attr_p) + warning (OPT_Wattributes, + "Bad option %s to optimize attribute.", p); + else + warning (OPT_Wpragmas, + "Bad option %s to pragma attribute", p); + continue; + } + + if (*p != '-') + { + *r++ = '-'; + + /* Assume that Ox is -Ox, a numeric value is -Ox, a s by + itself is -Os, and any other switch begins with a -f. */ + if ((*p >= '0' && *p <= '9') + || (p[0] == 's' && p[1] == '\0')) + *r++ = 'O'; + else if (*p != 'O') + *r++ = 'f'; + } + + memcpy (r, p, len2); + r[len2] = '\0'; + VEC_safe_push (const_char_p, gc, optimize_args, q); + } + + } + } + + opt_argc = VEC_length (const_char_p, optimize_args); + opt_argv = (const char **) alloca (sizeof (char *) * (opt_argc + 1)); + + for (i = 1; i < opt_argc; i++) + opt_argv[i] = VEC_index (const_char_p, optimize_args, i); + + saved_flag_strict_aliasing = flag_strict_aliasing; + + /* Now parse the options. */ + decode_options (opt_argc, opt_argv, &decoded_options, + &decoded_options_count); + + targetm.override_options_after_change(); + + /* Don't allow changing -fstrict-aliasing. */ + flag_strict_aliasing = saved_flag_strict_aliasing; + + VEC_truncate (const_char_p, optimize_args, 0); + return ret; +} + +/* For handling "optimize" attribute. arguments as in + struct attribute_spec.handler. */ + +static tree +handle_optimize_attribute (tree *node, tree name, tree args, + int ARG_UNUSED (flags), bool *no_add_attrs) +{ + /* Ensure we have a function type. */ + if (TREE_CODE (*node) != FUNCTION_DECL) + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + else + { + struct cl_optimization cur_opts; + tree old_opts = DECL_FUNCTION_SPECIFIC_OPTIMIZATION (*node); + + /* Save current options. */ + cl_optimization_save (&cur_opts); + + /* If we previously had some optimization options, use them as the + default. */ + if (old_opts) + cl_optimization_restore (TREE_OPTIMIZATION (old_opts)); + + /* Parse options, and update the vector. */ + parse_optimize_options (args, true); + DECL_FUNCTION_SPECIFIC_OPTIMIZATION (*node) + = build_optimization_node (); + + /* Restore current options. */ + cl_optimization_restore (&cur_opts); + } + + return NULL_TREE; +} + +/* Check for valid arguments being passed to a function. + ATTRS is a list of attributes. There are NARGS arguments in the array + ARGARRAY. TYPELIST is the list of argument types for the function. + */ +void +check_function_arguments (tree attrs, int nargs, tree *argarray, tree typelist) +{ + /* Check for null being passed in a pointer argument that must be + non-null. We also need to do this if format checking is enabled. */ + + if (warn_nonnull) + check_function_nonnull (attrs, nargs, argarray); + + /* Check for errors in format strings. */ + + if (warn_format || warn_missing_format_attribute) + check_function_format (attrs, nargs, argarray); + + if (warn_format) + check_function_sentinel (attrs, nargs, argarray, typelist); +} + +/* Generic argument checking recursion routine. PARAM is the argument to + be checked. PARAM_NUM is the number of the argument. CALLBACK is invoked + once the argument is resolved. CTX is context for the callback. */ +void +check_function_arguments_recurse (void (*callback) + (void *, tree, unsigned HOST_WIDE_INT), + void *ctx, tree param, + unsigned HOST_WIDE_INT param_num) +{ + if (CONVERT_EXPR_P (param) + && (TYPE_PRECISION (TREE_TYPE (param)) + == TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (param, 0))))) + { + /* Strip coercion. */ + check_function_arguments_recurse (callback, ctx, + TREE_OPERAND (param, 0), param_num); + return; + } + + if (TREE_CODE (param) == CALL_EXPR) + { + tree type = TREE_TYPE (TREE_TYPE (CALL_EXPR_FN (param))); + tree attrs; + bool found_format_arg = false; + + /* See if this is a call to a known internationalization function + that modifies a format arg. Such a function may have multiple + format_arg attributes (for example, ngettext). */ + + for (attrs = TYPE_ATTRIBUTES (type); + attrs; + attrs = TREE_CHAIN (attrs)) + if (is_attribute_p ("format_arg", TREE_PURPOSE (attrs))) + { + tree inner_arg; + tree format_num_expr; + int format_num; + int i; + call_expr_arg_iterator iter; + + /* Extract the argument number, which was previously checked + to be valid. */ + format_num_expr = TREE_VALUE (TREE_VALUE (attrs)); + + gcc_assert (TREE_CODE (format_num_expr) == INTEGER_CST + && !TREE_INT_CST_HIGH (format_num_expr)); + + format_num = TREE_INT_CST_LOW (format_num_expr); + + for (inner_arg = first_call_expr_arg (param, &iter), i = 1; + inner_arg != 0; + inner_arg = next_call_expr_arg (&iter), i++) + if (i == format_num) + { + check_function_arguments_recurse (callback, ctx, + inner_arg, param_num); + found_format_arg = true; + break; + } + } + + /* If we found a format_arg attribute and did a recursive check, + we are done with checking this argument. Otherwise, we continue + and this will be considered a non-literal. */ + if (found_format_arg) + return; + } + + if (TREE_CODE (param) == COND_EXPR) + { + /* Check both halves of the conditional expression. */ + check_function_arguments_recurse (callback, ctx, + TREE_OPERAND (param, 1), param_num); + check_function_arguments_recurse (callback, ctx, + TREE_OPERAND (param, 2), param_num); + return; + } + + (*callback) (ctx, param, param_num); +} + +/* Checks for a builtin function FNDECL that the number of arguments + NARGS against the required number REQUIRED and issues an error if + there is a mismatch. Returns true if the number of arguments is + correct, otherwise false. */ + +static bool +builtin_function_validate_nargs (tree fndecl, int nargs, int required) +{ + if (nargs < required) + { + error_at (input_location, + "not enough arguments to function %qE", fndecl); + return false; + } + else if (nargs > required) + { + error_at (input_location, + "too many arguments to function %qE", fndecl); + return false; + } + return true; +} + +/* Verifies the NARGS arguments ARGS to the builtin function FNDECL. + Returns false if there was an error, otherwise true. */ + +bool +check_builtin_function_arguments (tree fndecl, int nargs, tree *args) +{ + if (!DECL_BUILT_IN (fndecl) + || DECL_BUILT_IN_CLASS (fndecl) != BUILT_IN_NORMAL) + return true; + + switch (DECL_FUNCTION_CODE (fndecl)) + { + case BUILT_IN_CONSTANT_P: + return builtin_function_validate_nargs (fndecl, nargs, 1); + + case BUILT_IN_ISFINITE: + case BUILT_IN_ISINF: + case BUILT_IN_ISINF_SIGN: + case BUILT_IN_ISNAN: + case BUILT_IN_ISNORMAL: + if (builtin_function_validate_nargs (fndecl, nargs, 1)) + { + if (TREE_CODE (TREE_TYPE (args[0])) != REAL_TYPE) + { + error ("non-floating-point argument in call to " + "function %qE", fndecl); + return false; + } + return true; + } + return false; + + case BUILT_IN_ISGREATER: + case BUILT_IN_ISGREATEREQUAL: + case BUILT_IN_ISLESS: + case BUILT_IN_ISLESSEQUAL: + case BUILT_IN_ISLESSGREATER: + case BUILT_IN_ISUNORDERED: + if (builtin_function_validate_nargs (fndecl, nargs, 2)) + { + enum tree_code code0, code1; + code0 = TREE_CODE (TREE_TYPE (args[0])); + code1 = TREE_CODE (TREE_TYPE (args[1])); + if (!((code0 == REAL_TYPE && code1 == REAL_TYPE) + || (code0 == REAL_TYPE && code1 == INTEGER_TYPE) + || (code0 == INTEGER_TYPE && code1 == REAL_TYPE))) + { + error ("non-floating-point arguments in call to " + "function %qE", fndecl); + return false; + } + return true; + } + return false; + + case BUILT_IN_FPCLASSIFY: + if (builtin_function_validate_nargs (fndecl, nargs, 6)) + { + unsigned i; + + for (i=0; i<5; i++) + if (TREE_CODE (args[i]) != INTEGER_CST) + { + error ("non-const integer argument %u in call to function %qE", + i+1, fndecl); + return false; + } + + if (TREE_CODE (TREE_TYPE (args[5])) != REAL_TYPE) + { + error ("non-floating-point argument in call to function %qE", + fndecl); + return false; + } + return true; + } + return false; + + default: + return true; + } +} + +/* Function to help qsort sort FIELD_DECLs by name order. */ + +int +field_decl_cmp (const void *x_p, const void *y_p) +{ + const tree *const x = (const tree *const) x_p; + const tree *const y = (const tree *const) y_p; + + if (DECL_NAME (*x) == DECL_NAME (*y)) + /* A nontype is "greater" than a type. */ + return (TREE_CODE (*y) == TYPE_DECL) - (TREE_CODE (*x) == TYPE_DECL); + if (DECL_NAME (*x) == NULL_TREE) + return -1; + if (DECL_NAME (*y) == NULL_TREE) + return 1; + if (DECL_NAME (*x) < DECL_NAME (*y)) + return -1; + return 1; +} + +static struct { + gt_pointer_operator new_value; + void *cookie; +} resort_data; + +/* This routine compares two fields like field_decl_cmp but using the +pointer operator in resort_data. */ + +static int +resort_field_decl_cmp (const void *x_p, const void *y_p) +{ + const tree *const x = (const tree *const) x_p; + const tree *const y = (const tree *const) y_p; + + if (DECL_NAME (*x) == DECL_NAME (*y)) + /* A nontype is "greater" than a type. */ + return (TREE_CODE (*y) == TYPE_DECL) - (TREE_CODE (*x) == TYPE_DECL); + if (DECL_NAME (*x) == NULL_TREE) + return -1; + if (DECL_NAME (*y) == NULL_TREE) + return 1; + { + tree d1 = DECL_NAME (*x); + tree d2 = DECL_NAME (*y); + resort_data.new_value (&d1, resort_data.cookie); + resort_data.new_value (&d2, resort_data.cookie); + if (d1 < d2) + return -1; + } + return 1; +} + +/* Resort DECL_SORTED_FIELDS because pointers have been reordered. */ + +void +resort_sorted_fields (void *obj, + void * ARG_UNUSED (orig_obj), + gt_pointer_operator new_value, + void *cookie) +{ + struct sorted_fields_type *sf = (struct sorted_fields_type *) obj; + resort_data.new_value = new_value; + resort_data.cookie = cookie; + qsort (&sf->elts[0], sf->len, sizeof (tree), + resort_field_decl_cmp); +} + +/* Subroutine of c_parse_error. + Return the result of concatenating LHS and RHS. RHS is really + a string literal, its first character is indicated by RHS_START and + RHS_SIZE is its length (including the terminating NUL character). + + The caller is responsible for deleting the returned pointer. */ + +static char * +catenate_strings (const char *lhs, const char *rhs_start, int rhs_size) +{ + const int lhs_size = strlen (lhs); + char *result = XNEWVEC (char, lhs_size + rhs_size); + strncpy (result, lhs, lhs_size); + strncpy (result + lhs_size, rhs_start, rhs_size); + return result; +} + +/* Issue the error given by GMSGID, indicating that it occurred before + TOKEN, which had the associated VALUE. */ + +void +c_parse_error (const char *gmsgid, enum cpp_ttype token_type, + tree value, unsigned char token_flags) +{ +#define catenate_messages(M1, M2) catenate_strings ((M1), (M2), sizeof (M2)) + + char *message = NULL; + + if (token_type == CPP_EOF) + message = catenate_messages (gmsgid, " at end of input"); + else if (token_type == CPP_CHAR + || token_type == CPP_WCHAR + || token_type == CPP_CHAR16 + || token_type == CPP_CHAR32) + { + unsigned int val = TREE_INT_CST_LOW (value); + const char *prefix; + + switch (token_type) + { + default: + prefix = ""; + break; + case CPP_WCHAR: + prefix = "L"; + break; + case CPP_CHAR16: + prefix = "u"; + break; + case CPP_CHAR32: + prefix = "U"; + break; + } + + if (val <= UCHAR_MAX && ISGRAPH (val)) + message = catenate_messages (gmsgid, " before %s'%c'"); + else + message = catenate_messages (gmsgid, " before %s'\\x%x'"); + + error (message, prefix, val); + free (message); + message = NULL; + } + else if (token_type == CPP_STRING + || token_type == CPP_WSTRING + || token_type == CPP_STRING16 + || token_type == CPP_STRING32 + || token_type == CPP_UTF8STRING) + message = catenate_messages (gmsgid, " before string constant"); + else if (token_type == CPP_NUMBER) + message = catenate_messages (gmsgid, " before numeric constant"); + else if (token_type == CPP_NAME) + { + message = catenate_messages (gmsgid, " before %qE"); + error (message, value); + free (message); + message = NULL; + } + else if (token_type == CPP_PRAGMA) + message = catenate_messages (gmsgid, " before %<#pragma%>"); + else if (token_type == CPP_PRAGMA_EOL) + message = catenate_messages (gmsgid, " before end of line"); + else if (token_type < N_TTYPES) + { + message = catenate_messages (gmsgid, " before %qs token"); + error (message, cpp_type2name (token_type, token_flags)); + free (message); + message = NULL; + } + else + error (gmsgid); + + if (message) + { + error (message); + free (message); + } +#undef catenate_messages +} + +/* Mapping for cpp message reasons to the options that enable them. */ + +struct reason_option_codes_t +{ + const int reason; /* cpplib message reason. */ + const int option_code; /* gcc option that controls this message. */ +}; + +static const struct reason_option_codes_t option_codes[] = { + {CPP_W_DEPRECATED, OPT_Wdeprecated}, + {CPP_W_COMMENTS, OPT_Wcomments}, + {CPP_W_TRIGRAPHS, OPT_Wtrigraphs}, + {CPP_W_MULTICHAR, OPT_Wmultichar}, + {CPP_W_TRADITIONAL, OPT_Wtraditional}, + {CPP_W_LONG_LONG, OPT_Wlong_long}, + {CPP_W_ENDIF_LABELS, OPT_Wendif_labels}, + {CPP_W_VARIADIC_MACROS, OPT_Wvariadic_macros}, + {CPP_W_BUILTIN_MACRO_REDEFINED, OPT_Wbuiltin_macro_redefined}, + {CPP_W_UNDEF, OPT_Wundef}, + {CPP_W_UNUSED_MACROS, OPT_Wunused_macros}, + {CPP_W_CXX_OPERATOR_NAMES, OPT_Wc___compat}, + {CPP_W_NORMALIZE, OPT_Wnormalized_}, + {CPP_W_INVALID_PCH, OPT_Winvalid_pch}, + {CPP_W_WARNING_DIRECTIVE, OPT_Wcpp}, + {CPP_W_NONE, 0} +}; + +/* Return the gcc option code associated with the reason for a cpp + message, or 0 if none. */ + +static int +c_option_controlling_cpp_error (int reason) +{ + const struct reason_option_codes_t *entry; + + for (entry = option_codes; entry->reason != CPP_W_NONE; entry++) + { + if (entry->reason == reason) + return entry->option_code; + } + return 0; +} + +/* Callback from cpp_error for PFILE to print diagnostics from the + preprocessor. The diagnostic is of type LEVEL, with REASON set + to the reason code if LEVEL is represents a warning, at location + LOCATION unless this is after lexing and the compiler's location + should be used instead, with column number possibly overridden by + COLUMN_OVERRIDE if not zero; MSG is the translated message and AP + the arguments. Returns true if a diagnostic was emitted, false + otherwise. */ + +bool +c_cpp_error (cpp_reader *pfile ATTRIBUTE_UNUSED, int level, int reason, + location_t location, unsigned int column_override, + const char *msg, va_list *ap) +{ + diagnostic_info diagnostic; + diagnostic_t dlevel; + bool save_warn_system_headers = global_dc->warn_system_headers; + bool ret; + + switch (level) + { + case CPP_DL_WARNING_SYSHDR: + if (flag_no_output) + return false; + global_dc->warn_system_headers = 1; + /* Fall through. */ + case CPP_DL_WARNING: + if (flag_no_output) + return false; + dlevel = DK_WARNING; + break; + case CPP_DL_PEDWARN: + if (flag_no_output && !flag_pedantic_errors) + return false; + dlevel = DK_PEDWARN; + break; + case CPP_DL_ERROR: + dlevel = DK_ERROR; + break; + case CPP_DL_ICE: + dlevel = DK_ICE; + break; + case CPP_DL_NOTE: + dlevel = DK_NOTE; + break; + case CPP_DL_FATAL: + dlevel = DK_FATAL; + break; + default: + gcc_unreachable (); + } + if (done_lexing) + location = input_location; + diagnostic_set_info_translated (&diagnostic, msg, ap, + location, dlevel); + if (column_override) + diagnostic_override_column (&diagnostic, column_override); + diagnostic_override_option_index (&diagnostic, + c_option_controlling_cpp_error (reason)); + ret = report_diagnostic (&diagnostic); + if (level == CPP_DL_WARNING_SYSHDR) + global_dc->warn_system_headers = save_warn_system_headers; + return ret; +} + +/* Convert a character from the host to the target execution character + set. cpplib handles this, mostly. */ + +HOST_WIDE_INT +c_common_to_target_charset (HOST_WIDE_INT c) +{ + /* Character constants in GCC proper are sign-extended under -fsigned-char, + zero-extended under -fno-signed-char. cpplib insists that characters + and character constants are always unsigned. Hence we must convert + back and forth. */ + cppchar_t uc = ((cppchar_t)c) & ((((cppchar_t)1) << CHAR_BIT)-1); + + uc = cpp_host_to_exec_charset (parse_in, uc); + + if (flag_signed_char) + return ((HOST_WIDE_INT)uc) << (HOST_BITS_PER_WIDE_INT - CHAR_TYPE_SIZE) + >> (HOST_BITS_PER_WIDE_INT - CHAR_TYPE_SIZE); + else + return uc; +} + +/* Build the result of __builtin_offsetof. EXPR is a nested sequence of + component references, with STOP_REF, or alternatively an INDIRECT_REF of + NULL, at the bottom; much like the traditional rendering of offsetof as a + macro. Returns the folded and properly cast result. */ + +static tree +fold_offsetof_1 (tree expr, tree stop_ref) +{ + enum tree_code code = PLUS_EXPR; + tree base, off, t; + + if (expr == stop_ref && TREE_CODE (expr) != ERROR_MARK) + return size_zero_node; + + switch (TREE_CODE (expr)) + { + case ERROR_MARK: + return expr; + + case VAR_DECL: + error ("cannot apply % to static data member %qD", expr); + return error_mark_node; + + case CALL_EXPR: + case TARGET_EXPR: + error ("cannot apply % when % is overloaded"); + return error_mark_node; + + case NOP_EXPR: + case INDIRECT_REF: + if (!integer_zerop (TREE_OPERAND (expr, 0))) + { + error ("cannot apply % to a non constant address"); + return error_mark_node; + } + return size_zero_node; + + case COMPONENT_REF: + base = fold_offsetof_1 (TREE_OPERAND (expr, 0), stop_ref); + if (base == error_mark_node) + return base; + + t = TREE_OPERAND (expr, 1); + if (DECL_C_BIT_FIELD (t)) + { + error ("attempt to take address of bit-field structure " + "member %qD", t); + return error_mark_node; + } + off = size_binop_loc (input_location, PLUS_EXPR, DECL_FIELD_OFFSET (t), + size_int (tree_low_cst (DECL_FIELD_BIT_OFFSET (t), + 1) + / BITS_PER_UNIT)); + break; + + case ARRAY_REF: + base = fold_offsetof_1 (TREE_OPERAND (expr, 0), stop_ref); + if (base == error_mark_node) + return base; + + t = TREE_OPERAND (expr, 1); + if (TREE_CODE (t) == INTEGER_CST && tree_int_cst_sgn (t) < 0) + { + code = MINUS_EXPR; + t = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (t), t); + } + t = convert (sizetype, t); + off = size_binop (MULT_EXPR, TYPE_SIZE_UNIT (TREE_TYPE (expr)), t); + + /* Check if the offset goes beyond the upper bound of the array. */ + if (code == PLUS_EXPR && TREE_CODE (t) == INTEGER_CST) + { + tree upbound = array_ref_up_bound (expr); + if (upbound != NULL_TREE + && TREE_CODE (upbound) == INTEGER_CST + && !tree_int_cst_equal (upbound, + TYPE_MAX_VALUE (TREE_TYPE (upbound)))) + { + upbound = size_binop (PLUS_EXPR, upbound, + build_int_cst (TREE_TYPE (upbound), 1)); + if (tree_int_cst_lt (upbound, t)) + { + tree v; + + for (v = TREE_OPERAND (expr, 0); + TREE_CODE (v) == COMPONENT_REF; + v = TREE_OPERAND (v, 0)) + if (TREE_CODE (TREE_TYPE (TREE_OPERAND (v, 0))) + == RECORD_TYPE) + { + tree fld_chain = TREE_CHAIN (TREE_OPERAND (v, 1)); + for (; fld_chain; fld_chain = TREE_CHAIN (fld_chain)) + if (TREE_CODE (fld_chain) == FIELD_DECL) + break; + + if (fld_chain) + break; + } + /* Don't warn if the array might be considered a poor + man's flexible array member with a very permissive + definition thereof. */ + if (TREE_CODE (v) == ARRAY_REF + || TREE_CODE (v) == COMPONENT_REF) + warning (OPT_Warray_bounds, + "index %E denotes an offset " + "greater than size of %qT", + t, TREE_TYPE (TREE_OPERAND (expr, 0))); + } + } + } + break; + + case COMPOUND_EXPR: + /* Handle static members of volatile structs. */ + t = TREE_OPERAND (expr, 1); + gcc_assert (TREE_CODE (t) == VAR_DECL); + return fold_offsetof_1 (t, stop_ref); + + default: + gcc_unreachable (); + } + + return size_binop (code, base, off); +} + +tree +fold_offsetof (tree expr, tree stop_ref) +{ + /* Convert back from the internal sizetype to size_t. */ + return convert (size_type_node, fold_offsetof_1 (expr, stop_ref)); +} + +/* Warn for A ?: C expressions (with B omitted) where A is a boolean + expression, because B will always be true. */ + +void +warn_for_omitted_condop (location_t location, tree cond) +{ + if (truth_value_p (TREE_CODE (cond))) + warning_at (location, OPT_Wparentheses, + "the omitted middle operand in ?: will always be %, " + "suggest explicit middle operand"); +} + +/* Print an error message for an invalid lvalue. USE says + how the lvalue is being used and so selects the error message. */ + +void +lvalue_error (enum lvalue_use use) +{ + switch (use) + { + case lv_assign: + error ("lvalue required as left operand of assignment"); + break; + case lv_increment: + error ("lvalue required as increment operand"); + break; + case lv_decrement: + error ("lvalue required as decrement operand"); + break; + case lv_addressof: + error ("lvalue required as unary %<&%> operand"); + break; + case lv_asm: + error ("lvalue required in asm statement"); + break; + default: + gcc_unreachable (); + } +} + +/* *PTYPE is an incomplete array. Complete it with a domain based on + INITIAL_VALUE. If INITIAL_VALUE is not present, use 1 if DO_DEFAULT + is true. Return 0 if successful, 1 if INITIAL_VALUE can't be deciphered, + 2 if INITIAL_VALUE was NULL, and 3 if INITIAL_VALUE was empty. */ + +int +complete_array_type (tree *ptype, tree initial_value, bool do_default) +{ + tree maxindex, type, main_type, elt, unqual_elt; + int failure = 0, quals; + hashval_t hashcode = 0; + + maxindex = size_zero_node; + if (initial_value) + { + if (TREE_CODE (initial_value) == STRING_CST) + { + int eltsize + = int_size_in_bytes (TREE_TYPE (TREE_TYPE (initial_value))); + maxindex = size_int (TREE_STRING_LENGTH (initial_value)/eltsize - 1); + } + else if (TREE_CODE (initial_value) == CONSTRUCTOR) + { + VEC(constructor_elt,gc) *v = CONSTRUCTOR_ELTS (initial_value); + + if (VEC_empty (constructor_elt, v)) + { + if (pedantic) + failure = 3; + maxindex = integer_minus_one_node; + } + else + { + tree curindex; + unsigned HOST_WIDE_INT cnt; + constructor_elt *ce; + bool fold_p = false; + + if (VEC_index (constructor_elt, v, 0)->index) + maxindex = fold_convert_loc (input_location, sizetype, + VEC_index (constructor_elt, + v, 0)->index); + curindex = maxindex; + + for (cnt = 1; + VEC_iterate (constructor_elt, v, cnt, ce); + cnt++) + { + bool curfold_p = false; + if (ce->index) + curindex = ce->index, curfold_p = true; + else + { + if (fold_p) + curindex = fold_convert (sizetype, curindex); + curindex = size_binop (PLUS_EXPR, curindex, + size_one_node); + } + if (tree_int_cst_lt (maxindex, curindex)) + maxindex = curindex, fold_p = curfold_p; + } + if (fold_p) + maxindex = fold_convert (sizetype, maxindex); + } + } + else + { + /* Make an error message unless that happened already. */ + if (initial_value != error_mark_node) + failure = 1; + } + } + else + { + failure = 2; + if (!do_default) + return failure; + } + + type = *ptype; + elt = TREE_TYPE (type); + quals = TYPE_QUALS (strip_array_types (elt)); + if (quals == 0) + unqual_elt = elt; + else + unqual_elt = c_build_qualified_type (elt, KEEP_QUAL_ADDR_SPACE (quals)); + + /* Using build_distinct_type_copy and modifying things afterward instead + of using build_array_type to create a new type preserves all of the + TYPE_LANG_FLAG_? bits that the front end may have set. */ + main_type = build_distinct_type_copy (TYPE_MAIN_VARIANT (type)); + TREE_TYPE (main_type) = unqual_elt; + TYPE_DOMAIN (main_type) = build_index_type (maxindex); + layout_type (main_type); + + /* Make sure we have the canonical MAIN_TYPE. */ + hashcode = iterative_hash_object (TYPE_HASH (unqual_elt), hashcode); + hashcode = iterative_hash_object (TYPE_HASH (TYPE_DOMAIN (main_type)), + hashcode); + main_type = type_hash_canon (hashcode, main_type); + + /* Fix the canonical type. */ + if (TYPE_STRUCTURAL_EQUALITY_P (TREE_TYPE (main_type)) + || TYPE_STRUCTURAL_EQUALITY_P (TYPE_DOMAIN (main_type))) + SET_TYPE_STRUCTURAL_EQUALITY (main_type); + else if (TYPE_CANONICAL (TREE_TYPE (main_type)) != TREE_TYPE (main_type) + || (TYPE_CANONICAL (TYPE_DOMAIN (main_type)) + != TYPE_DOMAIN (main_type))) + TYPE_CANONICAL (main_type) + = build_array_type (TYPE_CANONICAL (TREE_TYPE (main_type)), + TYPE_CANONICAL (TYPE_DOMAIN (main_type))); + else + TYPE_CANONICAL (main_type) = main_type; + + if (quals == 0) + type = main_type; + else + type = c_build_qualified_type (main_type, quals); + + if (COMPLETE_TYPE_P (type) + && TREE_CODE (TYPE_SIZE_UNIT (type)) == INTEGER_CST + && TREE_OVERFLOW (TYPE_SIZE_UNIT (type))) + { + error ("size of array is too large"); + /* If we proceed with the array type as it is, we'll eventually + crash in tree_low_cst(). */ + type = error_mark_node; + } + + *ptype = type; + return failure; +} + + +/* Used to help initialize the builtin-types.def table. When a type of + the correct size doesn't exist, use error_mark_node instead of NULL. + The later results in segfaults even when a decl using the type doesn't + get invoked. */ + +tree +builtin_type_for_size (int size, bool unsignedp) +{ + tree type = lang_hooks.types.type_for_size (size, unsignedp); + return type ? type : error_mark_node; +} + +/* A helper function for resolve_overloaded_builtin in resolving the + overloaded __sync_ builtins. Returns a positive power of 2 if the + first operand of PARAMS is a pointer to a supported data type. + Returns 0 if an error is encountered. */ + +static int +sync_resolve_size (tree function, VEC(tree,gc) *params) +{ + tree type; + int size; + + if (VEC_empty (tree, params)) + { + error ("too few arguments to function %qE", function); + return 0; + } + + type = TREE_TYPE (VEC_index (tree, params, 0)); + if (TREE_CODE (type) != POINTER_TYPE) + goto incompatible; + + type = TREE_TYPE (type); + if (!INTEGRAL_TYPE_P (type) && !POINTER_TYPE_P (type)) + goto incompatible; + + size = tree_low_cst (TYPE_SIZE_UNIT (type), 1); + if (size == 1 || size == 2 || size == 4 || size == 8 || size == 16) + return size; + + incompatible: + error ("incompatible type for argument %d of %qE", 1, function); + return 0; +} + +/* A helper function for resolve_overloaded_builtin. Adds casts to + PARAMS to make arguments match up with those of FUNCTION. Drops + the variadic arguments at the end. Returns false if some error + was encountered; true on success. */ + +static bool +sync_resolve_params (tree orig_function, tree function, VEC(tree, gc) *params) +{ + tree arg_types = TYPE_ARG_TYPES (TREE_TYPE (function)); + tree ptype; + unsigned int parmnum; + + /* We've declared the implementation functions to use "volatile void *" + as the pointer parameter, so we shouldn't get any complaints from the + call to check_function_arguments what ever type the user used. */ + arg_types = TREE_CHAIN (arg_types); + ptype = TREE_TYPE (TREE_TYPE (VEC_index (tree, params, 0))); + + /* For the rest of the values, we need to cast these to FTYPE, so that we + don't get warnings for passing pointer types, etc. */ + parmnum = 0; + while (arg_types != void_list_node) + { + tree val; + + ++parmnum; + if (VEC_length (tree, params) <= parmnum) + { + error ("too few arguments to function %qE", orig_function); + return false; + } + + /* ??? Ideally for the first conversion we'd use convert_for_assignment + so that we get warnings for anything that doesn't match the pointer + type. This isn't portable across the C and C++ front ends atm. */ + val = VEC_index (tree, params, parmnum); + val = convert (ptype, val); + val = convert (TREE_VALUE (arg_types), val); + VEC_replace (tree, params, parmnum, val); + + arg_types = TREE_CHAIN (arg_types); + } + + /* The definition of these primitives is variadic, with the remaining + being "an optional list of variables protected by the memory barrier". + No clue what that's supposed to mean, precisely, but we consider all + call-clobbered variables to be protected so we're safe. */ + VEC_truncate (tree, params, parmnum + 1); + + return true; +} + +/* A helper function for resolve_overloaded_builtin. Adds a cast to + RESULT to make it match the type of the first pointer argument in + PARAMS. */ + +static tree +sync_resolve_return (tree first_param, tree result) +{ + tree ptype = TREE_TYPE (TREE_TYPE (first_param)); + ptype = TYPE_MAIN_VARIANT (ptype); + return convert (ptype, result); +} + +/* Some builtin functions are placeholders for other expressions. This + function should be called immediately after parsing the call expression + before surrounding code has committed to the type of the expression. + + LOC is the location of the builtin call. + + FUNCTION is the DECL that has been invoked; it is known to be a builtin. + PARAMS is the argument list for the call. The return value is non-null + when expansion is complete, and null if normal processing should + continue. */ + +tree +resolve_overloaded_builtin (location_t loc, tree function, VEC(tree,gc) *params) +{ + enum built_in_function orig_code = DECL_FUNCTION_CODE (function); + switch (DECL_BUILT_IN_CLASS (function)) + { + case BUILT_IN_NORMAL: + break; + case BUILT_IN_MD: + if (targetm.resolve_overloaded_builtin) + return targetm.resolve_overloaded_builtin (loc, function, params); + else + return NULL_TREE; + default: + return NULL_TREE; + } + + /* Handle BUILT_IN_NORMAL here. */ + switch (orig_code) + { + case BUILT_IN_FETCH_AND_ADD_N: + case BUILT_IN_FETCH_AND_SUB_N: + case BUILT_IN_FETCH_AND_OR_N: + case BUILT_IN_FETCH_AND_AND_N: + case BUILT_IN_FETCH_AND_XOR_N: + case BUILT_IN_FETCH_AND_NAND_N: + case BUILT_IN_ADD_AND_FETCH_N: + case BUILT_IN_SUB_AND_FETCH_N: + case BUILT_IN_OR_AND_FETCH_N: + case BUILT_IN_AND_AND_FETCH_N: + case BUILT_IN_XOR_AND_FETCH_N: + case BUILT_IN_NAND_AND_FETCH_N: + case BUILT_IN_BOOL_COMPARE_AND_SWAP_N: + case BUILT_IN_VAL_COMPARE_AND_SWAP_N: + case BUILT_IN_LOCK_TEST_AND_SET_N: + case BUILT_IN_LOCK_RELEASE_N: + { + int n = sync_resolve_size (function, params); + tree new_function, first_param, result; + + if (n == 0) + return error_mark_node; + + new_function = built_in_decls[orig_code + exact_log2 (n) + 1]; + if (!sync_resolve_params (function, new_function, params)) + return error_mark_node; + + first_param = VEC_index (tree, params, 0); + result = build_function_call_vec (loc, new_function, params, NULL); + if (orig_code != BUILT_IN_BOOL_COMPARE_AND_SWAP_N + && orig_code != BUILT_IN_LOCK_RELEASE_N) + result = sync_resolve_return (first_param, result); + + return result; + } + + default: + return NULL_TREE; + } +} + +/* Ignoring their sign, return true if two scalar types are the same. */ +bool +same_scalar_type_ignoring_signedness (tree t1, tree t2) +{ + enum tree_code c1 = TREE_CODE (t1), c2 = TREE_CODE (t2); + + gcc_assert ((c1 == INTEGER_TYPE || c1 == REAL_TYPE || c1 == FIXED_POINT_TYPE) + && (c2 == INTEGER_TYPE || c2 == REAL_TYPE + || c2 == FIXED_POINT_TYPE)); + + /* Equality works here because c_common_signed_type uses + TYPE_MAIN_VARIANT. */ + return c_common_signed_type (t1) + == c_common_signed_type (t2); +} + +/* Check for missing format attributes on function pointers. LTYPE is + the new type or left-hand side type. RTYPE is the old type or + right-hand side type. Returns TRUE if LTYPE is missing the desired + attribute. */ + +bool +check_missing_format_attribute (tree ltype, tree rtype) +{ + tree const ttr = TREE_TYPE (rtype), ttl = TREE_TYPE (ltype); + tree ra; + + for (ra = TYPE_ATTRIBUTES (ttr); ra; ra = TREE_CHAIN (ra)) + if (is_attribute_p ("format", TREE_PURPOSE (ra))) + break; + if (ra) + { + tree la; + for (la = TYPE_ATTRIBUTES (ttl); la; la = TREE_CHAIN (la)) + if (is_attribute_p ("format", TREE_PURPOSE (la))) + break; + return !la; + } + else + return false; +} + +/* Subscripting with type char is likely to lose on a machine where + chars are signed. So warn on any machine, but optionally. Don't + warn for unsigned char since that type is safe. Don't warn for + signed char because anyone who uses that must have done so + deliberately. Furthermore, we reduce the false positive load by + warning only for non-constant value of type char. */ + +void +warn_array_subscript_with_type_char (tree index) +{ + if (TYPE_MAIN_VARIANT (TREE_TYPE (index)) == char_type_node + && TREE_CODE (index) != INTEGER_CST) + warning (OPT_Wchar_subscripts, "array subscript has type %"); +} + +/* Implement -Wparentheses for the unexpected C precedence rules, to + cover cases like x + y << z which readers are likely to + misinterpret. We have seen an expression in which CODE is a binary + operator used to combine expressions ARG_LEFT and ARG_RIGHT, which + before folding had CODE_LEFT and CODE_RIGHT. CODE_LEFT and + CODE_RIGHT may be ERROR_MARK, which means that that side of the + expression was not formed using a binary or unary operator, or it + was enclosed in parentheses. */ + +void +warn_about_parentheses (enum tree_code code, + enum tree_code code_left, tree arg_left, + enum tree_code code_right, tree arg_right) +{ + if (!warn_parentheses) + return; + + /* This macro tests that the expression ARG with original tree code + CODE appears to be a boolean expression. or the result of folding a + boolean expression. */ +#define APPEARS_TO_BE_BOOLEAN_EXPR_P(CODE, ARG) \ + (truth_value_p (TREE_CODE (ARG)) \ + || TREE_CODE (TREE_TYPE (ARG)) == BOOLEAN_TYPE \ + /* Folding may create 0 or 1 integers from other expressions. */ \ + || ((CODE) != INTEGER_CST \ + && (integer_onep (ARG) || integer_zerop (ARG)))) + + switch (code) + { + case LSHIFT_EXPR: + if (code_left == PLUS_EXPR || code_right == PLUS_EXPR) + warning (OPT_Wparentheses, + "suggest parentheses around %<+%> inside %<<<%>"); + else if (code_left == MINUS_EXPR || code_right == MINUS_EXPR) + warning (OPT_Wparentheses, + "suggest parentheses around %<-%> inside %<<<%>"); + return; + + case RSHIFT_EXPR: + if (code_left == PLUS_EXPR || code_right == PLUS_EXPR) + warning (OPT_Wparentheses, + "suggest parentheses around %<+%> inside %<>>%>"); + else if (code_left == MINUS_EXPR || code_right == MINUS_EXPR) + warning (OPT_Wparentheses, + "suggest parentheses around %<-%> inside %<>>%>"); + return; + + case TRUTH_ORIF_EXPR: + if (code_left == TRUTH_ANDIF_EXPR || code_right == TRUTH_ANDIF_EXPR) + warning (OPT_Wparentheses, + "suggest parentheses around %<&&%> within %<||%>"); + return; + + case BIT_IOR_EXPR: + if (code_left == BIT_AND_EXPR || code_left == BIT_XOR_EXPR + || code_left == PLUS_EXPR || code_left == MINUS_EXPR + || code_right == BIT_AND_EXPR || code_right == BIT_XOR_EXPR + || code_right == PLUS_EXPR || code_right == MINUS_EXPR) + warning (OPT_Wparentheses, + "suggest parentheses around arithmetic in operand of %<|%>"); + /* Check cases like x|y==z */ + else if (TREE_CODE_CLASS (code_left) == tcc_comparison + || TREE_CODE_CLASS (code_right) == tcc_comparison) + warning (OPT_Wparentheses, + "suggest parentheses around comparison in operand of %<|%>"); + /* Check cases like !x | y */ + else if (code_left == TRUTH_NOT_EXPR + && !APPEARS_TO_BE_BOOLEAN_EXPR_P (code_right, arg_right)) + warning (OPT_Wparentheses, "suggest parentheses around operand of " + "% or change %<|%> to %<||%> or % to %<~%>"); + return; + + case BIT_XOR_EXPR: + if (code_left == BIT_AND_EXPR + || code_left == PLUS_EXPR || code_left == MINUS_EXPR + || code_right == BIT_AND_EXPR + || code_right == PLUS_EXPR || code_right == MINUS_EXPR) + warning (OPT_Wparentheses, + "suggest parentheses around arithmetic in operand of %<^%>"); + /* Check cases like x^y==z */ + else if (TREE_CODE_CLASS (code_left) == tcc_comparison + || TREE_CODE_CLASS (code_right) == tcc_comparison) + warning (OPT_Wparentheses, + "suggest parentheses around comparison in operand of %<^%>"); + return; + + case BIT_AND_EXPR: + if (code_left == PLUS_EXPR || code_right == PLUS_EXPR) + warning (OPT_Wparentheses, + "suggest parentheses around %<+%> in operand of %<&%>"); + else if (code_left == MINUS_EXPR || code_right == MINUS_EXPR) + warning (OPT_Wparentheses, + "suggest parentheses around %<-%> in operand of %<&%>"); + /* Check cases like x&y==z */ + else if (TREE_CODE_CLASS (code_left) == tcc_comparison + || TREE_CODE_CLASS (code_right) == tcc_comparison) + warning (OPT_Wparentheses, + "suggest parentheses around comparison in operand of %<&%>"); + /* Check cases like !x & y */ + else if (code_left == TRUTH_NOT_EXPR + && !APPEARS_TO_BE_BOOLEAN_EXPR_P (code_right, arg_right)) + warning (OPT_Wparentheses, "suggest parentheses around operand of " + "% or change %<&%> to %<&&%> or % to %<~%>"); + return; + + case EQ_EXPR: + if (TREE_CODE_CLASS (code_left) == tcc_comparison + || TREE_CODE_CLASS (code_right) == tcc_comparison) + warning (OPT_Wparentheses, + "suggest parentheses around comparison in operand of %<==%>"); + return; + case NE_EXPR: + if (TREE_CODE_CLASS (code_left) == tcc_comparison + || TREE_CODE_CLASS (code_right) == tcc_comparison) + warning (OPT_Wparentheses, + "suggest parentheses around comparison in operand of %"); + return; + + default: + if (TREE_CODE_CLASS (code) == tcc_comparison + && ((TREE_CODE_CLASS (code_left) == tcc_comparison + && code_left != NE_EXPR && code_left != EQ_EXPR + && INTEGRAL_TYPE_P (TREE_TYPE (arg_left))) + || (TREE_CODE_CLASS (code_right) == tcc_comparison + && code_right != NE_EXPR && code_right != EQ_EXPR + && INTEGRAL_TYPE_P (TREE_TYPE (arg_right))))) + warning (OPT_Wparentheses, "comparisons like % do not " + "have their mathematical meaning"); + return; + } +#undef NOT_A_BOOLEAN_EXPR_P +} + +/* If LABEL (a LABEL_DECL) has not been used, issue a warning. */ + +void +warn_for_unused_label (tree label) +{ + if (!TREE_USED (label)) + { + if (DECL_INITIAL (label)) + warning (OPT_Wunused_label, "label %q+D defined but not used", label); + else + warning (OPT_Wunused_label, "label %q+D declared but not defined", label); + } +} + +#ifndef TARGET_HAS_TARGETCM +struct gcc_targetcm targetcm = TARGETCM_INITIALIZER; +#endif + +/* Warn for division by zero according to the value of DIVISOR. LOC + is the location of the division operator. */ + +void +warn_for_div_by_zero (location_t loc, tree divisor) +{ + /* If DIVISOR is zero, and has integral or fixed-point type, issue a warning + about division by zero. Do not issue a warning if DIVISOR has a + floating-point type, since we consider 0.0/0.0 a valid way of + generating a NaN. */ + if (c_inhibit_evaluation_warnings == 0 + && (integer_zerop (divisor) || fixed_zerop (divisor))) + warning_at (loc, OPT_Wdiv_by_zero, "division by zero"); +} + +/* Subroutine of build_binary_op. Give warnings for comparisons + between signed and unsigned quantities that may fail. Do the + checking based on the original operand trees ORIG_OP0 and ORIG_OP1, + so that casts will be considered, but default promotions won't + be. + + LOCATION is the location of the comparison operator. + + The arguments of this function map directly to local variables + of build_binary_op. */ + +void +warn_for_sign_compare (location_t location, + tree orig_op0, tree orig_op1, + tree op0, tree op1, + tree result_type, enum tree_code resultcode) +{ + int op0_signed = !TYPE_UNSIGNED (TREE_TYPE (orig_op0)); + int op1_signed = !TYPE_UNSIGNED (TREE_TYPE (orig_op1)); + int unsignedp0, unsignedp1; + + /* In C++, check for comparison of different enum types. */ + if (c_dialect_cxx() + && TREE_CODE (TREE_TYPE (orig_op0)) == ENUMERAL_TYPE + && TREE_CODE (TREE_TYPE (orig_op1)) == ENUMERAL_TYPE + && TYPE_MAIN_VARIANT (TREE_TYPE (orig_op0)) + != TYPE_MAIN_VARIANT (TREE_TYPE (orig_op1))) + { + warning_at (location, + OPT_Wsign_compare, "comparison between types %qT and %qT", + TREE_TYPE (orig_op0), TREE_TYPE (orig_op1)); + } + + /* Do not warn if the comparison is being done in a signed type, + since the signed type will only be chosen if it can represent + all the values of the unsigned type. */ + if (!TYPE_UNSIGNED (result_type)) + /* OK */; + /* Do not warn if both operands are unsigned. */ + else if (op0_signed == op1_signed) + /* OK */; + else + { + tree sop, uop, base_type; + bool ovf; + + if (op0_signed) + sop = orig_op0, uop = orig_op1; + else + sop = orig_op1, uop = orig_op0; + + STRIP_TYPE_NOPS (sop); + STRIP_TYPE_NOPS (uop); + base_type = (TREE_CODE (result_type) == COMPLEX_TYPE + ? TREE_TYPE (result_type) : result_type); + + /* Do not warn if the signed quantity is an unsuffixed integer + literal (or some static constant expression involving such + literals or a conditional expression involving such literals) + and it is non-negative. */ + if (tree_expr_nonnegative_warnv_p (sop, &ovf)) + /* OK */; + /* Do not warn if the comparison is an equality operation, the + unsigned quantity is an integral constant, and it would fit + in the result if the result were signed. */ + else if (TREE_CODE (uop) == INTEGER_CST + && (resultcode == EQ_EXPR || resultcode == NE_EXPR) + && int_fits_type_p (uop, c_common_signed_type (base_type))) + /* OK */; + /* In C, do not warn if the unsigned quantity is an enumeration + constant and its maximum value would fit in the result if the + result were signed. */ + else if (!c_dialect_cxx() && TREE_CODE (uop) == INTEGER_CST + && TREE_CODE (TREE_TYPE (uop)) == ENUMERAL_TYPE + && int_fits_type_p (TYPE_MAX_VALUE (TREE_TYPE (uop)), + c_common_signed_type (base_type))) + /* OK */; + else + warning_at (location, + OPT_Wsign_compare, + "comparison between signed and unsigned integer expressions"); + } + + /* Warn if two unsigned values are being compared in a size larger + than their original size, and one (and only one) is the result of + a `~' operator. This comparison will always fail. + + Also warn if one operand is a constant, and the constant does not + have all bits set that are set in the ~ operand when it is + extended. */ + + op0 = get_narrower (op0, &unsignedp0); + op1 = get_narrower (op1, &unsignedp1); + + if ((TREE_CODE (op0) == BIT_NOT_EXPR) + ^ (TREE_CODE (op1) == BIT_NOT_EXPR)) + { + if (TREE_CODE (op0) == BIT_NOT_EXPR) + op0 = get_narrower (TREE_OPERAND (op0, 0), &unsignedp0); + if (TREE_CODE (op1) == BIT_NOT_EXPR) + op1 = get_narrower (TREE_OPERAND (op1, 0), &unsignedp1); + + if (host_integerp (op0, 0) || host_integerp (op1, 0)) + { + tree primop; + HOST_WIDE_INT constant, mask; + int unsignedp; + unsigned int bits; + + if (host_integerp (op0, 0)) + { + primop = op1; + unsignedp = unsignedp1; + constant = tree_low_cst (op0, 0); + } + else + { + primop = op0; + unsignedp = unsignedp0; + constant = tree_low_cst (op1, 0); + } + + bits = TYPE_PRECISION (TREE_TYPE (primop)); + if (bits < TYPE_PRECISION (result_type) + && bits < HOST_BITS_PER_LONG && unsignedp) + { + mask = (~ (HOST_WIDE_INT) 0) << bits; + if ((mask & constant) != mask) + { + if (constant == 0) + warning (OPT_Wsign_compare, + "promoted ~unsigned is always non-zero"); + else + warning_at (location, OPT_Wsign_compare, + "comparison of promoted ~unsigned with constant"); + } + } + } + else if (unsignedp0 && unsignedp1 + && (TYPE_PRECISION (TREE_TYPE (op0)) + < TYPE_PRECISION (result_type)) + && (TYPE_PRECISION (TREE_TYPE (op1)) + < TYPE_PRECISION (result_type))) + warning_at (location, OPT_Wsign_compare, + "comparison of promoted ~unsigned with unsigned"); + } +} + +/* Setup a TYPE_DECL node as a typedef representation. + + X is a TYPE_DECL for a typedef statement. Create a brand new + ..._TYPE node (which will be just a variant of the existing + ..._TYPE node with identical properties) and then install X + 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. */ + +void +set_underlying_type (tree x) +{ + if (x == error_mark_node) + return; + if (DECL_IS_BUILTIN (x)) + { + if (TYPE_NAME (TREE_TYPE (x)) == 0) + TYPE_NAME (TREE_TYPE (x)) = x; + } + else if (TREE_TYPE (x) != error_mark_node + && DECL_ORIGINAL_TYPE (x) == NULL_TREE) + { + tree tt = TREE_TYPE (x); + DECL_ORIGINAL_TYPE (x) = tt; + tt = build_variant_type_copy (tt); + TYPE_STUB_DECL (tt) = TYPE_STUB_DECL (DECL_ORIGINAL_TYPE (x)); + TYPE_NAME (tt) = x; + TREE_USED (tt) = TREE_USED (x); + TREE_TYPE (x) = tt; + } +} + +/* Record the types used by the current global variable declaration + being parsed, so that we can decide later to emit their debug info. + Those types are in types_used_by_cur_var_decl, and we are going to + store them in the types_used_by_vars_hash hash table. + DECL is the declaration of the global variable that has been parsed. */ + +void +record_types_used_by_current_var_decl (tree decl) +{ + gcc_assert (decl && DECL_P (decl) && TREE_STATIC (decl)); + + while (!VEC_empty (tree, types_used_by_cur_var_decl)) + { + tree type = VEC_pop (tree, types_used_by_cur_var_decl); + types_used_by_var_decl_insert (type, decl); + } +} + +/* The C and C++ parsers both use vectors to hold function arguments. + For efficiency, we keep a cache of unused vectors. This is the + cache. */ + +typedef VEC(tree,gc)* tree_gc_vec; +DEF_VEC_P(tree_gc_vec); +DEF_VEC_ALLOC_P(tree_gc_vec,gc); +static GTY((deletable)) VEC(tree_gc_vec,gc) *tree_vector_cache; + +/* Return a new vector from the cache. If the cache is empty, + allocate a new vector. These vectors are GC'ed, so it is OK if the + pointer is not released.. */ + +VEC(tree,gc) * +make_tree_vector (void) +{ + if (!VEC_empty (tree_gc_vec, tree_vector_cache)) + return VEC_pop (tree_gc_vec, tree_vector_cache); + else + { + /* Passing 0 to VEC_alloc returns NULL, and our callers require + that we always return a non-NULL value. The vector code uses + 4 when growing a NULL vector, so we do too. */ + return VEC_alloc (tree, gc, 4); + } +} + +/* Release a vector of trees back to the cache. */ + +void +release_tree_vector (VEC(tree,gc) *vec) +{ + if (vec != NULL) + { + VEC_truncate (tree, vec, 0); + VEC_safe_push (tree_gc_vec, gc, tree_vector_cache, vec); + } +} + +/* Get a new tree vector holding a single tree. */ + +VEC(tree,gc) * +make_tree_vector_single (tree t) +{ + VEC(tree,gc) *ret = make_tree_vector (); + VEC_quick_push (tree, ret, t); + return ret; +} + +/* Get a new tree vector which is a copy of an existing one. */ + +VEC(tree,gc) * +make_tree_vector_copy (const VEC(tree,gc) *orig) +{ + VEC(tree,gc) *ret; + unsigned int ix; + tree t; + + ret = make_tree_vector (); + VEC_reserve (tree, gc, ret, VEC_length (tree, orig)); + for (ix = 0; VEC_iterate (tree, orig, ix, t); ++ix) + VEC_quick_push (tree, ret, t); + return ret; +} + +#include "gt-c-family-c-common.h" diff --git a/gcc/c-family/c-common.def b/gcc/c-family/c-common.def new file mode 100644 index 00000000000..1c593633e12 --- /dev/null +++ b/gcc/c-family/c-common.def @@ -0,0 +1,53 @@ +/* This file contains the definitions and documentation for the + additional tree codes used in the GNU C compiler (see tree.def + for the standard codes). + Copyright (C) 1987, 1988, 1990, 1993, 1997, 1998, + 1999, 2000, 2001, 2004, 2005, 2007, 2009 Free Software Foundation, Inc. + Written by Benjamin Chelf + +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 3, 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 COPYING3. If not see +. */ + +/* Tree nodes used in the C frontend. These are also shared with the + C++ and Objective C frontends. */ + +/* A C_MAYBE_CONST_EXPR, currently only used for C and Objective C, + tracks information about constancy of an expression and VLA type + sizes or VM expressions from typeof that need to be evaluated + before the main expression. It is used during parsing and removed + in c_fully_fold. C_MAYBE_CONST_EXPR_PRE is the expression to + evaluate first, if not NULL; C_MAYBE_CONST_EXPR_EXPR is the main + expression. If C_MAYBE_CONST_EXPR_INT_OPERANDS is set then the + expression may be used in an unevaluated part of an integer + constant expression, but not in an evaluated part. If + C_MAYBE_CONST_EXPR_NON_CONST is set then the expression contains + something that cannot occur in an evaluated part of a constant + expression (or outside of sizeof in C90 mode); otherwise it does + not. */ +DEFTREECODE (C_MAYBE_CONST_EXPR, "c_maybe_const_expr", tcc_expression, 2) + +/* An EXCESS_PRECISION_EXPR, currently only used for C and Objective + C, represents an expression evaluated in greater range or precision + than its type. The type of the EXCESS_PRECISION_EXPR is the + semantic type while the operand represents what is actually being + evaluated. */ +DEFTREECODE (EXCESS_PRECISION_EXPR, "excess_precision_expr", tcc_expression, 1) + +/* +Local variables: +mode:c +End: +*/ diff --git a/gcc/c-family/c-common.h b/gcc/c-family/c-common.h new file mode 100644 index 00000000000..5784746e90a --- /dev/null +++ b/gcc/c-family/c-common.h @@ -0,0 +1,1009 @@ +/* Definitions for c-common.c. + Copyright (C) 1987, 1993, 1994, 1995, 1997, 1998, + 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009 + 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 3, 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 COPYING3. If not see +. */ + +#ifndef GCC_C_COMMON_H +#define GCC_C_COMMON_H + +#include "splay-tree.h" +#include "cpplib.h" +#include "ggc.h" + +/* In order for the format checking to accept the C frontend + diagnostic framework extensions, you must include this file before + toplev.h, not after. The C front end formats are a subset of those + for C++, so they are the appropriate set to use in common code; + cp-tree.h overrides this for C++. */ +#ifndef GCC_DIAG_STYLE +#define GCC_DIAG_STYLE __gcc_cdiag__ +#endif +#include "diagnostic-core.h" + +/* Usage of TREE_LANG_FLAG_?: + 0: TREE_NEGATED_INT (in INTEGER_CST). + IDENTIFIER_MARKED (used by search routines). + DECL_PRETTY_FUNCTION_P (in VAR_DECL) + C_MAYBE_CONST_EXPR_INT_OPERANDS (in C_MAYBE_CONST_EXPR, for C) + 1: C_DECLARED_LABEL_FLAG (in LABEL_DECL) + STATEMENT_LIST_STMT_EXPR (in STATEMENT_LIST) + C_MAYBE_CONST_EXPR_NON_CONST (in C_MAYBE_CONST_EXPR, for C) + 2: unused + 3: STATEMENT_LIST_HAS_LABEL (in STATEMENT_LIST) + 4: unused +*/ + +/* Reserved identifiers. This is the union of all the keywords for C, + C++, and Objective-C. All the type modifiers have to be in one + block at the beginning, because they are used as mask bits. There + are 27 type modifiers; if we add many more we will have to redesign + the mask mechanism. */ + +enum rid +{ + /* Modifiers: */ + /* C, in empirical order of frequency. */ + RID_STATIC = 0, + RID_UNSIGNED, RID_LONG, RID_CONST, RID_EXTERN, + RID_REGISTER, RID_TYPEDEF, RID_SHORT, RID_INLINE, + RID_VOLATILE, RID_SIGNED, RID_AUTO, RID_RESTRICT, + + /* C extensions */ + RID_COMPLEX, RID_THREAD, RID_SAT, + + /* C++ */ + RID_FRIEND, RID_VIRTUAL, RID_EXPLICIT, RID_EXPORT, RID_MUTABLE, + + /* ObjC */ + RID_IN, RID_OUT, RID_INOUT, RID_BYCOPY, RID_BYREF, RID_ONEWAY, + + /* C (reserved and imaginary types not implemented, so any use is a + syntax error) */ + RID_IMAGINARY, + + /* C */ + RID_INT, RID_CHAR, RID_FLOAT, RID_DOUBLE, RID_VOID, + RID_INT128, + RID_ENUM, RID_STRUCT, RID_UNION, RID_IF, RID_ELSE, + RID_WHILE, RID_DO, RID_FOR, RID_SWITCH, RID_CASE, + RID_DEFAULT, RID_BREAK, RID_CONTINUE, RID_RETURN, RID_GOTO, + RID_SIZEOF, + + /* C extensions */ + RID_ASM, RID_TYPEOF, RID_ALIGNOF, RID_ATTRIBUTE, RID_VA_ARG, + RID_EXTENSION, RID_IMAGPART, RID_REALPART, RID_LABEL, RID_CHOOSE_EXPR, + RID_TYPES_COMPATIBLE_P, + RID_DFLOAT32, RID_DFLOAT64, RID_DFLOAT128, + RID_FRACT, RID_ACCUM, + + /* This means to warn that this is a C++ keyword, and then treat it + as a normal identifier. */ + RID_CXX_COMPAT_WARN, + + /* Too many ways of getting the name of a function as a string */ + RID_FUNCTION_NAME, RID_PRETTY_FUNCTION_NAME, RID_C99_FUNCTION_NAME, + + /* C++ */ + RID_BOOL, RID_WCHAR, RID_CLASS, + RID_PUBLIC, RID_PRIVATE, RID_PROTECTED, + RID_TEMPLATE, RID_NULL, RID_CATCH, + RID_DELETE, RID_FALSE, RID_NAMESPACE, + RID_NEW, RID_OFFSETOF, RID_OPERATOR, + RID_THIS, RID_THROW, RID_TRUE, + RID_TRY, RID_TYPENAME, RID_TYPEID, + RID_USING, RID_CHAR16, RID_CHAR32, + + /* casts */ + RID_CONSTCAST, RID_DYNCAST, RID_REINTCAST, RID_STATCAST, + + /* C++ extensions */ + RID_HAS_NOTHROW_ASSIGN, RID_HAS_NOTHROW_CONSTRUCTOR, + RID_HAS_NOTHROW_COPY, RID_HAS_TRIVIAL_ASSIGN, + RID_HAS_TRIVIAL_CONSTRUCTOR, RID_HAS_TRIVIAL_COPY, + RID_HAS_TRIVIAL_DESTRUCTOR, RID_HAS_VIRTUAL_DESTRUCTOR, + RID_IS_ABSTRACT, RID_IS_BASE_OF, + RID_IS_CONVERTIBLE_TO, RID_IS_CLASS, + RID_IS_EMPTY, RID_IS_ENUM, + RID_IS_POD, RID_IS_POLYMORPHIC, + RID_IS_STD_LAYOUT, RID_IS_TRIVIAL, + RID_IS_UNION, + + /* C++0x */ + RID_CONSTEXPR, RID_DECLTYPE, RID_NOEXCEPT, RID_NULLPTR, RID_STATIC_ASSERT, + + /* Objective-C */ + RID_AT_ENCODE, RID_AT_END, + RID_AT_CLASS, RID_AT_ALIAS, RID_AT_DEFS, + RID_AT_PRIVATE, RID_AT_PROTECTED, RID_AT_PUBLIC, + RID_AT_PROTOCOL, RID_AT_SELECTOR, + RID_AT_THROW, RID_AT_TRY, RID_AT_CATCH, + RID_AT_FINALLY, RID_AT_SYNCHRONIZED, + RID_AT_INTERFACE, + RID_AT_IMPLEMENTATION, + + /* Named address support, mapping the keyword to a particular named address + number. Named address space 0 is reserved for the generic address. If + there are more than 254 named addresses, the addr_space_t type will need + to be grown from an unsigned char to unsigned short. */ + RID_ADDR_SPACE_0, /* generic address */ + RID_ADDR_SPACE_1, + RID_ADDR_SPACE_2, + RID_ADDR_SPACE_3, + RID_ADDR_SPACE_4, + RID_ADDR_SPACE_5, + RID_ADDR_SPACE_6, + RID_ADDR_SPACE_7, + RID_ADDR_SPACE_8, + RID_ADDR_SPACE_9, + RID_ADDR_SPACE_10, + RID_ADDR_SPACE_11, + RID_ADDR_SPACE_12, + RID_ADDR_SPACE_13, + RID_ADDR_SPACE_14, + RID_ADDR_SPACE_15, + + RID_FIRST_ADDR_SPACE = RID_ADDR_SPACE_0, + RID_LAST_ADDR_SPACE = RID_ADDR_SPACE_15, + + RID_MAX, + + RID_FIRST_MODIFIER = RID_STATIC, + RID_LAST_MODIFIER = RID_ONEWAY, + + RID_FIRST_CXX0X = RID_CONSTEXPR, + RID_LAST_CXX0X = RID_STATIC_ASSERT, + RID_FIRST_AT = RID_AT_ENCODE, + RID_LAST_AT = RID_AT_IMPLEMENTATION, + RID_FIRST_PQ = RID_IN, + RID_LAST_PQ = RID_ONEWAY +}; + +#define OBJC_IS_AT_KEYWORD(rid) \ + ((unsigned int) (rid) >= (unsigned int) RID_FIRST_AT && \ + (unsigned int) (rid) <= (unsigned int) RID_LAST_AT) + +#define OBJC_IS_PQ_KEYWORD(rid) \ + ((unsigned int) (rid) >= (unsigned int) RID_FIRST_PQ && \ + (unsigned int) (rid) <= (unsigned int) RID_LAST_PQ) + +/* The elements of `ridpointers' are identifier nodes for the reserved + type names and storage classes. It is indexed by a RID_... value. */ +extern GTY ((length ("(int) RID_MAX"))) tree *ridpointers; + +/* Standard named or nameless data types of the C compiler. */ + +enum c_tree_index +{ + CTI_CHAR16_TYPE, + CTI_CHAR32_TYPE, + CTI_WCHAR_TYPE, + CTI_UNDERLYING_WCHAR_TYPE, + CTI_WINT_TYPE, + CTI_SIGNED_SIZE_TYPE, /* For format checking only. */ + CTI_UNSIGNED_PTRDIFF_TYPE, /* For format checking only. */ + CTI_INTMAX_TYPE, + CTI_UINTMAX_TYPE, + CTI_WIDEST_INT_LIT_TYPE, + CTI_WIDEST_UINT_LIT_TYPE, + + /* Types for , that may not be defined on all + targets. */ + CTI_SIG_ATOMIC_TYPE, + CTI_INT8_TYPE, + CTI_INT16_TYPE, + CTI_INT32_TYPE, + CTI_INT64_TYPE, + CTI_UINT8_TYPE, + CTI_UINT16_TYPE, + CTI_UINT32_TYPE, + CTI_UINT64_TYPE, + CTI_INT_LEAST8_TYPE, + CTI_INT_LEAST16_TYPE, + CTI_INT_LEAST32_TYPE, + CTI_INT_LEAST64_TYPE, + CTI_UINT_LEAST8_TYPE, + CTI_UINT_LEAST16_TYPE, + CTI_UINT_LEAST32_TYPE, + CTI_UINT_LEAST64_TYPE, + CTI_INT_FAST8_TYPE, + CTI_INT_FAST16_TYPE, + CTI_INT_FAST32_TYPE, + CTI_INT_FAST64_TYPE, + CTI_UINT_FAST8_TYPE, + CTI_UINT_FAST16_TYPE, + CTI_UINT_FAST32_TYPE, + CTI_UINT_FAST64_TYPE, + CTI_INTPTR_TYPE, + CTI_UINTPTR_TYPE, + + CTI_CHAR_ARRAY_TYPE, + CTI_CHAR16_ARRAY_TYPE, + CTI_CHAR32_ARRAY_TYPE, + CTI_WCHAR_ARRAY_TYPE, + CTI_INT_ARRAY_TYPE, + CTI_STRING_TYPE, + CTI_CONST_STRING_TYPE, + + /* Type for boolean expressions (bool in C++, int in C). */ + CTI_TRUTHVALUE_TYPE, + CTI_TRUTHVALUE_TRUE, + CTI_TRUTHVALUE_FALSE, + + CTI_DEFAULT_FUNCTION_TYPE, + + /* These are not types, but we have to look them up all the time. */ + CTI_FUNCTION_NAME_DECL, + CTI_PRETTY_FUNCTION_NAME_DECL, + CTI_C99_FUNCTION_NAME_DECL, + CTI_SAVED_FUNCTION_NAME_DECLS, + + CTI_VOID_ZERO, + + CTI_NULL, + + CTI_MAX +}; + +#define C_CPP_HASHNODE(id) \ + (&(((struct c_common_identifier *) (id))->node)) +#define C_RID_CODE(id) \ + ((enum rid) (((struct c_common_identifier *) (id))->node.rid_code)) +#define C_SET_RID_CODE(id, code) \ + (((struct c_common_identifier *) (id))->node.rid_code = (unsigned char) code) + +/* Identifier part common to the C front ends. Inherits from + tree_identifier, despite appearances. */ +struct GTY(()) c_common_identifier { + struct tree_common common; + struct cpp_hashnode node; +}; + +/* An entry in the reserved keyword table. */ + +struct c_common_resword +{ + const char *const word; + ENUM_BITFIELD(rid) const rid : 16; + const unsigned int disable : 16; +}; + +/* Disable mask. Keywords are disabled if (reswords[i].disable & + mask) is _true_. Thus for keywords which are present in all + languages the disable field is zero. */ + +#define D_CONLY 0x001 /* C only (not in C++). */ +#define D_CXXONLY 0x002 /* C++ only (not in C). */ +#define D_C99 0x004 /* In C, C99 only. */ +#define D_CXX0X 0x008 /* In C++, C++0X only. */ +#define D_EXT 0x010 /* GCC extension. */ +#define D_EXT89 0x020 /* GCC extension incorporated in C99. */ +#define D_ASM 0x040 /* Disabled by -fno-asm. */ +#define D_OBJC 0x080 /* In Objective C and neither C nor C++. */ +#define D_CXX_OBJC 0x100 /* In Objective C, and C++, but not C. */ +#define D_CXXWARN 0x200 /* In C warn with -Wcxx-compat. */ + +/* The reserved keyword table. */ +extern const struct c_common_resword c_common_reswords[]; + +/* The number of items in the reserved keyword table. */ +extern const unsigned int num_c_common_reswords; + +#define char16_type_node c_global_trees[CTI_CHAR16_TYPE] +#define char32_type_node c_global_trees[CTI_CHAR32_TYPE] +#define wchar_type_node c_global_trees[CTI_WCHAR_TYPE] +#define underlying_wchar_type_node c_global_trees[CTI_UNDERLYING_WCHAR_TYPE] +#define wint_type_node c_global_trees[CTI_WINT_TYPE] +#define signed_size_type_node c_global_trees[CTI_SIGNED_SIZE_TYPE] +#define unsigned_ptrdiff_type_node c_global_trees[CTI_UNSIGNED_PTRDIFF_TYPE] +#define intmax_type_node c_global_trees[CTI_INTMAX_TYPE] +#define uintmax_type_node c_global_trees[CTI_UINTMAX_TYPE] +#define widest_integer_literal_type_node c_global_trees[CTI_WIDEST_INT_LIT_TYPE] +#define widest_unsigned_literal_type_node c_global_trees[CTI_WIDEST_UINT_LIT_TYPE] + +#define sig_atomic_type_node c_global_trees[CTI_SIG_ATOMIC_TYPE] +#define int8_type_node c_global_trees[CTI_INT8_TYPE] +#define int16_type_node c_global_trees[CTI_INT16_TYPE] +#define int32_type_node c_global_trees[CTI_INT32_TYPE] +#define int64_type_node c_global_trees[CTI_INT64_TYPE] +#define uint8_type_node c_global_trees[CTI_UINT8_TYPE] +#define uint16_type_node c_global_trees[CTI_UINT16_TYPE] +#define c_uint32_type_node c_global_trees[CTI_UINT32_TYPE] +#define c_uint64_type_node c_global_trees[CTI_UINT64_TYPE] +#define int_least8_type_node c_global_trees[CTI_INT_LEAST8_TYPE] +#define int_least16_type_node c_global_trees[CTI_INT_LEAST16_TYPE] +#define int_least32_type_node c_global_trees[CTI_INT_LEAST32_TYPE] +#define int_least64_type_node c_global_trees[CTI_INT_LEAST64_TYPE] +#define uint_least8_type_node c_global_trees[CTI_UINT_LEAST8_TYPE] +#define uint_least16_type_node c_global_trees[CTI_UINT_LEAST16_TYPE] +#define uint_least32_type_node c_global_trees[CTI_UINT_LEAST32_TYPE] +#define uint_least64_type_node c_global_trees[CTI_UINT_LEAST64_TYPE] +#define int_fast8_type_node c_global_trees[CTI_INT_FAST8_TYPE] +#define int_fast16_type_node c_global_trees[CTI_INT_FAST16_TYPE] +#define int_fast32_type_node c_global_trees[CTI_INT_FAST32_TYPE] +#define int_fast64_type_node c_global_trees[CTI_INT_FAST64_TYPE] +#define uint_fast8_type_node c_global_trees[CTI_UINT_FAST8_TYPE] +#define uint_fast16_type_node c_global_trees[CTI_UINT_FAST16_TYPE] +#define uint_fast32_type_node c_global_trees[CTI_UINT_FAST32_TYPE] +#define uint_fast64_type_node c_global_trees[CTI_UINT_FAST64_TYPE] +#define intptr_type_node c_global_trees[CTI_INTPTR_TYPE] +#define uintptr_type_node c_global_trees[CTI_UINTPTR_TYPE] + +#define truthvalue_type_node c_global_trees[CTI_TRUTHVALUE_TYPE] +#define truthvalue_true_node c_global_trees[CTI_TRUTHVALUE_TRUE] +#define truthvalue_false_node c_global_trees[CTI_TRUTHVALUE_FALSE] + +#define char_array_type_node c_global_trees[CTI_CHAR_ARRAY_TYPE] +#define char16_array_type_node c_global_trees[CTI_CHAR16_ARRAY_TYPE] +#define char32_array_type_node c_global_trees[CTI_CHAR32_ARRAY_TYPE] +#define wchar_array_type_node c_global_trees[CTI_WCHAR_ARRAY_TYPE] +#define int_array_type_node c_global_trees[CTI_INT_ARRAY_TYPE] +#define string_type_node c_global_trees[CTI_STRING_TYPE] +#define const_string_type_node c_global_trees[CTI_CONST_STRING_TYPE] + +#define default_function_type c_global_trees[CTI_DEFAULT_FUNCTION_TYPE] + +#define function_name_decl_node c_global_trees[CTI_FUNCTION_NAME_DECL] +#define pretty_function_name_decl_node c_global_trees[CTI_PRETTY_FUNCTION_NAME_DECL] +#define c99_function_name_decl_node c_global_trees[CTI_C99_FUNCTION_NAME_DECL] +#define saved_function_name_decls c_global_trees[CTI_SAVED_FUNCTION_NAME_DECLS] + +/* A node for `((void) 0)'. */ +#define void_zero_node c_global_trees[CTI_VOID_ZERO] + +/* The node for C++ `__null'. */ +#define null_node c_global_trees[CTI_NULL] + +extern GTY(()) tree c_global_trees[CTI_MAX]; + +/* In a RECORD_TYPE, a sorted array of the fields of the type, not a + tree for size reasons. */ +struct GTY((variable_size)) sorted_fields_type { + int len; + tree GTY((length ("%h.len"))) elts[1]; +}; + +/* Mark which labels are explicitly declared. + These may be shadowed, and may be referenced from nested functions. */ +#define C_DECLARED_LABEL_FLAG(label) TREE_LANG_FLAG_1 (label) + +typedef enum c_language_kind +{ + clk_c = 0, /* C90, C94 or C99 */ + clk_objc = 1, /* clk_c with ObjC features. */ + clk_cxx = 2, /* ANSI/ISO C++ */ + clk_objcxx = 3 /* clk_cxx with ObjC features. */ +} +c_language_kind; + +/* To test for a specific language use c_language, defined by each + front end. For "ObjC features" or "not C++" use the macros. */ +extern c_language_kind c_language; + +#define c_dialect_cxx() ((c_language & clk_cxx) != 0) +#define c_dialect_objc() ((c_language & clk_objc) != 0) + +/* The various name of operator that appears in error messages. */ +typedef enum ref_operator { + /* NULL */ + RO_NULL, + /* array indexing */ + RO_ARRAY_INDEXING, + /* unary * */ + RO_UNARY_STAR, + /* -> */ + RO_ARROW, + /* implicit conversion */ + RO_IMPLICIT_CONVERSION +} ref_operator; + +/* Information about a statement tree. */ + +struct GTY(()) stmt_tree_s { + /* The current statement list being collected. */ + tree x_cur_stmt_list; + + /* In C++, Nonzero if we should treat statements as full + expressions. In particular, this variable is no-zero if at the + end of a statement we should destroy any temporaries created + during that statement. Similarly, if, at the end of a block, we + should destroy any local variables in this block. Normally, this + variable is nonzero, since those are the normal semantics of + C++. + + However, in order to represent aggregate initialization code as + tree structure, we use statement-expressions. The statements + within the statement expression should not result in cleanups + being run until the entire enclosing statement is complete. + + This flag has no effect in C. */ + int stmts_are_full_exprs_p; +}; + +typedef struct stmt_tree_s *stmt_tree; + +/* Global state pertinent to the current function. Some C dialects + extend this structure with additional fields. */ + +struct GTY(()) c_language_function { + /* While we are parsing the function, this contains information + about the statement-tree that we are building. */ + struct stmt_tree_s x_stmt_tree; +}; + +/* When building a statement-tree, this is the current statement list + being collected. It's TREE_CHAIN is a back-pointer to the previous + statement list. */ + +#define cur_stmt_list (current_stmt_tree ()->x_cur_stmt_list) + +/* Language-specific hooks. */ + +/* If non-NULL, this function is called after a precompile header file + is loaded. */ +extern void (*lang_post_pch_load) (void); + +extern void push_file_scope (void); +extern void pop_file_scope (void); +extern stmt_tree current_stmt_tree (void); +extern tree push_stmt_list (void); +extern tree pop_stmt_list (tree); +extern tree add_stmt (tree); +extern void push_cleanup (tree, tree, bool); +extern tree pushdecl_top_level (tree); +extern tree pushdecl (tree); +extern tree build_modify_expr (location_t, tree, tree, enum tree_code, + location_t, tree, tree); +extern tree build_indirect_ref (location_t, tree, ref_operator); + +extern int c_expand_decl (tree); + +extern int field_decl_cmp (const void *, const void *); +extern void resort_sorted_fields (void *, void *, gt_pointer_operator, + void *); +extern bool has_c_linkage (const_tree decl); + +/* Switches common to the C front ends. */ + +/* Nonzero means don't output line number information. */ + +extern char flag_no_line_commands; + +/* Nonzero causes -E output not to be done, but directives such as + #define that have side effects are still obeyed. */ + +extern char flag_no_output; + +/* Nonzero means dump macros in some fashion; contains the 'D', 'M', + 'N' or 'U' of the command line switch. */ + +extern char flag_dump_macros; + +/* Nonzero means pass #include lines through to the output. */ + +extern char flag_dump_includes; + +/* Nonzero means process PCH files while preprocessing. */ + +extern bool flag_pch_preprocess; + +/* The file name to which we should write a precompiled header, or + NULL if no header will be written in this compile. */ + +extern const char *pch_file; + +/* Nonzero if an ISO standard was selected. It rejects macros in the + user's namespace. */ + +extern int flag_iso; + +/* Warn about #pragma directives that are not recognized. */ + +extern int warn_unknown_pragmas; /* Tri state variable. */ + +/* Warn about format/argument anomalies in calls to formatted I/O functions + (*printf, *scanf, strftime, strfmon, etc.). */ + +extern int warn_format; + + +/* C/ObjC language option variables. */ + + +/* Nonzero means allow type mismatches in conditional expressions; + just make their values `void'. */ + +extern int flag_cond_mismatch; + +/* Nonzero means enable C89 Amendment 1 features. */ + +extern int flag_isoc94; + +/* Nonzero means use the ISO C99 (or C1X) dialect of C. */ + +extern int flag_isoc99; + +/* Nonzero means use the ISO C1X dialect of C. */ + +extern int flag_isoc1x; + +/* Nonzero means that we have builtin functions, and main is an int. */ + +extern int flag_hosted; + +/* ObjC language option variables. */ + + +/* Tells the compiler that this is a special run. Do not perform any + compiling, instead we are to test some platform dependent features + and output a C header file with appropriate definitions. */ + +extern int print_struct_values; + +/* ???. Undocumented. */ + +extern const char *constant_string_class_name; + + +/* C++ language option variables. */ + + +/* Nonzero means generate separate instantiation control files and + juggle them at link time. */ + +extern int flag_use_repository; + +/* The supported C++ dialects. */ + +enum cxx_dialect { + /* C++98 */ + cxx98, + /* Experimental features that are likely to become part of + C++0x. */ + cxx0x +}; + +/* The C++ dialect being used. C++98 is the default. */ +extern enum cxx_dialect cxx_dialect; + +/* Maximum template instantiation depth. This limit is rather + arbitrary, but it exists to limit the time it takes to notice + infinite template instantiations. */ + +extern int max_tinst_depth; + +/* Nonzero means that we should not issue warnings about problems that + occur when the code is executed, because the code being processed + is not expected to be executed. This is set during parsing. This + is used for cases like sizeof() and "0 ? a : b". This is a count, + not a bool, because unexecuted expressions can nest. */ + +extern int c_inhibit_evaluation_warnings; + +/* Whether lexing has been completed, so subsequent preprocessor + errors should use the compiler's input_location. */ + +extern bool done_lexing; + +/* C types are partitioned into three subsets: object, function, and + incomplete types. */ +#define C_TYPE_OBJECT_P(type) \ + (TREE_CODE (type) != FUNCTION_TYPE && TYPE_SIZE (type)) + +#define C_TYPE_INCOMPLETE_P(type) \ + (TREE_CODE (type) != FUNCTION_TYPE && TYPE_SIZE (type) == 0) + +#define C_TYPE_FUNCTION_P(type) \ + (TREE_CODE (type) == FUNCTION_TYPE) + +/* For convenience we define a single macro to identify the class of + object or incomplete types. */ +#define C_TYPE_OBJECT_OR_INCOMPLETE_P(type) \ + (!C_TYPE_FUNCTION_P (type)) + +/* Attribute table common to the C front ends. */ +extern const struct attribute_spec c_common_attribute_table[]; +extern const struct attribute_spec c_common_format_attribute_table[]; + +/* Pointer to function to lazily generate the VAR_DECL for __FUNCTION__ etc. + ID is the identifier to use, NAME is the string. + TYPE_DEP indicates whether it depends on type of the function or not + (i.e. __PRETTY_FUNCTION__). */ + +extern tree (*make_fname_decl) (location_t, tree, int); + +/* In c-decl.c and cp/tree.c. FIXME. */ +extern void c_register_addr_space (const char *str, addr_space_t as); + +/* In c-common.c. */ +extern const char *c_addr_space_name (addr_space_t as); +extern tree identifier_global_value (tree); +extern void record_builtin_type (enum rid, const char *, tree); +extern tree build_void_list_node (void); +extern void start_fname_decls (void); +extern void finish_fname_decls (void); +extern const char *fname_as_string (int); +extern tree fname_decl (location_t, unsigned, tree); + +extern void check_function_arguments (tree, int, tree *, tree); +extern void check_function_arguments_recurse (void (*) + (void *, tree, + unsigned HOST_WIDE_INT), + void *, tree, + unsigned HOST_WIDE_INT); +extern bool check_builtin_function_arguments (tree, int, tree *); +extern void check_function_format (tree, int, tree *); +extern void set_Wformat (int); +extern tree handle_format_attribute (tree *, tree, tree, int, bool *); +extern tree handle_format_arg_attribute (tree *, tree, tree, int, bool *); +extern bool attribute_takes_identifier_p (const_tree); +extern int c_common_handle_option (size_t code, const char *arg, int value, int kind); +extern bool c_common_missing_argument (const char *opt, size_t code); +extern tree c_common_type_for_mode (enum machine_mode, int); +extern tree c_common_type_for_size (unsigned int, int); +extern tree c_common_fixed_point_type_for_size (unsigned int, unsigned int, + int, int); +extern tree c_common_unsigned_type (tree); +extern tree c_common_signed_type (tree); +extern tree c_common_signed_or_unsigned_type (int, tree); +extern tree c_build_bitfield_integer_type (unsigned HOST_WIDE_INT, int); +extern bool decl_with_nonnull_addr_p (const_tree); +extern tree c_fully_fold (tree, bool, bool *); +extern tree decl_constant_value_for_optimization (tree); +extern tree c_wrap_maybe_const (tree, bool); +extern tree c_save_expr (tree); +extern tree c_common_truthvalue_conversion (location_t, tree); +extern void c_apply_type_quals_to_decl (int, tree); +extern tree c_sizeof_or_alignof_type (location_t, tree, bool, int); +extern tree c_alignof_expr (location_t, tree); +/* Print an error message for invalid operands to arith operation CODE. + NOP_EXPR is used as a special case (see truthvalue_conversion). */ +extern void binary_op_error (location_t, enum tree_code, tree, tree); +extern tree fix_string_type (tree); +extern void constant_expression_warning (tree); +extern void constant_expression_error (tree); +extern bool strict_aliasing_warning (tree, tree, tree); +extern void warnings_for_convert_and_check (tree, tree, tree); +extern tree convert_and_check (tree, tree); +extern void overflow_warning (location_t, tree); +extern void warn_logical_operator (location_t, enum tree_code, tree, + enum tree_code, tree, enum tree_code, tree); +extern void check_main_parameter_types (tree decl); +extern bool c_determine_visibility (tree); +extern bool same_scalar_type_ignoring_signedness (tree, tree); +extern void mark_valid_location_for_stdc_pragma (bool); +extern bool valid_location_for_stdc_pragma_p (void); +extern void set_float_const_decimal64 (void); +extern void clear_float_const_decimal64 (void); +extern bool float_const_decimal64_p (void); + +#define c_sizeof(LOC, T) c_sizeof_or_alignof_type (LOC, T, true, 1) +#define c_alignof(LOC, T) c_sizeof_or_alignof_type (LOC, T, false, 1) + +/* Subroutine of build_binary_op, used for certain operations. */ +extern tree shorten_binary_op (tree result_type, tree op0, tree op1, bool bitwise); + +/* Subroutine of build_binary_op, used for comparison operations. + See if the operands have both been converted from subword integer types + and, if so, perhaps change them both back to their original type. */ +extern tree shorten_compare (tree *, tree *, tree *, enum tree_code *); + +extern tree pointer_int_sum (location_t, enum tree_code, tree, tree); + +/* Add qualifiers to a type, in the fashion for C. */ +extern tree c_build_qualified_type (tree, int); + +/* Build tree nodes and builtin functions common to both C and C++ language + frontends. */ +extern void c_common_nodes_and_builtins (void); + +extern void disable_builtin_function (const char *); + +extern void set_compound_literal_name (tree decl); + +extern tree build_va_arg (location_t, tree, tree); + +extern unsigned int c_common_init_options (unsigned int, const char **); +extern bool c_common_post_options (const char **); +extern bool c_common_init (void); +extern void c_common_finish (void); +extern void c_common_parse_file (int); +extern alias_set_type c_common_get_alias_set (tree); +extern void c_register_builtin_type (tree, const char*); +extern bool c_promoting_integer_type_p (const_tree); +extern int self_promoting_args_p (const_tree); +extern tree strip_pointer_operator (tree); +extern tree strip_pointer_or_array_types (tree); +extern HOST_WIDE_INT c_common_to_target_charset (HOST_WIDE_INT); + +/* This is the basic parsing function. */ +extern void c_parse_file (void); +/* This is misnamed, it actually performs end-of-compilation processing. */ +extern void finish_file (void); + +extern void warn_for_omitted_condop (location_t, tree); + +/* These macros provide convenient access to the various _STMT nodes. */ + +/* Nonzero if a given STATEMENT_LIST represents the outermost binding + if a statement expression. */ +#define STATEMENT_LIST_STMT_EXPR(NODE) \ + TREE_LANG_FLAG_1 (STATEMENT_LIST_CHECK (NODE)) + +/* Nonzero if a label has been added to the statement list. */ +#define STATEMENT_LIST_HAS_LABEL(NODE) \ + TREE_LANG_FLAG_3 (STATEMENT_LIST_CHECK (NODE)) + +/* C_MAYBE_CONST_EXPR accessors. */ +#define C_MAYBE_CONST_EXPR_PRE(NODE) \ + TREE_OPERAND (C_MAYBE_CONST_EXPR_CHECK (NODE), 0) +#define C_MAYBE_CONST_EXPR_EXPR(NODE) \ + TREE_OPERAND (C_MAYBE_CONST_EXPR_CHECK (NODE), 1) +#define C_MAYBE_CONST_EXPR_INT_OPERANDS(NODE) \ + TREE_LANG_FLAG_0 (C_MAYBE_CONST_EXPR_CHECK (NODE)) +#define C_MAYBE_CONST_EXPR_NON_CONST(NODE) \ + TREE_LANG_FLAG_1 (C_MAYBE_CONST_EXPR_CHECK (NODE)) +#define EXPR_INT_CONST_OPERANDS(EXPR) \ + (INTEGRAL_TYPE_P (TREE_TYPE (EXPR)) \ + && (TREE_CODE (EXPR) == INTEGER_CST \ + || (TREE_CODE (EXPR) == C_MAYBE_CONST_EXPR \ + && C_MAYBE_CONST_EXPR_INT_OPERANDS (EXPR)))) + +/* In a FIELD_DECL, nonzero if the decl was originally a bitfield. */ +#define DECL_C_BIT_FIELD(NODE) \ + (DECL_LANG_FLAG_4 (FIELD_DECL_CHECK (NODE)) == 1) +#define SET_DECL_C_BIT_FIELD(NODE) \ + (DECL_LANG_FLAG_4 (FIELD_DECL_CHECK (NODE)) = 1) +#define CLEAR_DECL_C_BIT_FIELD(NODE) \ + (DECL_LANG_FLAG_4 (FIELD_DECL_CHECK (NODE)) = 0) + +extern tree do_case (location_t, tree, tree); +extern tree build_stmt (location_t, enum tree_code, ...); +extern tree build_case_label (location_t, tree, tree, tree); + +/* These functions must be defined by each front-end which implements + a variant of the C language. They are used in c-common.c. */ + +extern tree build_unary_op (location_t, enum tree_code, tree, int); +extern tree build_binary_op (location_t, enum tree_code, tree, tree, int); +extern tree perform_integral_promotions (tree); + +/* These functions must be defined by each front-end which implements + a variant of the C language. They are used by port files. */ + +extern tree default_conversion (tree); + +/* Given two integer or real types, return the type for their sum. + Given two compatible ANSI C types, returns the merged type. */ + +extern tree common_type (tree, tree); + +extern tree decl_constant_value (tree); + +/* Handle increment and decrement of boolean types. */ +extern tree boolean_increment (enum tree_code, tree); + +extern int case_compare (splay_tree_key, splay_tree_key); + +extern tree c_add_case_label (location_t, splay_tree, tree, tree, tree, tree); + +extern void c_do_switch_warnings (splay_tree, location_t, tree, tree); + +extern tree build_function_call (location_t, tree, tree); + +extern tree build_function_call_vec (location_t, tree, + VEC(tree,gc) *, VEC(tree,gc) *); + +extern tree resolve_overloaded_builtin (location_t, tree, VEC(tree,gc) *); + +extern tree finish_label_address_expr (tree, location_t); + +/* Same function prototype, but the C and C++ front ends have + different implementations. Used in c-common.c. */ +extern tree lookup_label (tree); +extern tree lookup_name (tree); +extern bool lvalue_p (const_tree); + +extern bool vector_targets_convertible_p (const_tree t1, const_tree t2); +extern bool vector_types_convertible_p (const_tree t1, const_tree t2, bool emit_lax_note); + +extern rtx c_expand_expr (tree, rtx, enum machine_mode, int, rtx *); + +extern void init_c_lex (void); + +extern void c_cpp_builtins (cpp_reader *); +extern void c_cpp_builtins_optimize_pragma (cpp_reader *, tree, tree); +extern bool c_cpp_error (cpp_reader *, int, int, location_t, unsigned int, + const char *, va_list *) + ATTRIBUTE_GCC_DIAG(6,0); + +/* Positive if an implicit `extern "C"' scope has just been entered; + negative if such a scope has just been exited. */ +extern GTY(()) int pending_lang_change; + +/* Information recorded about each file examined during compilation. */ + +struct c_fileinfo +{ + int time; /* Time spent in the file. */ + + /* Flags used only by C++. + INTERFACE_ONLY nonzero means that we are in an "interface" section + of the compiler. INTERFACE_UNKNOWN nonzero means we cannot trust + the value of INTERFACE_ONLY. If INTERFACE_UNKNOWN is zero and + INTERFACE_ONLY is zero, it means that we are responsible for + exporting definitions that others might need. */ + short interface_only; + short interface_unknown; +}; + +struct c_fileinfo *get_fileinfo (const char *); +extern void dump_time_statistics (void); + +extern bool c_dump_tree (void *, tree); + +extern void verify_sequence_points (tree); + +extern tree fold_offsetof (tree, tree); + +/* Places where an lvalue, or modifiable lvalue, may be required. + Used to select diagnostic messages in lvalue_error and + readonly_error. */ +enum lvalue_use { + lv_assign, + lv_increment, + lv_decrement, + lv_addressof, + lv_asm +}; + +extern void lvalue_error (enum lvalue_use); + +extern int complete_array_type (tree *, tree, bool); + +extern tree builtin_type_for_size (int, bool); + +extern void warn_array_subscript_with_type_char (tree); +extern void warn_about_parentheses (enum tree_code, + enum tree_code, tree, + enum tree_code, tree); +extern void warn_for_unused_label (tree label); +extern void warn_for_div_by_zero (location_t, tree divisor); +extern void warn_for_sign_compare (location_t, + tree orig_op0, tree orig_op1, + tree op0, tree op1, + tree result_type, + enum tree_code resultcode); +extern void set_underlying_type (tree x); +extern VEC(tree,gc) *make_tree_vector (void); +extern void release_tree_vector (VEC(tree,gc) *); +extern VEC(tree,gc) *make_tree_vector_single (tree); +extern VEC(tree,gc) *make_tree_vector_copy (const VEC(tree,gc) *); + +/* In c-gimplify.c */ +extern void c_genericize (tree); +extern int c_gimplify_expr (tree *, gimple_seq *, gimple_seq *); +extern tree c_build_bind_expr (location_t, tree, tree); + +/* In c-pch.c */ +extern void pch_init (void); +extern int c_common_valid_pch (cpp_reader *pfile, const char *name, int fd); +extern void c_common_read_pch (cpp_reader *pfile, const char *name, int fd, + const char *orig); +extern void c_common_write_pch (void); +extern void c_common_no_more_pch (void); +extern void c_common_pch_pragma (cpp_reader *pfile, const char *); +extern void c_common_print_pch_checksum (FILE *f); + +/* In *-checksum.c */ +extern const unsigned char executable_checksum[16]; + +/* In c-cppbuiltin.c */ +extern void builtin_define_std (const char *macro); +extern void builtin_define_with_value (const char *, const char *, int); +extern void c_stddef_cpp_builtins (void); +extern void fe_file_change (const struct line_map *); +extern void c_parse_error (const char *, enum cpp_ttype, tree, unsigned char); + +/* Objective-C / Objective-C++ entry points. */ + +/* The following ObjC/ObjC++ functions are called by the C and/or C++ + front-ends; they all must have corresponding stubs in stub-objc.c. */ +extern tree objc_is_class_name (tree); +extern tree objc_is_object_ptr (tree); +extern void objc_check_decl (tree); +extern int objc_is_reserved_word (tree); +extern bool objc_compare_types (tree, tree, int, tree); +extern void objc_volatilize_decl (tree); +extern bool objc_type_quals_match (tree, tree); +extern tree objc_rewrite_function_call (tree, tree); +extern tree objc_message_selector (void); +extern tree objc_lookup_ivar (tree, tree); +extern void objc_clear_super_receiver (void); +extern int objc_is_public (tree, tree); +extern tree objc_is_id (tree); +extern void objc_declare_alias (tree, tree); +extern void objc_declare_class (tree); +extern void objc_declare_protocols (tree); +extern tree objc_build_message_expr (tree); +extern tree objc_finish_message_expr (tree, tree, tree); +extern tree objc_build_selector_expr (location_t, tree); +extern tree objc_build_protocol_expr (tree); +extern tree objc_build_encode_expr (tree); +extern tree objc_build_string_object (tree); +extern tree objc_get_protocol_qualified_type (tree, tree); +extern tree objc_get_class_reference (tree); +extern tree objc_get_class_ivars (tree); +extern void objc_start_class_interface (tree, tree, tree); +extern void objc_start_category_interface (tree, tree, tree); +extern void objc_start_protocol (tree, tree); +extern void objc_continue_interface (void); +extern void objc_finish_interface (void); +extern void objc_start_class_implementation (tree, tree); +extern void objc_start_category_implementation (tree, tree); +extern void objc_continue_implementation (void); +extern void objc_finish_implementation (void); +extern void objc_set_visibility (int); +extern void objc_set_method_type (enum tree_code); +extern tree objc_build_method_signature (tree, tree, tree, bool); +extern void objc_add_method_declaration (tree); +extern void objc_start_method_definition (tree); +extern void objc_finish_method_definition (tree); +extern void objc_add_instance_variable (tree); +extern tree objc_build_keyword_decl (tree, tree, tree); +extern tree objc_build_throw_stmt (location_t, tree); +extern void objc_begin_try_stmt (location_t, tree); +extern tree objc_finish_try_stmt (void); +extern void objc_begin_catch_clause (tree); +extern void objc_finish_catch_clause (void); +extern void objc_build_finally_clause (location_t, tree); +extern tree objc_build_synchronized (location_t, tree, tree); +extern int objc_static_init_needed_p (void); +extern tree objc_generate_static_init_call (tree); +extern tree objc_generate_write_barrier (tree, enum tree_code, tree); + +/* The following are provided by the C and C++ front-ends, and called by + ObjC/ObjC++. */ +extern void *objc_get_current_scope (void); +extern void objc_mark_locals_volatile (void *); + +/* In c-ppoutput.c */ +extern void init_pp_output (FILE *); +extern void preprocess_file (cpp_reader *); +extern void pp_file_change (const struct line_map *); +extern void pp_dir_change (cpp_reader *, const char *); +extern bool check_missing_format_attribute (tree, tree); + +/* In c-omp.c */ +extern tree c_finish_omp_master (location_t, tree); +extern tree c_finish_omp_critical (location_t, tree, tree); +extern tree c_finish_omp_ordered (location_t, tree); +extern void c_finish_omp_barrier (location_t); +extern tree c_finish_omp_atomic (location_t, enum tree_code, tree, tree); +extern void c_finish_omp_flush (location_t); +extern void c_finish_omp_taskwait (location_t); +extern tree c_finish_omp_for (location_t, tree, tree, tree, tree, tree, tree); +extern void c_split_parallel_clauses (location_t, tree, tree *, tree *); +extern enum omp_clause_default_kind c_omp_predetermined_sharing (tree); + +/* Not in c-omp.c; provided by the front end. */ +extern bool c_omp_sharing_predetermined (tree); +extern tree c_omp_remap_decl (tree, bool); +extern void record_types_used_by_current_var_decl (tree); + +#endif /* ! GCC_C_COMMON_H */ diff --git a/gcc/c-family/c-cppbuiltin.c b/gcc/c-family/c-cppbuiltin.c new file mode 100644 index 00000000000..fbace227195 --- /dev/null +++ b/gcc/c-family/c-cppbuiltin.c @@ -0,0 +1,1179 @@ +/* Define builtin-in macros for the C family front ends. + Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 + 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 3, 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 COPYING3. If not see +. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tm.h" +#include "tree.h" +#include "version.h" +#include "flags.h" +#include "c-common.h" +#include "c-pragma.h" +#include "output.h" +#include "debug.h" /* For dwarf2out_do_cfi_asm. */ +#include "toplev.h" +#include "tm_p.h" /* For TARGET_CPU_CPP_BUILTINS & friends. */ +#include "target.h" +#include "cpp-id-data.h" + +#ifndef TARGET_OS_CPP_BUILTINS +# define TARGET_OS_CPP_BUILTINS() +#endif + +#ifndef TARGET_OBJFMT_CPP_BUILTINS +# define TARGET_OBJFMT_CPP_BUILTINS() +#endif + +#ifndef REGISTER_PREFIX +#define REGISTER_PREFIX "" +#endif + +/* Non-static as some targets don't use it. */ +void builtin_define_std (const char *) ATTRIBUTE_UNUSED; +static void builtin_define_with_int_value (const char *, HOST_WIDE_INT); +static void builtin_define_with_hex_fp_value (const char *, tree, + int, const char *, + const char *, + const char *); +static void builtin_define_stdint_macros (void); +static void builtin_define_constants (const char *, tree); +static void builtin_define_type_max (const char *, tree); +static void builtin_define_type_minmax (const char *, const char *, tree); +static void builtin_define_type_precision (const char *, tree); +static void builtin_define_type_sizeof (const char *, tree); +static void builtin_define_float_constants (const char *, + const char *, + const char *, + tree); +static void define__GNUC__ (void); + +/* Define NAME with value TYPE precision. */ +static void +builtin_define_type_precision (const char *name, tree type) +{ + builtin_define_with_int_value (name, TYPE_PRECISION (type)); +} + +/* Define NAME with value TYPE size_unit. */ +static void +builtin_define_type_sizeof (const char *name, tree type) +{ + builtin_define_with_int_value (name, + tree_low_cst (TYPE_SIZE_UNIT (type), 1)); +} + +/* Define the float.h constants for TYPE using NAME_PREFIX, FP_SUFFIX, + and FP_CAST. */ +static void +builtin_define_float_constants (const char *name_prefix, + const char *fp_suffix, + const char *fp_cast, + tree type) +{ + /* Used to convert radix-based values to base 10 values in several cases. + + In the max_exp -> max_10_exp conversion for 128-bit IEEE, we need at + least 6 significant digits for correct results. Using the fraction + formed by (log(2)*1e6)/(log(10)*1e6) overflows a 32-bit integer as an + intermediate; perhaps someone can find a better approximation, in the + mean time, I suspect using doubles won't harm the bootstrap here. */ + + const double log10_2 = .30102999566398119521; + double log10_b; + const struct real_format *fmt; + const struct real_format *ldfmt; + + char name[64], buf[128]; + int dig, min_10_exp, max_10_exp; + int decimal_dig; + int type_decimal_dig; + + fmt = REAL_MODE_FORMAT (TYPE_MODE (type)); + gcc_assert (fmt->b != 10); + ldfmt = REAL_MODE_FORMAT (TYPE_MODE (long_double_type_node)); + gcc_assert (ldfmt->b != 10); + + /* The radix of the exponent representation. */ + if (type == float_type_node) + builtin_define_with_int_value ("__FLT_RADIX__", fmt->b); + log10_b = log10_2; + + /* The number of radix digits, p, in the floating-point significand. */ + sprintf (name, "__%s_MANT_DIG__", name_prefix); + builtin_define_with_int_value (name, fmt->p); + + /* The number of decimal digits, q, such that any floating-point number + with q decimal digits can be rounded into a floating-point number with + p radix b digits and back again without change to the q decimal digits, + + p log10 b if b is a power of 10 + floor((p - 1) log10 b) otherwise + */ + dig = (fmt->p - 1) * log10_b; + sprintf (name, "__%s_DIG__", name_prefix); + builtin_define_with_int_value (name, dig); + + /* The minimum negative int x such that b**(x-1) is a normalized float. */ + sprintf (name, "__%s_MIN_EXP__", name_prefix); + sprintf (buf, "(%d)", fmt->emin); + builtin_define_with_value (name, buf, 0); + + /* The minimum negative int x such that 10**x is a normalized float, + + ceil (log10 (b ** (emin - 1))) + = ceil (log10 (b) * (emin - 1)) + + Recall that emin is negative, so the integer truncation calculates + the ceiling, not the floor, in this case. */ + min_10_exp = (fmt->emin - 1) * log10_b; + sprintf (name, "__%s_MIN_10_EXP__", name_prefix); + sprintf (buf, "(%d)", min_10_exp); + builtin_define_with_value (name, buf, 0); + + /* The maximum int x such that b**(x-1) is a representable float. */ + sprintf (name, "__%s_MAX_EXP__", name_prefix); + builtin_define_with_int_value (name, fmt->emax); + + /* The maximum int x such that 10**x is in the range of representable + finite floating-point numbers, + + floor (log10((1 - b**-p) * b**emax)) + = floor (log10(1 - b**-p) + log10(b**emax)) + = floor (log10(1 - b**-p) + log10(b)*emax) + + The safest thing to do here is to just compute this number. But since + we don't link cc1 with libm, we cannot. We could implement log10 here + a series expansion, but that seems too much effort because: + + Note that the first term, for all extant p, is a number exceedingly close + to zero, but slightly negative. Note that the second term is an integer + scaling an irrational number, and that because of the floor we are only + interested in its integral portion. + + In order for the first term to have any effect on the integral portion + of the second term, the second term has to be exceedingly close to an + integer itself (e.g. 123.000000000001 or something). Getting a result + that close to an integer requires that the irrational multiplicand have + a long series of zeros in its expansion, which doesn't occur in the + first 20 digits or so of log10(b). + + Hand-waving aside, crunching all of the sets of constants above by hand + does not yield a case for which the first term is significant, which + in the end is all that matters. */ + max_10_exp = fmt->emax * log10_b; + sprintf (name, "__%s_MAX_10_EXP__", name_prefix); + builtin_define_with_int_value (name, max_10_exp); + + /* The number of decimal digits, n, such that any floating-point number + can be rounded to n decimal digits and back again without change to + the value. + + p * log10(b) if b is a power of 10 + ceil(1 + p * log10(b)) otherwise + + The only macro we care about is this number for the widest supported + floating type, but we want this value for rendering constants below. */ + { + double d_decimal_dig + = 1 + (fmt->p < ldfmt->p ? ldfmt->p : fmt->p) * log10_b; + decimal_dig = d_decimal_dig; + if (decimal_dig < d_decimal_dig) + decimal_dig++; + } + /* Similar, for this type rather than long double. */ + { + double type_d_decimal_dig = 1 + fmt->p * log10_b; + type_decimal_dig = type_d_decimal_dig; + if (type_decimal_dig < type_d_decimal_dig) + type_decimal_dig++; + } + if (type == long_double_type_node) + builtin_define_with_int_value ("__DECIMAL_DIG__", decimal_dig); + else + { + sprintf (name, "__%s_DECIMAL_DIG__", name_prefix); + builtin_define_with_int_value (name, type_decimal_dig); + } + + /* Since, for the supported formats, B is always a power of 2, we + construct the following numbers directly as a hexadecimal + constants. */ + get_max_float (fmt, buf, sizeof (buf)); + + sprintf (name, "__%s_MAX__", name_prefix); + builtin_define_with_hex_fp_value (name, type, decimal_dig, buf, fp_suffix, fp_cast); + + /* The minimum normalized positive floating-point number, + b**(emin-1). */ + sprintf (name, "__%s_MIN__", name_prefix); + sprintf (buf, "0x1p%d", fmt->emin - 1); + builtin_define_with_hex_fp_value (name, type, decimal_dig, buf, fp_suffix, fp_cast); + + /* The difference between 1 and the least value greater than 1 that is + representable in the given floating point type, b**(1-p). */ + sprintf (name, "__%s_EPSILON__", name_prefix); + if (fmt->pnan < fmt->p) + /* This is an IBM extended double format, so 1.0 + any double is + representable precisely. */ + sprintf (buf, "0x1p%d", fmt->emin - fmt->p); + else + sprintf (buf, "0x1p%d", 1 - fmt->p); + builtin_define_with_hex_fp_value (name, type, decimal_dig, buf, fp_suffix, fp_cast); + + /* For C++ std::numeric_limits::denorm_min. The minimum denormalized + positive floating-point number, b**(emin-p). Zero for formats that + don't support denormals. */ + sprintf (name, "__%s_DENORM_MIN__", name_prefix); + if (fmt->has_denorm) + { + sprintf (buf, "0x1p%d", fmt->emin - fmt->p); + builtin_define_with_hex_fp_value (name, type, decimal_dig, + buf, fp_suffix, fp_cast); + } + else + { + sprintf (buf, "0.0%s", fp_suffix); + builtin_define_with_value (name, buf, 0); + } + + sprintf (name, "__%s_HAS_DENORM__", name_prefix); + builtin_define_with_value (name, fmt->has_denorm ? "1" : "0", 0); + + /* For C++ std::numeric_limits::has_infinity. */ + sprintf (name, "__%s_HAS_INFINITY__", name_prefix); + builtin_define_with_int_value (name, + MODE_HAS_INFINITIES (TYPE_MODE (type))); + /* For C++ std::numeric_limits::has_quiet_NaN. We do not have a + predicate to distinguish a target that has both quiet and + signalling NaNs from a target that has only quiet NaNs or only + signalling NaNs, so we assume that a target that has any kind of + NaN has quiet NaNs. */ + sprintf (name, "__%s_HAS_QUIET_NAN__", name_prefix); + builtin_define_with_int_value (name, MODE_HAS_NANS (TYPE_MODE (type))); +} + +/* Define __DECx__ constants for TYPE using NAME_PREFIX and SUFFIX. */ +static void +builtin_define_decimal_float_constants (const char *name_prefix, + const char *suffix, + tree type) +{ + const struct real_format *fmt; + char name[64], buf[128], *p; + int digits; + + fmt = REAL_MODE_FORMAT (TYPE_MODE (type)); + + /* The number of radix digits, p, in the significand. */ + sprintf (name, "__%s_MANT_DIG__", name_prefix); + builtin_define_with_int_value (name, fmt->p); + + /* The minimum negative int x such that b**(x-1) is a normalized float. */ + sprintf (name, "__%s_MIN_EXP__", name_prefix); + sprintf (buf, "(%d)", fmt->emin); + builtin_define_with_value (name, buf, 0); + + /* The maximum int x such that b**(x-1) is a representable float. */ + sprintf (name, "__%s_MAX_EXP__", name_prefix); + builtin_define_with_int_value (name, fmt->emax); + + /* Compute the minimum representable value. */ + sprintf (name, "__%s_MIN__", name_prefix); + sprintf (buf, "1E%d%s", fmt->emin - 1, suffix); + builtin_define_with_value (name, buf, 0); + + /* Compute the maximum representable value. */ + sprintf (name, "__%s_MAX__", name_prefix); + p = buf; + for (digits = fmt->p; digits; digits--) + { + *p++ = '9'; + if (digits == fmt->p) + *p++ = '.'; + } + *p = 0; + /* fmt->p plus 1, to account for the decimal point and fmt->emax + minus 1 because the digits are nines, not 1.0. */ + sprintf (&buf[fmt->p + 1], "E%d%s", fmt->emax - 1, suffix); + builtin_define_with_value (name, buf, 0); + + /* Compute epsilon (the difference between 1 and least value greater + than 1 representable). */ + sprintf (name, "__%s_EPSILON__", name_prefix); + sprintf (buf, "1E-%d%s", fmt->p - 1, suffix); + builtin_define_with_value (name, buf, 0); + + /* Minimum subnormal positive decimal value. */ + sprintf (name, "__%s_SUBNORMAL_MIN__", name_prefix); + p = buf; + for (digits = fmt->p; digits > 1; digits--) + { + *p++ = '0'; + if (digits == fmt->p) + *p++ = '.'; + } + *p = 0; + sprintf (&buf[fmt->p], "1E%d%s", fmt->emin - 1, suffix); + builtin_define_with_value (name, buf, 0); +} + +/* Define fixed-point constants for TYPE using NAME_PREFIX and SUFFIX. */ + +static void +builtin_define_fixed_point_constants (const char *name_prefix, + const char *suffix, + tree type) +{ + char name[64], buf[256], *new_buf; + int i, mod; + + sprintf (name, "__%s_FBIT__", name_prefix); + builtin_define_with_int_value (name, TYPE_FBIT (type)); + + sprintf (name, "__%s_IBIT__", name_prefix); + builtin_define_with_int_value (name, TYPE_IBIT (type)); + + /* If there is no suffix, defines are for fixed-point modes. + We just return. */ + if (strcmp (suffix, "") == 0) + return; + + if (TYPE_UNSIGNED (type)) + { + sprintf (name, "__%s_MIN__", name_prefix); + sprintf (buf, "0.0%s", suffix); + builtin_define_with_value (name, buf, 0); + } + else + { + sprintf (name, "__%s_MIN__", name_prefix); + if (ALL_ACCUM_MODE_P (TYPE_MODE (type))) + sprintf (buf, "(-0X1P%d%s-0X1P%d%s)", TYPE_IBIT (type) - 1, suffix, + TYPE_IBIT (type) - 1, suffix); + else + sprintf (buf, "(-0.5%s-0.5%s)", suffix, suffix); + builtin_define_with_value (name, buf, 0); + } + + sprintf (name, "__%s_MAX__", name_prefix); + sprintf (buf, "0X"); + new_buf = buf + 2; + mod = (TYPE_FBIT (type) + TYPE_IBIT (type)) % 4; + if (mod) + sprintf (new_buf++, "%x", (1 << mod) - 1); + for (i = 0; i < (TYPE_FBIT (type) + TYPE_IBIT (type)) / 4; i++) + sprintf (new_buf++, "F"); + sprintf (new_buf, "P-%d%s", TYPE_FBIT (type), suffix); + builtin_define_with_value (name, buf, 0); + + sprintf (name, "__%s_EPSILON__", name_prefix); + sprintf (buf, "0x1P-%d%s", TYPE_FBIT (type), suffix); + builtin_define_with_value (name, buf, 0); +} + +/* Define __GNUC__, __GNUC_MINOR__ and __GNUC_PATCHLEVEL__. */ +static void +define__GNUC__ (void) +{ + int major, minor, patchlevel; + + if (sscanf (BASEVER, "%d.%d.%d", &major, &minor, &patchlevel) != 3) + { + sscanf (BASEVER, "%d.%d", &major, &minor); + patchlevel = 0; + } + cpp_define_formatted (parse_in, "__GNUC__=%d", major); + cpp_define_formatted (parse_in, "__GNUC_MINOR__=%d", minor); + cpp_define_formatted (parse_in, "__GNUC_PATCHLEVEL__=%d", patchlevel); + + if (c_dialect_cxx ()) + cpp_define_formatted (parse_in, "__GNUG__=%d", major); +} + +/* Define macros used by . */ +static void +builtin_define_stdint_macros (void) +{ + builtin_define_type_max ("__INTMAX_MAX__", intmax_type_node); + builtin_define_constants ("__INTMAX_C", intmax_type_node); + builtin_define_type_max ("__UINTMAX_MAX__", uintmax_type_node); + builtin_define_constants ("__UINTMAX_C", uintmax_type_node); + if (sig_atomic_type_node) + builtin_define_type_minmax ("__SIG_ATOMIC_MIN__", "__SIG_ATOMIC_MAX__", + sig_atomic_type_node); + if (int8_type_node) + builtin_define_type_max ("__INT8_MAX__", int8_type_node); + if (int16_type_node) + builtin_define_type_max ("__INT16_MAX__", int16_type_node); + if (int32_type_node) + builtin_define_type_max ("__INT32_MAX__", int32_type_node); + if (int64_type_node) + builtin_define_type_max ("__INT64_MAX__", int64_type_node); + if (uint8_type_node) + builtin_define_type_max ("__UINT8_MAX__", uint8_type_node); + if (uint16_type_node) + builtin_define_type_max ("__UINT16_MAX__", uint16_type_node); + if (c_uint32_type_node) + builtin_define_type_max ("__UINT32_MAX__", c_uint32_type_node); + if (c_uint64_type_node) + builtin_define_type_max ("__UINT64_MAX__", c_uint64_type_node); + if (int_least8_type_node) + { + builtin_define_type_max ("__INT_LEAST8_MAX__", int_least8_type_node); + builtin_define_constants ("__INT8_C", int_least8_type_node); + } + if (int_least16_type_node) + { + builtin_define_type_max ("__INT_LEAST16_MAX__", int_least16_type_node); + builtin_define_constants ("__INT16_C", int_least16_type_node); + } + if (int_least32_type_node) + { + builtin_define_type_max ("__INT_LEAST32_MAX__", int_least32_type_node); + builtin_define_constants ("__INT32_C", int_least32_type_node); + } + if (int_least64_type_node) + { + builtin_define_type_max ("__INT_LEAST64_MAX__", int_least64_type_node); + builtin_define_constants ("__INT64_C", int_least64_type_node); + } + if (uint_least8_type_node) + { + builtin_define_type_max ("__UINT_LEAST8_MAX__", uint_least8_type_node); + builtin_define_constants ("__UINT8_C", uint_least8_type_node); + } + if (uint_least16_type_node) + { + builtin_define_type_max ("__UINT_LEAST16_MAX__", uint_least16_type_node); + builtin_define_constants ("__UINT16_C", uint_least16_type_node); + } + if (uint_least32_type_node) + { + builtin_define_type_max ("__UINT_LEAST32_MAX__", uint_least32_type_node); + builtin_define_constants ("__UINT32_C", uint_least32_type_node); + } + if (uint_least64_type_node) + { + builtin_define_type_max ("__UINT_LEAST64_MAX__", uint_least64_type_node); + builtin_define_constants ("__UINT64_C", uint_least64_type_node); + } + if (int_fast8_type_node) + builtin_define_type_max ("__INT_FAST8_MAX__", int_fast8_type_node); + if (int_fast16_type_node) + builtin_define_type_max ("__INT_FAST16_MAX__", int_fast16_type_node); + if (int_fast32_type_node) + builtin_define_type_max ("__INT_FAST32_MAX__", int_fast32_type_node); + if (int_fast64_type_node) + builtin_define_type_max ("__INT_FAST64_MAX__", int_fast64_type_node); + if (uint_fast8_type_node) + builtin_define_type_max ("__UINT_FAST8_MAX__", uint_fast8_type_node); + if (uint_fast16_type_node) + builtin_define_type_max ("__UINT_FAST16_MAX__", uint_fast16_type_node); + if (uint_fast32_type_node) + builtin_define_type_max ("__UINT_FAST32_MAX__", uint_fast32_type_node); + if (uint_fast64_type_node) + builtin_define_type_max ("__UINT_FAST64_MAX__", uint_fast64_type_node); + if (intptr_type_node) + builtin_define_type_max ("__INTPTR_MAX__", intptr_type_node); + if (uintptr_type_node) + builtin_define_type_max ("__UINTPTR_MAX__", uintptr_type_node); +} + +/* Adjust the optimization macros when a #pragma GCC optimization is done to + reflect the current level. */ +void +c_cpp_builtins_optimize_pragma (cpp_reader *pfile, tree prev_tree, + tree cur_tree) +{ + struct cl_optimization *prev = TREE_OPTIMIZATION (prev_tree); + struct cl_optimization *cur = TREE_OPTIMIZATION (cur_tree); + bool prev_fast_math; + bool cur_fast_math; + + /* -undef turns off target-specific built-ins. */ + if (flag_undef) + return; + + /* Other target-independent built-ins determined by command-line + options. */ + if (!prev->optimize_size && cur->optimize_size) + cpp_define (pfile, "__OPTIMIZE_SIZE__"); + else if (prev->optimize_size && !cur->optimize_size) + cpp_undef (pfile, "__OPTIMIZE_SIZE__"); + + if (!prev->optimize && cur->optimize) + cpp_define (pfile, "__OPTIMIZE__"); + else if (prev->optimize && !cur->optimize) + cpp_undef (pfile, "__OPTIMIZE__"); + + prev_fast_math = fast_math_flags_struct_set_p (prev); + cur_fast_math = fast_math_flags_struct_set_p (cur); + if (!prev_fast_math && cur_fast_math) + cpp_define (pfile, "__FAST_MATH__"); + else if (prev_fast_math && !cur_fast_math) + cpp_undef (pfile, "__FAST_MATH__"); + + if (!prev->flag_signaling_nans && cur->flag_signaling_nans) + cpp_define (pfile, "__SUPPORT_SNAN__"); + else if (prev->flag_signaling_nans && !cur->flag_signaling_nans) + cpp_undef (pfile, "__SUPPORT_SNAN__"); + + if (!prev->flag_finite_math_only && cur->flag_finite_math_only) + { + cpp_undef (pfile, "__FINITE_MATH_ONLY__"); + cpp_define (pfile, "__FINITE_MATH_ONLY__=1"); + } + else if (!prev->flag_finite_math_only && cur->flag_finite_math_only) + { + cpp_undef (pfile, "__FINITE_MATH_ONLY__"); + cpp_define (pfile, "__FINITE_MATH_ONLY__=0"); + } +} + + +/* Hook that registers front end and target-specific built-ins. */ +void +c_cpp_builtins (cpp_reader *pfile) +{ + /* -undef turns off target-specific built-ins. */ + if (flag_undef) + return; + + define__GNUC__ (); + + /* For stddef.h. They require macros defined in c-common.c. */ + c_stddef_cpp_builtins (); + + if (c_dialect_cxx ()) + { + if (flag_weak && SUPPORTS_ONE_ONLY) + cpp_define (pfile, "__GXX_WEAK__=1"); + else + cpp_define (pfile, "__GXX_WEAK__=0"); + if (warn_deprecated) + cpp_define (pfile, "__DEPRECATED"); + if (flag_rtti) + cpp_define (pfile, "__GXX_RTTI"); + if (cxx_dialect == cxx0x) + cpp_define (pfile, "__GXX_EXPERIMENTAL_CXX0X__"); + } + /* Note that we define this for C as well, so that we know if + __attribute__((cleanup)) will interface with EH. */ + if (flag_exceptions) + cpp_define (pfile, "__EXCEPTIONS"); + + /* Represents the C++ ABI version, always defined so it can be used while + preprocessing C and assembler. */ + if (flag_abi_version == 0) + /* Use a very large value so that: + + #if __GXX_ABI_VERSION >= + + will work whether the user explicitly says "-fabi-version=x" or + "-fabi-version=0". Do not use INT_MAX because that will be + different from system to system. */ + builtin_define_with_int_value ("__GXX_ABI_VERSION", 999999); + else if (flag_abi_version == 1) + /* Due to a historical accident, this version had the value + "102". */ + builtin_define_with_int_value ("__GXX_ABI_VERSION", 102); + else + /* Newer versions have values 1002, 1003, .... */ + builtin_define_with_int_value ("__GXX_ABI_VERSION", + 1000 + flag_abi_version); + + /* libgcc needs to know this. */ + if (USING_SJLJ_EXCEPTIONS) + cpp_define (pfile, "__USING_SJLJ_EXCEPTIONS__"); + + /* limits.h and stdint.h need to know these. */ + builtin_define_type_max ("__SCHAR_MAX__", signed_char_type_node); + builtin_define_type_max ("__SHRT_MAX__", short_integer_type_node); + builtin_define_type_max ("__INT_MAX__", integer_type_node); + builtin_define_type_max ("__LONG_MAX__", long_integer_type_node); + builtin_define_type_max ("__LONG_LONG_MAX__", long_long_integer_type_node); + builtin_define_type_minmax ("__WCHAR_MIN__", "__WCHAR_MAX__", + underlying_wchar_type_node); + builtin_define_type_minmax ("__WINT_MIN__", "__WINT_MAX__", wint_type_node); + builtin_define_type_max ("__PTRDIFF_MAX__", ptrdiff_type_node); + builtin_define_type_max ("__SIZE_MAX__", size_type_node); + + builtin_define_type_precision ("__CHAR_BIT__", char_type_node); + + /* stdint.h and the testsuite need to know these. */ + builtin_define_stdint_macros (); + + /* float.h needs to know these. */ + + builtin_define_with_int_value ("__FLT_EVAL_METHOD__", + TARGET_FLT_EVAL_METHOD); + + /* And decfloat.h needs this. */ + builtin_define_with_int_value ("__DEC_EVAL_METHOD__", + TARGET_DEC_EVAL_METHOD); + + builtin_define_float_constants ("FLT", "F", "%s", float_type_node); + /* Cast the double precision constants. This is needed when single + precision constants are specified or when pragma FLOAT_CONST_DECIMAL64 + is used. The correct result is computed by the compiler when using + macros that include a cast. */ + builtin_define_float_constants ("DBL", "L", "((double)%s)", double_type_node); + builtin_define_float_constants ("LDBL", "L", "%s", long_double_type_node); + + /* For decfloat.h. */ + builtin_define_decimal_float_constants ("DEC32", "DF", dfloat32_type_node); + builtin_define_decimal_float_constants ("DEC64", "DD", dfloat64_type_node); + builtin_define_decimal_float_constants ("DEC128", "DL", dfloat128_type_node); + + /* For fixed-point fibt, ibit, max, min, and epsilon. */ + if (targetm.fixed_point_supported_p ()) + { + builtin_define_fixed_point_constants ("SFRACT", "HR", + short_fract_type_node); + builtin_define_fixed_point_constants ("USFRACT", "UHR", + unsigned_short_fract_type_node); + builtin_define_fixed_point_constants ("FRACT", "R", + fract_type_node); + builtin_define_fixed_point_constants ("UFRACT", "UR", + unsigned_fract_type_node); + builtin_define_fixed_point_constants ("LFRACT", "LR", + long_fract_type_node); + builtin_define_fixed_point_constants ("ULFRACT", "ULR", + unsigned_long_fract_type_node); + builtin_define_fixed_point_constants ("LLFRACT", "LLR", + long_long_fract_type_node); + builtin_define_fixed_point_constants ("ULLFRACT", "ULLR", + unsigned_long_long_fract_type_node); + builtin_define_fixed_point_constants ("SACCUM", "HK", + short_accum_type_node); + builtin_define_fixed_point_constants ("USACCUM", "UHK", + unsigned_short_accum_type_node); + builtin_define_fixed_point_constants ("ACCUM", "K", + accum_type_node); + builtin_define_fixed_point_constants ("UACCUM", "UK", + unsigned_accum_type_node); + builtin_define_fixed_point_constants ("LACCUM", "LK", + long_accum_type_node); + builtin_define_fixed_point_constants ("ULACCUM", "ULK", + unsigned_long_accum_type_node); + builtin_define_fixed_point_constants ("LLACCUM", "LLK", + long_long_accum_type_node); + builtin_define_fixed_point_constants ("ULLACCUM", "ULLK", + unsigned_long_long_accum_type_node); + + builtin_define_fixed_point_constants ("QQ", "", qq_type_node); + builtin_define_fixed_point_constants ("HQ", "", hq_type_node); + builtin_define_fixed_point_constants ("SQ", "", sq_type_node); + builtin_define_fixed_point_constants ("DQ", "", dq_type_node); + builtin_define_fixed_point_constants ("TQ", "", tq_type_node); + builtin_define_fixed_point_constants ("UQQ", "", uqq_type_node); + builtin_define_fixed_point_constants ("UHQ", "", uhq_type_node); + builtin_define_fixed_point_constants ("USQ", "", usq_type_node); + builtin_define_fixed_point_constants ("UDQ", "", udq_type_node); + builtin_define_fixed_point_constants ("UTQ", "", utq_type_node); + builtin_define_fixed_point_constants ("HA", "", ha_type_node); + builtin_define_fixed_point_constants ("SA", "", sa_type_node); + builtin_define_fixed_point_constants ("DA", "", da_type_node); + builtin_define_fixed_point_constants ("TA", "", ta_type_node); + builtin_define_fixed_point_constants ("UHA", "", uha_type_node); + builtin_define_fixed_point_constants ("USA", "", usa_type_node); + builtin_define_fixed_point_constants ("UDA", "", uda_type_node); + builtin_define_fixed_point_constants ("UTA", "", uta_type_node); + } + + /* For use in assembly language. */ + builtin_define_with_value ("__REGISTER_PREFIX__", REGISTER_PREFIX, 0); + builtin_define_with_value ("__USER_LABEL_PREFIX__", user_label_prefix, 0); + + /* Misc. */ + builtin_define_with_value ("__VERSION__", version_string, 1); + + if (flag_gnu89_inline) + cpp_define (pfile, "__GNUC_GNU_INLINE__"); + else + cpp_define (pfile, "__GNUC_STDC_INLINE__"); + + /* Definitions for LP64 model. */ + if (TYPE_PRECISION (long_integer_type_node) == 64 + && POINTER_SIZE == 64 + && TYPE_PRECISION (integer_type_node) == 32) + { + cpp_define (pfile, "_LP64"); + cpp_define (pfile, "__LP64__"); + } + + /* Other target-independent built-ins determined by command-line + options. */ + if (optimize_size) + cpp_define (pfile, "__OPTIMIZE_SIZE__"); + if (optimize) + cpp_define (pfile, "__OPTIMIZE__"); + + if (fast_math_flags_set_p ()) + cpp_define (pfile, "__FAST_MATH__"); + if (flag_no_inline) + cpp_define (pfile, "__NO_INLINE__"); + if (flag_signaling_nans) + cpp_define (pfile, "__SUPPORT_SNAN__"); + if (flag_finite_math_only) + cpp_define (pfile, "__FINITE_MATH_ONLY__=1"); + else + cpp_define (pfile, "__FINITE_MATH_ONLY__=0"); + if (flag_pic) + { + builtin_define_with_int_value ("__pic__", flag_pic); + builtin_define_with_int_value ("__PIC__", flag_pic); + } + if (flag_pie) + { + builtin_define_with_int_value ("__pie__", flag_pie); + builtin_define_with_int_value ("__PIE__", flag_pie); + } + + if (flag_iso) + cpp_define (pfile, "__STRICT_ANSI__"); + + if (!flag_signed_char) + cpp_define (pfile, "__CHAR_UNSIGNED__"); + + if (c_dialect_cxx () && TYPE_UNSIGNED (wchar_type_node)) + cpp_define (pfile, "__WCHAR_UNSIGNED__"); + + /* Tell source code if the compiler makes sync_compare_and_swap + builtins available. */ +#ifdef HAVE_sync_compare_and_swapqi + if (HAVE_sync_compare_and_swapqi) + cpp_define (pfile, "__GCC_HAVE_SYNC_COMPARE_AND_SWAP_1"); +#endif + +#ifdef HAVE_sync_compare_and_swaphi + if (HAVE_sync_compare_and_swaphi) + cpp_define (pfile, "__GCC_HAVE_SYNC_COMPARE_AND_SWAP_2"); +#endif + +#ifdef HAVE_sync_compare_and_swapsi + if (HAVE_sync_compare_and_swapsi) + cpp_define (pfile, "__GCC_HAVE_SYNC_COMPARE_AND_SWAP_4"); +#endif + +#ifdef HAVE_sync_compare_and_swapdi + if (HAVE_sync_compare_and_swapdi) + cpp_define (pfile, "__GCC_HAVE_SYNC_COMPARE_AND_SWAP_8"); +#endif + +#ifdef HAVE_sync_compare_and_swapti + if (HAVE_sync_compare_and_swapti) + cpp_define (pfile, "__GCC_HAVE_SYNC_COMPARE_AND_SWAP_16"); +#endif + +#ifdef DWARF2_UNWIND_INFO + if (dwarf2out_do_cfi_asm ()) + cpp_define (pfile, "__GCC_HAVE_DWARF2_CFI_ASM"); +#endif + + /* Make the choice of ObjC runtime visible to source code. */ + if (c_dialect_objc () && flag_next_runtime) + cpp_define (pfile, "__NEXT_RUNTIME__"); + + /* Show the availability of some target pragmas. */ + cpp_define (pfile, "__PRAGMA_REDEFINE_EXTNAME"); + + if (targetm.handle_pragma_extern_prefix) + cpp_define (pfile, "__PRAGMA_EXTERN_PREFIX"); + + /* Make the choice of the stack protector runtime visible to source code. + The macro names and values here were chosen for compatibility with an + earlier implementation, i.e. ProPolice. */ + if (flag_stack_protect == 2) + cpp_define (pfile, "__SSP_ALL__=2"); + else if (flag_stack_protect == 1) + cpp_define (pfile, "__SSP__=1"); + + if (flag_openmp) + cpp_define (pfile, "_OPENMP=200805"); + + builtin_define_type_sizeof ("__SIZEOF_INT__", integer_type_node); + builtin_define_type_sizeof ("__SIZEOF_LONG__", long_integer_type_node); + builtin_define_type_sizeof ("__SIZEOF_LONG_LONG__", + long_long_integer_type_node); + if (int128_integer_type_node != NULL_TREE) + builtin_define_type_sizeof ("__SIZEOF_INT128__", + int128_integer_type_node); + builtin_define_type_sizeof ("__SIZEOF_SHORT__", short_integer_type_node); + builtin_define_type_sizeof ("__SIZEOF_FLOAT__", float_type_node); + builtin_define_type_sizeof ("__SIZEOF_DOUBLE__", double_type_node); + builtin_define_type_sizeof ("__SIZEOF_LONG_DOUBLE__", long_double_type_node); + builtin_define_type_sizeof ("__SIZEOF_SIZE_T__", size_type_node); + builtin_define_type_sizeof ("__SIZEOF_WCHAR_T__", wchar_type_node); + builtin_define_type_sizeof ("__SIZEOF_WINT_T__", wint_type_node); + builtin_define_type_sizeof ("__SIZEOF_PTRDIFF_T__", + unsigned_ptrdiff_type_node); + /* ptr_type_node can't be used here since ptr_mode is only set when + toplev calls backend_init which is not done with -E switch. */ + builtin_define_with_int_value ("__SIZEOF_POINTER__", + POINTER_SIZE / BITS_PER_UNIT); + + /* A straightforward target hook doesn't work, because of problems + linking that hook's body when part of non-C front ends. */ +# define preprocessing_asm_p() (cpp_get_options (pfile)->lang == CLK_ASM) +# define preprocessing_trad_p() (cpp_get_options (pfile)->traditional) +# define builtin_define(TXT) cpp_define (pfile, TXT) +# define builtin_assert(TXT) cpp_assert (pfile, TXT) + TARGET_CPU_CPP_BUILTINS (); + TARGET_OS_CPP_BUILTINS (); + TARGET_OBJFMT_CPP_BUILTINS (); + + /* Support the __declspec keyword by turning them into attributes. + Note that the current way we do this may result in a collision + with predefined attributes later on. This can be solved by using + one attribute, say __declspec__, and passing args to it. The + problem with that approach is that args are not accumulated: each + new appearance would clobber any existing args. */ + if (TARGET_DECLSPEC) + builtin_define ("__declspec(x)=__attribute__((x))"); + + /* If decimal floating point is supported, tell the user if the + alternate format (BID) is used instead of the standard (DPD) + format. */ + if (ENABLE_DECIMAL_FLOAT && ENABLE_DECIMAL_BID_FORMAT) + cpp_define (pfile, "__DECIMAL_BID_FORMAT__"); + + builtin_define_with_int_value ("__BIGGEST_ALIGNMENT__", + BIGGEST_ALIGNMENT / BITS_PER_UNIT); +} + +/* Pass an object-like macro. If it doesn't lie in the user's + namespace, defines it unconditionally. Otherwise define a version + with two leading underscores, and another version with two leading + and trailing underscores, and define the original only if an ISO + standard was not nominated. + + e.g. passing "unix" defines "__unix", "__unix__" and possibly + "unix". Passing "_mips" defines "__mips", "__mips__" and possibly + "_mips". */ +void +builtin_define_std (const char *macro) +{ + size_t len = strlen (macro); + char *buff = (char *) alloca (len + 5); + char *p = buff + 2; + char *q = p + len; + + /* prepend __ (or maybe just _) if in user's namespace. */ + memcpy (p, macro, len + 1); + if (!( *p == '_' && (p[1] == '_' || ISUPPER (p[1])))) + { + if (*p != '_') + *--p = '_'; + if (p[1] != '_') + *--p = '_'; + } + cpp_define (parse_in, p); + + /* If it was in user's namespace... */ + if (p != buff + 2) + { + /* Define the macro with leading and following __. */ + if (q[-1] != '_') + *q++ = '_'; + if (q[-2] != '_') + *q++ = '_'; + *q = '\0'; + cpp_define (parse_in, p); + + /* Finally, define the original macro if permitted. */ + if (!flag_iso) + cpp_define (parse_in, macro); + } +} + +/* Pass an object-like macro and a value to define it to. The third + parameter says whether or not to turn the value into a string + constant. */ +void +builtin_define_with_value (const char *macro, const char *expansion, int is_str) +{ + char *buf; + size_t mlen = strlen (macro); + size_t elen = strlen (expansion); + size_t extra = 2; /* space for an = and a NUL */ + + if (is_str) + extra += 2; /* space for two quote marks */ + + buf = (char *) alloca (mlen + elen + extra); + if (is_str) + sprintf (buf, "%s=\"%s\"", macro, expansion); + else + sprintf (buf, "%s=%s", macro, expansion); + + cpp_define (parse_in, buf); +} + + +/* Pass an object-like macro and an integer value to define it to. */ +static void +builtin_define_with_int_value (const char *macro, HOST_WIDE_INT value) +{ + char *buf; + size_t mlen = strlen (macro); + size_t vlen = 18; + size_t extra = 2; /* space for = and NUL. */ + + buf = (char *) alloca (mlen + vlen + extra); + memcpy (buf, macro, mlen); + buf[mlen] = '='; + sprintf (buf + mlen + 1, HOST_WIDE_INT_PRINT_DEC, value); + + cpp_define (parse_in, buf); +} + +/* builtin_define_with_hex_fp_value is very expensive, so the following + array and function allows it to be done lazily when __DBL_MAX__ + etc. is first used. */ + +struct GTY(()) lazy_hex_fp_value_struct +{ + const char *hex_str; + cpp_macro *macro; + enum machine_mode mode; + int digits; + const char *fp_suffix; +}; +static GTY(()) struct lazy_hex_fp_value_struct lazy_hex_fp_values[12]; +static GTY(()) int lazy_hex_fp_value_count; + +static bool +lazy_hex_fp_value (cpp_reader *pfile ATTRIBUTE_UNUSED, + cpp_hashnode *node) +{ + REAL_VALUE_TYPE real; + char dec_str[64], buf1[256]; + unsigned int idx; + if (node->value.builtin < BT_FIRST_USER + || (int) node->value.builtin >= BT_FIRST_USER + lazy_hex_fp_value_count) + return false; + + idx = node->value.builtin - BT_FIRST_USER; + real_from_string (&real, lazy_hex_fp_values[idx].hex_str); + real_to_decimal_for_mode (dec_str, &real, sizeof (dec_str), + lazy_hex_fp_values[idx].digits, 0, + lazy_hex_fp_values[idx].mode); + + sprintf (buf1, "%s%s", dec_str, lazy_hex_fp_values[idx].fp_suffix); + node->flags &= ~(NODE_BUILTIN | NODE_USED); + node->value.macro = lazy_hex_fp_values[idx].macro; + for (idx = 0; idx < node->value.macro->count; idx++) + if (node->value.macro->exp.tokens[idx].type == CPP_NUMBER) + break; + gcc_assert (idx < node->value.macro->count); + node->value.macro->exp.tokens[idx].val.str.len = strlen (buf1); + node->value.macro->exp.tokens[idx].val.str.text + = (const unsigned char *) ggc_strdup (buf1); + return true; +} + +/* Pass an object-like macro a hexadecimal floating-point value. */ +static void +builtin_define_with_hex_fp_value (const char *macro, + tree type, int digits, + const char *hex_str, + const char *fp_suffix, + const char *fp_cast) +{ + REAL_VALUE_TYPE real; + char dec_str[64], buf1[256], buf2[256]; + + /* This is very expensive, so if possible expand them lazily. */ + if (lazy_hex_fp_value_count < 12 + && flag_dump_macros == 0 + && !cpp_get_options (parse_in)->traditional) + { + struct cpp_hashnode *node; + if (lazy_hex_fp_value_count == 0) + cpp_get_callbacks (parse_in)->user_builtin_macro = lazy_hex_fp_value; + sprintf (buf2, fp_cast, "1.1"); + sprintf (buf1, "%s=%s", macro, buf2); + cpp_define (parse_in, buf1); + node = C_CPP_HASHNODE (get_identifier (macro)); + lazy_hex_fp_values[lazy_hex_fp_value_count].hex_str + = ggc_strdup (hex_str); + lazy_hex_fp_values[lazy_hex_fp_value_count].mode = TYPE_MODE (type); + lazy_hex_fp_values[lazy_hex_fp_value_count].digits = digits; + lazy_hex_fp_values[lazy_hex_fp_value_count].fp_suffix = fp_suffix; + lazy_hex_fp_values[lazy_hex_fp_value_count].macro = node->value.macro; + node->flags |= NODE_BUILTIN; + node->value.builtin + = (enum cpp_builtin_type) (BT_FIRST_USER + lazy_hex_fp_value_count); + lazy_hex_fp_value_count++; + return; + } + + /* Hex values are really cool and convenient, except that they're + not supported in strict ISO C90 mode. First, the "p-" sequence + is not valid as part of a preprocessor number. Second, we get a + pedwarn from the preprocessor, which has no context, so we can't + suppress the warning with __extension__. + + So instead what we do is construct the number in hex (because + it's easy to get the exact correct value), parse it as a real, + then print it back out as decimal. */ + + real_from_string (&real, hex_str); + real_to_decimal_for_mode (dec_str, &real, sizeof (dec_str), digits, 0, + TYPE_MODE (type)); + + /* Assemble the macro in the following fashion + macro = fp_cast [dec_str fp_suffix] */ + sprintf (buf1, "%s%s", dec_str, fp_suffix); + sprintf (buf2, fp_cast, buf1); + sprintf (buf1, "%s=%s", macro, buf2); + + cpp_define (parse_in, buf1); +} + +/* Return a string constant for the suffix for a value of type TYPE + promoted according to the integer promotions. The type must be one + of the standard integer type nodes. */ + +static const char * +type_suffix (tree type) +{ + static const char *const suffixes[] = { "", "U", "L", "UL", "LL", "ULL" }; + int unsigned_suffix; + int is_long; + + if (type == long_long_integer_type_node + || type == long_long_unsigned_type_node) + is_long = 2; + else if (type == long_integer_type_node + || type == long_unsigned_type_node) + is_long = 1; + else if (type == integer_type_node + || type == unsigned_type_node + || type == short_integer_type_node + || type == short_unsigned_type_node + || type == signed_char_type_node + || type == unsigned_char_type_node + /* ??? "char" is not a signed or unsigned integer type and + so is not permitted for the standard typedefs, but some + systems use it anyway. */ + || type == char_type_node) + is_long = 0; + else + gcc_unreachable (); + + unsigned_suffix = TYPE_UNSIGNED (type); + if (TYPE_PRECISION (type) < TYPE_PRECISION (integer_type_node)) + unsigned_suffix = 0; + return suffixes[is_long * 2 + unsigned_suffix]; +} + +/* Define MACRO as a constant-suffix macro for TYPE. */ +static void +builtin_define_constants (const char *macro, tree type) +{ + const char *suffix; + char *buf; + + suffix = type_suffix (type); + + if (suffix[0] == 0) + { + buf = (char *) alloca (strlen (macro) + 6); + sprintf (buf, "%s(c)=c", macro); + } + else + { + buf = (char *) alloca (strlen (macro) + 9 + strlen (suffix) + 1); + sprintf (buf, "%s(c)=c ## %s", macro, suffix); + } + + cpp_define (parse_in, buf); +} + +/* Define MAX for TYPE based on the precision of the type. */ + +static void +builtin_define_type_max (const char *macro, tree type) +{ + builtin_define_type_minmax (NULL, macro, type); +} + +/* Define MIN_MACRO (if not NULL) and MAX_MACRO for TYPE based on the + precision of the type. */ + +static void +builtin_define_type_minmax (const char *min_macro, const char *max_macro, + tree type) +{ + static const char *const values[] + = { "127", "255", + "32767", "65535", + "2147483647", "4294967295", + "9223372036854775807", "18446744073709551615", + "170141183460469231731687303715884105727", + "340282366920938463463374607431768211455" }; + + const char *value, *suffix; + char *buf; + size_t idx; + + /* Pre-rendering the values mean we don't have to futz with printing a + multi-word decimal value. There are also a very limited number of + precisions that we support, so it's really a waste of time. */ + switch (TYPE_PRECISION (type)) + { + case 8: idx = 0; break; + case 16: idx = 2; break; + case 32: idx = 4; break; + case 64: idx = 6; break; + case 128: idx = 8; break; + default: gcc_unreachable (); + } + + value = values[idx + TYPE_UNSIGNED (type)]; + suffix = type_suffix (type); + + buf = (char *) alloca (strlen (max_macro) + 1 + strlen (value) + + strlen (suffix) + 1); + sprintf (buf, "%s=%s%s", max_macro, value, suffix); + + cpp_define (parse_in, buf); + + if (min_macro) + { + if (TYPE_UNSIGNED (type)) + { + buf = (char *) alloca (strlen (min_macro) + 2 + strlen (suffix) + 1); + sprintf (buf, "%s=0%s", min_macro, suffix); + } + else + { + buf = (char *) alloca (strlen (min_macro) + 3 + + strlen (max_macro) + 6); + sprintf (buf, "%s=(-%s - 1)", min_macro, max_macro); + } + cpp_define (parse_in, buf); + } +} + +#include "gt-c-family-c-cppbuiltin.h" diff --git a/gcc/c-family/c-dump.c b/gcc/c-family/c-dump.c new file mode 100644 index 00000000000..71e872e22cb --- /dev/null +++ b/gcc/c-family/c-dump.c @@ -0,0 +1,61 @@ +/* Tree-dumping functionality for C-family languages. + Copyright (C) 2002, 2004, 2005, 2007 Free Software Foundation, Inc. + Written by Mark Mitchell + +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 3, 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 COPYING3. If not see +. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tm.h" +#include "tree.h" +#include "tree-dump.h" +#include "c-common.h" + +/* Dump information common to statements from STMT. */ + +void +dump_stmt (dump_info_p di, const_tree t) +{ + if (EXPR_HAS_LOCATION (t)) + dump_int (di, "line", EXPR_LINENO (t)); +} + +/* Dump any C-specific tree codes and attributes of common codes. */ + +bool +c_dump_tree (void *dump_info, tree t) +{ + enum tree_code code; + dump_info_p di = (dump_info_p) dump_info; + + /* Figure out what kind of node this is. */ + code = TREE_CODE (t); + + switch (code) + { + case FIELD_DECL: + if (DECL_C_BIT_FIELD (t)) + dump_string (di, "bitfield"); + break; + + default: + break; + } + + return false; +} diff --git a/gcc/c-family/c-format.c b/gcc/c-family/c-format.c new file mode 100644 index 00000000000..2c73ead370c --- /dev/null +++ b/gcc/c-family/c-format.c @@ -0,0 +1,2870 @@ +/* Check calls to formatted I/O functions (-Wformat). + Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, + 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009, 2010 + 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 3, 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 COPYING3. If not see +. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tm.h" +#include "tree.h" +#include "flags.h" +#include "c-common.h" +#include "toplev.h" +#include "intl.h" +#include "diagnostic-core.h" +#include "langhooks.h" +#include "c-format.h" +#include "alloc-pool.h" + +/* Set format warning options according to a -Wformat=n option. */ + +void +set_Wformat (int setting) +{ + warn_format = setting; + warn_format_extra_args = setting; + warn_format_zero_length = setting; + warn_format_contains_nul = setting; + if (setting != 1) + { + warn_format_nonliteral = setting; + warn_format_security = setting; + warn_format_y2k = setting; + } + /* Make sure not to disable -Wnonnull if -Wformat=0 is specified. */ + if (setting) + warn_nonnull = setting; +} + + +/* Handle attributes associated with format checking. */ + +/* This must be in the same order as format_types, except for + format_type_error. Target-specific format types do not have + matching enum values. */ +enum format_type { printf_format_type, asm_fprintf_format_type, + gcc_diag_format_type, gcc_tdiag_format_type, + gcc_cdiag_format_type, + gcc_cxxdiag_format_type, gcc_gfc_format_type, + format_type_error = -1}; + +typedef struct function_format_info +{ + int format_type; /* type of format (printf, scanf, etc.) */ + unsigned HOST_WIDE_INT format_num; /* number of format argument */ + unsigned HOST_WIDE_INT first_arg_num; /* number of first arg (zero for varargs) */ +} function_format_info; + +static bool decode_format_attr (tree, function_format_info *, int); +static int decode_format_type (const char *); + +static bool check_format_string (tree argument, + unsigned HOST_WIDE_INT format_num, + int flags, bool *no_add_attrs); +static bool get_constant (tree expr, unsigned HOST_WIDE_INT *value, + int validated_p); +static const char *convert_format_name_to_system_name (const char *attr_name); +static bool cmp_attribs (const char *tattr_name, const char *attr_name); + +/* Handle a "format_arg" attribute; arguments as in + struct attribute_spec.handler. */ +tree +handle_format_arg_attribute (tree *node, tree ARG_UNUSED (name), + tree args, int flags, bool *no_add_attrs) +{ + tree type = *node; + tree format_num_expr = TREE_VALUE (args); + unsigned HOST_WIDE_INT format_num = 0; + tree argument; + + if (!get_constant (format_num_expr, &format_num, 0)) + { + error ("format string has invalid operand number"); + *no_add_attrs = true; + return NULL_TREE; + } + + argument = TYPE_ARG_TYPES (type); + if (argument) + { + if (!check_format_string (argument, format_num, flags, no_add_attrs)) + return NULL_TREE; + } + + if (TREE_CODE (TREE_TYPE (type)) != POINTER_TYPE + || (TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (type))) + != char_type_node)) + { + if (!(flags & (int) ATTR_FLAG_BUILT_IN)) + error ("function does not return string type"); + *no_add_attrs = true; + return NULL_TREE; + } + + return NULL_TREE; +} + +/* Verify that the format_num argument is actually a string, in case + the format attribute is in error. */ +static bool +check_format_string (tree argument, unsigned HOST_WIDE_INT format_num, + int flags, bool *no_add_attrs) +{ + unsigned HOST_WIDE_INT i; + + for (i = 1; i != format_num; i++) + { + if (argument == 0) + break; + argument = TREE_CHAIN (argument); + } + + if (!argument + || TREE_CODE (TREE_VALUE (argument)) != POINTER_TYPE + || (TYPE_MAIN_VARIANT (TREE_TYPE (TREE_VALUE (argument))) + != char_type_node)) + { + if (!(flags & (int) ATTR_FLAG_BUILT_IN)) + error ("format string argument not a string type"); + *no_add_attrs = true; + return false; + } + + return true; +} + +/* Verify EXPR is a constant, and store its value. + If validated_p is true there should be no errors. + Returns true on success, false otherwise. */ +static bool +get_constant (tree expr, unsigned HOST_WIDE_INT *value, int validated_p) +{ + if (TREE_CODE (expr) != INTEGER_CST || TREE_INT_CST_HIGH (expr) != 0) + { + gcc_assert (!validated_p); + return false; + } + + *value = TREE_INT_CST_LOW (expr); + + return true; +} + +/* Decode the arguments to a "format" attribute into a + function_format_info structure. It is already known that the list + is of the right length. If VALIDATED_P is true, then these + attributes have already been validated and must not be erroneous; + if false, it will give an error message. Returns true if the + attributes are successfully decoded, false otherwise. */ + +static bool +decode_format_attr (tree args, function_format_info *info, int validated_p) +{ + tree format_type_id = TREE_VALUE (args); + tree format_num_expr = TREE_VALUE (TREE_CHAIN (args)); + tree first_arg_num_expr + = TREE_VALUE (TREE_CHAIN (TREE_CHAIN (args))); + + if (TREE_CODE (format_type_id) != IDENTIFIER_NODE) + { + gcc_assert (!validated_p); + error ("unrecognized format specifier"); + return false; + } + else + { + const char *p = IDENTIFIER_POINTER (format_type_id); + + p = convert_format_name_to_system_name (p); + + info->format_type = decode_format_type (p); + + if (info->format_type == format_type_error) + { + gcc_assert (!validated_p); + warning (OPT_Wformat, "%qE is an unrecognized format function type", + format_type_id); + return false; + } + } + + if (!get_constant (format_num_expr, &info->format_num, validated_p)) + { + error ("format string has invalid operand number"); + return false; + } + + if (!get_constant (first_arg_num_expr, &info->first_arg_num, validated_p)) + { + error ("%<...%> has invalid operand number"); + return false; + } + + if (info->first_arg_num != 0 && info->first_arg_num <= info->format_num) + { + gcc_assert (!validated_p); + error ("format string argument follows the args to be formatted"); + return false; + } + + return true; +} + +/* Check a call to a format function against a parameter list. */ + +/* The C standard version C++ is treated as equivalent to + or inheriting from, for the purpose of format features supported. */ +#define CPLUSPLUS_STD_VER STD_C94 +/* The C standard version we are checking formats against when pedantic. */ +#define C_STD_VER ((int) (c_dialect_cxx () \ + ? CPLUSPLUS_STD_VER \ + : (flag_isoc99 \ + ? STD_C99 \ + : (flag_isoc94 ? STD_C94 : STD_C89)))) +/* The name to give to the standard version we are warning about when + pedantic. FEATURE_VER is the version in which the feature warned out + appeared, which is higher than C_STD_VER. */ +#define C_STD_NAME(FEATURE_VER) (c_dialect_cxx () \ + ? "ISO C++" \ + : ((FEATURE_VER) == STD_EXT \ + ? "ISO C" \ + : "ISO C90")) +/* Adjust a C standard version, which may be STD_C9L, to account for + -Wno-long-long. Returns other standard versions unchanged. */ +#define ADJ_STD(VER) ((int) ((VER) == STD_C9L \ + ? (warn_long_long ? STD_C99 : STD_C89) \ + : (VER))) + +/* Structure describing details of a type expected in format checking, + and the type to check against it. */ +typedef struct format_wanted_type +{ + /* The type wanted. */ + tree wanted_type; + /* The name of this type to use in diagnostics. */ + const char *wanted_type_name; + /* Should be type checked just for scalar width identity. */ + int scalar_identity_flag; + /* The level of indirection through pointers at which this type occurs. */ + int pointer_count; + /* Whether, when pointer_count is 1, to allow any character type when + pedantic, rather than just the character or void type specified. */ + int char_lenient_flag; + /* Whether the argument, dereferenced once, is written into and so the + argument must not be a pointer to a const-qualified type. */ + int writing_in_flag; + /* Whether the argument, dereferenced once, is read from and so + must not be a NULL pointer. */ + int reading_from_flag; + /* If warnings should be of the form "field precision should have + type 'int'", the name to use (in this case "field precision"), + otherwise NULL, for "format expects type 'long'" type + messages. */ + const char *name; + /* The actual parameter to check against the wanted type. */ + tree param; + /* The argument number of that parameter. */ + int arg_num; + /* The next type to check for this format conversion, or NULL if none. */ + struct format_wanted_type *next; +} format_wanted_type; + +/* Convenience macro for format_length_info meaning unused. */ +#define NO_FMT NULL, FMT_LEN_none, STD_C89 + +static const format_length_info printf_length_specs[] = +{ + { "h", FMT_LEN_h, STD_C89, "hh", FMT_LEN_hh, STD_C99, 0 }, + { "l", FMT_LEN_l, STD_C89, "ll", FMT_LEN_ll, STD_C9L, 0 }, + { "q", FMT_LEN_ll, STD_EXT, NO_FMT, 0 }, + { "L", FMT_LEN_L, STD_C89, NO_FMT, 0 }, + { "z", FMT_LEN_z, STD_C99, NO_FMT, 0 }, + { "Z", FMT_LEN_z, STD_EXT, NO_FMT, 0 }, + { "t", FMT_LEN_t, STD_C99, NO_FMT, 0 }, + { "j", FMT_LEN_j, STD_C99, NO_FMT, 0 }, + { "H", FMT_LEN_H, STD_EXT, NO_FMT, 0 }, + { "D", FMT_LEN_D, STD_EXT, "DD", FMT_LEN_DD, STD_EXT, 0 }, + { NO_FMT, NO_FMT, 0 } +}; + +/* Length specifiers valid for asm_fprintf. */ +static const format_length_info asm_fprintf_length_specs[] = +{ + { "l", FMT_LEN_l, STD_C89, "ll", FMT_LEN_ll, STD_C89, 0 }, + { "w", FMT_LEN_none, STD_C89, NO_FMT, 0 }, + { NO_FMT, NO_FMT, 0 } +}; + +/* Length specifiers valid for GCC diagnostics. */ +static const format_length_info gcc_diag_length_specs[] = +{ + { "l", FMT_LEN_l, STD_C89, "ll", FMT_LEN_ll, STD_C89, 0 }, + { "w", FMT_LEN_none, STD_C89, NO_FMT, 0 }, + { NO_FMT, NO_FMT, 0 } +}; + +/* The custom diagnostics all accept the same length specifiers. */ +#define gcc_tdiag_length_specs gcc_diag_length_specs +#define gcc_cdiag_length_specs gcc_diag_length_specs +#define gcc_cxxdiag_length_specs gcc_diag_length_specs + +/* This differs from printf_length_specs only in that "Z" is not accepted. */ +static const format_length_info scanf_length_specs[] = +{ + { "h", FMT_LEN_h, STD_C89, "hh", FMT_LEN_hh, STD_C99, 0 }, + { "l", FMT_LEN_l, STD_C89, "ll", FMT_LEN_ll, STD_C9L, 0 }, + { "q", FMT_LEN_ll, STD_EXT, NO_FMT, 0 }, + { "L", FMT_LEN_L, STD_C89, NO_FMT, 0 }, + { "z", FMT_LEN_z, STD_C99, NO_FMT, 0 }, + { "t", FMT_LEN_t, STD_C99, NO_FMT, 0 }, + { "j", FMT_LEN_j, STD_C99, NO_FMT, 0 }, + { "H", FMT_LEN_H, STD_EXT, NO_FMT, 0 }, + { "D", FMT_LEN_D, STD_EXT, "DD", FMT_LEN_DD, STD_EXT, 0 }, + { NO_FMT, NO_FMT, 0 } +}; + + +/* All tables for strfmon use STD_C89 everywhere, since -pedantic warnings + make no sense for a format type not part of any C standard version. */ +static const format_length_info strfmon_length_specs[] = +{ + /* A GNU extension. */ + { "L", FMT_LEN_L, STD_C89, NO_FMT, 0 }, + { NO_FMT, NO_FMT, 0 } +}; + + +/* For now, the Fortran front-end routines only use l as length modifier. */ +static const format_length_info gcc_gfc_length_specs[] = +{ + { "l", FMT_LEN_l, STD_C89, NO_FMT, 0 }, + { NO_FMT, NO_FMT, 0 } +}; + + +static const format_flag_spec printf_flag_specs[] = +{ + { ' ', 0, 0, N_("' ' flag"), N_("the ' ' printf flag"), STD_C89 }, + { '+', 0, 0, N_("'+' flag"), N_("the '+' printf flag"), STD_C89 }, + { '#', 0, 0, N_("'#' flag"), N_("the '#' printf flag"), STD_C89 }, + { '0', 0, 0, N_("'0' flag"), N_("the '0' printf flag"), STD_C89 }, + { '-', 0, 0, N_("'-' flag"), N_("the '-' printf flag"), STD_C89 }, + { '\'', 0, 0, N_("''' flag"), N_("the ''' printf flag"), STD_EXT }, + { 'I', 0, 0, N_("'I' flag"), N_("the 'I' printf flag"), STD_EXT }, + { 'w', 0, 0, N_("field width"), N_("field width in printf format"), STD_C89 }, + { 'p', 0, 0, N_("precision"), N_("precision in printf format"), STD_C89 }, + { 'L', 0, 0, N_("length modifier"), N_("length modifier in printf format"), STD_C89 }, + { 0, 0, 0, NULL, NULL, STD_C89 } +}; + + +static const format_flag_pair printf_flag_pairs[] = +{ + { ' ', '+', 1, 0 }, + { '0', '-', 1, 0 }, + { '0', 'p', 1, 'i' }, + { 0, 0, 0, 0 } +}; + +static const format_flag_spec asm_fprintf_flag_specs[] = +{ + { ' ', 0, 0, N_("' ' flag"), N_("the ' ' printf flag"), STD_C89 }, + { '+', 0, 0, N_("'+' flag"), N_("the '+' printf flag"), STD_C89 }, + { '#', 0, 0, N_("'#' flag"), N_("the '#' printf flag"), STD_C89 }, + { '0', 0, 0, N_("'0' flag"), N_("the '0' printf flag"), STD_C89 }, + { '-', 0, 0, N_("'-' flag"), N_("the '-' printf flag"), STD_C89 }, + { 'w', 0, 0, N_("field width"), N_("field width in printf format"), STD_C89 }, + { 'p', 0, 0, N_("precision"), N_("precision in printf format"), STD_C89 }, + { 'L', 0, 0, N_("length modifier"), N_("length modifier in printf format"), STD_C89 }, + { 0, 0, 0, NULL, NULL, STD_C89 } +}; + +static const format_flag_pair asm_fprintf_flag_pairs[] = +{ + { ' ', '+', 1, 0 }, + { '0', '-', 1, 0 }, + { '0', 'p', 1, 'i' }, + { 0, 0, 0, 0 } +}; + +static const format_flag_pair gcc_diag_flag_pairs[] = +{ + { 0, 0, 0, 0 } +}; + +#define gcc_tdiag_flag_pairs gcc_diag_flag_pairs +#define gcc_cdiag_flag_pairs gcc_diag_flag_pairs +#define gcc_cxxdiag_flag_pairs gcc_diag_flag_pairs + +static const format_flag_pair gcc_gfc_flag_pairs[] = +{ + { 0, 0, 0, 0 } +}; + +static const format_flag_spec gcc_diag_flag_specs[] = +{ + { '+', 0, 0, N_("'+' flag"), N_("the '+' printf flag"), STD_C89 }, + { '#', 0, 0, N_("'#' flag"), N_("the '#' printf flag"), STD_C89 }, + { 'q', 0, 0, N_("'q' flag"), N_("the 'q' diagnostic flag"), STD_C89 }, + { 'p', 0, 0, N_("precision"), N_("precision in printf format"), STD_C89 }, + { 'L', 0, 0, N_("length modifier"), N_("length modifier in printf format"), STD_C89 }, + { 0, 0, 0, NULL, NULL, STD_C89 } +}; + +#define gcc_tdiag_flag_specs gcc_diag_flag_specs +#define gcc_cdiag_flag_specs gcc_diag_flag_specs +#define gcc_cxxdiag_flag_specs gcc_diag_flag_specs + +static const format_flag_spec scanf_flag_specs[] = +{ + { '*', 0, 0, N_("assignment suppression"), N_("the assignment suppression scanf feature"), STD_C89 }, + { 'a', 0, 0, N_("'a' flag"), N_("the 'a' scanf flag"), STD_EXT }, + { 'm', 0, 0, N_("'m' flag"), N_("the 'm' scanf flag"), STD_EXT }, + { 'w', 0, 0, N_("field width"), N_("field width in scanf format"), STD_C89 }, + { 'L', 0, 0, N_("length modifier"), N_("length modifier in scanf format"), STD_C89 }, + { '\'', 0, 0, N_("''' flag"), N_("the ''' scanf flag"), STD_EXT }, + { 'I', 0, 0, N_("'I' flag"), N_("the 'I' scanf flag"), STD_EXT }, + { 0, 0, 0, NULL, NULL, STD_C89 } +}; + + +static const format_flag_pair scanf_flag_pairs[] = +{ + { '*', 'L', 0, 0 }, + { 'a', 'm', 0, 0 }, + { 0, 0, 0, 0 } +}; + + +static const format_flag_spec strftime_flag_specs[] = +{ + { '_', 0, 0, N_("'_' flag"), N_("the '_' strftime flag"), STD_EXT }, + { '-', 0, 0, N_("'-' flag"), N_("the '-' strftime flag"), STD_EXT }, + { '0', 0, 0, N_("'0' flag"), N_("the '0' strftime flag"), STD_EXT }, + { '^', 0, 0, N_("'^' flag"), N_("the '^' strftime flag"), STD_EXT }, + { '#', 0, 0, N_("'#' flag"), N_("the '#' strftime flag"), STD_EXT }, + { 'w', 0, 0, N_("field width"), N_("field width in strftime format"), STD_EXT }, + { 'E', 0, 0, N_("'E' modifier"), N_("the 'E' strftime modifier"), STD_C99 }, + { 'O', 0, 0, N_("'O' modifier"), N_("the 'O' strftime modifier"), STD_C99 }, + { 'O', 'o', 0, NULL, N_("the 'O' modifier"), STD_EXT }, + { 0, 0, 0, NULL, NULL, STD_C89 } +}; + + +static const format_flag_pair strftime_flag_pairs[] = +{ + { 'E', 'O', 0, 0 }, + { '_', '-', 0, 0 }, + { '_', '0', 0, 0 }, + { '-', '0', 0, 0 }, + { '^', '#', 0, 0 }, + { 0, 0, 0, 0 } +}; + + +static const format_flag_spec strfmon_flag_specs[] = +{ + { '=', 0, 1, N_("fill character"), N_("fill character in strfmon format"), STD_C89 }, + { '^', 0, 0, N_("'^' flag"), N_("the '^' strfmon flag"), STD_C89 }, + { '+', 0, 0, N_("'+' flag"), N_("the '+' strfmon flag"), STD_C89 }, + { '(', 0, 0, N_("'(' flag"), N_("the '(' strfmon flag"), STD_C89 }, + { '!', 0, 0, N_("'!' flag"), N_("the '!' strfmon flag"), STD_C89 }, + { '-', 0, 0, N_("'-' flag"), N_("the '-' strfmon flag"), STD_C89 }, + { 'w', 0, 0, N_("field width"), N_("field width in strfmon format"), STD_C89 }, + { '#', 0, 0, N_("left precision"), N_("left precision in strfmon format"), STD_C89 }, + { 'p', 0, 0, N_("right precision"), N_("right precision in strfmon format"), STD_C89 }, + { 'L', 0, 0, N_("length modifier"), N_("length modifier in strfmon format"), STD_C89 }, + { 0, 0, 0, NULL, NULL, STD_C89 } +}; + +static const format_flag_pair strfmon_flag_pairs[] = +{ + { '+', '(', 0, 0 }, + { 0, 0, 0, 0 } +}; + + +static const format_char_info print_char_table[] = +{ + /* C89 conversion specifiers. */ + { "di", 0, STD_C89, { T89_I, T99_SC, T89_S, T89_L, T9L_LL, TEX_LL, T99_SST, T99_PD, T99_IM, BADLEN, BADLEN, BADLEN }, "-wp0 +'I", "i", NULL }, + { "oxX", 0, STD_C89, { T89_UI, T99_UC, T89_US, T89_UL, T9L_ULL, TEX_ULL, T99_ST, T99_UPD, T99_UIM, BADLEN, BADLEN, BADLEN }, "-wp0#", "i", NULL }, + { "u", 0, STD_C89, { T89_UI, T99_UC, T89_US, T89_UL, T9L_ULL, TEX_ULL, T99_ST, T99_UPD, T99_UIM, BADLEN, BADLEN, BADLEN }, "-wp0'I", "i", NULL }, + { "fgG", 0, STD_C89, { T89_D, BADLEN, BADLEN, T99_D, BADLEN, T89_LD, BADLEN, BADLEN, BADLEN, TEX_D32, TEX_D64, TEX_D128 }, "-wp0 +#'I", "", NULL }, + { "eE", 0, STD_C89, { T89_D, BADLEN, BADLEN, T99_D, BADLEN, T89_LD, BADLEN, BADLEN, BADLEN, TEX_D32, TEX_D64, TEX_D128 }, "-wp0 +#I", "", NULL }, + { "c", 0, STD_C89, { T89_I, BADLEN, BADLEN, T94_WI, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "-w", "", NULL }, + { "s", 1, STD_C89, { T89_C, BADLEN, BADLEN, T94_W, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "-wp", "cR", NULL }, + { "p", 1, STD_C89, { T89_V, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "-w", "c", NULL }, + { "n", 1, STD_C89, { T89_I, T99_SC, T89_S, T89_L, T9L_LL, BADLEN, T99_SST, T99_PD, T99_IM, BADLEN, BADLEN, BADLEN }, "", "W", NULL }, + /* C99 conversion specifiers. */ + { "F", 0, STD_C99, { T99_D, BADLEN, BADLEN, T99_D, BADLEN, T99_LD, BADLEN, BADLEN, BADLEN, TEX_D32, TEX_D64, TEX_D128 }, "-wp0 +#'I", "", NULL }, + { "aA", 0, STD_C99, { T99_D, BADLEN, BADLEN, T99_D, BADLEN, T99_LD, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "-wp0 +#", "", NULL }, + /* X/Open conversion specifiers. */ + { "C", 0, STD_EXT, { TEX_WI, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "-w", "", NULL }, + { "S", 1, STD_EXT, { TEX_W, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "-wp", "R", NULL }, + /* GNU conversion specifiers. */ + { "m", 0, STD_EXT, { T89_V, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "-wp", "", NULL }, + { NULL, 0, STD_C89, NOLENGTHS, NULL, NULL, NULL } +}; + +static const format_char_info asm_fprintf_char_table[] = +{ + /* C89 conversion specifiers. */ + { "di", 0, STD_C89, { T89_I, BADLEN, BADLEN, T89_L, T9L_LL, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "-wp0 +", "i", NULL }, + { "oxX", 0, STD_C89, { T89_UI, BADLEN, BADLEN, T89_UL, T9L_ULL, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "-wp0#", "i", NULL }, + { "u", 0, STD_C89, { T89_UI, BADLEN, BADLEN, T89_UL, T9L_ULL, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "-wp0", "i", NULL }, + { "c", 0, STD_C89, { T89_I, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "-w", "", NULL }, + { "s", 1, STD_C89, { T89_C, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "-wp", "cR", NULL }, + + /* asm_fprintf conversion specifiers. */ + { "O", 0, STD_C89, NOARGUMENTS, "", "", NULL }, + { "R", 0, STD_C89, NOARGUMENTS, "", "", NULL }, + { "I", 0, STD_C89, NOARGUMENTS, "", "", NULL }, + { "L", 0, STD_C89, NOARGUMENTS, "", "", NULL }, + { "U", 0, STD_C89, NOARGUMENTS, "", "", NULL }, + { "r", 0, STD_C89, { T89_I, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "", "", NULL }, + { "@", 0, STD_C89, NOARGUMENTS, "", "", NULL }, + { NULL, 0, STD_C89, NOLENGTHS, NULL, NULL, NULL } +}; + +static const format_char_info gcc_diag_char_table[] = +{ + /* C89 conversion specifiers. */ + { "di", 0, STD_C89, { T89_I, BADLEN, BADLEN, T89_L, T9L_LL, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "", NULL }, + { "ox", 0, STD_C89, { T89_UI, BADLEN, BADLEN, T89_UL, T9L_ULL, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "", NULL }, + { "u", 0, STD_C89, { T89_UI, BADLEN, BADLEN, T89_UL, T9L_ULL, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "", NULL }, + { "c", 0, STD_C89, { T89_I, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "", NULL }, + { "s", 1, STD_C89, { T89_C, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "pq", "cR", NULL }, + { "p", 1, STD_C89, { T89_V, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "c", NULL }, + + /* Custom conversion specifiers. */ + + /* These will require a "tree" at runtime. */ + { "K", 0, STD_C89, { T89_V, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "", NULL }, + + { "<>'", 0, STD_C89, NOARGUMENTS, "", "", NULL }, + { "m", 0, STD_C89, NOARGUMENTS, "q", "", NULL }, + { NULL, 0, STD_C89, NOLENGTHS, NULL, NULL, NULL } +}; + +static const format_char_info gcc_tdiag_char_table[] = +{ + /* C89 conversion specifiers. */ + { "di", 0, STD_C89, { T89_I, BADLEN, BADLEN, T89_L, T9L_LL, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "", NULL }, + { "ox", 0, STD_C89, { T89_UI, BADLEN, BADLEN, T89_UL, T9L_ULL, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "", NULL }, + { "u", 0, STD_C89, { T89_UI, BADLEN, BADLEN, T89_UL, T9L_ULL, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "", NULL }, + { "c", 0, STD_C89, { T89_I, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "", NULL }, + { "s", 1, STD_C89, { T89_C, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "pq", "cR", NULL }, + { "p", 1, STD_C89, { T89_V, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "c", NULL }, + + /* Custom conversion specifiers. */ + + /* These will require a "tree" at runtime. */ + { "DFKTEV", 0, STD_C89, { T89_V, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q+", "", NULL }, + + { "v", 0,STD_C89, { T89_I, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q#", "", NULL }, + + { "<>'", 0, STD_C89, NOARGUMENTS, "", "", NULL }, + { "m", 0, STD_C89, NOARGUMENTS, "q", "", NULL }, + { NULL, 0, STD_C89, NOLENGTHS, NULL, NULL, NULL } +}; + +static const format_char_info gcc_cdiag_char_table[] = +{ + /* C89 conversion specifiers. */ + { "di", 0, STD_C89, { T89_I, BADLEN, BADLEN, T89_L, T9L_LL, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "", NULL }, + { "ox", 0, STD_C89, { T89_UI, BADLEN, BADLEN, T89_UL, T9L_ULL, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "", NULL }, + { "u", 0, STD_C89, { T89_UI, BADLEN, BADLEN, T89_UL, T9L_ULL, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "", NULL }, + { "c", 0, STD_C89, { T89_I, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "", NULL }, + { "s", 1, STD_C89, { T89_C, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "pq", "cR", NULL }, + { "p", 1, STD_C89, { T89_V, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "c", NULL }, + + /* Custom conversion specifiers. */ + + /* These will require a "tree" at runtime. */ + { "DEFKTV", 0, STD_C89, { T89_V, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q+", "", NULL }, + + { "v", 0,STD_C89, { T89_I, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q#", "", NULL }, + + { "<>'", 0, STD_C89, NOARGUMENTS, "", "", NULL }, + { "m", 0, STD_C89, NOARGUMENTS, "q", "", NULL }, + { NULL, 0, STD_C89, NOLENGTHS, NULL, NULL, NULL } +}; + +static const format_char_info gcc_cxxdiag_char_table[] = +{ + /* C89 conversion specifiers. */ + { "di", 0, STD_C89, { T89_I, BADLEN, BADLEN, T89_L, T9L_LL, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "", NULL }, + { "ox", 0, STD_C89, { T89_UI, BADLEN, BADLEN, T89_UL, T9L_ULL, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "", NULL }, + { "u", 0, STD_C89, { T89_UI, BADLEN, BADLEN, T89_UL, T9L_ULL, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "", NULL }, + { "c", 0, STD_C89, { T89_I, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "", NULL }, + { "s", 1, STD_C89, { T89_C, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "pq", "cR", NULL }, + { "p", 1, STD_C89, { T89_V, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "c", NULL }, + + /* Custom conversion specifiers. */ + + /* These will require a "tree" at runtime. */ + { "ADEFKTV",0,STD_C89,{ T89_V, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q+#", "", NULL }, + + { "v", 0,STD_C89, { T89_I, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q#", "", NULL }, + + /* These accept either an 'int' or an 'enum tree_code' (which is handled as an 'int'.) */ + { "CLOPQ",0,STD_C89, { T89_I, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "", NULL }, + + { "<>'", 0, STD_C89, NOARGUMENTS, "", "", NULL }, + { "m", 0, STD_C89, NOARGUMENTS, "q", "", NULL }, + { NULL, 0, STD_C89, NOLENGTHS, NULL, NULL, NULL } +}; + +static const format_char_info gcc_gfc_char_table[] = +{ + /* C89 conversion specifiers. */ + { "di", 0, STD_C89, { T89_I, BADLEN, BADLEN, T89_L, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "", "", NULL }, + { "u", 0, STD_C89, { T89_UI, BADLEN, BADLEN, T89_UL, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "", "", NULL }, + { "c", 0, STD_C89, { T89_I, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "", "", NULL }, + { "s", 1, STD_C89, { T89_C, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "", "cR", NULL }, + + /* gfc conversion specifiers. */ + + { "C", 0, STD_C89, NOARGUMENTS, "", "", NULL }, + + /* This will require a "locus" at runtime. */ + { "L", 0, STD_C89, { T89_V, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "", "R", NULL }, + + { NULL, 0, STD_C89, NOLENGTHS, NULL, NULL, NULL } +}; + +static const format_char_info scan_char_table[] = +{ + /* C89 conversion specifiers. */ + { "di", 1, STD_C89, { T89_I, T99_SC, T89_S, T89_L, T9L_LL, TEX_LL, T99_SST, T99_PD, T99_IM, BADLEN, BADLEN, BADLEN }, "*w'I", "W", NULL }, + { "u", 1, STD_C89, { T89_UI, T99_UC, T89_US, T89_UL, T9L_ULL, TEX_ULL, T99_ST, T99_UPD, T99_UIM, BADLEN, BADLEN, BADLEN }, "*w'I", "W", NULL }, + { "oxX", 1, STD_C89, { T89_UI, T99_UC, T89_US, T89_UL, T9L_ULL, TEX_ULL, T99_ST, T99_UPD, T99_UIM, BADLEN, BADLEN, BADLEN }, "*w", "W", NULL }, + { "efgEG", 1, STD_C89, { T89_F, BADLEN, BADLEN, T89_D, BADLEN, T89_LD, BADLEN, BADLEN, BADLEN, TEX_D32, TEX_D64, TEX_D128 }, "*w'", "W", NULL }, + { "c", 1, STD_C89, { T89_C, BADLEN, BADLEN, T94_W, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "*mw", "cW", NULL }, + { "s", 1, STD_C89, { T89_C, BADLEN, BADLEN, T94_W, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "*amw", "cW", NULL }, + { "[", 1, STD_C89, { T89_C, BADLEN, BADLEN, T94_W, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "*amw", "cW[", NULL }, + { "p", 2, STD_C89, { T89_V, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "*w", "W", NULL }, + { "n", 1, STD_C89, { T89_I, T99_SC, T89_S, T89_L, T9L_LL, BADLEN, T99_SST, T99_PD, T99_IM, BADLEN, BADLEN, BADLEN }, "", "W", NULL }, + /* C99 conversion specifiers. */ + { "F", 1, STD_C99, { T99_F, BADLEN, BADLEN, T99_D, BADLEN, T99_LD, BADLEN, BADLEN, BADLEN, TEX_D32, TEX_D64, TEX_D128 }, "*w'", "W", NULL }, + { "aA", 1, STD_C99, { T99_F, BADLEN, BADLEN, T99_D, BADLEN, T99_LD, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "*w'", "W", NULL }, + /* X/Open conversion specifiers. */ + { "C", 1, STD_EXT, { TEX_W, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "*mw", "W", NULL }, + { "S", 1, STD_EXT, { TEX_W, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "*amw", "W", NULL }, + { NULL, 0, STD_C89, NOLENGTHS, NULL, NULL, NULL } +}; + +static const format_char_info time_char_table[] = +{ + /* C89 conversion specifiers. */ + { "ABZab", 0, STD_C89, NOLENGTHS, "^#", "", NULL }, + { "cx", 0, STD_C89, NOLENGTHS, "E", "3", NULL }, + { "HIMSUWdmw", 0, STD_C89, NOLENGTHS, "-_0Ow", "", NULL }, + { "j", 0, STD_C89, NOLENGTHS, "-_0Ow", "o", NULL }, + { "p", 0, STD_C89, NOLENGTHS, "#", "", NULL }, + { "X", 0, STD_C89, NOLENGTHS, "E", "", NULL }, + { "y", 0, STD_C89, NOLENGTHS, "EO-_0w", "4", NULL }, + { "Y", 0, STD_C89, NOLENGTHS, "-_0EOw", "o", NULL }, + { "%", 0, STD_C89, NOLENGTHS, "", "", NULL }, + /* C99 conversion specifiers. */ + { "C", 0, STD_C99, NOLENGTHS, "-_0EOw", "o", NULL }, + { "D", 0, STD_C99, NOLENGTHS, "", "2", NULL }, + { "eVu", 0, STD_C99, NOLENGTHS, "-_0Ow", "", NULL }, + { "FRTnrt", 0, STD_C99, NOLENGTHS, "", "", NULL }, + { "g", 0, STD_C99, NOLENGTHS, "O-_0w", "2o", NULL }, + { "G", 0, STD_C99, NOLENGTHS, "-_0Ow", "o", NULL }, + { "h", 0, STD_C99, NOLENGTHS, "^#", "", NULL }, + { "z", 0, STD_C99, NOLENGTHS, "O", "o", NULL }, + /* GNU conversion specifiers. */ + { "kls", 0, STD_EXT, NOLENGTHS, "-_0Ow", "", NULL }, + { "P", 0, STD_EXT, NOLENGTHS, "", "", NULL }, + { NULL, 0, STD_C89, NOLENGTHS, NULL, NULL, NULL } +}; + +static const format_char_info monetary_char_table[] = +{ + { "in", 0, STD_C89, { T89_D, BADLEN, BADLEN, BADLEN, BADLEN, T89_LD, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "=^+(!-w#p", "", NULL }, + { NULL, 0, STD_C89, NOLENGTHS, NULL, NULL, NULL } +}; + +/* This must be in the same order as enum format_type. */ +static const format_kind_info format_types_orig[] = +{ + { "gnu_printf", printf_length_specs, print_char_table, " +#0-'I", NULL, + printf_flag_specs, printf_flag_pairs, + FMT_FLAG_ARG_CONVERT|FMT_FLAG_DOLLAR_MULTIPLE|FMT_FLAG_USE_DOLLAR|FMT_FLAG_EMPTY_PREC_OK, + 'w', 0, 'p', 0, 'L', 0, + &integer_type_node, &integer_type_node + }, + { "asm_fprintf", asm_fprintf_length_specs, asm_fprintf_char_table, " +#0-", NULL, + asm_fprintf_flag_specs, asm_fprintf_flag_pairs, + FMT_FLAG_ARG_CONVERT|FMT_FLAG_EMPTY_PREC_OK, + 'w', 0, 'p', 0, 'L', 0, + NULL, NULL + }, + { "gcc_diag", gcc_diag_length_specs, gcc_diag_char_table, "q+#", NULL, + gcc_diag_flag_specs, gcc_diag_flag_pairs, + FMT_FLAG_ARG_CONVERT, + 0, 0, 'p', 0, 'L', 0, + NULL, &integer_type_node + }, + { "gcc_tdiag", gcc_tdiag_length_specs, gcc_tdiag_char_table, "q+#", NULL, + gcc_tdiag_flag_specs, gcc_tdiag_flag_pairs, + FMT_FLAG_ARG_CONVERT, + 0, 0, 'p', 0, 'L', 0, + NULL, &integer_type_node + }, + { "gcc_cdiag", gcc_cdiag_length_specs, gcc_cdiag_char_table, "q+#", NULL, + gcc_cdiag_flag_specs, gcc_cdiag_flag_pairs, + FMT_FLAG_ARG_CONVERT, + 0, 0, 'p', 0, 'L', 0, + NULL, &integer_type_node + }, + { "gcc_cxxdiag", gcc_cxxdiag_length_specs, gcc_cxxdiag_char_table, "q+#", NULL, + gcc_cxxdiag_flag_specs, gcc_cxxdiag_flag_pairs, + FMT_FLAG_ARG_CONVERT, + 0, 0, 'p', 0, 'L', 0, + NULL, &integer_type_node + }, + { "gcc_gfc", gcc_gfc_length_specs, gcc_gfc_char_table, "", NULL, + NULL, gcc_gfc_flag_pairs, + FMT_FLAG_ARG_CONVERT, + 0, 0, 0, 0, 0, 0, + NULL, NULL + }, + { "gnu_scanf", scanf_length_specs, scan_char_table, "*'I", NULL, + scanf_flag_specs, scanf_flag_pairs, + FMT_FLAG_ARG_CONVERT|FMT_FLAG_SCANF_A_KLUDGE|FMT_FLAG_USE_DOLLAR|FMT_FLAG_ZERO_WIDTH_BAD|FMT_FLAG_DOLLAR_GAP_POINTER_OK, + 'w', 0, 0, '*', 'L', 'm', + NULL, NULL + }, + { "gnu_strftime", NULL, time_char_table, "_-0^#", "EO", + strftime_flag_specs, strftime_flag_pairs, + FMT_FLAG_FANCY_PERCENT_OK, 'w', 0, 0, 0, 0, 0, + NULL, NULL + }, + { "gnu_strfmon", strfmon_length_specs, monetary_char_table, "=^+(!-", NULL, + strfmon_flag_specs, strfmon_flag_pairs, + FMT_FLAG_ARG_CONVERT, 'w', '#', 'p', 0, 'L', 0, + NULL, NULL + } +}; + +/* This layer of indirection allows GCC to reassign format_types with + new data if necessary, while still allowing the original data to be + const. */ +static const format_kind_info *format_types = format_types_orig; +/* We can modify this one. We also add target-specific format types + to the end of the array. */ +static format_kind_info *dynamic_format_types; + +static int n_format_types = ARRAY_SIZE (format_types_orig); + +/* Structure detailing the results of checking a format function call + where the format expression may be a conditional expression with + many leaves resulting from nested conditional expressions. */ +typedef struct +{ + /* Number of leaves of the format argument that could not be checked + as they were not string literals. */ + int number_non_literal; + /* Number of leaves of the format argument that were null pointers or + string literals, but had extra format arguments. */ + int number_extra_args; + /* Number of leaves of the format argument that were null pointers or + string literals, but had extra format arguments and used $ operand + numbers. */ + int number_dollar_extra_args; + /* Number of leaves of the format argument that were wide string + literals. */ + int number_wide; + /* Number of leaves of the format argument that were empty strings. */ + int number_empty; + /* Number of leaves of the format argument that were unterminated + strings. */ + int number_unterminated; + /* Number of leaves of the format argument that were not counted above. */ + int number_other; +} format_check_results; + +typedef struct +{ + format_check_results *res; + function_format_info *info; + tree params; +} format_check_context; + +static void check_format_info (function_format_info *, tree); +static void check_format_arg (void *, tree, unsigned HOST_WIDE_INT); +static void check_format_info_main (format_check_results *, + function_format_info *, + const char *, int, tree, + unsigned HOST_WIDE_INT, alloc_pool); + +static void init_dollar_format_checking (int, tree); +static int maybe_read_dollar_number (const char **, int, + tree, tree *, const format_kind_info *); +static bool avoid_dollar_number (const char *); +static void finish_dollar_format_checking (format_check_results *, int); + +static const format_flag_spec *get_flag_spec (const format_flag_spec *, + int, const char *); + +static void check_format_types (format_wanted_type *, const char *, int); +static void format_type_warning (const char *, const char *, int, tree, + int, const char *, tree, int); + +/* Decode a format type from a string, returning the type, or + format_type_error if not valid, in which case the caller should print an + error message. */ +static int +decode_format_type (const char *s) +{ + int i; + int slen; + + s = convert_format_name_to_system_name (s); + slen = strlen (s); + for (i = 0; i < n_format_types; i++) + { + int alen; + if (!strcmp (s, format_types[i].name)) + return i; + alen = strlen (format_types[i].name); + if (slen == alen + 4 && s[0] == '_' && s[1] == '_' + && s[slen - 1] == '_' && s[slen - 2] == '_' + && !strncmp (s + 2, format_types[i].name, alen)) + return i; + } + return format_type_error; +} + + +/* Check the argument list of a call to printf, scanf, etc. + ATTRS are the attributes on the function type. There are NARGS argument + values in the array ARGARRAY. + Also, if -Wmissing-format-attribute, + warn for calls to vprintf or vscanf in functions with no such format + attribute themselves. */ + +void +check_function_format (tree attrs, int nargs, tree *argarray) +{ + tree a; + + /* See if this function has any format attributes. */ + for (a = attrs; a; a = TREE_CHAIN (a)) + { + if (is_attribute_p ("format", TREE_PURPOSE (a))) + { + /* Yup; check it. */ + function_format_info info; + decode_format_attr (TREE_VALUE (a), &info, 1); + if (warn_format) + { + /* FIXME: Rewrite all the internal functions in this file + to use the ARGARRAY directly instead of constructing this + temporary list. */ + tree params = NULL_TREE; + int i; + for (i = nargs - 1; i >= 0; i--) + params = tree_cons (NULL_TREE, argarray[i], params); + check_format_info (&info, params); + } + if (warn_missing_format_attribute && info.first_arg_num == 0 + && (format_types[info.format_type].flags + & (int) FMT_FLAG_ARG_CONVERT)) + { + tree c; + for (c = TYPE_ATTRIBUTES (TREE_TYPE (current_function_decl)); + c; + c = TREE_CHAIN (c)) + if (is_attribute_p ("format", TREE_PURPOSE (c)) + && (decode_format_type (IDENTIFIER_POINTER + (TREE_VALUE (TREE_VALUE (c)))) + == info.format_type)) + break; + if (c == NULL_TREE) + { + /* Check if the current function has a parameter to which + the format attribute could be attached; if not, it + can't be a candidate for a format attribute, despite + the vprintf-like or vscanf-like call. */ + tree args; + for (args = DECL_ARGUMENTS (current_function_decl); + args != 0; + args = TREE_CHAIN (args)) + { + if (TREE_CODE (TREE_TYPE (args)) == POINTER_TYPE + && (TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (args))) + == char_type_node)) + break; + } + if (args != 0) + warning (OPT_Wmissing_format_attribute, "function might " + "be possible candidate for %qs format attribute", + format_types[info.format_type].name); + } + } + } + } +} + + +/* Variables used by the checking of $ operand number formats. */ +static char *dollar_arguments_used = NULL; +static char *dollar_arguments_pointer_p = NULL; +static int dollar_arguments_alloc = 0; +static int dollar_arguments_count; +static int dollar_first_arg_num; +static int dollar_max_arg_used; +static int dollar_format_warned; + +/* Initialize the checking for a format string that may contain $ + parameter number specifications; we will need to keep track of whether + each parameter has been used. FIRST_ARG_NUM is the number of the first + argument that is a parameter to the format, or 0 for a vprintf-style + function; PARAMS is the list of arguments starting at this argument. */ + +static void +init_dollar_format_checking (int first_arg_num, tree params) +{ + tree oparams = params; + + dollar_first_arg_num = first_arg_num; + dollar_arguments_count = 0; + dollar_max_arg_used = 0; + dollar_format_warned = 0; + if (first_arg_num > 0) + { + while (params) + { + dollar_arguments_count++; + params = TREE_CHAIN (params); + } + } + if (dollar_arguments_alloc < dollar_arguments_count) + { + if (dollar_arguments_used) + free (dollar_arguments_used); + if (dollar_arguments_pointer_p) + free (dollar_arguments_pointer_p); + dollar_arguments_alloc = dollar_arguments_count; + dollar_arguments_used = XNEWVEC (char, dollar_arguments_alloc); + dollar_arguments_pointer_p = XNEWVEC (char, dollar_arguments_alloc); + } + if (dollar_arguments_alloc) + { + memset (dollar_arguments_used, 0, dollar_arguments_alloc); + if (first_arg_num > 0) + { + int i = 0; + params = oparams; + while (params) + { + dollar_arguments_pointer_p[i] = (TREE_CODE (TREE_TYPE (TREE_VALUE (params))) + == POINTER_TYPE); + params = TREE_CHAIN (params); + i++; + } + } + } +} + + +/* Look for a decimal number followed by a $ in *FORMAT. If DOLLAR_NEEDED + is set, it is an error if one is not found; otherwise, it is OK. If + such a number is found, check whether it is within range and mark that + numbered operand as being used for later checking. Returns the operand + number if found and within range, zero if no such number was found and + this is OK, or -1 on error. PARAMS points to the first operand of the + format; PARAM_PTR is made to point to the parameter referred to. If + a $ format is found, *FORMAT is updated to point just after it. */ + +static int +maybe_read_dollar_number (const char **format, + int dollar_needed, tree params, tree *param_ptr, + const format_kind_info *fki) +{ + int argnum; + int overflow_flag; + const char *fcp = *format; + if (!ISDIGIT (*fcp)) + { + if (dollar_needed) + { + warning (OPT_Wformat, "missing $ operand number in format"); + return -1; + } + else + return 0; + } + argnum = 0; + overflow_flag = 0; + while (ISDIGIT (*fcp)) + { + int nargnum; + nargnum = 10 * argnum + (*fcp - '0'); + if (nargnum < 0 || nargnum / 10 != argnum) + overflow_flag = 1; + argnum = nargnum; + fcp++; + } + if (*fcp != '$') + { + if (dollar_needed) + { + warning (OPT_Wformat, "missing $ operand number in format"); + return -1; + } + else + return 0; + } + *format = fcp + 1; + if (pedantic && !dollar_format_warned) + { + warning (OPT_Wformat, "%s does not support %%n$ operand number formats", + C_STD_NAME (STD_EXT)); + dollar_format_warned = 1; + } + if (overflow_flag || argnum == 0 + || (dollar_first_arg_num && argnum > dollar_arguments_count)) + { + warning (OPT_Wformat, "operand number out of range in format"); + return -1; + } + if (argnum > dollar_max_arg_used) + dollar_max_arg_used = argnum; + /* For vprintf-style functions we may need to allocate more memory to + track which arguments are used. */ + while (dollar_arguments_alloc < dollar_max_arg_used) + { + int nalloc; + nalloc = 2 * dollar_arguments_alloc + 16; + dollar_arguments_used = XRESIZEVEC (char, dollar_arguments_used, + nalloc); + dollar_arguments_pointer_p = XRESIZEVEC (char, dollar_arguments_pointer_p, + nalloc); + memset (dollar_arguments_used + dollar_arguments_alloc, 0, + nalloc - dollar_arguments_alloc); + dollar_arguments_alloc = nalloc; + } + if (!(fki->flags & (int) FMT_FLAG_DOLLAR_MULTIPLE) + && dollar_arguments_used[argnum - 1] == 1) + { + dollar_arguments_used[argnum - 1] = 2; + warning (OPT_Wformat, "format argument %d used more than once in %s format", + argnum, fki->name); + } + else + dollar_arguments_used[argnum - 1] = 1; + if (dollar_first_arg_num) + { + int i; + *param_ptr = params; + for (i = 1; i < argnum && *param_ptr != 0; i++) + *param_ptr = TREE_CHAIN (*param_ptr); + + /* This case shouldn't be caught here. */ + gcc_assert (*param_ptr); + } + else + *param_ptr = 0; + return argnum; +} + +/* Ensure that FORMAT does not start with a decimal number followed by + a $; give a diagnostic and return true if it does, false otherwise. */ + +static bool +avoid_dollar_number (const char *format) +{ + if (!ISDIGIT (*format)) + return false; + while (ISDIGIT (*format)) + format++; + if (*format == '$') + { + warning (OPT_Wformat, "$ operand number used after format without operand number"); + return true; + } + return false; +} + + +/* Finish the checking for a format string that used $ operand number formats + instead of non-$ formats. We check for unused operands before used ones + (a serious error, since the implementation of the format function + can't know what types to pass to va_arg to find the later arguments). + and for unused operands at the end of the format (if we know how many + arguments the format had, so not for vprintf). If there were operand + numbers out of range on a non-vprintf-style format, we won't have reached + here. If POINTER_GAP_OK, unused arguments are OK if all arguments are + pointers. */ + +static void +finish_dollar_format_checking (format_check_results *res, int pointer_gap_ok) +{ + int i; + bool found_pointer_gap = false; + for (i = 0; i < dollar_max_arg_used; i++) + { + if (!dollar_arguments_used[i]) + { + if (pointer_gap_ok && (dollar_first_arg_num == 0 + || dollar_arguments_pointer_p[i])) + found_pointer_gap = true; + else + warning (OPT_Wformat, + "format argument %d unused before used argument %d in $-style format", + i + 1, dollar_max_arg_used); + } + } + if (found_pointer_gap + || (dollar_first_arg_num + && dollar_max_arg_used < dollar_arguments_count)) + { + res->number_other--; + res->number_dollar_extra_args++; + } +} + + +/* Retrieve the specification for a format flag. SPEC contains the + specifications for format flags for the applicable kind of format. + FLAG is the flag in question. If PREDICATES is NULL, the basic + spec for that flag must be retrieved and must exist. If + PREDICATES is not NULL, it is a string listing possible predicates + for the spec entry; if an entry predicated on any of these is + found, it is returned, otherwise NULL is returned. */ + +static const format_flag_spec * +get_flag_spec (const format_flag_spec *spec, int flag, const char *predicates) +{ + int i; + for (i = 0; spec[i].flag_char != 0; i++) + { + if (spec[i].flag_char != flag) + continue; + if (predicates != NULL) + { + if (spec[i].predicate != 0 + && strchr (predicates, spec[i].predicate) != 0) + return &spec[i]; + } + else if (spec[i].predicate == 0) + return &spec[i]; + } + gcc_assert (predicates); + return NULL; +} + + +/* Check the argument list of a call to printf, scanf, etc. + INFO points to the function_format_info structure. + PARAMS is the list of argument values. */ + +static void +check_format_info (function_format_info *info, tree params) +{ + format_check_context format_ctx; + unsigned HOST_WIDE_INT arg_num; + tree format_tree; + format_check_results res; + /* Skip to format argument. If the argument isn't available, there's + no work for us to do; prototype checking will catch the problem. */ + for (arg_num = 1; ; ++arg_num) + { + if (params == 0) + return; + if (arg_num == info->format_num) + break; + params = TREE_CHAIN (params); + } + format_tree = TREE_VALUE (params); + params = TREE_CHAIN (params); + if (format_tree == 0) + return; + + res.number_non_literal = 0; + res.number_extra_args = 0; + res.number_dollar_extra_args = 0; + res.number_wide = 0; + res.number_empty = 0; + res.number_unterminated = 0; + res.number_other = 0; + + format_ctx.res = &res; + format_ctx.info = info; + format_ctx.params = params; + + check_function_arguments_recurse (check_format_arg, &format_ctx, + format_tree, arg_num); + + if (res.number_non_literal > 0) + { + /* Functions taking a va_list normally pass a non-literal format + string. These functions typically are declared with + first_arg_num == 0, so avoid warning in those cases. */ + if (!(format_types[info->format_type].flags & (int) FMT_FLAG_ARG_CONVERT)) + { + /* For strftime-like formats, warn for not checking the format + string; but there are no arguments to check. */ + warning (OPT_Wformat_nonliteral, + "format not a string literal, format string not checked"); + } + else if (info->first_arg_num != 0) + { + /* If there are no arguments for the format at all, we may have + printf (foo) which is likely to be a security hole. */ + while (arg_num + 1 < info->first_arg_num) + { + if (params == 0) + break; + params = TREE_CHAIN (params); + ++arg_num; + } + if (params == 0 && warn_format_security) + warning (OPT_Wformat_security, + "format not a string literal and no format arguments"); + else if (params == 0 && warn_format_nonliteral) + warning (OPT_Wformat_nonliteral, + "format not a string literal and no format arguments"); + else + warning (OPT_Wformat_nonliteral, + "format not a string literal, argument types not checked"); + } + } + + /* If there were extra arguments to the format, normally warn. However, + the standard does say extra arguments are ignored, so in the specific + case where we have multiple leaves (conditional expressions or + ngettext) allow extra arguments if at least one leaf didn't have extra + arguments, but was otherwise OK (either non-literal or checked OK). + If the format is an empty string, this should be counted similarly to the + case of extra format arguments. */ + if (res.number_extra_args > 0 && res.number_non_literal == 0 + && res.number_other == 0) + warning (OPT_Wformat_extra_args, "too many arguments for format"); + if (res.number_dollar_extra_args > 0 && res.number_non_literal == 0 + && res.number_other == 0) + warning (OPT_Wformat_extra_args, "unused arguments in $-style format"); + if (res.number_empty > 0 && res.number_non_literal == 0 + && res.number_other == 0) + warning (OPT_Wformat_zero_length, "zero-length %s format string", + format_types[info->format_type].name); + + if (res.number_wide > 0) + warning (OPT_Wformat, "format is a wide character string"); + + if (res.number_unterminated > 0) + warning (OPT_Wformat, "unterminated format string"); +} + +/* Callback from check_function_arguments_recurse to check a + format string. FORMAT_TREE is the format parameter. ARG_NUM + is the number of the format argument. CTX points to a + format_check_context. */ + +static void +check_format_arg (void *ctx, tree format_tree, + unsigned HOST_WIDE_INT arg_num) +{ + format_check_context *format_ctx = (format_check_context *) ctx; + format_check_results *res = format_ctx->res; + function_format_info *info = format_ctx->info; + tree params = format_ctx->params; + + int format_length; + HOST_WIDE_INT offset; + const char *format_chars; + tree array_size = 0; + tree array_init; + alloc_pool fwt_pool; + + if (integer_zerop (format_tree)) + { + /* Skip to first argument to check, so we can see if this format + has any arguments (it shouldn't). */ + while (arg_num + 1 < info->first_arg_num) + { + if (params == 0) + return; + params = TREE_CHAIN (params); + ++arg_num; + } + + if (params == 0) + res->number_other++; + else + res->number_extra_args++; + + return; + } + + offset = 0; + if (TREE_CODE (format_tree) == POINTER_PLUS_EXPR) + { + tree arg0, arg1; + + arg0 = TREE_OPERAND (format_tree, 0); + arg1 = TREE_OPERAND (format_tree, 1); + STRIP_NOPS (arg0); + STRIP_NOPS (arg1); + if (TREE_CODE (arg1) == INTEGER_CST) + format_tree = arg0; + else + { + res->number_non_literal++; + return; + } + if (!host_integerp (arg1, 0) + || (offset = tree_low_cst (arg1, 0)) < 0) + { + res->number_non_literal++; + return; + } + } + if (TREE_CODE (format_tree) != ADDR_EXPR) + { + res->number_non_literal++; + return; + } + format_tree = TREE_OPERAND (format_tree, 0); + if (TREE_CODE (format_tree) == ARRAY_REF + && host_integerp (TREE_OPERAND (format_tree, 1), 0) + && (offset += tree_low_cst (TREE_OPERAND (format_tree, 1), 0)) >= 0) + format_tree = TREE_OPERAND (format_tree, 0); + if (TREE_CODE (format_tree) == VAR_DECL + && TREE_CODE (TREE_TYPE (format_tree)) == ARRAY_TYPE + && (array_init = decl_constant_value (format_tree)) != format_tree + && TREE_CODE (array_init) == STRING_CST) + { + /* Extract the string constant initializer. Note that this may include + a trailing NUL character that is not in the array (e.g. + const char a[3] = "foo";). */ + array_size = DECL_SIZE_UNIT (format_tree); + format_tree = array_init; + } + if (TREE_CODE (format_tree) != STRING_CST) + { + res->number_non_literal++; + return; + } + if (TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (format_tree))) != char_type_node) + { + res->number_wide++; + return; + } + format_chars = TREE_STRING_POINTER (format_tree); + format_length = TREE_STRING_LENGTH (format_tree); + if (array_size != 0) + { + /* Variable length arrays can't be initialized. */ + gcc_assert (TREE_CODE (array_size) == INTEGER_CST); + + if (host_integerp (array_size, 0)) + { + HOST_WIDE_INT array_size_value = TREE_INT_CST_LOW (array_size); + if (array_size_value > 0 + && array_size_value == (int) array_size_value + && format_length > array_size_value) + format_length = array_size_value; + } + } + if (offset) + { + if (offset >= format_length) + { + res->number_non_literal++; + return; + } + format_chars += offset; + format_length -= offset; + } + if (format_length < 1 || format_chars[--format_length] != 0) + { + res->number_unterminated++; + return; + } + if (format_length == 0) + { + res->number_empty++; + return; + } + + /* Skip to first argument to check. */ + while (arg_num + 1 < info->first_arg_num) + { + if (params == 0) + return; + params = TREE_CHAIN (params); + ++arg_num; + } + /* Provisionally increment res->number_other; check_format_info_main + will decrement it if it finds there are extra arguments, but this way + need not adjust it for every return. */ + res->number_other++; + fwt_pool = create_alloc_pool ("format_wanted_type pool", + sizeof (format_wanted_type), 10); + check_format_info_main (res, info, format_chars, format_length, + params, arg_num, fwt_pool); + free_alloc_pool (fwt_pool); +} + + +/* Do the main part of checking a call to a format function. FORMAT_CHARS + is the NUL-terminated format string (which at this point may contain + internal NUL characters); FORMAT_LENGTH is its length (excluding the + terminating NUL character). ARG_NUM is one less than the number of + the first format argument to check; PARAMS points to that format + argument in the list of arguments. */ + +static void +check_format_info_main (format_check_results *res, + function_format_info *info, const char *format_chars, + int format_length, tree params, + unsigned HOST_WIDE_INT arg_num, alloc_pool fwt_pool) +{ + const char *orig_format_chars = format_chars; + tree first_fillin_param = params; + + const format_kind_info *fki = &format_types[info->format_type]; + const format_flag_spec *flag_specs = fki->flag_specs; + const format_flag_pair *bad_flag_pairs = fki->bad_flag_pairs; + + /* -1 if no conversions taking an operand have been found; 0 if one has + and it didn't use $; 1 if $ formats are in use. */ + int has_operand_number = -1; + + init_dollar_format_checking (info->first_arg_num, first_fillin_param); + + while (1) + { + int i; + int suppressed = FALSE; + const char *length_chars = NULL; + enum format_lengths length_chars_val = FMT_LEN_none; + enum format_std_version length_chars_std = STD_C89; + int format_char; + tree cur_param; + tree wanted_type; + int main_arg_num = 0; + tree main_arg_params = 0; + enum format_std_version wanted_type_std; + const char *wanted_type_name; + format_wanted_type width_wanted_type; + format_wanted_type precision_wanted_type; + format_wanted_type main_wanted_type; + format_wanted_type *first_wanted_type = NULL; + format_wanted_type *last_wanted_type = NULL; + const format_length_info *fli = NULL; + const format_char_info *fci = NULL; + char flag_chars[256]; + int alloc_flag = 0; + int scalar_identity_flag = 0; + const char *format_start = format_chars; + if (*format_chars == 0) + { + if (format_chars - orig_format_chars != format_length) + warning (OPT_Wformat_contains_nul, "embedded %<\\0%> in format"); + if (info->first_arg_num != 0 && params != 0 + && has_operand_number <= 0) + { + res->number_other--; + res->number_extra_args++; + } + if (has_operand_number > 0) + finish_dollar_format_checking (res, fki->flags & (int) FMT_FLAG_DOLLAR_GAP_POINTER_OK); + return; + } + if (*format_chars++ != '%') + continue; + if (*format_chars == 0) + { + warning (OPT_Wformat, "spurious trailing %<%%%> in format"); + continue; + } + if (*format_chars == '%') + { + ++format_chars; + continue; + } + flag_chars[0] = 0; + + if ((fki->flags & (int) FMT_FLAG_USE_DOLLAR) && has_operand_number != 0) + { + /* Possibly read a $ operand number at the start of the format. + If one was previously used, one is required here. If one + is not used here, we can't immediately conclude this is a + format without them, since it could be printf %m or scanf %*. */ + int opnum; + opnum = maybe_read_dollar_number (&format_chars, 0, + first_fillin_param, + &main_arg_params, fki); + if (opnum == -1) + return; + else if (opnum > 0) + { + has_operand_number = 1; + main_arg_num = opnum + info->first_arg_num - 1; + } + } + else if (fki->flags & FMT_FLAG_USE_DOLLAR) + { + if (avoid_dollar_number (format_chars)) + return; + } + + /* Read any format flags, but do not yet validate them beyond removing + duplicates, since in general validation depends on the rest of + the format. */ + while (*format_chars != 0 + && strchr (fki->flag_chars, *format_chars) != 0) + { + const format_flag_spec *s = get_flag_spec (flag_specs, + *format_chars, NULL); + if (strchr (flag_chars, *format_chars) != 0) + { + warning (OPT_Wformat, "repeated %s in format", _(s->name)); + } + else + { + i = strlen (flag_chars); + flag_chars[i++] = *format_chars; + flag_chars[i] = 0; + } + if (s->skip_next_char) + { + ++format_chars; + if (*format_chars == 0) + { + warning (OPT_Wformat, "missing fill character at end of strfmon format"); + return; + } + } + ++format_chars; + } + + /* Read any format width, possibly * or *m$. */ + if (fki->width_char != 0) + { + if (fki->width_type != NULL && *format_chars == '*') + { + i = strlen (flag_chars); + flag_chars[i++] = fki->width_char; + flag_chars[i] = 0; + /* "...a field width...may be indicated by an asterisk. + In this case, an int argument supplies the field width..." */ + ++format_chars; + if (has_operand_number != 0) + { + int opnum; + opnum = maybe_read_dollar_number (&format_chars, + has_operand_number == 1, + first_fillin_param, + ¶ms, fki); + if (opnum == -1) + return; + else if (opnum > 0) + { + has_operand_number = 1; + arg_num = opnum + info->first_arg_num - 1; + } + else + has_operand_number = 0; + } + else + { + if (avoid_dollar_number (format_chars)) + return; + } + if (info->first_arg_num != 0) + { + if (params == 0) + { + warning (OPT_Wformat, "too few arguments for format"); + return; + } + cur_param = TREE_VALUE (params); + if (has_operand_number <= 0) + { + params = TREE_CHAIN (params); + ++arg_num; + } + width_wanted_type.wanted_type = *fki->width_type; + width_wanted_type.wanted_type_name = NULL; + width_wanted_type.pointer_count = 0; + width_wanted_type.char_lenient_flag = 0; + width_wanted_type.scalar_identity_flag = 0; + width_wanted_type.writing_in_flag = 0; + width_wanted_type.reading_from_flag = 0; + width_wanted_type.name = _("field width"); + width_wanted_type.param = cur_param; + width_wanted_type.arg_num = arg_num; + width_wanted_type.next = NULL; + if (last_wanted_type != 0) + last_wanted_type->next = &width_wanted_type; + if (first_wanted_type == 0) + first_wanted_type = &width_wanted_type; + last_wanted_type = &width_wanted_type; + } + } + else + { + /* Possibly read a numeric width. If the width is zero, + we complain if appropriate. */ + int non_zero_width_char = FALSE; + int found_width = FALSE; + while (ISDIGIT (*format_chars)) + { + found_width = TRUE; + if (*format_chars != '0') + non_zero_width_char = TRUE; + ++format_chars; + } + if (found_width && !non_zero_width_char && + (fki->flags & (int) FMT_FLAG_ZERO_WIDTH_BAD)) + warning (OPT_Wformat, "zero width in %s format", fki->name); + if (found_width) + { + i = strlen (flag_chars); + flag_chars[i++] = fki->width_char; + flag_chars[i] = 0; + } + } + } + + /* Read any format left precision (must be a number, not *). */ + if (fki->left_precision_char != 0 && *format_chars == '#') + { + ++format_chars; + i = strlen (flag_chars); + flag_chars[i++] = fki->left_precision_char; + flag_chars[i] = 0; + if (!ISDIGIT (*format_chars)) + warning (OPT_Wformat, "empty left precision in %s format", fki->name); + while (ISDIGIT (*format_chars)) + ++format_chars; + } + + /* Read any format precision, possibly * or *m$. */ + if (fki->precision_char != 0 && *format_chars == '.') + { + ++format_chars; + i = strlen (flag_chars); + flag_chars[i++] = fki->precision_char; + flag_chars[i] = 0; + if (fki->precision_type != NULL && *format_chars == '*') + { + /* "...a...precision...may be indicated by an asterisk. + In this case, an int argument supplies the...precision." */ + ++format_chars; + if (has_operand_number != 0) + { + int opnum; + opnum = maybe_read_dollar_number (&format_chars, + has_operand_number == 1, + first_fillin_param, + ¶ms, fki); + if (opnum == -1) + return; + else if (opnum > 0) + { + has_operand_number = 1; + arg_num = opnum + info->first_arg_num - 1; + } + else + has_operand_number = 0; + } + else + { + if (avoid_dollar_number (format_chars)) + return; + } + if (info->first_arg_num != 0) + { + if (params == 0) + { + warning (OPT_Wformat, "too few arguments for format"); + return; + } + cur_param = TREE_VALUE (params); + if (has_operand_number <= 0) + { + params = TREE_CHAIN (params); + ++arg_num; + } + precision_wanted_type.wanted_type = *fki->precision_type; + precision_wanted_type.wanted_type_name = NULL; + precision_wanted_type.pointer_count = 0; + precision_wanted_type.char_lenient_flag = 0; + precision_wanted_type.scalar_identity_flag = 0; + precision_wanted_type.writing_in_flag = 0; + precision_wanted_type.reading_from_flag = 0; + precision_wanted_type.name = _("field precision"); + precision_wanted_type.param = cur_param; + precision_wanted_type.arg_num = arg_num; + precision_wanted_type.next = NULL; + if (last_wanted_type != 0) + last_wanted_type->next = &precision_wanted_type; + if (first_wanted_type == 0) + first_wanted_type = &precision_wanted_type; + last_wanted_type = &precision_wanted_type; + } + } + else + { + if (!(fki->flags & (int) FMT_FLAG_EMPTY_PREC_OK) + && !ISDIGIT (*format_chars)) + warning (OPT_Wformat, "empty precision in %s format", fki->name); + while (ISDIGIT (*format_chars)) + ++format_chars; + } + } + + if (fki->alloc_char && fki->alloc_char == *format_chars) + { + i = strlen (flag_chars); + flag_chars[i++] = fki->alloc_char; + flag_chars[i] = 0; + format_chars++; + } + + /* Handle the scanf allocation kludge. */ + if (fki->flags & (int) FMT_FLAG_SCANF_A_KLUDGE) + { + if (*format_chars == 'a' && !flag_isoc99) + { + if (format_chars[1] == 's' || format_chars[1] == 'S' + || format_chars[1] == '[') + { + /* 'a' is used as a flag. */ + i = strlen (flag_chars); + flag_chars[i++] = 'a'; + flag_chars[i] = 0; + format_chars++; + } + } + } + + /* Read any length modifier, if this kind of format has them. */ + fli = fki->length_char_specs; + length_chars = NULL; + length_chars_val = FMT_LEN_none; + length_chars_std = STD_C89; + scalar_identity_flag = 0; + if (fli) + { + while (fli->name != 0 + && strncmp (fli->name, format_chars, strlen (fli->name))) + fli++; + if (fli->name != 0) + { + format_chars += strlen (fli->name); + if (fli->double_name != 0 && fli->name[0] == *format_chars) + { + format_chars++; + length_chars = fli->double_name; + length_chars_val = fli->double_index; + length_chars_std = fli->double_std; + } + else + { + length_chars = fli->name; + length_chars_val = fli->index; + length_chars_std = fli->std; + scalar_identity_flag = fli->scalar_identity_flag; + } + i = strlen (flag_chars); + flag_chars[i++] = fki->length_code_char; + flag_chars[i] = 0; + } + if (pedantic) + { + /* Warn if the length modifier is non-standard. */ + if (ADJ_STD (length_chars_std) > C_STD_VER) + warning (OPT_Wformat, + "%s does not support the %qs %s length modifier", + C_STD_NAME (length_chars_std), length_chars, + fki->name); + } + } + + /* Read any modifier (strftime E/O). */ + if (fki->modifier_chars != NULL) + { + while (*format_chars != 0 + && strchr (fki->modifier_chars, *format_chars) != 0) + { + if (strchr (flag_chars, *format_chars) != 0) + { + const format_flag_spec *s = get_flag_spec (flag_specs, + *format_chars, NULL); + warning (OPT_Wformat, "repeated %s in format", _(s->name)); + } + else + { + i = strlen (flag_chars); + flag_chars[i++] = *format_chars; + flag_chars[i] = 0; + } + ++format_chars; + } + } + + format_char = *format_chars; + if (format_char == 0 + || (!(fki->flags & (int) FMT_FLAG_FANCY_PERCENT_OK) + && format_char == '%')) + { + warning (OPT_Wformat, "conversion lacks type at end of format"); + continue; + } + format_chars++; + fci = fki->conversion_specs; + while (fci->format_chars != 0 + && strchr (fci->format_chars, format_char) == 0) + ++fci; + if (fci->format_chars == 0) + { + if (ISGRAPH (format_char)) + warning (OPT_Wformat, "unknown conversion type character %qc in format", + format_char); + else + warning (OPT_Wformat, "unknown conversion type character 0x%x in format", + format_char); + continue; + } + if (pedantic) + { + if (ADJ_STD (fci->std) > C_STD_VER) + warning (OPT_Wformat, "%s does not support the %<%%%c%> %s format", + C_STD_NAME (fci->std), format_char, fki->name); + } + + /* Validate the individual flags used, removing any that are invalid. */ + { + int d = 0; + for (i = 0; flag_chars[i] != 0; i++) + { + const format_flag_spec *s = get_flag_spec (flag_specs, + flag_chars[i], NULL); + flag_chars[i - d] = flag_chars[i]; + if (flag_chars[i] == fki->length_code_char) + continue; + if (strchr (fci->flag_chars, flag_chars[i]) == 0) + { + warning (OPT_Wformat, "%s used with %<%%%c%> %s format", + _(s->name), format_char, fki->name); + d++; + continue; + } + if (pedantic) + { + const format_flag_spec *t; + if (ADJ_STD (s->std) > C_STD_VER) + warning (OPT_Wformat, "%s does not support %s", + C_STD_NAME (s->std), _(s->long_name)); + t = get_flag_spec (flag_specs, flag_chars[i], fci->flags2); + if (t != NULL && ADJ_STD (t->std) > ADJ_STD (s->std)) + { + const char *long_name = (t->long_name != NULL + ? t->long_name + : s->long_name); + if (ADJ_STD (t->std) > C_STD_VER) + warning (OPT_Wformat, + "%s does not support %s with the %<%%%c%> %s format", + C_STD_NAME (t->std), _(long_name), + format_char, fki->name); + } + } + } + flag_chars[i - d] = 0; + } + + if ((fki->flags & (int) FMT_FLAG_SCANF_A_KLUDGE) + && strchr (flag_chars, 'a') != 0) + alloc_flag = 1; + if (fki->alloc_char && strchr (flag_chars, fki->alloc_char) != 0) + alloc_flag = 1; + + if (fki->suppression_char + && strchr (flag_chars, fki->suppression_char) != 0) + suppressed = 1; + + /* Validate the pairs of flags used. */ + for (i = 0; bad_flag_pairs[i].flag_char1 != 0; i++) + { + const format_flag_spec *s, *t; + if (strchr (flag_chars, bad_flag_pairs[i].flag_char1) == 0) + continue; + if (strchr (flag_chars, bad_flag_pairs[i].flag_char2) == 0) + continue; + if (bad_flag_pairs[i].predicate != 0 + && strchr (fci->flags2, bad_flag_pairs[i].predicate) == 0) + continue; + s = get_flag_spec (flag_specs, bad_flag_pairs[i].flag_char1, NULL); + t = get_flag_spec (flag_specs, bad_flag_pairs[i].flag_char2, NULL); + if (bad_flag_pairs[i].ignored) + { + if (bad_flag_pairs[i].predicate != 0) + warning (OPT_Wformat, + "%s ignored with %s and %<%%%c%> %s format", + _(s->name), _(t->name), format_char, + fki->name); + else + warning (OPT_Wformat, "%s ignored with %s in %s format", + _(s->name), _(t->name), fki->name); + } + else + { + if (bad_flag_pairs[i].predicate != 0) + warning (OPT_Wformat, + "use of %s and %s together with %<%%%c%> %s format", + _(s->name), _(t->name), format_char, + fki->name); + else + warning (OPT_Wformat, "use of %s and %s together in %s format", + _(s->name), _(t->name), fki->name); + } + } + + /* Give Y2K warnings. */ + if (warn_format_y2k) + { + int y2k_level = 0; + if (strchr (fci->flags2, '4') != 0) + if (strchr (flag_chars, 'E') != 0) + y2k_level = 3; + else + y2k_level = 2; + else if (strchr (fci->flags2, '3') != 0) + y2k_level = 3; + else if (strchr (fci->flags2, '2') != 0) + y2k_level = 2; + if (y2k_level == 3) + warning (OPT_Wformat_y2k, "%<%%%c%> yields only last 2 digits of " + "year in some locales", format_char); + else if (y2k_level == 2) + warning (OPT_Wformat_y2k, "%<%%%c%> yields only last 2 digits of " + "year", format_char); + } + + if (strchr (fci->flags2, '[') != 0) + { + /* Skip over scan set, in case it happens to have '%' in it. */ + if (*format_chars == '^') + ++format_chars; + /* Find closing bracket; if one is hit immediately, then + it's part of the scan set rather than a terminator. */ + if (*format_chars == ']') + ++format_chars; + while (*format_chars && *format_chars != ']') + ++format_chars; + if (*format_chars != ']') + /* The end of the format string was reached. */ + warning (OPT_Wformat, "no closing %<]%> for %<%%[%> format"); + } + + wanted_type = 0; + wanted_type_name = 0; + if (fki->flags & (int) FMT_FLAG_ARG_CONVERT) + { + wanted_type = (fci->types[length_chars_val].type + ? *fci->types[length_chars_val].type : 0); + wanted_type_name = fci->types[length_chars_val].name; + wanted_type_std = fci->types[length_chars_val].std; + if (wanted_type == 0) + { + warning (OPT_Wformat, + "use of %qs length modifier with %qc type character", + length_chars, format_char); + /* Heuristic: skip one argument when an invalid length/type + combination is encountered. */ + arg_num++; + if (params == 0) + { + warning (OPT_Wformat, "too few arguments for format"); + return; + } + params = TREE_CHAIN (params); + continue; + } + else if (pedantic + /* Warn if non-standard, provided it is more non-standard + than the length and type characters that may already + have been warned for. */ + && ADJ_STD (wanted_type_std) > ADJ_STD (length_chars_std) + && ADJ_STD (wanted_type_std) > ADJ_STD (fci->std)) + { + if (ADJ_STD (wanted_type_std) > C_STD_VER) + warning (OPT_Wformat, + "%s does not support the %<%%%s%c%> %s format", + C_STD_NAME (wanted_type_std), length_chars, + format_char, fki->name); + } + } + + main_wanted_type.next = NULL; + + /* Finally. . .check type of argument against desired type! */ + if (info->first_arg_num == 0) + continue; + if ((fci->pointer_count == 0 && wanted_type == void_type_node) + || suppressed) + { + if (main_arg_num != 0) + { + if (suppressed) + warning (OPT_Wformat, "operand number specified with " + "suppressed assignment"); + else + warning (OPT_Wformat, "operand number specified for format " + "taking no argument"); + } + } + else + { + format_wanted_type *wanted_type_ptr; + + if (main_arg_num != 0) + { + arg_num = main_arg_num; + params = main_arg_params; + } + else + { + ++arg_num; + if (has_operand_number > 0) + { + warning (OPT_Wformat, "missing $ operand number in format"); + return; + } + else + has_operand_number = 0; + } + + wanted_type_ptr = &main_wanted_type; + while (fci) + { + if (params == 0) + { + warning (OPT_Wformat, "too few arguments for format"); + return; + } + + cur_param = TREE_VALUE (params); + params = TREE_CHAIN (params); + + wanted_type_ptr->wanted_type = wanted_type; + wanted_type_ptr->wanted_type_name = wanted_type_name; + wanted_type_ptr->pointer_count = fci->pointer_count + alloc_flag; + wanted_type_ptr->char_lenient_flag = 0; + if (strchr (fci->flags2, 'c') != 0) + wanted_type_ptr->char_lenient_flag = 1; + wanted_type_ptr->scalar_identity_flag = 0; + if (scalar_identity_flag) + wanted_type_ptr->scalar_identity_flag = 1; + wanted_type_ptr->writing_in_flag = 0; + wanted_type_ptr->reading_from_flag = 0; + if (alloc_flag) + wanted_type_ptr->writing_in_flag = 1; + else + { + if (strchr (fci->flags2, 'W') != 0) + wanted_type_ptr->writing_in_flag = 1; + if (strchr (fci->flags2, 'R') != 0) + wanted_type_ptr->reading_from_flag = 1; + } + wanted_type_ptr->name = NULL; + wanted_type_ptr->param = cur_param; + wanted_type_ptr->arg_num = arg_num; + wanted_type_ptr->next = NULL; + if (last_wanted_type != 0) + last_wanted_type->next = wanted_type_ptr; + if (first_wanted_type == 0) + first_wanted_type = wanted_type_ptr; + last_wanted_type = wanted_type_ptr; + + fci = fci->chain; + if (fci) + { + wanted_type_ptr = (format_wanted_type *) + pool_alloc (fwt_pool); + arg_num++; + wanted_type = *fci->types[length_chars_val].type; + wanted_type_name = fci->types[length_chars_val].name; + } + } + } + + if (first_wanted_type != 0) + check_format_types (first_wanted_type, format_start, + format_chars - format_start); + } +} + + +/* Check the argument types from a single format conversion (possibly + including width and precision arguments). */ +static void +check_format_types (format_wanted_type *types, const char *format_start, + int format_length) +{ + for (; types != 0; types = types->next) + { + tree cur_param; + tree cur_type; + tree orig_cur_type; + tree wanted_type; + int arg_num; + int i; + int char_type_flag; + cur_param = types->param; + cur_type = TREE_TYPE (cur_param); + if (cur_type == error_mark_node) + continue; + orig_cur_type = cur_type; + char_type_flag = 0; + wanted_type = types->wanted_type; + arg_num = types->arg_num; + + /* The following should not occur here. */ + gcc_assert (wanted_type); + gcc_assert (wanted_type != void_type_node || types->pointer_count); + + if (types->pointer_count == 0) + wanted_type = lang_hooks.types.type_promotes_to (wanted_type); + + wanted_type = TYPE_MAIN_VARIANT (wanted_type); + + STRIP_NOPS (cur_param); + + /* Check the types of any additional pointer arguments + that precede the "real" argument. */ + for (i = 0; i < types->pointer_count; ++i) + { + if (TREE_CODE (cur_type) == POINTER_TYPE) + { + cur_type = TREE_TYPE (cur_type); + if (cur_type == error_mark_node) + break; + + /* Check for writing through a NULL pointer. */ + if (types->writing_in_flag + && i == 0 + && cur_param != 0 + && integer_zerop (cur_param)) + warning (OPT_Wformat, "writing through null pointer " + "(argument %d)", arg_num); + + /* Check for reading through a NULL pointer. */ + if (types->reading_from_flag + && i == 0 + && cur_param != 0 + && integer_zerop (cur_param)) + warning (OPT_Wformat, "reading through null pointer " + "(argument %d)", arg_num); + + if (cur_param != 0 && TREE_CODE (cur_param) == ADDR_EXPR) + cur_param = TREE_OPERAND (cur_param, 0); + else + cur_param = 0; + + /* See if this is an attempt to write into a const type with + scanf or with printf "%n". Note: the writing in happens + at the first indirection only, if for example + void * const * is passed to scanf %p; passing + const void ** is simply passing an incompatible type. */ + if (types->writing_in_flag + && i == 0 + && (TYPE_READONLY (cur_type) + || (cur_param != 0 + && (CONSTANT_CLASS_P (cur_param) + || (DECL_P (cur_param) + && TREE_READONLY (cur_param)))))) + warning (OPT_Wformat, "writing into constant object " + "(argument %d)", arg_num); + + /* If there are extra type qualifiers beyond the first + indirection, then this makes the types technically + incompatible. */ + if (i > 0 + && pedantic + && (TYPE_READONLY (cur_type) + || TYPE_VOLATILE (cur_type) + || TYPE_RESTRICT (cur_type))) + warning (OPT_Wformat, "extra type qualifiers in format " + "argument (argument %d)", + arg_num); + + } + else + { + format_type_warning (types->name, format_start, format_length, + wanted_type, types->pointer_count, + types->wanted_type_name, orig_cur_type, + arg_num); + break; + } + } + + if (i < types->pointer_count) + continue; + + cur_type = TYPE_MAIN_VARIANT (cur_type); + + /* Check whether the argument type is a character type. This leniency + only applies to certain formats, flagged with 'c'. + */ + if (types->char_lenient_flag) + char_type_flag = (cur_type == char_type_node + || cur_type == signed_char_type_node + || cur_type == unsigned_char_type_node); + + /* Check the type of the "real" argument, if there's a type we want. */ + if (lang_hooks.types_compatible_p (wanted_type, cur_type)) + continue; + /* If we want 'void *', allow any pointer type. + (Anything else would already have got a warning.) + With -pedantic, only allow pointers to void and to character + types. */ + if (wanted_type == void_type_node + && (!pedantic || (i == 1 && char_type_flag))) + continue; + /* Don't warn about differences merely in signedness, unless + -pedantic. With -pedantic, warn if the type is a pointer + target and not a character type, and for character types at + a second level of indirection. */ + if (TREE_CODE (wanted_type) == INTEGER_TYPE + && TREE_CODE (cur_type) == INTEGER_TYPE + && (!pedantic || i == 0 || (i == 1 && char_type_flag)) + && (TYPE_UNSIGNED (wanted_type) + ? wanted_type == c_common_unsigned_type (cur_type) + : wanted_type == c_common_signed_type (cur_type))) + continue; + /* Likewise, "signed char", "unsigned char" and "char" are + equivalent but the above test won't consider them equivalent. */ + if (wanted_type == char_type_node + && (!pedantic || i < 2) + && char_type_flag) + continue; + if (types->scalar_identity_flag + && (TREE_CODE (cur_type) == TREE_CODE (wanted_type) + || (INTEGRAL_TYPE_P (cur_type) + && INTEGRAL_TYPE_P (wanted_type))) + && TYPE_PRECISION (cur_type) == TYPE_PRECISION (wanted_type)) + continue; + /* Now we have a type mismatch. */ + format_type_warning (types->name, format_start, format_length, + wanted_type, types->pointer_count, + types->wanted_type_name, orig_cur_type, arg_num); + } +} + + +/* Give a warning about a format argument of different type from that + expected. DESCR is a description such as "field precision", or + NULL for an ordinary format. For an ordinary format, FORMAT_START + points to where the format starts in the format string and + FORMAT_LENGTH is its length. WANTED_TYPE is the type the argument + should have after POINTER_COUNT pointer dereferences. + WANTED_NAME_NAME is a possibly more friendly name of WANTED_TYPE, + or NULL if the ordinary name of the type should be used. ARG_TYPE + is the type of the actual argument. ARG_NUM is the number of that + argument. */ +static void +format_type_warning (const char *descr, const char *format_start, + int format_length, tree wanted_type, int pointer_count, + const char *wanted_type_name, tree arg_type, int arg_num) +{ + char *p; + /* If ARG_TYPE is a typedef with a misleading name (for example, + size_t but not the standard size_t expected by printf %zu), avoid + printing the typedef name. */ + if (wanted_type_name + && TYPE_NAME (arg_type) + && TREE_CODE (TYPE_NAME (arg_type)) == TYPE_DECL + && DECL_NAME (TYPE_NAME (arg_type)) + && !strcmp (wanted_type_name, + lang_hooks.decl_printable_name (TYPE_NAME (arg_type), 2))) + arg_type = TYPE_MAIN_VARIANT (arg_type); + /* The format type and name exclude any '*' for pointers, so those + must be formatted manually. For all the types we currently have, + this is adequate, but formats taking pointers to functions or + arrays would require the full type to be built up in order to + print it with %T. */ + p = (char *) alloca (pointer_count + 2); + if (pointer_count == 0) + p[0] = 0; + else if (c_dialect_cxx ()) + { + memset (p, '*', pointer_count); + p[pointer_count] = 0; + } + else + { + p[0] = ' '; + memset (p + 1, '*', pointer_count); + p[pointer_count + 1] = 0; + } + if (wanted_type_name) + { + if (descr) + warning (OPT_Wformat, "%s should have type %<%s%s%>, " + "but argument %d has type %qT", + descr, wanted_type_name, p, arg_num, arg_type); + else + warning (OPT_Wformat, "format %q.*s expects type %<%s%s%>, " + "but argument %d has type %qT", + format_length, format_start, wanted_type_name, p, + arg_num, arg_type); + } + else + { + if (descr) + warning (OPT_Wformat, "%s should have type %<%T%s%>, " + "but argument %d has type %qT", + descr, wanted_type, p, arg_num, arg_type); + else + warning (OPT_Wformat, "format %q.*s expects type %<%T%s%>, " + "but argument %d has type %qT", + format_length, format_start, wanted_type, p, arg_num, arg_type); + } +} + + +/* Given a format_char_info array FCI, and a character C, this function + returns the index into the conversion_specs where that specifier's + data is located. The character must exist. */ +static unsigned int +find_char_info_specifier_index (const format_char_info *fci, int c) +{ + unsigned i; + + for (i = 0; fci->format_chars; i++, fci++) + if (strchr (fci->format_chars, c)) + return i; + + /* We shouldn't be looking for a non-existent specifier. */ + gcc_unreachable (); +} + +/* Given a format_length_info array FLI, and a character C, this + function returns the index into the conversion_specs where that + modifier's data is located. The character must exist. */ +static unsigned int +find_length_info_modifier_index (const format_length_info *fli, int c) +{ + unsigned i; + + for (i = 0; fli->name; i++, fli++) + if (strchr (fli->name, c)) + return i; + + /* We shouldn't be looking for a non-existent modifier. */ + gcc_unreachable (); +} + +/* Determine the type of HOST_WIDE_INT in the code being compiled for + use in GCC's __asm_fprintf__ custom format attribute. You must + have set dynamic_format_types before calling this function. */ +static void +init_dynamic_asm_fprintf_info (void) +{ + static tree hwi; + + if (!hwi) + { + format_length_info *new_asm_fprintf_length_specs; + unsigned int i; + + /* Find the underlying type for HOST_WIDE_INT. For the %w + length modifier to work, one must have issued: "typedef + HOST_WIDE_INT __gcc_host_wide_int__;" in one's source code + prior to using that modifier. */ + hwi = maybe_get_identifier ("__gcc_host_wide_int__"); + if (!hwi) + { + error ("%<__gcc_host_wide_int__%> is not defined as a type"); + return; + } + hwi = identifier_global_value (hwi); + if (!hwi || TREE_CODE (hwi) != TYPE_DECL) + { + error ("%<__gcc_host_wide_int__%> is not defined as a type"); + return; + } + hwi = DECL_ORIGINAL_TYPE (hwi); + gcc_assert (hwi); + if (hwi != long_integer_type_node && hwi != long_long_integer_type_node) + { + error ("%<__gcc_host_wide_int__%> is not defined as %" + " or %"); + return; + } + + /* Create a new (writable) copy of asm_fprintf_length_specs. */ + new_asm_fprintf_length_specs = (format_length_info *) + xmemdup (asm_fprintf_length_specs, + sizeof (asm_fprintf_length_specs), + sizeof (asm_fprintf_length_specs)); + + /* HOST_WIDE_INT must be one of 'long' or 'long long'. */ + i = find_length_info_modifier_index (new_asm_fprintf_length_specs, 'w'); + if (hwi == long_integer_type_node) + new_asm_fprintf_length_specs[i].index = FMT_LEN_l; + else if (hwi == long_long_integer_type_node) + new_asm_fprintf_length_specs[i].index = FMT_LEN_ll; + else + gcc_unreachable (); + + /* Assign the new data for use. */ + dynamic_format_types[asm_fprintf_format_type].length_char_specs = + new_asm_fprintf_length_specs; + } +} + +/* Determine the type of a "locus" in the code being compiled for use + in GCC's __gcc_gfc__ custom format attribute. You must have set + dynamic_format_types before calling this function. */ +static void +init_dynamic_gfc_info (void) +{ + static tree locus; + + if (!locus) + { + static format_char_info *gfc_fci; + + /* For the GCC __gcc_gfc__ custom format specifier to work, one + must have declared 'locus' prior to using this attribute. If + we haven't seen this declarations then you shouldn't use the + specifier requiring that type. */ + if ((locus = maybe_get_identifier ("locus"))) + { + locus = identifier_global_value (locus); + if (locus) + { + if (TREE_CODE (locus) != TYPE_DECL + || TREE_TYPE (locus) == error_mark_node) + { + error ("% is not defined as a type"); + locus = 0; + } + else + locus = TREE_TYPE (locus); + } + } + + /* Assign the new data for use. */ + + /* Handle the __gcc_gfc__ format specifics. */ + if (!gfc_fci) + dynamic_format_types[gcc_gfc_format_type].conversion_specs = + gfc_fci = (format_char_info *) + xmemdup (gcc_gfc_char_table, + sizeof (gcc_gfc_char_table), + sizeof (gcc_gfc_char_table)); + if (locus) + { + const unsigned i = find_char_info_specifier_index (gfc_fci, 'L'); + gfc_fci[i].types[0].type = &locus; + gfc_fci[i].pointer_count = 1; + } + } +} + +/* Determine the types of "tree" and "location_t" in the code being + compiled for use in GCC's diagnostic custom format attributes. You + must have set dynamic_format_types before calling this function. */ +static void +init_dynamic_diag_info (void) +{ + static tree t, loc, hwi; + + if (!loc || !t || !hwi) + { + static format_char_info *diag_fci, *tdiag_fci, *cdiag_fci, *cxxdiag_fci; + static format_length_info *diag_ls; + unsigned int i; + + /* For the GCC-diagnostics custom format specifiers to work, one + must have declared 'tree' and/or 'location_t' prior to using + those attributes. If we haven't seen these declarations then + you shouldn't use the specifiers requiring these types. + However we don't force a hard ICE because we may see only one + or the other type. */ + if ((loc = maybe_get_identifier ("location_t"))) + { + loc = identifier_global_value (loc); + if (loc) + { + if (TREE_CODE (loc) != TYPE_DECL) + { + error ("% is not defined as a type"); + loc = 0; + } + else + loc = TREE_TYPE (loc); + } + } + + /* We need to grab the underlying 'union tree_node' so peek into + an extra type level. */ + if ((t = maybe_get_identifier ("tree"))) + { + t = identifier_global_value (t); + if (t) + { + if (TREE_CODE (t) != TYPE_DECL) + { + error ("% is not defined as a type"); + t = 0; + } + else if (TREE_CODE (TREE_TYPE (t)) != POINTER_TYPE) + { + error ("% is not defined as a pointer type"); + t = 0; + } + else + t = TREE_TYPE (TREE_TYPE (t)); + } + } + + /* Find the underlying type for HOST_WIDE_INT. For the %w + length modifier to work, one must have issued: "typedef + HOST_WIDE_INT __gcc_host_wide_int__;" in one's source code + prior to using that modifier. */ + if ((hwi = maybe_get_identifier ("__gcc_host_wide_int__"))) + { + hwi = identifier_global_value (hwi); + if (hwi) + { + if (TREE_CODE (hwi) != TYPE_DECL) + { + error ("%<__gcc_host_wide_int__%> is not defined as a type"); + hwi = 0; + } + else + { + hwi = DECL_ORIGINAL_TYPE (hwi); + gcc_assert (hwi); + if (hwi != long_integer_type_node + && hwi != long_long_integer_type_node) + { + error ("%<__gcc_host_wide_int__%> is not defined" + " as % or %"); + hwi = 0; + } + } + } + } + + /* Assign the new data for use. */ + + /* All the GCC diag formats use the same length specs. */ + if (!diag_ls) + dynamic_format_types[gcc_diag_format_type].length_char_specs = + dynamic_format_types[gcc_tdiag_format_type].length_char_specs = + dynamic_format_types[gcc_cdiag_format_type].length_char_specs = + dynamic_format_types[gcc_cxxdiag_format_type].length_char_specs = + diag_ls = (format_length_info *) + xmemdup (gcc_diag_length_specs, + sizeof (gcc_diag_length_specs), + sizeof (gcc_diag_length_specs)); + if (hwi) + { + /* HOST_WIDE_INT must be one of 'long' or 'long long'. */ + i = find_length_info_modifier_index (diag_ls, 'w'); + if (hwi == long_integer_type_node) + diag_ls[i].index = FMT_LEN_l; + else if (hwi == long_long_integer_type_node) + diag_ls[i].index = FMT_LEN_ll; + else + gcc_unreachable (); + } + + /* Handle the __gcc_diag__ format specifics. */ + if (!diag_fci) + dynamic_format_types[gcc_diag_format_type].conversion_specs = + diag_fci = (format_char_info *) + xmemdup (gcc_diag_char_table, + sizeof (gcc_diag_char_table), + sizeof (gcc_diag_char_table)); + if (t) + { + i = find_char_info_specifier_index (diag_fci, 'K'); + diag_fci[i].types[0].type = &t; + diag_fci[i].pointer_count = 1; + } + + /* Handle the __gcc_tdiag__ format specifics. */ + if (!tdiag_fci) + dynamic_format_types[gcc_tdiag_format_type].conversion_specs = + tdiag_fci = (format_char_info *) + xmemdup (gcc_tdiag_char_table, + sizeof (gcc_tdiag_char_table), + sizeof (gcc_tdiag_char_table)); + if (t) + { + /* All specifiers taking a tree share the same struct. */ + i = find_char_info_specifier_index (tdiag_fci, 'D'); + tdiag_fci[i].types[0].type = &t; + tdiag_fci[i].pointer_count = 1; + i = find_char_info_specifier_index (tdiag_fci, 'K'); + tdiag_fci[i].types[0].type = &t; + tdiag_fci[i].pointer_count = 1; + } + + /* Handle the __gcc_cdiag__ format specifics. */ + if (!cdiag_fci) + dynamic_format_types[gcc_cdiag_format_type].conversion_specs = + cdiag_fci = (format_char_info *) + xmemdup (gcc_cdiag_char_table, + sizeof (gcc_cdiag_char_table), + sizeof (gcc_cdiag_char_table)); + if (t) + { + /* All specifiers taking a tree share the same struct. */ + i = find_char_info_specifier_index (cdiag_fci, 'D'); + cdiag_fci[i].types[0].type = &t; + cdiag_fci[i].pointer_count = 1; + i = find_char_info_specifier_index (cdiag_fci, 'K'); + cdiag_fci[i].types[0].type = &t; + cdiag_fci[i].pointer_count = 1; + } + + /* Handle the __gcc_cxxdiag__ format specifics. */ + if (!cxxdiag_fci) + dynamic_format_types[gcc_cxxdiag_format_type].conversion_specs = + cxxdiag_fci = (format_char_info *) + xmemdup (gcc_cxxdiag_char_table, + sizeof (gcc_cxxdiag_char_table), + sizeof (gcc_cxxdiag_char_table)); + if (t) + { + /* All specifiers taking a tree share the same struct. */ + i = find_char_info_specifier_index (cxxdiag_fci, 'D'); + cxxdiag_fci[i].types[0].type = &t; + cxxdiag_fci[i].pointer_count = 1; + i = find_char_info_specifier_index (cxxdiag_fci, 'K'); + cxxdiag_fci[i].types[0].type = &t; + cxxdiag_fci[i].pointer_count = 1; + } + } +} + +#ifdef TARGET_FORMAT_TYPES +extern const format_kind_info TARGET_FORMAT_TYPES[]; +#endif + +#ifdef TARGET_OVERRIDES_FORMAT_ATTRIBUTES +extern const target_ovr_attr TARGET_OVERRIDES_FORMAT_ATTRIBUTES[]; +#endif +#ifdef TARGET_OVERRIDES_FORMAT_INIT + extern void TARGET_OVERRIDES_FORMAT_INIT (void); +#endif + +/* Attributes such as "printf" are equivalent to those such as + "gnu_printf" unless this is overridden by a target. */ +static const target_ovr_attr gnu_target_overrides_format_attributes[] = +{ + { "gnu_printf", "printf" }, + { "gnu_scanf", "scanf" }, + { "gnu_strftime", "strftime" }, + { "gnu_strfmon", "strfmon" }, + { NULL, NULL } +}; + +/* Translate to unified attribute name. This is used in decode_format_type and + decode_format_attr. In attr_name the user specified argument is passed. It + returns the unified format name from TARGET_OVERRIDES_FORMAT_ATTRIBUTES + or the attr_name passed to this function, if there is no matching entry. */ +static const char * +convert_format_name_to_system_name (const char *attr_name) +{ + int i; + + if (attr_name == NULL || *attr_name == 0 + || strncmp (attr_name, "gcc_", 4) == 0) + return attr_name; +#ifdef TARGET_OVERRIDES_FORMAT_INIT + TARGET_OVERRIDES_FORMAT_INIT (); +#endif + +#ifdef TARGET_OVERRIDES_FORMAT_ATTRIBUTES + /* Check if format attribute is overridden by target. */ + if (TARGET_OVERRIDES_FORMAT_ATTRIBUTES != NULL + && TARGET_OVERRIDES_FORMAT_ATTRIBUTES_COUNT > 0) + { + for (i = 0; i < TARGET_OVERRIDES_FORMAT_ATTRIBUTES_COUNT; ++i) + { + if (cmp_attribs (TARGET_OVERRIDES_FORMAT_ATTRIBUTES[i].named_attr_src, + attr_name)) + return attr_name; + if (cmp_attribs (TARGET_OVERRIDES_FORMAT_ATTRIBUTES[i].named_attr_dst, + attr_name)) + return TARGET_OVERRIDES_FORMAT_ATTRIBUTES[i].named_attr_src; + } + } +#endif + /* Otherwise default to gnu format. */ + for (i = 0; + gnu_target_overrides_format_attributes[i].named_attr_src != NULL; + ++i) + { + if (cmp_attribs (gnu_target_overrides_format_attributes[i].named_attr_src, + attr_name)) + return attr_name; + if (cmp_attribs (gnu_target_overrides_format_attributes[i].named_attr_dst, + attr_name)) + return gnu_target_overrides_format_attributes[i].named_attr_src; + } + + return attr_name; +} + +/* Return true if TATTR_NAME and ATTR_NAME are the same format attribute, + counting "name" and "__name__" as the same, false otherwise. */ +static bool +cmp_attribs (const char *tattr_name, const char *attr_name) +{ + int alen = strlen (attr_name); + int slen = (tattr_name ? strlen (tattr_name) : 0); + if (alen > 4 && attr_name[0] == '_' && attr_name[1] == '_' + && attr_name[alen - 1] == '_' && attr_name[alen - 2] == '_') + { + attr_name += 2; + alen -= 4; + } + if (alen != slen || strncmp (tattr_name, attr_name, alen) != 0) + return false; + return true; +} + +/* Handle a "format" attribute; arguments as in + struct attribute_spec.handler. */ +tree +handle_format_attribute (tree *node, tree ARG_UNUSED (name), tree args, + int flags, bool *no_add_attrs) +{ + tree type = *node; + function_format_info info; + tree argument; + +#ifdef TARGET_FORMAT_TYPES + /* If the target provides additional format types, we need to + add them to FORMAT_TYPES at first use. */ + if (TARGET_FORMAT_TYPES != NULL && !dynamic_format_types) + { + dynamic_format_types = XNEWVEC (format_kind_info, + n_format_types + TARGET_N_FORMAT_TYPES); + memcpy (dynamic_format_types, format_types_orig, + sizeof (format_types_orig)); + memcpy (&dynamic_format_types[n_format_types], TARGET_FORMAT_TYPES, + TARGET_N_FORMAT_TYPES * sizeof (dynamic_format_types[0])); + + format_types = dynamic_format_types; + n_format_types += TARGET_N_FORMAT_TYPES; + } +#endif + + if (!decode_format_attr (args, &info, 0)) + { + *no_add_attrs = true; + return NULL_TREE; + } + + argument = TYPE_ARG_TYPES (type); + if (argument) + { + if (!check_format_string (argument, info.format_num, flags, + no_add_attrs)) + return NULL_TREE; + + if (info.first_arg_num != 0) + { + unsigned HOST_WIDE_INT arg_num = 1; + + /* Verify that first_arg_num points to the last arg, + the ... */ + while (argument) + arg_num++, argument = TREE_CHAIN (argument); + + if (arg_num != info.first_arg_num) + { + if (!(flags & (int) ATTR_FLAG_BUILT_IN)) + error ("args to be formatted is not %<...%>"); + *no_add_attrs = true; + return NULL_TREE; + } + } + } + + /* Check if this is a strftime variant. Just for this variant + FMT_FLAG_ARG_CONVERT is not set. */ + if ((format_types[info.format_type].flags & (int) FMT_FLAG_ARG_CONVERT) == 0 + && info.first_arg_num != 0) + { + error ("strftime formats cannot format arguments"); + *no_add_attrs = true; + return NULL_TREE; + } + + /* If this is a custom GCC-internal format type, we have to + initialize certain bits at runtime. */ + if (info.format_type == asm_fprintf_format_type + || info.format_type == gcc_gfc_format_type + || info.format_type == gcc_diag_format_type + || info.format_type == gcc_tdiag_format_type + || info.format_type == gcc_cdiag_format_type + || info.format_type == gcc_cxxdiag_format_type) + { + /* Our first time through, we have to make sure that our + format_type data is allocated dynamically and is modifiable. */ + if (!dynamic_format_types) + format_types = dynamic_format_types = (format_kind_info *) + xmemdup (format_types_orig, sizeof (format_types_orig), + sizeof (format_types_orig)); + + /* If this is format __asm_fprintf__, we have to initialize + GCC's notion of HOST_WIDE_INT for checking %wd. */ + if (info.format_type == asm_fprintf_format_type) + init_dynamic_asm_fprintf_info (); + /* If this is format __gcc_gfc__, we have to initialize GCC's + notion of 'locus' at runtime for %L. */ + else if (info.format_type == gcc_gfc_format_type) + init_dynamic_gfc_info (); + /* If this is one of the diagnostic attributes, then we have to + initialize 'location_t' and 'tree' at runtime. */ + else if (info.format_type == gcc_diag_format_type + || info.format_type == gcc_tdiag_format_type + || info.format_type == gcc_cdiag_format_type + || info.format_type == gcc_cxxdiag_format_type) + init_dynamic_diag_info (); + else + gcc_unreachable (); + } + + return NULL_TREE; +} diff --git a/gcc/c-family/c-format.h b/gcc/c-family/c-format.h new file mode 100644 index 00000000000..9d01f0af495 --- /dev/null +++ b/gcc/c-family/c-format.h @@ -0,0 +1,326 @@ +/* Check calls to formatted I/O functions (-Wformat). + Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, + 2001, 2002, 2003, 2004, 2007, 2008 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 3, 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 COPYING3. If not see +. */ + +#ifndef GCC_C_FORMAT_H +#define GCC_C_FORMAT_H + +/* The meaningfully distinct length modifiers for format checking recognized + by GCC. */ +enum format_lengths +{ + FMT_LEN_none, + FMT_LEN_hh, + FMT_LEN_h, + FMT_LEN_l, + FMT_LEN_ll, + FMT_LEN_L, + FMT_LEN_z, + FMT_LEN_t, + FMT_LEN_j, + FMT_LEN_H, + FMT_LEN_D, + FMT_LEN_DD, + FMT_LEN_MAX +}; + + +/* The standard versions in which various format features appeared. */ +enum format_std_version +{ + STD_C89, + STD_C94, + STD_C9L, /* C99, but treat as C89 if -Wno-long-long. */ + STD_C99, + STD_EXT +}; + +/* Flags that may apply to a particular kind of format checked by GCC. */ +enum +{ + /* This format converts arguments of types determined by the + format string. */ + FMT_FLAG_ARG_CONVERT = 1, + /* The scanf allocation 'a' kludge applies to this format kind. */ + FMT_FLAG_SCANF_A_KLUDGE = 2, + /* A % during parsing a specifier is allowed to be a modified % rather + that indicating the format is broken and we are out-of-sync. */ + FMT_FLAG_FANCY_PERCENT_OK = 4, + /* With $ operand numbers, it is OK to reference the same argument more + than once. */ + FMT_FLAG_DOLLAR_MULTIPLE = 8, + /* This format type uses $ operand numbers (strfmon doesn't). */ + FMT_FLAG_USE_DOLLAR = 16, + /* Zero width is bad in this type of format (scanf). */ + FMT_FLAG_ZERO_WIDTH_BAD = 32, + /* Empty precision specification is OK in this type of format (printf). */ + FMT_FLAG_EMPTY_PREC_OK = 64, + /* Gaps are allowed in the arguments with $ operand numbers if all + arguments are pointers (scanf). */ + FMT_FLAG_DOLLAR_GAP_POINTER_OK = 128 + /* Not included here: details of whether width or precision may occur + (controlled by width_char and precision_char); details of whether + '*' can be used for these (width_type and precision_type); details + of whether length modifiers can occur (length_char_specs). */ +}; + +/* Structure describing a length modifier supported in format checking, and + possibly a doubled version such as "hh". */ +typedef struct +{ + /* Name of the single-character length modifier. If prefixed by + a zero character, it describes a multi character length + modifier, like I64, I32, etc. */ + const char *name; + /* Index into a format_char_info.types array. */ + enum format_lengths index; + /* Standard version this length appears in. */ + enum format_std_version std; + /* Same, if the modifier can be repeated, or NULL if it can't. */ + const char *double_name; + enum format_lengths double_index; + enum format_std_version double_std; + + /* If this flag is set, just scalar width identity is checked, and + not the type identity itself. */ + int scalar_identity_flag; +} format_length_info; + + +/* Structure describing the combination of a conversion specifier + (or a set of specifiers which act identically) and a length modifier. */ +typedef struct +{ + /* The standard version this combination of length and type appeared in. + This is only relevant if greater than those for length and type + individually; otherwise it is ignored. */ + enum format_std_version std; + /* The name to use for the type, if different from that generated internally + (e.g., "signed size_t"). */ + const char *name; + /* The type itself. */ + tree *type; +} format_type_detail; + + +/* Macros to fill out tables of these. */ +#define NOARGUMENTS { T89_V, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN } +#define BADLEN { STD_C89, NULL, NULL } +#define NOLENGTHS { BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN } + + +/* Structure describing a format conversion specifier (or a set of specifiers + which act identically), and the length modifiers used with it. */ +typedef struct format_char_info +{ + const char *format_chars; + int pointer_count; + enum format_std_version std; + /* Types accepted for each length modifier. */ + format_type_detail types[FMT_LEN_MAX]; + /* List of other modifier characters allowed with these specifiers. + This lists flags, and additionally "w" for width, "p" for precision + (right precision, for strfmon), "#" for left precision (strfmon), + "a" for scanf "a" allocation extension (not applicable in C99 mode), + "*" for scanf suppression, and "E" and "O" for those strftime + modifiers. */ + const char *flag_chars; + /* List of additional flags describing these conversion specifiers. + "c" for generic character pointers being allowed, "2" for strftime + two digit year formats, "3" for strftime formats giving two digit + years in some locales, "4" for "2" which becomes "3" with an "E" modifier, + "o" if use of strftime "O" is a GNU extension beyond C99, + "W" if the argument is a pointer which is dereferenced and written into, + "R" if the argument is a pointer which is dereferenced and read from, + "i" for printf integer formats where the '0' flag is ignored with + precision, and "[" for the starting character of a scanf scanset. */ + const char *flags2; + /* If this format conversion character consumes more than one argument, + CHAIN points to information about the next argument. For later + arguments, only POINTER_COUNT, TYPES, and the "c", "R", and "W" flags + in FLAGS2 are used. */ + const struct format_char_info *chain; +} format_char_info; + + +/* Structure describing a flag accepted by some kind of format. */ +typedef struct +{ + /* The flag character in question (0 for end of array). */ + int flag_char; + /* Zero if this entry describes the flag character in general, or a + nonzero character that may be found in flags2 if it describes the + flag when used with certain formats only. If the latter, only + the first such entry found that applies to the current conversion + specifier is used; the values of 'name' and 'long_name' it supplies + will be used, if non-NULL and the standard version is higher than + the unpredicated one, for any pedantic warning. For example, 'o' + for strftime formats (meaning 'O' is an extension over C99). */ + int predicate; + /* Nonzero if the next character after this flag in the format should + be skipped ('=' in strfmon), zero otherwise. */ + int skip_next_char; + /* The name to use for this flag in diagnostic messages. For example, + N_("'0' flag"), N_("field width"). */ + const char *name; + /* Long name for this flag in diagnostic messages; currently only used for + "ISO C does not support ...". For example, N_("the 'I' printf flag"). */ + const char *long_name; + /* The standard version in which it appeared. */ + enum format_std_version std; +} format_flag_spec; + + +/* Structure describing a combination of flags that is bad for some kind + of format. */ +typedef struct +{ + /* The first flag character in question (0 for end of array). */ + int flag_char1; + /* The second flag character. */ + int flag_char2; + /* Nonzero if the message should say that the first flag is ignored with + the second, zero if the combination should simply be objected to. */ + int ignored; + /* Zero if this entry applies whenever this flag combination occurs, + a nonzero character from flags2 if it only applies in some + circumstances (e.g. 'i' for printf formats ignoring 0 with precision). */ + int predicate; +} format_flag_pair; + + +/* Structure describing a particular kind of format processed by GCC. */ +typedef struct +{ + /* The name of this kind of format, for use in diagnostics. Also + the name of the attribute (without preceding and following __). */ + const char *name; + /* Specifications of the length modifiers accepted; possibly NULL. */ + const format_length_info *length_char_specs; + /* Details of the conversion specification characters accepted. */ + const format_char_info *conversion_specs; + /* String listing the flag characters that are accepted. */ + const char *flag_chars; + /* String listing modifier characters (strftime) accepted. May be NULL. */ + const char *modifier_chars; + /* Details of the flag characters, including pseudo-flags. */ + const format_flag_spec *flag_specs; + /* Details of bad combinations of flags. */ + const format_flag_pair *bad_flag_pairs; + /* Flags applicable to this kind of format. */ + int flags; + /* Flag character to treat a width as, or 0 if width not used. */ + int width_char; + /* Flag character to treat a left precision (strfmon) as, + or 0 if left precision not used. */ + int left_precision_char; + /* Flag character to treat a precision (for strfmon, right precision) as, + or 0 if precision not used. */ + int precision_char; + /* If a flag character has the effect of suppressing the conversion of + an argument ('*' in scanf), that flag character, otherwise 0. */ + int suppression_char; + /* Flag character to treat a length modifier as (ignored if length + modifiers not used). Need not be placed in flag_chars for conversion + specifiers, but is used to check for bad combinations such as length + modifier with assignment suppression in scanf. */ + int length_code_char; + /* Assignment-allocation flag character ('m' in scanf), otherwise 0. */ + int alloc_char; + /* Pointer to type of argument expected if '*' is used for a width, + or NULL if '*' not used for widths. */ + tree *width_type; + /* Pointer to type of argument expected if '*' is used for a precision, + or NULL if '*' not used for precisions. */ + tree *precision_type; +} format_kind_info; + +#define T_I &integer_type_node +#define T89_I { STD_C89, NULL, T_I } +#define T_L &long_integer_type_node +#define T89_L { STD_C89, NULL, T_L } +#define T_LL &long_long_integer_type_node +#define T9L_LL { STD_C9L, NULL, T_LL } +#define TEX_LL { STD_EXT, NULL, T_LL } +#define T_S &short_integer_type_node +#define T89_S { STD_C89, NULL, T_S } +#define T_UI &unsigned_type_node +#define T89_UI { STD_C89, NULL, T_UI } +#define T_UL &long_unsigned_type_node +#define T89_UL { STD_C89, NULL, T_UL } +#define T_ULL &long_long_unsigned_type_node +#define T9L_ULL { STD_C9L, NULL, T_ULL } +#define TEX_ULL { STD_EXT, NULL, T_ULL } +#define T_US &short_unsigned_type_node +#define T89_US { STD_C89, NULL, T_US } +#define T_F &float_type_node +#define T89_F { STD_C89, NULL, T_F } +#define T99_F { STD_C99, NULL, T_F } +#define T_D &double_type_node +#define T89_D { STD_C89, NULL, T_D } +#define T99_D { STD_C99, NULL, T_D } +#define T_LD &long_double_type_node +#define T89_LD { STD_C89, NULL, T_LD } +#define T99_LD { STD_C99, NULL, T_LD } +#define T_C &char_type_node +#define T89_C { STD_C89, NULL, T_C } +#define T_SC &signed_char_type_node +#define T99_SC { STD_C99, NULL, T_SC } +#define T_UC &unsigned_char_type_node +#define T99_UC { STD_C99, NULL, T_UC } +#define T_V &void_type_node +#define T89_V { STD_C89, NULL, T_V } +#define T_W &wchar_type_node +#define T94_W { STD_C94, "wchar_t", T_W } +#define TEX_W { STD_EXT, "wchar_t", T_W } +#define T_WI &wint_type_node +#define T94_WI { STD_C94, "wint_t", T_WI } +#define TEX_WI { STD_EXT, "wint_t", T_WI } +#define T_ST &size_type_node +#define T99_ST { STD_C99, "size_t", T_ST } +#define T_SST &signed_size_type_node +#define T99_SST { STD_C99, "signed size_t", T_SST } +#define T_PD &ptrdiff_type_node +#define T99_PD { STD_C99, "ptrdiff_t", T_PD } +#define T_UPD &unsigned_ptrdiff_type_node +#define T99_UPD { STD_C99, "unsigned ptrdiff_t", T_UPD } +#define T_IM &intmax_type_node +#define T99_IM { STD_C99, "intmax_t", T_IM } +#define T_UIM &uintmax_type_node +#define T99_UIM { STD_C99, "uintmax_t", T_UIM } +#define T_D32 &dfloat32_type_node +#define TEX_D32 { STD_EXT, "_Decimal32", T_D32 } +#define T_D64 &dfloat64_type_node +#define TEX_D64 { STD_EXT, "_Decimal64", T_D64 } +#define T_D128 &dfloat128_type_node +#define TEX_D128 { STD_EXT, "_Decimal128", T_D128 } + +/* Structure describing how format attributes such as "printf" are + interpreted as "gnu_printf" or "ms_printf" on a particular system. + TARGET_OVERRIDES_FORMAT_ATTRIBUTES is used to specify target-specific + defaults. */ +typedef struct +{ + /* The name of the to be copied format attribute. */ + const char *named_attr_src; + /* The name of the to be overridden format attribute. */ + const char *named_attr_dst; +} target_ovr_attr; + +#endif /* GCC_C_FORMAT_H */ diff --git a/gcc/c-family/c-gimplify.c b/gcc/c-family/c-gimplify.c new file mode 100644 index 00000000000..f446ebbb214 --- /dev/null +++ b/gcc/c-family/c-gimplify.c @@ -0,0 +1,189 @@ +/* Tree lowering pass. This pass gimplifies the tree representation built + by the C-based front ends. The structure of gimplified, or + language-independent, trees is dictated by the grammar described in this + file. + Copyright (C) 2002, 2003, 2004, 2005, 2007, 2008, 2009, 2010 + Free Software Foundation, Inc. + Lowering of expressions contributed by Sebastian Pop + Re-written to support lowering of whole function trees, documentation + and miscellaneous cleanups by Diego Novillo + +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 3, 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 COPYING3. If not see +. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tm.h" +#include "tree.h" +#include "c-common.h" +#include "gimple.h" +#include "basic-block.h" +#include "tree-inline.h" +#include "diagnostic-core.h" +#include "langhooks.h" +#include "langhooks-def.h" +#include "flags.h" +#include "toplev.h" +#include "tree-dump.h" +#include "c-pretty-print.h" +#include "cgraph.h" + + +/* The gimplification pass converts the language-dependent trees + (ld-trees) emitted by the parser into language-independent trees + (li-trees) that are the target of SSA analysis and transformations. + + Language-independent trees are based on the SIMPLE intermediate + representation used in the McCAT compiler framework: + + "Designing the McCAT Compiler Based on a Family of Structured + Intermediate Representations," + L. Hendren, C. Donawa, M. Emami, G. Gao, Justiani, and B. Sridharan, + Proceedings of the 5th International Workshop on Languages and + Compilers for Parallel Computing, no. 757 in Lecture Notes in + Computer Science, New Haven, Connecticut, pp. 406-420, + Springer-Verlag, August 3-5, 1992. + + http://www-acaps.cs.mcgill.ca/info/McCAT/McCAT.html + + Basically, we walk down gimplifying the nodes that we encounter. As we + walk back up, we check that they fit our constraints, and copy them + into temporaries if not. */ + +/* Gimplification of statement trees. */ + +/* Convert the tree representation of FNDECL from C frontend trees to + GENERIC. */ + +void +c_genericize (tree fndecl) +{ + FILE *dump_orig; + int local_dump_flags; + struct cgraph_node *cgn; + + /* Dump the C-specific tree IR. */ + dump_orig = dump_begin (TDI_original, &local_dump_flags); + if (dump_orig) + { + fprintf (dump_orig, "\n;; Function %s", + lang_hooks.decl_printable_name (fndecl, 2)); + fprintf (dump_orig, " (%s)\n", + (!DECL_ASSEMBLER_NAME_SET_P (fndecl) ? "null" + : IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (fndecl)))); + fprintf (dump_orig, ";; enabled by -%s\n", dump_flag_name (TDI_original)); + fprintf (dump_orig, "\n"); + + if (local_dump_flags & TDF_RAW) + dump_node (DECL_SAVED_TREE (fndecl), + TDF_SLIM | local_dump_flags, dump_orig); + else + print_c_tree (dump_orig, DECL_SAVED_TREE (fndecl)); + fprintf (dump_orig, "\n"); + + dump_end (TDI_original, dump_orig); + } + + /* Dump all nested functions now. */ + cgn = cgraph_node (fndecl); + for (cgn = cgn->nested; cgn ; cgn = cgn->next_nested) + c_genericize (cgn->decl); +} + +static void +add_block_to_enclosing (tree block) +{ + unsigned i; + tree enclosing; + gimple bind; + VEC(gimple, heap) *stack = gimple_bind_expr_stack (); + + for (i = 0; VEC_iterate (gimple, stack, i, bind); i++) + if (gimple_bind_block (bind)) + break; + + enclosing = gimple_bind_block (bind); + BLOCK_SUBBLOCKS (enclosing) = chainon (BLOCK_SUBBLOCKS (enclosing), block); +} + +/* Genericize a scope by creating a new BIND_EXPR. + BLOCK is either a BLOCK representing the scope or a chain of _DECLs. + In the latter case, we need to create a new BLOCK and add it to the + BLOCK_SUBBLOCKS of the enclosing block. + BODY is a chain of C _STMT nodes for the contents of the scope, to be + genericized. */ + +tree +c_build_bind_expr (location_t loc, tree block, tree body) +{ + tree decls, bind; + + if (block == NULL_TREE) + decls = NULL_TREE; + else if (TREE_CODE (block) == BLOCK) + decls = BLOCK_VARS (block); + else + { + decls = block; + if (DECL_ARTIFICIAL (decls)) + block = NULL_TREE; + else + { + block = make_node (BLOCK); + BLOCK_VARS (block) = decls; + add_block_to_enclosing (block); + } + } + + if (!body) + body = build_empty_stmt (loc); + if (decls || block) + { + bind = build3 (BIND_EXPR, void_type_node, decls, body, block); + TREE_SIDE_EFFECTS (bind) = 1; + SET_EXPR_LOCATION (bind, loc); + } + else + bind = body; + + return bind; +} + +/* Gimplification of expression trees. */ + +/* Do C-specific gimplification on *EXPR_P. PRE_P and POST_P are as in + gimplify_expr. */ + +int +c_gimplify_expr (tree *expr_p, gimple_seq *pre_p ATTRIBUTE_UNUSED, + gimple_seq *post_p ATTRIBUTE_UNUSED) +{ + enum tree_code code = TREE_CODE (*expr_p); + + /* This is handled mostly by gimplify.c, but we have to deal with + not warning about int x = x; as it is a GCC extension to turn off + this warning but only if warn_init_self is zero. */ + if (code == DECL_EXPR + && TREE_CODE (DECL_EXPR_DECL (*expr_p)) == VAR_DECL + && !DECL_EXTERNAL (DECL_EXPR_DECL (*expr_p)) + && !TREE_STATIC (DECL_EXPR_DECL (*expr_p)) + && (DECL_INITIAL (DECL_EXPR_DECL (*expr_p)) == DECL_EXPR_DECL (*expr_p)) + && !warn_init_self) + TREE_NO_WARNING (DECL_EXPR_DECL (*expr_p)) = 1; + + return GS_UNHANDLED; +} diff --git a/gcc/c-family/c-lex.c b/gcc/c-family/c-lex.c new file mode 100644 index 00000000000..5af574db226 --- /dev/null +++ b/gcc/c-family/c-lex.c @@ -0,0 +1,1058 @@ +/* Mainly the interface between cpplib and the C front ends. + Copyright (C) 1987, 1988, 1989, 1992, 1994, 1995, 1996, 1997 + 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009, 2010 + 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 3, 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 COPYING3. If not see +. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tm.h" + +#include "tree.h" +#include "input.h" +#include "output.h" +#include "c-common.h" +#include "flags.h" +#include "timevar.h" +#include "cpplib.h" +#include "c-pragma.h" +#include "toplev.h" +#include "intl.h" +#include "splay-tree.h" +#include "debug.h" +#include "target.h" + +/* We may keep statistics about how long which files took to compile. */ +static int header_time, body_time; +static splay_tree file_info_tree; + +int pending_lang_change; /* If we need to switch languages - C++ only */ +int c_header_level; /* depth in C headers - C++ only */ + +static tree interpret_integer (const cpp_token *, unsigned int); +static tree interpret_float (const cpp_token *, unsigned int); +static tree interpret_fixed (const cpp_token *, unsigned int); +static enum integer_type_kind narrowest_unsigned_type + (unsigned HOST_WIDE_INT, unsigned HOST_WIDE_INT, unsigned int); +static enum integer_type_kind narrowest_signed_type + (unsigned HOST_WIDE_INT, unsigned HOST_WIDE_INT, unsigned int); +static enum cpp_ttype lex_string (const cpp_token *, tree *, bool, bool); +static tree lex_charconst (const cpp_token *); +static void update_header_times (const char *); +static int dump_one_header (splay_tree_node, void *); +static void cb_line_change (cpp_reader *, const cpp_token *, int); +static void cb_ident (cpp_reader *, unsigned int, const cpp_string *); +static void cb_def_pragma (cpp_reader *, unsigned int); +static void cb_define (cpp_reader *, unsigned int, cpp_hashnode *); +static void cb_undef (cpp_reader *, unsigned int, cpp_hashnode *); + +void +init_c_lex (void) +{ + struct cpp_callbacks *cb; + struct c_fileinfo *toplevel; + + /* The get_fileinfo data structure must be initialized before + cpp_read_main_file is called. */ + toplevel = get_fileinfo (""); + if (flag_detailed_statistics) + { + header_time = 0; + body_time = get_run_time (); + toplevel->time = body_time; + } + + cb = cpp_get_callbacks (parse_in); + + cb->line_change = cb_line_change; + cb->ident = cb_ident; + cb->def_pragma = cb_def_pragma; + cb->valid_pch = c_common_valid_pch; + cb->read_pch = c_common_read_pch; + + /* Set the debug callbacks if we can use them. */ + if (debug_info_level == DINFO_LEVEL_VERBOSE + && (write_symbols == DWARF2_DEBUG + || write_symbols == VMS_AND_DWARF2_DEBUG)) + { + cb->define = cb_define; + cb->undef = cb_undef; + } +} + +struct c_fileinfo * +get_fileinfo (const char *name) +{ + splay_tree_node n; + struct c_fileinfo *fi; + + if (!file_info_tree) + file_info_tree = splay_tree_new ((splay_tree_compare_fn) strcmp, + 0, + (splay_tree_delete_value_fn) free); + + n = splay_tree_lookup (file_info_tree, (splay_tree_key) name); + if (n) + return (struct c_fileinfo *) n->value; + + fi = XNEW (struct c_fileinfo); + fi->time = 0; + fi->interface_only = 0; + fi->interface_unknown = 1; + splay_tree_insert (file_info_tree, (splay_tree_key) name, + (splay_tree_value) fi); + return fi; +} + +static void +update_header_times (const char *name) +{ + /* Changing files again. This means currently collected time + is charged against header time, and body time starts back at 0. */ + if (flag_detailed_statistics) + { + int this_time = get_run_time (); + struct c_fileinfo *file = get_fileinfo (name); + header_time += this_time - body_time; + file->time += this_time - body_time; + body_time = this_time; + } +} + +static int +dump_one_header (splay_tree_node n, void * ARG_UNUSED (dummy)) +{ + print_time ((const char *) n->key, + ((struct c_fileinfo *) n->value)->time); + return 0; +} + +void +dump_time_statistics (void) +{ + struct c_fileinfo *file = get_fileinfo (input_filename); + int this_time = get_run_time (); + file->time += this_time - body_time; + + fprintf (stderr, "\n******\n"); + print_time ("header files (total)", header_time); + print_time ("main file (total)", this_time - body_time); + fprintf (stderr, "ratio = %g : 1\n", + (double) header_time / (double) (this_time - body_time)); + fprintf (stderr, "\n******\n"); + + splay_tree_foreach (file_info_tree, dump_one_header, 0); +} + +static void +cb_ident (cpp_reader * ARG_UNUSED (pfile), + unsigned int ARG_UNUSED (line), + const cpp_string * ARG_UNUSED (str)) +{ +#ifdef ASM_OUTPUT_IDENT + if (!flag_no_ident) + { + /* Convert escapes in the string. */ + cpp_string cstr = { 0, 0 }; + if (cpp_interpret_string (pfile, str, 1, &cstr, CPP_STRING)) + { + ASM_OUTPUT_IDENT (asm_out_file, (const char *) cstr.text); + free (CONST_CAST (unsigned char *, cstr.text)); + } + } +#endif +} + +/* Called at the start of every non-empty line. TOKEN is the first + lexed token on the line. Used for diagnostic line numbers. */ +static void +cb_line_change (cpp_reader * ARG_UNUSED (pfile), const cpp_token *token, + int parsing_args) +{ + if (token->type != CPP_EOF && !parsing_args) + input_location = token->src_loc; +} + +void +fe_file_change (const struct line_map *new_map) +{ + if (new_map == NULL) + return; + + if (new_map->reason == LC_ENTER) + { + /* Don't stack the main buffer on the input stack; + we already did in compile_file. */ + if (!MAIN_FILE_P (new_map)) + { + unsigned int included_at = LAST_SOURCE_LINE_LOCATION (new_map - 1); + int line = 0; + if (included_at > BUILTINS_LOCATION) + line = SOURCE_LINE (new_map - 1, included_at); + + input_location = new_map->start_location; + (*debug_hooks->start_source_file) (line, new_map->to_file); +#ifndef NO_IMPLICIT_EXTERN_C + if (c_header_level) + ++c_header_level; + else if (new_map->sysp == 2) + { + c_header_level = 1; + ++pending_lang_change; + } +#endif + } + } + else if (new_map->reason == LC_LEAVE) + { +#ifndef NO_IMPLICIT_EXTERN_C + if (c_header_level && --c_header_level == 0) + { + if (new_map->sysp == 2) + warning (0, "badly nested C headers from preprocessor"); + --pending_lang_change; + } +#endif + input_location = new_map->start_location; + + (*debug_hooks->end_source_file) (new_map->to_line); + } + + update_header_times (new_map->to_file); + input_location = new_map->start_location; +} + +static void +cb_def_pragma (cpp_reader *pfile, source_location loc) +{ + /* Issue a warning message if we have been asked to do so. Ignore + unknown pragmas in system headers unless an explicit + -Wunknown-pragmas has been given. */ + if (warn_unknown_pragmas > in_system_header) + { + const unsigned char *space, *name; + const cpp_token *s; + location_t fe_loc = loc; + + space = name = (const unsigned char *) ""; + s = cpp_get_token (pfile); + if (s->type != CPP_EOF) + { + space = cpp_token_as_text (pfile, s); + s = cpp_get_token (pfile); + if (s->type == CPP_NAME) + name = cpp_token_as_text (pfile, s); + } + + warning_at (fe_loc, OPT_Wunknown_pragmas, "ignoring #pragma %s %s", + space, name); + } +} + +/* #define callback for DWARF and DWARF2 debug info. */ +static void +cb_define (cpp_reader *pfile, source_location loc, cpp_hashnode *node) +{ + const struct line_map *map = linemap_lookup (line_table, loc); + (*debug_hooks->define) (SOURCE_LINE (map, loc), + (const char *) cpp_macro_definition (pfile, node)); +} + +/* #undef callback for DWARF and DWARF2 debug info. */ +static void +cb_undef (cpp_reader * ARG_UNUSED (pfile), source_location loc, + cpp_hashnode *node) +{ + const struct line_map *map = linemap_lookup (line_table, loc); + (*debug_hooks->undef) (SOURCE_LINE (map, loc), + (const char *) NODE_NAME (node)); +} + +/* Read a token and return its type. Fill *VALUE with its value, if + applicable. Fill *CPP_FLAGS with the token's flags, if it is + non-NULL. */ + +enum cpp_ttype +c_lex_with_flags (tree *value, location_t *loc, unsigned char *cpp_flags, + int lex_flags) +{ + static bool no_more_pch; + const cpp_token *tok; + enum cpp_ttype type; + unsigned char add_flags = 0; + + timevar_push (TV_CPP); + retry: + tok = cpp_get_token_with_location (parse_in, loc); + type = tok->type; + + retry_after_at: + switch (type) + { + case CPP_PADDING: + goto retry; + + case CPP_NAME: + *value = HT_IDENT_TO_GCC_IDENT (HT_NODE (tok->val.node.node)); + break; + + case CPP_NUMBER: + { + unsigned int flags = cpp_classify_number (parse_in, tok); + + switch (flags & CPP_N_CATEGORY) + { + case CPP_N_INVALID: + /* cpplib has issued an error. */ + *value = error_mark_node; + break; + + case CPP_N_INTEGER: + /* C++ uses '0' to mark virtual functions as pure. + Set PURE_ZERO to pass this information to the C++ parser. */ + if (tok->val.str.len == 1 && *tok->val.str.text == '0') + add_flags = PURE_ZERO; + *value = interpret_integer (tok, flags); + break; + + case CPP_N_FLOATING: + *value = interpret_float (tok, flags); + break; + + default: + gcc_unreachable (); + } + } + break; + + case CPP_ATSIGN: + /* An @ may give the next token special significance in Objective-C. */ + if (c_dialect_objc ()) + { + location_t atloc = *loc; + location_t newloc; + + retry_at: + tok = cpp_get_token_with_location (parse_in, &newloc); + type = tok->type; + switch (type) + { + case CPP_PADDING: + goto retry_at; + + case CPP_STRING: + case CPP_WSTRING: + case CPP_STRING16: + case CPP_STRING32: + case CPP_UTF8STRING: + type = lex_string (tok, value, true, true); + break; + + case CPP_NAME: + *value = HT_IDENT_TO_GCC_IDENT (HT_NODE (tok->val.node.node)); + if (objc_is_reserved_word (*value)) + { + type = CPP_AT_NAME; + break; + } + /* FALLTHROUGH */ + + default: + /* ... or not. */ + error_at (atloc, "stray %<@%> in program"); + *loc = newloc; + goto retry_after_at; + } + break; + } + + /* FALLTHROUGH */ + case CPP_HASH: + case CPP_PASTE: + { + unsigned char name[8]; + + *cpp_spell_token (parse_in, tok, name, true) = 0; + + error ("stray %qs in program", name); + } + + goto retry; + + case CPP_OTHER: + { + cppchar_t c = tok->val.str.text[0]; + + if (c == '"' || c == '\'') + error ("missing terminating %c character", (int) c); + else if (ISGRAPH (c)) + error ("stray %qc in program", (int) c); + else + error ("stray %<\\%o%> in program", (int) c); + } + goto retry; + + case CPP_CHAR: + case CPP_WCHAR: + case CPP_CHAR16: + case CPP_CHAR32: + *value = lex_charconst (tok); + break; + + case CPP_STRING: + case CPP_WSTRING: + case CPP_STRING16: + case CPP_STRING32: + case CPP_UTF8STRING: + if ((lex_flags & C_LEX_STRING_NO_JOIN) == 0) + { + type = lex_string (tok, value, false, + (lex_flags & C_LEX_STRING_NO_TRANSLATE) == 0); + break; + } + *value = build_string (tok->val.str.len, (const char *) tok->val.str.text); + break; + + case CPP_PRAGMA: + *value = build_int_cst (NULL, tok->val.pragma); + break; + + /* These tokens should not be visible outside cpplib. */ + case CPP_HEADER_NAME: + case CPP_MACRO_ARG: + gcc_unreachable (); + + /* CPP_COMMENT will appear when compiling with -C and should be + ignored. */ + case CPP_COMMENT: + goto retry; + + default: + *value = NULL_TREE; + break; + } + + if (cpp_flags) + *cpp_flags = tok->flags | add_flags; + + if (!no_more_pch) + { + no_more_pch = true; + c_common_no_more_pch (); + } + + timevar_pop (TV_CPP); + + return type; +} + +/* Returns the narrowest C-visible unsigned type, starting with the + minimum specified by FLAGS, that can fit HIGH:LOW, or itk_none if + there isn't one. */ + +static enum integer_type_kind +narrowest_unsigned_type (unsigned HOST_WIDE_INT low, + unsigned HOST_WIDE_INT high, + unsigned int flags) +{ + int itk; + + if ((flags & CPP_N_WIDTH) == CPP_N_SMALL) + itk = itk_unsigned_int; + else if ((flags & CPP_N_WIDTH) == CPP_N_MEDIUM) + itk = itk_unsigned_long; + else + itk = itk_unsigned_long_long; + + for (; itk < itk_none; itk += 2 /* skip unsigned types */) + { + tree upper; + + if (integer_types[itk] == NULL_TREE) + continue; + upper = TYPE_MAX_VALUE (integer_types[itk]); + + if ((unsigned HOST_WIDE_INT) TREE_INT_CST_HIGH (upper) > high + || ((unsigned HOST_WIDE_INT) TREE_INT_CST_HIGH (upper) == high + && TREE_INT_CST_LOW (upper) >= low)) + return (enum integer_type_kind) itk; + } + + return itk_none; +} + +/* Ditto, but narrowest signed type. */ +static enum integer_type_kind +narrowest_signed_type (unsigned HOST_WIDE_INT low, + unsigned HOST_WIDE_INT high, unsigned int flags) +{ + int itk; + + if ((flags & CPP_N_WIDTH) == CPP_N_SMALL) + itk = itk_int; + else if ((flags & CPP_N_WIDTH) == CPP_N_MEDIUM) + itk = itk_long; + else + itk = itk_long_long; + + + for (; itk < itk_none; itk += 2 /* skip signed types */) + { + tree upper; + + if (integer_types[itk] == NULL_TREE) + continue; + upper = TYPE_MAX_VALUE (integer_types[itk]); + + if ((unsigned HOST_WIDE_INT) TREE_INT_CST_HIGH (upper) > high + || ((unsigned HOST_WIDE_INT) TREE_INT_CST_HIGH (upper) == high + && TREE_INT_CST_LOW (upper) >= low)) + return (enum integer_type_kind) itk; + } + + return itk_none; +} + +/* Interpret TOKEN, an integer with FLAGS as classified by cpplib. */ +static tree +interpret_integer (const cpp_token *token, unsigned int flags) +{ + tree value, type; + enum integer_type_kind itk; + cpp_num integer; + cpp_options *options = cpp_get_options (parse_in); + + integer = cpp_interpret_integer (parse_in, token, flags); + integer = cpp_num_sign_extend (integer, options->precision); + + /* The type of a constant with a U suffix is straightforward. */ + if (flags & CPP_N_UNSIGNED) + itk = narrowest_unsigned_type (integer.low, integer.high, flags); + else + { + /* The type of a potentially-signed integer constant varies + depending on the base it's in, the standard in use, and the + length suffixes. */ + enum integer_type_kind itk_u + = narrowest_unsigned_type (integer.low, integer.high, flags); + enum integer_type_kind itk_s + = narrowest_signed_type (integer.low, integer.high, flags); + + /* In both C89 and C99, octal and hex constants may be signed or + unsigned, whichever fits tighter. We do not warn about this + choice differing from the traditional choice, as the constant + is probably a bit pattern and either way will work. */ + if ((flags & CPP_N_RADIX) != CPP_N_DECIMAL) + itk = MIN (itk_u, itk_s); + else + { + /* In C99, decimal constants are always signed. + In C89, decimal constants that don't fit in long have + undefined behavior; we try to make them unsigned long. + In GCC's extended C89, that last is true of decimal + constants that don't fit in long long, too. */ + + itk = itk_s; + if (itk_s > itk_u && itk_s > itk_long) + { + if (!flag_isoc99) + { + if (itk_u < itk_unsigned_long) + itk_u = itk_unsigned_long; + itk = itk_u; + warning (0, "this decimal constant is unsigned only in ISO C90"); + } + else + warning (OPT_Wtraditional, + "this decimal constant would be unsigned in ISO C90"); + } + } + } + + if (itk == itk_none) + /* cpplib has already issued a warning for overflow. */ + type = ((flags & CPP_N_UNSIGNED) + ? widest_unsigned_literal_type_node + : widest_integer_literal_type_node); + else + { + type = integer_types[itk]; + if (itk > itk_unsigned_long + && (flags & CPP_N_WIDTH) != CPP_N_LARGE) + emit_diagnostic + ((c_dialect_cxx () ? cxx_dialect == cxx98 : !flag_isoc99) + ? DK_PEDWARN : DK_WARNING, + input_location, OPT_Wlong_long, + (flags & CPP_N_UNSIGNED) + ? "integer constant is too large for % type" + : "integer constant is too large for % type"); + } + + value = build_int_cst_wide (type, integer.low, integer.high); + + /* Convert imaginary to a complex type. */ + if (flags & CPP_N_IMAGINARY) + value = build_complex (NULL_TREE, build_int_cst (type, 0), value); + + return value; +} + +/* Interpret TOKEN, a floating point number with FLAGS as classified + by cpplib. */ +static tree +interpret_float (const cpp_token *token, unsigned int flags) +{ + tree type; + tree const_type; + tree value; + REAL_VALUE_TYPE real; + REAL_VALUE_TYPE real_trunc; + char *copy; + size_t copylen; + + /* Default (no suffix) depends on whether the FLOAT_CONST_DECIMAL64 + pragma has been used and is either double or _Decimal64. Types + that are not allowed with decimal float default to double. */ + if (flags & CPP_N_DEFAULT) + { + flags ^= CPP_N_DEFAULT; + flags |= CPP_N_MEDIUM; + + if (((flags & CPP_N_HEX) == 0) && ((flags & CPP_N_IMAGINARY) == 0)) + { + warning (OPT_Wunsuffixed_float_constants, + "unsuffixed float constant"); + if (float_const_decimal64_p ()) + flags |= CPP_N_DFLOAT; + } + } + + /* Decode _Fract and _Accum. */ + if (flags & CPP_N_FRACT || flags & CPP_N_ACCUM) + return interpret_fixed (token, flags); + + /* Decode type based on width and properties. */ + if (flags & CPP_N_DFLOAT) + if ((flags & CPP_N_WIDTH) == CPP_N_LARGE) + type = dfloat128_type_node; + else if ((flags & CPP_N_WIDTH) == CPP_N_SMALL) + type = dfloat32_type_node; + else + type = dfloat64_type_node; + else + if (flags & CPP_N_WIDTH_MD) + { + char suffix; + enum machine_mode mode; + + if ((flags & CPP_N_WIDTH_MD) == CPP_N_MD_W) + suffix = 'w'; + else + suffix = 'q'; + + mode = targetm.c.mode_for_suffix (suffix); + if (mode == VOIDmode) + { + error ("unsupported non-standard suffix on floating constant"); + + return error_mark_node; + } + else + pedwarn (input_location, OPT_pedantic, "non-standard suffix on floating constant"); + + type = c_common_type_for_mode (mode, 0); + gcc_assert (type); + } + else if ((flags & CPP_N_WIDTH) == CPP_N_LARGE) + type = long_double_type_node; + else if ((flags & CPP_N_WIDTH) == CPP_N_SMALL + || flag_single_precision_constant) + type = float_type_node; + else + type = double_type_node; + + const_type = excess_precision_type (type); + if (!const_type) + const_type = type; + + /* Copy the constant to a nul-terminated buffer. If the constant + has any suffixes, cut them off; REAL_VALUE_ATOF/ REAL_VALUE_HTOF + can't handle them. */ + copylen = token->val.str.len; + if (flags & CPP_N_DFLOAT) + copylen -= 2; + else + { + if ((flags & CPP_N_WIDTH) != CPP_N_MEDIUM) + /* Must be an F or L or machine defined suffix. */ + copylen--; + if (flags & CPP_N_IMAGINARY) + /* I or J suffix. */ + copylen--; + } + + copy = (char *) alloca (copylen + 1); + memcpy (copy, token->val.str.text, copylen); + copy[copylen] = '\0'; + + real_from_string3 (&real, copy, TYPE_MODE (const_type)); + if (const_type != type) + /* Diagnosing if the result of converting the value with excess + precision to the semantic type would overflow (with associated + double rounding) is more appropriate than diagnosing if the + result of converting the string directly to the semantic type + would overflow. */ + real_convert (&real_trunc, TYPE_MODE (type), &real); + + /* Both C and C++ require a diagnostic for a floating constant + outside the range of representable values of its type. Since we + have __builtin_inf* to produce an infinity, this is now a + mandatory pedwarn if the target does not support infinities. */ + if (REAL_VALUE_ISINF (real) + || (const_type != type && REAL_VALUE_ISINF (real_trunc))) + { + if (!MODE_HAS_INFINITIES (TYPE_MODE (type))) + pedwarn (input_location, 0, "floating constant exceeds range of %qT", type); + else + warning (OPT_Woverflow, "floating constant exceeds range of %qT", type); + } + /* We also give a warning if the value underflows. */ + else if (REAL_VALUES_EQUAL (real, dconst0) + || (const_type != type && REAL_VALUES_EQUAL (real_trunc, dconst0))) + { + REAL_VALUE_TYPE realvoidmode; + int overflow = real_from_string (&realvoidmode, copy); + if (overflow < 0 || !REAL_VALUES_EQUAL (realvoidmode, dconst0)) + warning (OPT_Woverflow, "floating constant truncated to zero"); + } + + /* Create a node with determined type and value. */ + value = build_real (const_type, real); + if (flags & CPP_N_IMAGINARY) + value = build_complex (NULL_TREE, convert (const_type, integer_zero_node), + value); + + if (type != const_type) + value = build1 (EXCESS_PRECISION_EXPR, type, value); + + return value; +} + +/* Interpret TOKEN, a fixed-point number with FLAGS as classified + by cpplib. */ + +static tree +interpret_fixed (const cpp_token *token, unsigned int flags) +{ + tree type; + tree value; + FIXED_VALUE_TYPE fixed; + char *copy; + size_t copylen; + + copylen = token->val.str.len; + + if (flags & CPP_N_FRACT) /* _Fract. */ + { + if (flags & CPP_N_UNSIGNED) /* Unsigned _Fract. */ + { + if ((flags & CPP_N_WIDTH) == CPP_N_LARGE) + { + type = unsigned_long_long_fract_type_node; + copylen -= 4; + } + else if ((flags & CPP_N_WIDTH) == CPP_N_MEDIUM) + { + type = unsigned_long_fract_type_node; + copylen -= 3; + } + else if ((flags & CPP_N_WIDTH) == CPP_N_SMALL) + { + type = unsigned_short_fract_type_node; + copylen -= 3; + } + else + { + type = unsigned_fract_type_node; + copylen -= 2; + } + } + else /* Signed _Fract. */ + { + if ((flags & CPP_N_WIDTH) == CPP_N_LARGE) + { + type = long_long_fract_type_node; + copylen -= 3; + } + else if ((flags & CPP_N_WIDTH) == CPP_N_MEDIUM) + { + type = long_fract_type_node; + copylen -= 2; + } + else if ((flags & CPP_N_WIDTH) == CPP_N_SMALL) + { + type = short_fract_type_node; + copylen -= 2; + } + else + { + type = fract_type_node; + copylen --; + } + } + } + else /* _Accum. */ + { + if (flags & CPP_N_UNSIGNED) /* Unsigned _Accum. */ + { + if ((flags & CPP_N_WIDTH) == CPP_N_LARGE) + { + type = unsigned_long_long_accum_type_node; + copylen -= 4; + } + else if ((flags & CPP_N_WIDTH) == CPP_N_MEDIUM) + { + type = unsigned_long_accum_type_node; + copylen -= 3; + } + else if ((flags & CPP_N_WIDTH) == CPP_N_SMALL) + { + type = unsigned_short_accum_type_node; + copylen -= 3; + } + else + { + type = unsigned_accum_type_node; + copylen -= 2; + } + } + else /* Signed _Accum. */ + { + if ((flags & CPP_N_WIDTH) == CPP_N_LARGE) + { + type = long_long_accum_type_node; + copylen -= 3; + } + else if ((flags & CPP_N_WIDTH) == CPP_N_MEDIUM) + { + type = long_accum_type_node; + copylen -= 2; + } + else if ((flags & CPP_N_WIDTH) == CPP_N_SMALL) + { + type = short_accum_type_node; + copylen -= 2; + } + else + { + type = accum_type_node; + copylen --; + } + } + } + + copy = (char *) alloca (copylen + 1); + memcpy (copy, token->val.str.text, copylen); + copy[copylen] = '\0'; + + fixed_from_string (&fixed, copy, TYPE_MODE (type)); + + /* Create a node with determined type and value. */ + value = build_fixed (type, fixed); + + return value; +} + +/* Convert a series of STRING, WSTRING, STRING16, STRING32 and/or + UTF8STRING tokens into a tree, performing string constant + concatenation. TOK is the first of these. VALP is the location + to write the string into. OBJC_STRING indicates whether an '@' token + preceded the incoming token. + Returns the CPP token type of the result (CPP_STRING, CPP_WSTRING, + CPP_STRING32, CPP_STRING16, CPP_UTF8STRING, or CPP_OBJC_STRING). + + This is unfortunately more work than it should be. If any of the + strings in the series has an L prefix, the result is a wide string + (6.4.5p4). Whether or not the result is a wide string affects the + meaning of octal and hexadecimal escapes (6.4.4.4p6,9). But escape + sequences do not continue across the boundary between two strings in + a series (6.4.5p7), so we must not lose the boundaries. Therefore + cpp_interpret_string takes a vector of cpp_string structures, which + we must arrange to provide. */ + +static enum cpp_ttype +lex_string (const cpp_token *tok, tree *valp, bool objc_string, bool translate) +{ + tree value; + size_t concats = 0; + struct obstack str_ob; + cpp_string istr; + enum cpp_ttype type = tok->type; + + /* Try to avoid the overhead of creating and destroying an obstack + for the common case of just one string. */ + cpp_string str = tok->val.str; + cpp_string *strs = &str; + + retry: + tok = cpp_get_token (parse_in); + switch (tok->type) + { + case CPP_PADDING: + goto retry; + case CPP_ATSIGN: + if (c_dialect_objc ()) + { + objc_string = true; + goto retry; + } + /* FALLTHROUGH */ + + default: + break; + + case CPP_WSTRING: + case CPP_STRING16: + case CPP_STRING32: + case CPP_UTF8STRING: + if (type != tok->type) + { + if (type == CPP_STRING) + type = tok->type; + else + error ("unsupported non-standard concatenation of string literals"); + } + + case CPP_STRING: + if (!concats) + { + gcc_obstack_init (&str_ob); + obstack_grow (&str_ob, &str, sizeof (cpp_string)); + } + + concats++; + obstack_grow (&str_ob, &tok->val.str, sizeof (cpp_string)); + goto retry; + } + + /* We have read one more token than we want. */ + _cpp_backup_tokens (parse_in, 1); + if (concats) + strs = XOBFINISH (&str_ob, cpp_string *); + + if (concats && !objc_string && !in_system_header) + warning (OPT_Wtraditional, + "traditional C rejects string constant concatenation"); + + if ((translate + ? cpp_interpret_string : cpp_interpret_string_notranslate) + (parse_in, strs, concats + 1, &istr, type)) + { + value = build_string (istr.len, (const char *) istr.text); + free (CONST_CAST (unsigned char *, istr.text)); + } + else + { + /* Callers cannot generally handle error_mark_node in this context, + so return the empty string instead. cpp_interpret_string has + issued an error. */ + switch (type) + { + default: + case CPP_STRING: + case CPP_UTF8STRING: + value = build_string (1, ""); + break; + case CPP_STRING16: + value = build_string (TYPE_PRECISION (char16_type_node) + / TYPE_PRECISION (char_type_node), + "\0"); /* char16_t is 16 bits */ + break; + case CPP_STRING32: + value = build_string (TYPE_PRECISION (char32_type_node) + / TYPE_PRECISION (char_type_node), + "\0\0\0"); /* char32_t is 32 bits */ + break; + case CPP_WSTRING: + value = build_string (TYPE_PRECISION (wchar_type_node) + / TYPE_PRECISION (char_type_node), + "\0\0\0"); /* widest supported wchar_t + is 32 bits */ + break; + } + } + + switch (type) + { + default: + case CPP_STRING: + case CPP_UTF8STRING: + TREE_TYPE (value) = char_array_type_node; + break; + case CPP_STRING16: + TREE_TYPE (value) = char16_array_type_node; + break; + case CPP_STRING32: + TREE_TYPE (value) = char32_array_type_node; + break; + case CPP_WSTRING: + TREE_TYPE (value) = wchar_array_type_node; + } + *valp = fix_string_type (value); + + if (concats) + obstack_free (&str_ob, 0); + + return objc_string ? CPP_OBJC_STRING : type; +} + +/* Converts a (possibly wide) character constant token into a tree. */ +static tree +lex_charconst (const cpp_token *token) +{ + cppchar_t result; + tree type, value; + unsigned int chars_seen; + int unsignedp = 0; + + result = cpp_interpret_charconst (parse_in, token, + &chars_seen, &unsignedp); + + if (token->type == CPP_WCHAR) + type = wchar_type_node; + else if (token->type == CPP_CHAR32) + type = char32_type_node; + else if (token->type == CPP_CHAR16) + type = char16_type_node; + /* In C, a character constant has type 'int'. + In C++ 'char', but multi-char charconsts have type 'int'. */ + else if (!c_dialect_cxx () || chars_seen > 1) + type = integer_type_node; + else + type = char_type_node; + + /* Cast to cppchar_signed_t to get correct sign-extension of RESULT + before possibly widening to HOST_WIDE_INT for build_int_cst. */ + if (unsignedp || (cppchar_signed_t) result >= 0) + value = build_int_cst_wide (type, result, 0); + else + value = build_int_cst_wide (type, (cppchar_signed_t) result, -1); + + return value; +} diff --git a/gcc/c-family/c-omp.c b/gcc/c-family/c-omp.c new file mode 100644 index 00000000000..31970bdeaee --- /dev/null +++ b/gcc/c-family/c-omp.c @@ -0,0 +1,531 @@ +/* This file contains routines to construct GNU OpenMP constructs, + called from parsing in the C and C++ front ends. + + Copyright (C) 2005, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. + Contributed by Richard Henderson , + Diego Novillo . + +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 3, 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 COPYING3. If not see +. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tree.h" +#include "c-common.h" +#include "toplev.h" +#include "gimple.h" /* For create_tmp_var_raw. */ +#include "langhooks.h" + + +/* Complete a #pragma omp master construct. STMT is the structured-block + that follows the pragma. LOC is the l*/ + +tree +c_finish_omp_master (location_t loc, tree stmt) +{ + tree t = add_stmt (build1 (OMP_MASTER, void_type_node, stmt)); + SET_EXPR_LOCATION (t, loc); + return t; +} + +/* Complete a #pragma omp critical construct. STMT is the structured-block + that follows the pragma, NAME is the identifier in the pragma, or null + if it was omitted. LOC is the location of the #pragma. */ + +tree +c_finish_omp_critical (location_t loc, tree body, tree name) +{ + tree stmt = make_node (OMP_CRITICAL); + TREE_TYPE (stmt) = void_type_node; + OMP_CRITICAL_BODY (stmt) = body; + OMP_CRITICAL_NAME (stmt) = name; + SET_EXPR_LOCATION (stmt, loc); + return add_stmt (stmt); +} + +/* Complete a #pragma omp ordered construct. STMT is the structured-block + that follows the pragma. LOC is the location of the #pragma. */ + +tree +c_finish_omp_ordered (location_t loc, tree stmt) +{ + tree t = build1 (OMP_ORDERED, void_type_node, stmt); + SET_EXPR_LOCATION (t, loc); + return add_stmt (t); +} + + +/* Complete a #pragma omp barrier construct. LOC is the location of + the #pragma. */ + +void +c_finish_omp_barrier (location_t loc) +{ + tree x; + + x = built_in_decls[BUILT_IN_GOMP_BARRIER]; + x = build_call_expr_loc (loc, x, 0); + add_stmt (x); +} + + +/* Complete a #pragma omp taskwait construct. LOC is the location of the + pragma. */ + +void +c_finish_omp_taskwait (location_t loc) +{ + tree x; + + x = built_in_decls[BUILT_IN_GOMP_TASKWAIT]; + x = build_call_expr_loc (loc, x, 0); + add_stmt (x); +} + + +/* Complete a #pragma omp atomic construct. The expression to be + implemented atomically is LHS code= RHS. LOC is the location of + the atomic statement. The value returned is either error_mark_node + (if the construct was erroneous) or an OMP_ATOMIC node which should + be added to the current statement tree with add_stmt.*/ + +tree +c_finish_omp_atomic (location_t loc, enum tree_code code, tree lhs, tree rhs) +{ + tree x, type, addr; + + if (lhs == error_mark_node || rhs == error_mark_node) + return error_mark_node; + + /* ??? According to one reading of the OpenMP spec, complex type are + supported, but there are no atomic stores for any architecture. + But at least icc 9.0 doesn't support complex types here either. + And lets not even talk about vector types... */ + type = TREE_TYPE (lhs); + if (!INTEGRAL_TYPE_P (type) + && !POINTER_TYPE_P (type) + && !SCALAR_FLOAT_TYPE_P (type)) + { + error_at (loc, "invalid expression type for %<#pragma omp atomic%>"); + return error_mark_node; + } + + /* ??? Validate that rhs does not overlap lhs. */ + + /* Take and save the address of the lhs. From then on we'll reference it + via indirection. */ + addr = build_unary_op (loc, ADDR_EXPR, lhs, 0); + if (addr == error_mark_node) + return error_mark_node; + addr = save_expr (addr); + if (TREE_CODE (addr) != SAVE_EXPR + && (TREE_CODE (addr) != ADDR_EXPR + || TREE_CODE (TREE_OPERAND (addr, 0)) != VAR_DECL)) + { + /* Make sure LHS is simple enough so that goa_lhs_expr_p can recognize + it even after unsharing function body. */ + tree var = create_tmp_var_raw (TREE_TYPE (addr), NULL); + DECL_CONTEXT (var) = current_function_decl; + addr = build4 (TARGET_EXPR, TREE_TYPE (addr), var, addr, NULL, NULL); + } + lhs = build_indirect_ref (loc, addr, RO_NULL); + + /* There are lots of warnings, errors, and conversions that need to happen + in the course of interpreting a statement. Use the normal mechanisms + to do this, and then take it apart again. */ + x = build_modify_expr (input_location, lhs, NULL_TREE, code, + input_location, rhs, NULL_TREE); + if (x == error_mark_node) + return error_mark_node; + gcc_assert (TREE_CODE (x) == MODIFY_EXPR); + rhs = TREE_OPERAND (x, 1); + + /* Punt the actual generation of atomic operations to common code. */ + x = build2 (OMP_ATOMIC, void_type_node, addr, rhs); + SET_EXPR_LOCATION (x, loc); + return x; +} + + +/* Complete a #pragma omp flush construct. We don't do anything with + the variable list that the syntax allows. LOC is the location of + the #pragma. */ + +void +c_finish_omp_flush (location_t loc) +{ + tree x; + + x = built_in_decls[BUILT_IN_SYNCHRONIZE]; + x = build_call_expr_loc (loc, x, 0); + add_stmt (x); +} + + +/* Check and canonicalize #pragma omp for increment expression. + Helper function for c_finish_omp_for. */ + +static tree +check_omp_for_incr_expr (location_t loc, tree exp, tree decl) +{ + tree t; + + if (!INTEGRAL_TYPE_P (TREE_TYPE (exp)) + || TYPE_PRECISION (TREE_TYPE (exp)) < TYPE_PRECISION (TREE_TYPE (decl))) + return error_mark_node; + + if (exp == decl) + return build_int_cst (TREE_TYPE (exp), 0); + + switch (TREE_CODE (exp)) + { + CASE_CONVERT: + t = check_omp_for_incr_expr (loc, TREE_OPERAND (exp, 0), decl); + if (t != error_mark_node) + return fold_convert_loc (loc, TREE_TYPE (exp), t); + break; + case MINUS_EXPR: + t = check_omp_for_incr_expr (loc, TREE_OPERAND (exp, 0), decl); + if (t != error_mark_node) + return fold_build2_loc (loc, MINUS_EXPR, + TREE_TYPE (exp), t, TREE_OPERAND (exp, 1)); + break; + case PLUS_EXPR: + t = check_omp_for_incr_expr (loc, TREE_OPERAND (exp, 0), decl); + if (t != error_mark_node) + return fold_build2_loc (loc, PLUS_EXPR, + TREE_TYPE (exp), t, TREE_OPERAND (exp, 1)); + t = check_omp_for_incr_expr (loc, TREE_OPERAND (exp, 1), decl); + if (t != error_mark_node) + return fold_build2_loc (loc, PLUS_EXPR, + TREE_TYPE (exp), TREE_OPERAND (exp, 0), t); + break; + default: + break; + } + + return error_mark_node; +} + +/* Validate and emit code for the OpenMP directive #pragma omp for. + DECLV is a vector of iteration variables, for each collapsed loop. + INITV, CONDV and INCRV are vectors containing initialization + expressions, controlling predicates and increment expressions. + BODY is the body of the loop and PRE_BODY statements that go before + the loop. */ + +tree +c_finish_omp_for (location_t locus, tree declv, tree initv, tree condv, + tree incrv, tree body, tree pre_body) +{ + location_t elocus; + bool fail = false; + int i; + + gcc_assert (TREE_VEC_LENGTH (declv) == TREE_VEC_LENGTH (initv)); + gcc_assert (TREE_VEC_LENGTH (declv) == TREE_VEC_LENGTH (condv)); + gcc_assert (TREE_VEC_LENGTH (declv) == TREE_VEC_LENGTH (incrv)); + for (i = 0; i < TREE_VEC_LENGTH (declv); i++) + { + tree decl = TREE_VEC_ELT (declv, i); + tree init = TREE_VEC_ELT (initv, i); + tree cond = TREE_VEC_ELT (condv, i); + tree incr = TREE_VEC_ELT (incrv, i); + + elocus = locus; + if (EXPR_HAS_LOCATION (init)) + elocus = EXPR_LOCATION (init); + + /* Validate the iteration variable. */ + if (!INTEGRAL_TYPE_P (TREE_TYPE (decl)) + && TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE) + { + error_at (elocus, "invalid type for iteration variable %qE", decl); + fail = true; + } + + /* In the case of "for (int i = 0...)", init will be a decl. It should + have a DECL_INITIAL that we can turn into an assignment. */ + if (init == decl) + { + elocus = DECL_SOURCE_LOCATION (decl); + + init = DECL_INITIAL (decl); + if (init == NULL) + { + error_at (elocus, "%qE is not initialized", decl); + init = integer_zero_node; + fail = true; + } + + init = build_modify_expr (elocus, decl, NULL_TREE, NOP_EXPR, + /* FIXME diagnostics: This should + be the location of the INIT. */ + elocus, + init, + NULL_TREE); + } + gcc_assert (TREE_CODE (init) == MODIFY_EXPR); + gcc_assert (TREE_OPERAND (init, 0) == decl); + + if (cond == NULL_TREE) + { + error_at (elocus, "missing controlling predicate"); + fail = true; + } + else + { + bool cond_ok = false; + + if (EXPR_HAS_LOCATION (cond)) + elocus = EXPR_LOCATION (cond); + + if (TREE_CODE (cond) == LT_EXPR + || TREE_CODE (cond) == LE_EXPR + || TREE_CODE (cond) == GT_EXPR + || TREE_CODE (cond) == GE_EXPR + || TREE_CODE (cond) == NE_EXPR + || TREE_CODE (cond) == EQ_EXPR) + { + tree op0 = TREE_OPERAND (cond, 0); + tree op1 = TREE_OPERAND (cond, 1); + + /* 2.5.1. The comparison in the condition is computed in + the type of DECL, otherwise the behavior is undefined. + + For example: + long n; int i; + i < n; + + according to ISO will be evaluated as: + (long)i < n; + + We want to force: + i < (int)n; */ + if (TREE_CODE (op0) == NOP_EXPR + && decl == TREE_OPERAND (op0, 0)) + { + TREE_OPERAND (cond, 0) = TREE_OPERAND (op0, 0); + TREE_OPERAND (cond, 1) + = fold_build1_loc (elocus, NOP_EXPR, TREE_TYPE (decl), + TREE_OPERAND (cond, 1)); + } + else if (TREE_CODE (op1) == NOP_EXPR + && decl == TREE_OPERAND (op1, 0)) + { + TREE_OPERAND (cond, 1) = TREE_OPERAND (op1, 0); + TREE_OPERAND (cond, 0) + = fold_build1_loc (elocus, NOP_EXPR, TREE_TYPE (decl), + TREE_OPERAND (cond, 0)); + } + + if (decl == TREE_OPERAND (cond, 0)) + cond_ok = true; + else if (decl == TREE_OPERAND (cond, 1)) + { + TREE_SET_CODE (cond, + swap_tree_comparison (TREE_CODE (cond))); + TREE_OPERAND (cond, 1) = TREE_OPERAND (cond, 0); + TREE_OPERAND (cond, 0) = decl; + cond_ok = true; + } + + if (TREE_CODE (cond) == NE_EXPR + || TREE_CODE (cond) == EQ_EXPR) + { + if (!INTEGRAL_TYPE_P (TREE_TYPE (decl))) + cond_ok = false; + else if (operand_equal_p (TREE_OPERAND (cond, 1), + TYPE_MIN_VALUE (TREE_TYPE (decl)), + 0)) + TREE_SET_CODE (cond, TREE_CODE (cond) == NE_EXPR + ? GT_EXPR : LE_EXPR); + else if (operand_equal_p (TREE_OPERAND (cond, 1), + TYPE_MAX_VALUE (TREE_TYPE (decl)), + 0)) + TREE_SET_CODE (cond, TREE_CODE (cond) == NE_EXPR + ? LT_EXPR : GE_EXPR); + else + cond_ok = false; + } + } + + if (!cond_ok) + { + error_at (elocus, "invalid controlling predicate"); + fail = true; + } + } + + if (incr == NULL_TREE) + { + error_at (elocus, "missing increment expression"); + fail = true; + } + else + { + bool incr_ok = false; + + if (EXPR_HAS_LOCATION (incr)) + elocus = EXPR_LOCATION (incr); + + /* Check all the valid increment expressions: v++, v--, ++v, --v, + v = v + incr, v = incr + v and v = v - incr. */ + switch (TREE_CODE (incr)) + { + case POSTINCREMENT_EXPR: + case PREINCREMENT_EXPR: + case POSTDECREMENT_EXPR: + case PREDECREMENT_EXPR: + if (TREE_OPERAND (incr, 0) != decl) + break; + + incr_ok = true; + if (POINTER_TYPE_P (TREE_TYPE (decl)) + && TREE_OPERAND (incr, 1)) + { + tree t = fold_convert_loc (elocus, + sizetype, TREE_OPERAND (incr, 1)); + + if (TREE_CODE (incr) == POSTDECREMENT_EXPR + || TREE_CODE (incr) == PREDECREMENT_EXPR) + t = fold_build1_loc (elocus, NEGATE_EXPR, sizetype, t); + t = build2 (POINTER_PLUS_EXPR, TREE_TYPE (decl), decl, t); + incr = build2 (MODIFY_EXPR, void_type_node, decl, t); + } + break; + + case MODIFY_EXPR: + if (TREE_OPERAND (incr, 0) != decl) + break; + if (TREE_OPERAND (incr, 1) == decl) + break; + if (TREE_CODE (TREE_OPERAND (incr, 1)) == PLUS_EXPR + && (TREE_OPERAND (TREE_OPERAND (incr, 1), 0) == decl + || TREE_OPERAND (TREE_OPERAND (incr, 1), 1) == decl)) + incr_ok = true; + else if ((TREE_CODE (TREE_OPERAND (incr, 1)) == MINUS_EXPR + || (TREE_CODE (TREE_OPERAND (incr, 1)) + == POINTER_PLUS_EXPR)) + && TREE_OPERAND (TREE_OPERAND (incr, 1), 0) == decl) + incr_ok = true; + else + { + tree t = check_omp_for_incr_expr (elocus, + TREE_OPERAND (incr, 1), + decl); + if (t != error_mark_node) + { + incr_ok = true; + t = build2 (PLUS_EXPR, TREE_TYPE (decl), decl, t); + incr = build2 (MODIFY_EXPR, void_type_node, decl, t); + } + } + break; + + default: + break; + } + if (!incr_ok) + { + error_at (elocus, "invalid increment expression"); + fail = true; + } + } + + TREE_VEC_ELT (initv, i) = init; + TREE_VEC_ELT (incrv, i) = incr; + } + + if (fail) + return NULL; + else + { + tree t = make_node (OMP_FOR); + + TREE_TYPE (t) = void_type_node; + OMP_FOR_INIT (t) = initv; + OMP_FOR_COND (t) = condv; + OMP_FOR_INCR (t) = incrv; + OMP_FOR_BODY (t) = body; + OMP_FOR_PRE_BODY (t) = pre_body; + + SET_EXPR_LOCATION (t, locus); + return add_stmt (t); + } +} + + +/* Divide CLAUSES into two lists: those that apply to a parallel + construct, and those that apply to a work-sharing construct. Place + the results in *PAR_CLAUSES and *WS_CLAUSES respectively. In + addition, add a nowait clause to the work-sharing list. LOC is the + location of the OMP_PARALLEL*. */ + +void +c_split_parallel_clauses (location_t loc, tree clauses, + tree *par_clauses, tree *ws_clauses) +{ + tree next; + + *par_clauses = NULL; + *ws_clauses = build_omp_clause (loc, OMP_CLAUSE_NOWAIT); + + for (; clauses ; clauses = next) + { + next = OMP_CLAUSE_CHAIN (clauses); + + switch (OMP_CLAUSE_CODE (clauses)) + { + case OMP_CLAUSE_PRIVATE: + case OMP_CLAUSE_SHARED: + case OMP_CLAUSE_FIRSTPRIVATE: + case OMP_CLAUSE_LASTPRIVATE: + case OMP_CLAUSE_REDUCTION: + case OMP_CLAUSE_COPYIN: + case OMP_CLAUSE_IF: + case OMP_CLAUSE_NUM_THREADS: + case OMP_CLAUSE_DEFAULT: + OMP_CLAUSE_CHAIN (clauses) = *par_clauses; + *par_clauses = clauses; + break; + + case OMP_CLAUSE_SCHEDULE: + case OMP_CLAUSE_ORDERED: + case OMP_CLAUSE_COLLAPSE: + OMP_CLAUSE_CHAIN (clauses) = *ws_clauses; + *ws_clauses = clauses; + break; + + default: + gcc_unreachable (); + } + } +} + +/* True if OpenMP sharing attribute of DECL is predetermined. */ + +enum omp_clause_default_kind +c_omp_predetermined_sharing (tree decl) +{ + /* Variables with const-qualified type having no mutable member + are predetermined shared. */ + if (TREE_READONLY (decl)) + return OMP_CLAUSE_DEFAULT_SHARED; + + return OMP_CLAUSE_DEFAULT_UNSPECIFIED; +} diff --git a/gcc/c-family/c-opts.c b/gcc/c-family/c-opts.c new file mode 100644 index 00000000000..2f8d5d86230 --- /dev/null +++ b/gcc/c-family/c-opts.c @@ -0,0 +1,1660 @@ +/* C/ObjC/C++ command line option handling. + Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 + Free Software Foundation, Inc. + Contributed by Neil Booth. + +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 3, 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 COPYING3. If not see +. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tree.h" +#include "c-common.h" +#include "c-pragma.h" +#include "flags.h" +#include "toplev.h" +#include "langhooks.h" +#include "diagnostic.h" +#include "intl.h" +#include "cppdefault.h" +#include "incpath.h" +#include "debug.h" /* For debug_hooks. */ +#include "opts.h" +#include "options.h" +#include "mkdeps.h" +#include "target.h" /* For gcc_targetcm. */ +#include "tm_p.h" /* For C_COMMON_OVERRIDE_OPTIONS. */ + +#ifndef DOLLARS_IN_IDENTIFIERS +# define DOLLARS_IN_IDENTIFIERS true +#endif + +#ifndef TARGET_SYSTEM_ROOT +# define TARGET_SYSTEM_ROOT NULL +#endif + +#ifndef TARGET_OPTF +#define TARGET_OPTF(ARG) +#endif + +/* CPP's options. */ +cpp_options *cpp_opts; + +/* Input filename. */ +static const char *this_input_filename; + +/* Filename and stream for preprocessed output. */ +static const char *out_fname; +static FILE *out_stream; + +/* Append dependencies to deps_file. */ +static bool deps_append; + +/* If dependency switches (-MF etc.) have been given. */ +static bool deps_seen; + +/* If -v seen. */ +static bool verbose; + +/* Dependency output file. */ +static const char *deps_file; + +/* The prefix given by -iprefix, if any. */ +static const char *iprefix; + +/* The multilib directory given by -imultilib, if any. */ +static const char *imultilib; + +/* The system root, if any. Overridden by -isysroot. */ +static const char *sysroot = TARGET_SYSTEM_ROOT; + +/* Zero disables all standard directories for headers. */ +static bool std_inc = true; + +/* Zero disables the C++-specific standard directories for headers. */ +static bool std_cxx_inc = true; + +/* If the quote chain has been split by -I-. */ +static bool quote_chain_split; + +/* If -Wunused-macros. */ +static bool warn_unused_macros; + +/* If -Wvariadic-macros. */ +static bool warn_variadic_macros = true; + +/* Number of deferred options. */ +static size_t deferred_count; + +/* Number of deferred options scanned for -include. */ +static size_t include_cursor; + +static void handle_OPT_d (const char *); +static void set_std_cxx98 (int); +static void set_std_cxx0x (int); +static void set_std_c89 (int, int); +static void set_std_c99 (int); +static void set_std_c1x (int); +static void check_deps_environment_vars (void); +static void handle_deferred_opts (void); +static void sanitize_cpp_opts (void); +static void add_prefixed_path (const char *, size_t); +static void push_command_line_include (void); +static void cb_file_change (cpp_reader *, const struct line_map *); +static void cb_dir_change (cpp_reader *, const char *); +static void finish_options (void); + +#ifndef STDC_0_IN_SYSTEM_HEADERS +#define STDC_0_IN_SYSTEM_HEADERS 0 +#endif + +/* Holds switches parsed by c_common_handle_option (), but whose + handling is deferred to c_common_post_options (). */ +static void defer_opt (enum opt_code, const char *); +static struct deferred_opt +{ + enum opt_code code; + const char *arg; +} *deferred_opts; + + +static const unsigned int +c_family_lang_mask = (CL_C | CL_CXX | CL_ObjC | CL_ObjCXX); + +/* Complain that switch CODE expects an argument but none was + provided. OPT was the command-line option. Return FALSE to get + the default message in opts.c, TRUE if we provide a specialized + one. */ +bool +c_common_missing_argument (const char *opt, size_t code) +{ + switch (code) + { + default: + /* Pick up the default message. */ + return false; + + case OPT_fconstant_string_class_: + error ("no class name specified with %qs", opt); + break; + + case OPT_A: + error ("assertion missing after %qs", opt); + break; + + case OPT_D: + case OPT_U: + error ("macro name missing after %qs", opt); + break; + + case OPT_F: + case OPT_I: + case OPT_idirafter: + case OPT_isysroot: + case OPT_isystem: + case OPT_iquote: + error ("missing path after %qs", opt); + break; + + case OPT_MF: + case OPT_MD: + case OPT_MMD: + case OPT_include: + case OPT_imacros: + case OPT_o: + error ("missing filename after %qs", opt); + break; + + case OPT_MQ: + case OPT_MT: + error ("missing makefile target after %qs", opt); + break; + } + + return true; +} + +/* Defer option CODE with argument ARG. */ +static void +defer_opt (enum opt_code code, const char *arg) +{ + deferred_opts[deferred_count].code = code; + deferred_opts[deferred_count].arg = arg; + deferred_count++; +} + +/* -Werror= may set a warning option to enable a warning that is emitted + by the preprocessor. Set any corresponding flag in cpp_opts. */ + +static void +warning_as_error_callback (int option_index) +{ + switch (option_index) + { + default: + /* Ignore options not associated with the preprocessor. */ + break; + + case OPT_Wdeprecated: + cpp_opts->warn_deprecated = 1; + break; + + case OPT_Wcomment: + case OPT_Wcomments: + cpp_opts->warn_comments = 1; + break; + + case OPT_Wtrigraphs: + cpp_opts->warn_trigraphs = 1; + break; + + case OPT_Wmultichar: + cpp_opts->warn_multichar = 1; + break; + + case OPT_Wtraditional: + cpp_opts->warn_traditional = 1; + break; + + case OPT_Wlong_long: + cpp_opts->warn_long_long = 1; + break; + + case OPT_Wendif_labels: + cpp_opts->warn_endif_labels = 1; + break; + + case OPT_Wvariadic_macros: + /* Set the local flag that is used later to update cpp_opts. */ + warn_variadic_macros = 1; + break; + + case OPT_Wbuiltin_macro_redefined: + cpp_opts->warn_builtin_macro_redefined = 1; + break; + + case OPT_Wundef: + cpp_opts->warn_undef = 1; + break; + + case OPT_Wunused_macros: + /* Set the local flag that is used later to update cpp_opts. */ + warn_unused_macros = 1; + break; + + case OPT_Wc___compat: + /* Add warnings in the same way as c_common_handle_option below. */ + if (warn_enum_compare == -1) + warn_enum_compare = 1; + if (warn_jump_misses_init == -1) + warn_jump_misses_init = 1; + cpp_opts->warn_cxx_operator_names = 1; + break; + + case OPT_Wnormalized_: + inform (input_location, "-Werror=normalized=: Set -Wnormalized=nfc"); + cpp_opts->warn_normalize = normalized_C; + break; + + case OPT_Winvalid_pch: + cpp_opts->warn_invalid_pch = 1; + break; + + case OPT_Wcpp: + /* Handled by standard diagnostics using the option's associated + boolean variable. */ + break; + } +} + +/* Common initialization before parsing options. */ +unsigned int +c_common_init_options (unsigned int argc, const char **argv) +{ + static const unsigned int lang_flags[] = {CL_C, CL_ObjC, CL_CXX, CL_ObjCXX}; + unsigned int i, result; + struct cpp_callbacks *cb; + + /* Register callback for warnings enabled by -Werror=. */ + register_warning_as_error_callback (warning_as_error_callback); + + /* This is conditionalized only because that is the way the front + ends used to do it. Maybe this should be unconditional? */ + if (c_dialect_cxx ()) + { + /* By default wrap lines at 80 characters. Is getenv + ("COLUMNS") preferable? */ + diagnostic_line_cutoff (global_dc) = 80; + /* By default, emit location information once for every + diagnostic message. */ + diagnostic_prefixing_rule (global_dc) = DIAGNOSTICS_SHOW_PREFIX_ONCE; + } + + global_dc->opt_permissive = OPT_fpermissive; + + parse_in = cpp_create_reader (c_dialect_cxx () ? CLK_GNUCXX: CLK_GNUC89, + ident_hash, line_table); + cb = cpp_get_callbacks (parse_in); + cb->error = c_cpp_error; + + cpp_opts = cpp_get_options (parse_in); + cpp_opts->dollars_in_ident = DOLLARS_IN_IDENTIFIERS; + cpp_opts->objc = c_dialect_objc (); + + /* Reset to avoid warnings on internal definitions. We set it just + before passing on command-line options to cpplib. */ + cpp_opts->warn_dollars = 0; + + flag_exceptions = c_dialect_cxx (); + warn_pointer_arith = c_dialect_cxx (); + warn_write_strings = c_dialect_cxx(); + flag_warn_unused_result = true; + + /* By default, C99-like requirements for complex multiply and divide. */ + flag_complex_method = 2; + + deferred_opts = XNEWVEC (struct deferred_opt, argc); + + result = lang_flags[c_language]; + + if (c_language == clk_c) + { + /* If preprocessing assembly language, accept any of the C-family + front end options since the driver may pass them through. */ + for (i = 1; i < argc; i++) + if (! strcmp (argv[i], "-lang-asm")) + { + result |= CL_C | CL_ObjC | CL_CXX | CL_ObjCXX; + break; + } + } + + return result; +} + +/* Handle switch SCODE with argument ARG. VALUE is true, unless no- + form of an -f or -W option was given. Returns 0 if the switch was + invalid, a negative number to prevent language-independent + processing in toplev.c (a hack necessary for the short-term). */ +int +c_common_handle_option (size_t scode, const char *arg, int value, + int kind) +{ + const struct cl_option *option = &cl_options[scode]; + enum opt_code code = (enum opt_code) scode; + int result = 1; + + /* Prevent resetting the language standard to a C dialect when the driver + has already determined that we're looking at assembler input. */ + bool preprocessing_asm_p = (cpp_get_options (parse_in)->lang == CLK_ASM); + + switch (code) + { + default: + if (cl_options[code].flags & c_family_lang_mask) + { + if ((option->flags & CL_TARGET) + && ! targetcm.handle_c_option (scode, arg, value)) + result = 0; + break; + } + result = 0; + break; + + case OPT__output_pch_: + pch_file = arg; + break; + + case OPT_A: + defer_opt (code, arg); + break; + + case OPT_C: + cpp_opts->discard_comments = 0; + break; + + case OPT_CC: + cpp_opts->discard_comments = 0; + cpp_opts->discard_comments_in_macro_exp = 0; + break; + + case OPT_D: + defer_opt (code, arg); + break; + + case OPT_H: + cpp_opts->print_include_names = 1; + break; + + case OPT_F: + TARGET_OPTF (xstrdup (arg)); + break; + + case OPT_I: + if (strcmp (arg, "-")) + add_path (xstrdup (arg), BRACKET, 0, true); + else + { + if (quote_chain_split) + error ("-I- specified twice"); + quote_chain_split = true; + split_quote_chain (); + inform (input_location, "obsolete option -I- used, please use -iquote instead"); + } + break; + + case OPT_M: + case OPT_MM: + /* When doing dependencies with -M or -MM, suppress normal + preprocessed output, but still do -dM etc. as software + depends on this. Preprocessed output does occur if -MD, -MMD + or environment var dependency generation is used. */ + cpp_opts->deps.style = (code == OPT_M ? DEPS_SYSTEM: DEPS_USER); + flag_no_output = 1; + break; + + case OPT_MD: + case OPT_MMD: + cpp_opts->deps.style = (code == OPT_MD ? DEPS_SYSTEM: DEPS_USER); + cpp_opts->deps.need_preprocessor_output = true; + deps_file = arg; + break; + + case OPT_MF: + deps_seen = true; + deps_file = arg; + break; + + case OPT_MG: + deps_seen = true; + cpp_opts->deps.missing_files = true; + break; + + case OPT_MP: + deps_seen = true; + cpp_opts->deps.phony_targets = true; + break; + + case OPT_MQ: + case OPT_MT: + deps_seen = true; + defer_opt (code, arg); + break; + + case OPT_P: + flag_no_line_commands = 1; + break; + + case OPT_U: + defer_opt (code, arg); + break; + + case OPT_Wall: + warn_unused = value; + set_Wformat (value); + handle_option (OPT_Wimplicit, value, NULL, c_family_lang_mask, kind); + warn_char_subscripts = value; + warn_missing_braces = value; + warn_parentheses = value; + warn_return_type = value; + warn_sequence_point = value; /* Was C only. */ + warn_switch = value; + if (warn_strict_aliasing == -1) + set_Wstrict_aliasing (value); + warn_address = value; + if (warn_strict_overflow == -1) + warn_strict_overflow = value; + warn_array_bounds = value; + warn_volatile_register_var = value; + + /* Only warn about unknown pragmas that are not in system + headers. */ + warn_unknown_pragmas = value; + + warn_uninitialized = value; + + if (!c_dialect_cxx ()) + { + /* We set this to 2 here, but 1 in -Wmain, so -ffreestanding + can turn it off only if it's not explicit. */ + if (warn_main == -1) + warn_main = (value ? 2 : 0); + + /* In C, -Wall turns on -Wenum-compare, which we do here. + In C++ it is on by default, which is done in + c_common_post_options. */ + if (warn_enum_compare == -1) + warn_enum_compare = value; + } + else + { + /* C++-specific warnings. */ + warn_sign_compare = value; + warn_reorder = value; + warn_cxx0x_compat = value; + } + + cpp_opts->warn_trigraphs = value; + cpp_opts->warn_comments = value; + cpp_opts->warn_num_sign_change = value; + + if (warn_pointer_sign == -1) + warn_pointer_sign = value; + break; + + case OPT_Wbuiltin_macro_redefined: + cpp_opts->warn_builtin_macro_redefined = value; + break; + + case OPT_Wcomment: + case OPT_Wcomments: + cpp_opts->warn_comments = value; + break; + + case OPT_Wc___compat: + /* Because -Wenum-compare is the default in C++, -Wc++-compat + implies -Wenum-compare. */ + if (warn_enum_compare == -1 && value) + warn_enum_compare = value; + /* Because C++ always warns about a goto which misses an + initialization, -Wc++-compat turns on -Wjump-misses-init. */ + if (warn_jump_misses_init == -1 && value) + warn_jump_misses_init = value; + cpp_opts->warn_cxx_operator_names = value; + break; + + case OPT_Wdeprecated: + cpp_opts->warn_deprecated = value; + break; + + case OPT_Wendif_labels: + cpp_opts->warn_endif_labels = value; + break; + + case OPT_Werror: + global_dc->warning_as_error_requested = value; + break; + + case OPT_Werror_implicit_function_declaration: + /* For backward compatibility, this is the same as + -Werror=implicit-function-declaration. */ + enable_warning_as_error ("implicit-function-declaration", value, CL_C | CL_ObjC); + break; + + case OPT_Wformat: + set_Wformat (value); + break; + + case OPT_Wformat_: + set_Wformat (atoi (arg)); + break; + + case OPT_Wimplicit: + gcc_assert (value == 0 || value == 1); + if (warn_implicit_int == -1) + handle_option (OPT_Wimplicit_int, value, NULL, + c_family_lang_mask, kind); + if (warn_implicit_function_declaration == -1) + handle_option (OPT_Wimplicit_function_declaration, value, NULL, + c_family_lang_mask, kind); + break; + + case OPT_Wimport: + /* Silently ignore for now. */ + break; + + case OPT_Winvalid_pch: + cpp_opts->warn_invalid_pch = value; + break; + + case OPT_Wmissing_include_dirs: + cpp_opts->warn_missing_include_dirs = value; + break; + + case OPT_Wmultichar: + cpp_opts->warn_multichar = value; + break; + + case OPT_Wnormalized_: + if (!value || (arg && strcasecmp (arg, "none") == 0)) + cpp_opts->warn_normalize = normalized_none; + else if (!arg || strcasecmp (arg, "nfkc") == 0) + cpp_opts->warn_normalize = normalized_KC; + else if (strcasecmp (arg, "id") == 0) + cpp_opts->warn_normalize = normalized_identifier_C; + else if (strcasecmp (arg, "nfc") == 0) + cpp_opts->warn_normalize = normalized_C; + else + error ("argument %qs to %<-Wnormalized%> not recognized", arg); + break; + + case OPT_Wreturn_type: + warn_return_type = value; + break; + + case OPT_Wtraditional: + cpp_opts->warn_traditional = value; + break; + + case OPT_Wtrigraphs: + cpp_opts->warn_trigraphs = value; + break; + + case OPT_Wundef: + cpp_opts->warn_undef = value; + break; + + case OPT_Wunknown_pragmas: + /* Set to greater than 1, so that even unknown pragmas in + system headers will be warned about. */ + warn_unknown_pragmas = value * 2; + break; + + case OPT_Wunused_macros: + warn_unused_macros = value; + break; + + case OPT_Wvariadic_macros: + warn_variadic_macros = value; + break; + + case OPT_Wwrite_strings: + warn_write_strings = value; + break; + + case OPT_Weffc__: + warn_ecpp = value; + if (value) + warn_nonvdtor = true; + break; + + case OPT_ansi: + if (!c_dialect_cxx ()) + set_std_c89 (false, true); + else + set_std_cxx98 (true); + break; + + case OPT_d: + handle_OPT_d (arg); + break; + + case OPT_fcond_mismatch: + if (!c_dialect_cxx ()) + { + flag_cond_mismatch = value; + break; + } + /* Fall through. */ + + case OPT_fall_virtual: + case OPT_falt_external_templates: + case OPT_fenum_int_equiv: + case OPT_fexternal_templates: + case OPT_fguiding_decls: + case OPT_fhonor_std: + case OPT_fhuge_objects: + case OPT_flabels_ok: + case OPT_fname_mangling_version_: + case OPT_fnew_abi: + case OPT_fnonnull_objects: + case OPT_fsquangle: + case OPT_fstrict_prototype: + case OPT_fthis_is_variable: + case OPT_fvtable_thunks: + case OPT_fxref: + case OPT_fvtable_gc: + warning (0, "switch %qs is no longer supported", option->opt_text); + break; + + case OPT_fbuiltin_: + if (value) + result = 0; + else + disable_builtin_function (arg); + break; + + case OPT_fdirectives_only: + cpp_opts->directives_only = value; + break; + + case OPT_fdollars_in_identifiers: + cpp_opts->dollars_in_ident = value; + break; + + case OPT_ffreestanding: + value = !value; + /* Fall through.... */ + case OPT_fhosted: + flag_hosted = value; + flag_no_builtin = !value; + break; + + case OPT_fconstant_string_class_: + constant_string_class_name = arg; + break; + + case OPT_fdefault_inline: + /* Ignore. */ + break; + + case OPT_fextended_identifiers: + cpp_opts->extended_identifiers = value; + break; + + case OPT_fgnu_runtime: + flag_next_runtime = !value; + break; + + case OPT_fhandle_exceptions: + warning (0, "-fhandle-exceptions has been renamed -fexceptions (and is now on by default)"); + flag_exceptions = value; + break; + + case OPT_fnext_runtime: + flag_next_runtime = value; + break; + + case OPT_foperator_names: + cpp_opts->operator_names = value; + break; + + case OPT_foptional_diags: + /* Ignore. */ + break; + + case OPT_fpch_deps: + cpp_opts->restore_pch_deps = value; + break; + + case OPT_fpch_preprocess: + flag_pch_preprocess = value; + break; + + case OPT_fpermissive: + flag_permissive = value; + global_dc->permissive = value; + break; + + case OPT_fpreprocessed: + cpp_opts->preprocessed = value; + break; + + case OPT_frepo: + flag_use_repository = value; + if (value) + flag_implicit_templates = 0; + break; + + case OPT_ftabstop_: + /* It is documented that we silently ignore silly values. */ + if (value >= 1 && value <= 100) + cpp_opts->tabstop = value; + break; + + case OPT_fexec_charset_: + cpp_opts->narrow_charset = arg; + break; + + case OPT_fwide_exec_charset_: + cpp_opts->wide_charset = arg; + break; + + case OPT_finput_charset_: + cpp_opts->input_charset = arg; + break; + + case OPT_ftemplate_depth_: + /* Kept for backwards compatibility. */ + case OPT_ftemplate_depth_eq: + max_tinst_depth = value; + break; + + case OPT_fvisibility_inlines_hidden: + visibility_options.inlines_hidden = value; + break; + + case OPT_femit_struct_debug_baseonly: + set_struct_debug_option ("base"); + break; + + case OPT_femit_struct_debug_reduced: + set_struct_debug_option ("dir:ord:sys,dir:gen:any,ind:base"); + break; + + case OPT_femit_struct_debug_detailed_: + set_struct_debug_option (arg); + break; + + case OPT_idirafter: + add_path (xstrdup (arg), AFTER, 0, true); + break; + + case OPT_imacros: + case OPT_include: + defer_opt (code, arg); + break; + + case OPT_imultilib: + imultilib = arg; + break; + + case OPT_iprefix: + iprefix = arg; + break; + + case OPT_iquote: + add_path (xstrdup (arg), QUOTE, 0, true); + break; + + case OPT_isysroot: + sysroot = arg; + break; + + case OPT_isystem: + add_path (xstrdup (arg), SYSTEM, 0, true); + break; + + case OPT_iwithprefix: + add_prefixed_path (arg, SYSTEM); + break; + + case OPT_iwithprefixbefore: + add_prefixed_path (arg, BRACKET); + break; + + case OPT_lang_asm: + cpp_set_lang (parse_in, CLK_ASM); + cpp_opts->dollars_in_ident = false; + break; + + case OPT_nostdinc: + std_inc = false; + break; + + case OPT_nostdinc__: + std_cxx_inc = false; + break; + + case OPT_o: + if (!out_fname) + out_fname = arg; + else + error ("output filename specified twice"); + break; + + /* We need to handle the -pedantic switches here, rather than in + c_common_post_options, so that a subsequent -Wno-endif-labels + is not overridden. */ + case OPT_pedantic_errors: + case OPT_pedantic: + cpp_opts->pedantic = 1; + cpp_opts->warn_endif_labels = 1; + if (warn_pointer_sign == -1) + warn_pointer_sign = 1; + if (warn_overlength_strings == -1) + warn_overlength_strings = 1; + if (warn_main == -1) + warn_main = 2; + break; + + case OPT_print_objc_runtime_info: + print_struct_values = 1; + break; + + case OPT_print_pch_checksum: + c_common_print_pch_checksum (stdout); + exit_after_options = true; + break; + + case OPT_remap: + cpp_opts->remap = 1; + break; + + case OPT_std_c__98: + case OPT_std_gnu__98: + if (!preprocessing_asm_p) + set_std_cxx98 (code == OPT_std_c__98 /* ISO */); + break; + + case OPT_std_c__0x: + case OPT_std_gnu__0x: + if (!preprocessing_asm_p) + set_std_cxx0x (code == OPT_std_c__0x /* ISO */); + break; + + case OPT_std_c89: + case OPT_std_c90: + case OPT_std_iso9899_1990: + case OPT_std_iso9899_199409: + if (!preprocessing_asm_p) + set_std_c89 (code == OPT_std_iso9899_199409 /* c94 */, true /* ISO */); + break; + + case OPT_std_gnu89: + case OPT_std_gnu90: + if (!preprocessing_asm_p) + set_std_c89 (false /* c94 */, false /* ISO */); + break; + + case OPT_std_c99: + case OPT_std_c9x: + case OPT_std_iso9899_1999: + case OPT_std_iso9899_199x: + if (!preprocessing_asm_p) + set_std_c99 (true /* ISO */); + break; + + case OPT_std_gnu99: + case OPT_std_gnu9x: + if (!preprocessing_asm_p) + set_std_c99 (false /* ISO */); + break; + + case OPT_std_c1x: + if (!preprocessing_asm_p) + set_std_c1x (true /* ISO */); + break; + + case OPT_std_gnu1x: + if (!preprocessing_asm_p) + set_std_c1x (false /* ISO */); + break; + + case OPT_trigraphs: + cpp_opts->trigraphs = 1; + break; + + case OPT_traditional_cpp: + cpp_opts->traditional = 1; + break; + + case OPT_v: + verbose = true; + break; + + case OPT_Wabi: + warn_psabi = value; + break; + } + + return result; +} + +/* Post-switch processing. */ +bool +c_common_post_options (const char **pfilename) +{ + struct cpp_callbacks *cb; + + /* Canonicalize the input and output filenames. */ + if (in_fnames == NULL) + { + in_fnames = XNEWVEC (const char *, 1); + in_fnames[0] = ""; + } + else if (strcmp (in_fnames[0], "-") == 0) + in_fnames[0] = ""; + + if (out_fname == NULL || !strcmp (out_fname, "-")) + out_fname = ""; + + if (cpp_opts->deps.style == DEPS_NONE) + check_deps_environment_vars (); + + handle_deferred_opts (); + + sanitize_cpp_opts (); + + register_include_chains (parse_in, sysroot, iprefix, imultilib, + std_inc, std_cxx_inc && c_dialect_cxx (), verbose); + +#ifdef C_COMMON_OVERRIDE_OPTIONS + /* Some machines may reject certain combinations of C + language-specific options. */ + C_COMMON_OVERRIDE_OPTIONS; +#endif + + /* Excess precision other than "fast" requires front-end + support. */ + if (c_dialect_cxx ()) + { + if (flag_excess_precision_cmdline == EXCESS_PRECISION_STANDARD + && TARGET_FLT_EVAL_METHOD_NON_DEFAULT) + sorry ("-fexcess-precision=standard for C++"); + flag_excess_precision_cmdline = EXCESS_PRECISION_FAST; + } + else if (flag_excess_precision_cmdline == EXCESS_PRECISION_DEFAULT) + flag_excess_precision_cmdline = (flag_iso + ? EXCESS_PRECISION_STANDARD + : EXCESS_PRECISION_FAST); + + /* By default we use C99 inline semantics in GNU99 or C99 mode. C99 + inline semantics are not supported in GNU89 or C89 mode. */ + if (flag_gnu89_inline == -1) + flag_gnu89_inline = !flag_isoc99; + else if (!flag_gnu89_inline && !flag_isoc99) + error ("-fno-gnu89-inline is only supported in GNU99 or C99 mode"); + + /* Default to ObjC sjlj exception handling if NeXT runtime. */ + if (flag_objc_sjlj_exceptions < 0) + flag_objc_sjlj_exceptions = flag_next_runtime; + if (flag_objc_exceptions && !flag_objc_sjlj_exceptions) + flag_exceptions = 1; + + /* -Wextra implies the following flags + unless explicitly overridden. */ + if (warn_type_limits == -1) + warn_type_limits = extra_warnings; + if (warn_clobbered == -1) + warn_clobbered = extra_warnings; + if (warn_empty_body == -1) + warn_empty_body = extra_warnings; + if (warn_sign_compare == -1) + warn_sign_compare = extra_warnings; + if (warn_missing_field_initializers == -1) + warn_missing_field_initializers = extra_warnings; + if (warn_missing_parameter_type == -1) + warn_missing_parameter_type = extra_warnings; + if (warn_old_style_declaration == -1) + warn_old_style_declaration = extra_warnings; + if (warn_override_init == -1) + warn_override_init = extra_warnings; + if (warn_ignored_qualifiers == -1) + warn_ignored_qualifiers = extra_warnings; + + /* -Wpointer-sign is disabled by default, but it is enabled if any + of -Wall or -pedantic are given. */ + if (warn_pointer_sign == -1) + warn_pointer_sign = 0; + + if (warn_strict_aliasing == -1) + warn_strict_aliasing = 0; + if (warn_strict_overflow == -1) + warn_strict_overflow = 0; + if (warn_jump_misses_init == -1) + warn_jump_misses_init = 0; + + /* -Woverlength-strings is off by default, but is enabled by -pedantic. + It is never enabled in C++, as the minimum limit is not normative + in that standard. */ + if (warn_overlength_strings == -1 || c_dialect_cxx ()) + warn_overlength_strings = 0; + + /* Wmain is enabled by default in C++ but not in C. */ + /* Wmain is disabled by default for -ffreestanding (!flag_hosted), + even if -Wall was given (warn_main will be 2 if set by -Wall, 1 + if set by -Wmain). */ + if (warn_main == -1) + warn_main = (c_dialect_cxx () && flag_hosted) ? 1 : 0; + else if (warn_main == 2) + warn_main = flag_hosted ? 1 : 0; + + /* In C, -Wconversion enables -Wsign-conversion (unless disabled + through -Wno-sign-conversion). While in C++, + -Wsign-conversion needs to be requested explicitly. */ + if (warn_sign_conversion == -1) + warn_sign_conversion = (c_dialect_cxx ()) ? 0 : warn_conversion; + + /* In C, -Wall and -Wc++-compat enable -Wenum-compare, which we do + in c_common_handle_option; if it has not yet been set, it is + disabled by default. In C++, it is enabled by default. */ + if (warn_enum_compare == -1) + warn_enum_compare = c_dialect_cxx () ? 1 : 0; + + /* -Wpacked-bitfield-compat is on by default for the C languages. The + warning is issued in stor-layout.c which is not part of the front-end so + we need to selectively turn it on here. */ + if (warn_packed_bitfield_compat == -1) + warn_packed_bitfield_compat = 1; + + /* Special format checking options don't work without -Wformat; warn if + they are used. */ + if (!warn_format) + { + warning (OPT_Wformat_y2k, + "-Wformat-y2k ignored without -Wformat"); + warning (OPT_Wformat_extra_args, + "-Wformat-extra-args ignored without -Wformat"); + warning (OPT_Wformat_zero_length, + "-Wformat-zero-length ignored without -Wformat"); + warning (OPT_Wformat_nonliteral, + "-Wformat-nonliteral ignored without -Wformat"); + warning (OPT_Wformat_contains_nul, + "-Wformat-contains-nul ignored without -Wformat"); + warning (OPT_Wformat_security, + "-Wformat-security ignored without -Wformat"); + } + + if (warn_implicit == -1) + warn_implicit = 0; + + if (warn_implicit_int == -1) + warn_implicit_int = 0; + + /* -Wimplicit-function-declaration is enabled by default for C99. */ + if (warn_implicit_function_declaration == -1) + warn_implicit_function_declaration = flag_isoc99; + + /* If we're allowing C++0x constructs, don't warn about C++0x + compatibility problems. */ + if (cxx_dialect == cxx0x) + warn_cxx0x_compat = 0; + + if (flag_preprocess_only) + { + /* Open the output now. We must do so even if flag_no_output is + on, because there may be other output than from the actual + preprocessing (e.g. from -dM). */ + if (out_fname[0] == '\0') + out_stream = stdout; + else + out_stream = fopen (out_fname, "w"); + + if (out_stream == NULL) + { + fatal_error ("opening output file %s: %m", out_fname); + return false; + } + + if (num_in_fnames > 1) + error ("too many filenames given. Type %s --help for usage", + progname); + + init_pp_output (out_stream); + } + else + { + init_c_lex (); + + /* Yuk. WTF is this? I do know ObjC relies on it somewhere. */ + input_location = UNKNOWN_LOCATION; + } + + cb = cpp_get_callbacks (parse_in); + cb->file_change = cb_file_change; + cb->dir_change = cb_dir_change; + cpp_post_options (parse_in); + + input_location = UNKNOWN_LOCATION; + + *pfilename = this_input_filename + = cpp_read_main_file (parse_in, in_fnames[0]); + /* Don't do any compilation or preprocessing if there is no input file. */ + if (this_input_filename == NULL) + { + errorcount++; + return false; + } + + if (flag_working_directory + && flag_preprocess_only && !flag_no_line_commands) + pp_dir_change (parse_in, get_src_pwd ()); + + return flag_preprocess_only; +} + +/* Front end initialization common to C, ObjC and C++. */ +bool +c_common_init (void) +{ + /* Set up preprocessor arithmetic. Must be done after call to + c_common_nodes_and_builtins for type nodes to be good. */ + cpp_opts->precision = TYPE_PRECISION (intmax_type_node); + cpp_opts->char_precision = TYPE_PRECISION (char_type_node); + cpp_opts->int_precision = TYPE_PRECISION (integer_type_node); + cpp_opts->wchar_precision = TYPE_PRECISION (wchar_type_node); + cpp_opts->unsigned_wchar = TYPE_UNSIGNED (wchar_type_node); + cpp_opts->bytes_big_endian = BYTES_BIG_ENDIAN; + + /* This can't happen until after wchar_precision and bytes_big_endian + are known. */ + cpp_init_iconv (parse_in); + + if (version_flag) + c_common_print_pch_checksum (stderr); + + /* Has to wait until now so that cpplib has its hash table. */ + init_pragma (); + + if (flag_preprocess_only) + { + finish_options (); + preprocess_file (parse_in); + return false; + } + + return true; +} + +/* Initialize the integrated preprocessor after debug output has been + initialized; loop over each input file. */ +void +c_common_parse_file (int set_yydebug) +{ + unsigned int i; + + if (set_yydebug) + switch (c_language) + { + case clk_c: + warning(0, "The C parser does not support -dy, option ignored"); + break; + case clk_objc: + warning(0, + "The Objective-C parser does not support -dy, option ignored"); + break; + case clk_cxx: + warning(0, "The C++ parser does not support -dy, option ignored"); + break; + case clk_objcxx: + warning(0, + "The Objective-C++ parser does not support -dy, option ignored"); + break; + default: + gcc_unreachable (); + } + + i = 0; + for (;;) + { + finish_options (); + pch_init (); + push_file_scope (); + c_parse_file (); + finish_file (); + pop_file_scope (); + /* And end the main input file, if the debug writer wants it */ + if (debug_hooks->start_end_main_source_file) + (*debug_hooks->end_source_file) (0); + if (++i >= num_in_fnames) + break; + cpp_undef_all (parse_in); + cpp_clear_file_cache (parse_in); + this_input_filename + = cpp_read_main_file (parse_in, in_fnames[i]); + /* If an input file is missing, abandon further compilation. + cpplib has issued a diagnostic. */ + if (!this_input_filename) + break; + } +} + +/* Common finish hook for the C, ObjC and C++ front ends. */ +void +c_common_finish (void) +{ + FILE *deps_stream = NULL; + + /* Don't write the deps file if there are errors. */ + if (cpp_opts->deps.style != DEPS_NONE && !seen_error ()) + { + /* If -M or -MM was seen without -MF, default output to the + output stream. */ + if (!deps_file) + deps_stream = out_stream; + else + { + deps_stream = fopen (deps_file, deps_append ? "a": "w"); + if (!deps_stream) + fatal_error ("opening dependency file %s: %m", deps_file); + } + } + + /* For performance, avoid tearing down cpplib's internal structures + with cpp_destroy (). */ + cpp_finish (parse_in, deps_stream); + + if (deps_stream && deps_stream != out_stream + && (ferror (deps_stream) || fclose (deps_stream))) + fatal_error ("closing dependency file %s: %m", deps_file); + + if (out_stream && (ferror (out_stream) || fclose (out_stream))) + fatal_error ("when writing output to %s: %m", out_fname); +} + +/* Either of two environment variables can specify output of + dependencies. Their value is either "OUTPUT_FILE" or "OUTPUT_FILE + DEPS_TARGET", where OUTPUT_FILE is the file to write deps info to + and DEPS_TARGET is the target to mention in the deps. They also + result in dependency information being appended to the output file + rather than overwriting it, and like Sun's compiler + SUNPRO_DEPENDENCIES suppresses the dependency on the main file. */ +static void +check_deps_environment_vars (void) +{ + char *spec; + + GET_ENVIRONMENT (spec, "DEPENDENCIES_OUTPUT"); + if (spec) + cpp_opts->deps.style = DEPS_USER; + else + { + GET_ENVIRONMENT (spec, "SUNPRO_DEPENDENCIES"); + if (spec) + { + cpp_opts->deps.style = DEPS_SYSTEM; + cpp_opts->deps.ignore_main_file = true; + } + } + + if (spec) + { + /* Find the space before the DEPS_TARGET, if there is one. */ + char *s = strchr (spec, ' '); + if (s) + { + /* Let the caller perform MAKE quoting. */ + defer_opt (OPT_MT, s + 1); + *s = '\0'; + } + + /* Command line -MF overrides environment variables and default. */ + if (!deps_file) + deps_file = spec; + + deps_append = 1; + deps_seen = true; + } +} + +/* Handle deferred command line switches. */ +static void +handle_deferred_opts (void) +{ + size_t i; + struct deps *deps; + + /* Avoid allocating the deps buffer if we don't need it. + (This flag may be true without there having been -MT or -MQ + options, but we'll still need the deps buffer.) */ + if (!deps_seen) + return; + + deps = cpp_get_deps (parse_in); + + for (i = 0; i < deferred_count; i++) + { + struct deferred_opt *opt = &deferred_opts[i]; + + if (opt->code == OPT_MT || opt->code == OPT_MQ) + deps_add_target (deps, opt->arg, opt->code == OPT_MQ); + } +} + +/* These settings are appropriate for GCC, but not necessarily so for + cpplib as a library. */ +static void +sanitize_cpp_opts (void) +{ + /* If we don't know what style of dependencies to output, complain + if any other dependency switches have been given. */ + if (deps_seen && cpp_opts->deps.style == DEPS_NONE) + error ("to generate dependencies you must specify either -M or -MM"); + + /* -dM and dependencies suppress normal output; do it here so that + the last -d[MDN] switch overrides earlier ones. */ + if (flag_dump_macros == 'M') + flag_no_output = 1; + + /* By default, -fdirectives-only implies -dD. This allows subsequent phases + to perform proper macro expansion. */ + if (cpp_opts->directives_only && !cpp_opts->preprocessed && !flag_dump_macros) + flag_dump_macros = 'D'; + + /* Disable -dD, -dN and -dI if normal output is suppressed. Allow + -dM since at least glibc relies on -M -dM to work. */ + /* Also, flag_no_output implies flag_no_line_commands, always. */ + if (flag_no_output) + { + if (flag_dump_macros != 'M') + flag_dump_macros = 0; + flag_dump_includes = 0; + flag_no_line_commands = 1; + } + else if (cpp_opts->deps.missing_files) + error ("-MG may only be used with -M or -MM"); + + cpp_opts->unsigned_char = !flag_signed_char; + cpp_opts->stdc_0_in_system_headers = STDC_0_IN_SYSTEM_HEADERS; + + /* Wlong-long is disabled by default. It is enabled by: + [-pedantic | -Wtraditional] -std=[gnu|c]++98 ; or + [-pedantic | -Wtraditional] -std=non-c99 . + + Either -Wlong-long or -Wno-long-long override any other settings. */ + if (warn_long_long == -1) + warn_long_long = ((pedantic || warn_traditional) + && (c_dialect_cxx () ? cxx_dialect == cxx98 : !flag_isoc99)); + cpp_opts->warn_long_long = warn_long_long; + + /* Similarly with -Wno-variadic-macros. No check for c99 here, since + this also turns off warnings about GCCs extension. */ + cpp_opts->warn_variadic_macros + = warn_variadic_macros && (pedantic || warn_traditional); + + /* If we're generating preprocessor output, emit current directory + if explicitly requested or if debugging information is enabled. + ??? Maybe we should only do it for debugging formats that + actually output the current directory? */ + if (flag_working_directory == -1) + flag_working_directory = (debug_info_level != DINFO_LEVEL_NONE); + + if (cpp_opts->directives_only) + { + if (warn_unused_macros) + error ("-fdirectives-only is incompatible with -Wunused_macros"); + if (cpp_opts->traditional) + error ("-fdirectives-only is incompatible with -traditional"); + } +} + +/* Add include path with a prefix at the front of its name. */ +static void +add_prefixed_path (const char *suffix, size_t chain) +{ + char *path; + const char *prefix; + size_t prefix_len, suffix_len; + + suffix_len = strlen (suffix); + prefix = iprefix ? iprefix : cpp_GCC_INCLUDE_DIR; + prefix_len = iprefix ? strlen (iprefix) : cpp_GCC_INCLUDE_DIR_len; + + path = (char *) xmalloc (prefix_len + suffix_len + 1); + memcpy (path, prefix, prefix_len); + memcpy (path + prefix_len, suffix, suffix_len); + path[prefix_len + suffix_len] = '\0'; + + add_path (path, chain, 0, false); +} + +/* Handle -D, -U, -A, -imacros, and the first -include. */ +static void +finish_options (void) +{ + if (!cpp_opts->preprocessed) + { + size_t i; + + cb_file_change (parse_in, + linemap_add (line_table, LC_RENAME, 0, + _(""), 0)); + + cpp_init_builtins (parse_in, flag_hosted); + c_cpp_builtins (parse_in); + + /* We're about to send user input to cpplib, so make it warn for + things that we previously (when we sent it internal definitions) + told it to not warn. + + C99 permits implementation-defined characters in identifiers. + The documented meaning of -std= is to turn off extensions that + conflict with the specified standard, and since a strictly + conforming program cannot contain a '$', we do not condition + their acceptance on the -std= setting. */ + cpp_opts->warn_dollars = (cpp_opts->pedantic && !cpp_opts->c99); + + cb_file_change (parse_in, + linemap_add (line_table, LC_RENAME, 0, + _(""), 0)); + + for (i = 0; i < deferred_count; i++) + { + struct deferred_opt *opt = &deferred_opts[i]; + + if (opt->code == OPT_D) + cpp_define (parse_in, opt->arg); + else if (opt->code == OPT_U) + cpp_undef (parse_in, opt->arg); + else if (opt->code == OPT_A) + { + if (opt->arg[0] == '-') + cpp_unassert (parse_in, opt->arg + 1); + else + cpp_assert (parse_in, opt->arg); + } + } + + /* Start the main input file, if the debug writer wants it. */ + if (debug_hooks->start_end_main_source_file + && !flag_preprocess_only) + (*debug_hooks->start_source_file) (0, this_input_filename); + + /* Handle -imacros after -D and -U. */ + for (i = 0; i < deferred_count; i++) + { + struct deferred_opt *opt = &deferred_opts[i]; + + if (opt->code == OPT_imacros + && cpp_push_include (parse_in, opt->arg)) + { + /* Disable push_command_line_include callback for now. */ + include_cursor = deferred_count + 1; + cpp_scan_nooutput (parse_in); + } + } + } + else + { + if (cpp_opts->directives_only) + cpp_init_special_builtins (parse_in); + + /* Start the main input file, if the debug writer wants it. */ + if (debug_hooks->start_end_main_source_file + && !flag_preprocess_only) + (*debug_hooks->start_source_file) (0, this_input_filename); + } + + include_cursor = 0; + push_command_line_include (); +} + +/* Give CPP the next file given by -include, if any. */ +static void +push_command_line_include (void) +{ + while (include_cursor < deferred_count) + { + struct deferred_opt *opt = &deferred_opts[include_cursor++]; + + if (!cpp_opts->preprocessed && opt->code == OPT_include + && cpp_push_include (parse_in, opt->arg)) + return; + } + + if (include_cursor == deferred_count) + { + include_cursor++; + /* -Wunused-macros should only warn about macros defined hereafter. */ + cpp_opts->warn_unused_macros = warn_unused_macros; + /* Restore the line map from . */ + if (!cpp_opts->preprocessed) + cpp_change_file (parse_in, LC_RENAME, this_input_filename); + + /* Set this here so the client can change the option if it wishes, + and after stacking the main file so we don't trace the main file. */ + line_table->trace_includes = cpp_opts->print_include_names; + } +} + +/* File change callback. Has to handle -include files. */ +static void +cb_file_change (cpp_reader * ARG_UNUSED (pfile), + const struct line_map *new_map) +{ + if (flag_preprocess_only) + pp_file_change (new_map); + else + fe_file_change (new_map); + + if (new_map == 0 || (new_map->reason == LC_LEAVE && MAIN_FILE_P (new_map))) + push_command_line_include (); +} + +void +cb_dir_change (cpp_reader * ARG_UNUSED (pfile), const char *dir) +{ + if (!set_src_pwd (dir)) + warning (0, "too late for # directive to set debug directory"); +} + +/* Set the C 89 standard (with 1994 amendments if C94, without GNU + extensions if ISO). There is no concept of gnu94. */ +static void +set_std_c89 (int c94, int iso) +{ + cpp_set_lang (parse_in, c94 ? CLK_STDC94: iso ? CLK_STDC89: CLK_GNUC89); + flag_iso = iso; + flag_no_asm = iso; + flag_no_gnu_keywords = iso; + flag_no_nonansi_builtin = iso; + flag_isoc94 = c94; + flag_isoc99 = 0; + flag_isoc1x = 0; +} + +/* Set the C 99 standard (without GNU extensions if ISO). */ +static void +set_std_c99 (int iso) +{ + cpp_set_lang (parse_in, iso ? CLK_STDC99: CLK_GNUC99); + flag_no_asm = iso; + flag_no_nonansi_builtin = iso; + flag_iso = iso; + flag_isoc1x = 0; + flag_isoc99 = 1; + flag_isoc94 = 1; +} + +/* Set the C 1X standard draft (without GNU extensions if ISO). */ +static void +set_std_c1x (int iso) +{ + cpp_set_lang (parse_in, iso ? CLK_STDC1X: CLK_GNUC1X); + flag_no_asm = iso; + flag_no_nonansi_builtin = iso; + flag_iso = iso; + flag_isoc1x = 1; + flag_isoc99 = 1; + flag_isoc94 = 1; +} + +/* Set the C++ 98 standard (without GNU extensions if ISO). */ +static void +set_std_cxx98 (int iso) +{ + cpp_set_lang (parse_in, iso ? CLK_CXX98: CLK_GNUCXX); + flag_no_gnu_keywords = iso; + flag_no_nonansi_builtin = iso; + flag_iso = iso; + cxx_dialect = cxx98; +} + +/* Set the C++ 0x working draft "standard" (without GNU extensions if ISO). */ +static void +set_std_cxx0x (int iso) +{ + cpp_set_lang (parse_in, iso ? CLK_CXX0X: CLK_GNUCXX0X); + flag_no_gnu_keywords = iso; + flag_no_nonansi_builtin = iso; + flag_iso = iso; + cxx_dialect = cxx0x; +} + +/* Args to -d specify what to dump. Silently ignore + unrecognized options; they may be aimed at toplev.c. */ +static void +handle_OPT_d (const char *arg) +{ + char c; + + while ((c = *arg++) != '\0') + switch (c) + { + case 'M': /* Dump macros only. */ + case 'N': /* Dump names. */ + case 'D': /* Dump definitions. */ + case 'U': /* Dump used macros. */ + flag_dump_macros = c; + break; + + case 'I': + flag_dump_includes = 1; + break; + } +} diff --git a/gcc/c-family/c-pch.c b/gcc/c-family/c-pch.c new file mode 100644 index 00000000000..951ab1fc303 --- /dev/null +++ b/gcc/c-family/c-pch.c @@ -0,0 +1,517 @@ +/* Precompiled header implementation for the C languages. + Copyright (C) 2000, 2002, 2003, 2004, 2005, 2007, 2008, 2009, 2010 + 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 3, 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 COPYING3. If not see +. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "version.h" +#include "cpplib.h" +#include "tree.h" +#include "flags.h" +#include "c-common.h" +#include "output.h" +#include "toplev.h" +#include "debug.h" +#include "c-pragma.h" +#include "ggc.h" +#include "langhooks.h" +#include "hosthooks.h" +#include "target.h" +#include "opts.h" +#include "timevar.h" + +/* This is a list of flag variables that must match exactly, and their + names for the error message. The possible values for *flag_var must + fit in a 'signed char'. */ + +static const struct c_pch_matching +{ + int *flag_var; + const char *flag_name; +} pch_matching[] = { + { &flag_exceptions, "-fexceptions" }, +}; + +enum { + MATCH_SIZE = ARRAY_SIZE (pch_matching) +}; + +/* The value of the checksum in the dummy compiler that is actually + checksummed. That compiler should never be run. */ +static const char no_checksum[16] = { 0 }; + +/* Information about flags and suchlike that affect PCH validity. + + Before this structure is read, both an initial 8-character identification + string, and a 16-byte checksum, have been read and validated. */ + +struct c_pch_validity +{ + unsigned char debug_info_type; + signed char match[MATCH_SIZE]; + void (*pch_init) (void); + size_t target_data_length; +}; + +struct c_pch_header +{ + unsigned long asm_size; +}; + +#define IDENT_LENGTH 8 + +/* The file we'll be writing the PCH to. */ +static FILE *pch_outfile; + +/* The position in the assembler output file when pch_init was called. */ +static long asm_file_startpos; + +static const char *get_ident (void); + +/* Compute an appropriate 8-byte magic number for the PCH file, so that + utilities like file(1) can identify it, and so that GCC can quickly + ignore non-PCH files and PCH files that are of a completely different + format. */ + +static const char * +get_ident (void) +{ + static char result[IDENT_LENGTH]; + static const char templ[] = "gpch.013"; + static const char c_language_chars[] = "Co+O"; + + memcpy (result, templ, IDENT_LENGTH); + result[4] = c_language_chars[c_language]; + + return result; +} + +/* Prepare to write a PCH file, if one is being written. This is + called at the start of compilation. + + Also, print out the executable checksum if -fverbose-asm is in effect. */ + +void +pch_init (void) +{ + FILE *f; + struct c_pch_validity v; + void *target_validity; + static const char partial_pch[] = "gpcWrite"; + +#ifdef ASM_COMMENT_START + if (flag_verbose_asm) + { + fprintf (asm_out_file, "%s ", ASM_COMMENT_START); + c_common_print_pch_checksum (asm_out_file); + fputc ('\n', asm_out_file); + } +#endif + + if (!pch_file) + return; + + f = fopen (pch_file, "w+b"); + if (f == NULL) + fatal_error ("can%'t create precompiled header %s: %m", pch_file); + pch_outfile = f; + + gcc_assert (memcmp (executable_checksum, no_checksum, 16) != 0); + + memset (&v, '\0', sizeof (v)); + v.debug_info_type = write_symbols; + { + size_t i; + for (i = 0; i < MATCH_SIZE; i++) + { + v.match[i] = *pch_matching[i].flag_var; + gcc_assert (v.match[i] == *pch_matching[i].flag_var); + } + } + v.pch_init = &pch_init; + target_validity = targetm.get_pch_validity (&v.target_data_length); + + if (fwrite (partial_pch, IDENT_LENGTH, 1, f) != 1 + || fwrite (executable_checksum, 16, 1, f) != 1 + || fwrite (&v, sizeof (v), 1, f) != 1 + || fwrite (target_validity, v.target_data_length, 1, f) != 1) + fatal_error ("can%'t write to %s: %m", pch_file); + + /* We need to be able to re-read the output. */ + /* The driver always provides a valid -o option. */ + if (asm_file_name == NULL + || strcmp (asm_file_name, "-") == 0) + fatal_error ("%qs is not a valid output file", asm_file_name); + + asm_file_startpos = ftell (asm_out_file); + + /* Let the debugging format deal with the PCHness. */ + (*debug_hooks->handle_pch) (0); + + cpp_save_state (parse_in, f); +} + +/* Write the PCH file. This is called at the end of a compilation which + will produce a PCH file. */ + +void +c_common_write_pch (void) +{ + char *buf; + long asm_file_end; + long written; + struct c_pch_header h; + + timevar_push (TV_PCH_SAVE); + + (*debug_hooks->handle_pch) (1); + + cpp_write_pch_deps (parse_in, pch_outfile); + + asm_file_end = ftell (asm_out_file); + h.asm_size = asm_file_end - asm_file_startpos; + + if (fwrite (&h, sizeof (h), 1, pch_outfile) != 1) + fatal_error ("can%'t write %s: %m", pch_file); + + buf = XNEWVEC (char, 16384); + + if (fseek (asm_out_file, asm_file_startpos, SEEK_SET) != 0) + fatal_error ("can%'t seek in %s: %m", asm_file_name); + + for (written = asm_file_startpos; written < asm_file_end; ) + { + long size = asm_file_end - written; + if (size > 16384) + size = 16384; + if (fread (buf, size, 1, asm_out_file) != 1) + fatal_error ("can%'t read %s: %m", asm_file_name); + if (fwrite (buf, size, 1, pch_outfile) != 1) + fatal_error ("can%'t write %s: %m", pch_file); + written += size; + } + free (buf); + /* asm_out_file can be written afterwards, so fseek to clear + _IOREAD flag. */ + if (fseek (asm_out_file, 0, SEEK_END) != 0) + fatal_error ("can%'t seek in %s: %m", asm_file_name); + + gt_pch_save (pch_outfile); + + timevar_push (TV_PCH_CPP_SAVE); + cpp_write_pch_state (parse_in, pch_outfile); + timevar_pop (TV_PCH_CPP_SAVE); + + if (fseek (pch_outfile, 0, SEEK_SET) != 0 + || fwrite (get_ident (), IDENT_LENGTH, 1, pch_outfile) != 1) + fatal_error ("can%'t write %s: %m", pch_file); + + fclose (pch_outfile); + + timevar_pop (TV_PCH_SAVE); +} + +/* Check the PCH file called NAME, open on FD, to see if it can be + used in this compilation. Return 1 if valid, 0 if the file can't + be used now but might be if it's seen later in the compilation, and + 2 if this file could never be used in the compilation. */ + +int +c_common_valid_pch (cpp_reader *pfile, const char *name, int fd) +{ + int sizeread; + int result; + char ident[IDENT_LENGTH + 16]; + const char *pch_ident; + struct c_pch_validity v; + + /* Perform a quick test of whether this is a valid + precompiled header for the current language. */ + + gcc_assert (memcmp (executable_checksum, no_checksum, 16) != 0); + + sizeread = read (fd, ident, IDENT_LENGTH + 16); + if (sizeread == -1) + fatal_error ("can%'t read %s: %m", name); + else if (sizeread != IDENT_LENGTH + 16) + { + if (cpp_get_options (pfile)->warn_invalid_pch) + cpp_error (pfile, CPP_DL_WARNING, "%s: too short to be a PCH file", + name); + return 2; + } + + pch_ident = get_ident(); + if (memcmp (ident, pch_ident, IDENT_LENGTH) != 0) + { + if (cpp_get_options (pfile)->warn_invalid_pch) + { + if (memcmp (ident, pch_ident, 5) == 0) + /* It's a PCH, for the right language, but has the wrong version. + */ + cpp_error (pfile, CPP_DL_WARNING, + "%s: not compatible with this GCC version", name); + else if (memcmp (ident, pch_ident, 4) == 0) + /* It's a PCH for the wrong language. */ + cpp_error (pfile, CPP_DL_WARNING, "%s: not for %s", name, + lang_hooks.name); + else + /* Not any kind of PCH. */ + cpp_error (pfile, CPP_DL_WARNING, "%s: not a PCH file", name); + } + return 2; + } + if (memcmp (ident + IDENT_LENGTH, executable_checksum, 16) != 0) + { + if (cpp_get_options (pfile)->warn_invalid_pch) + cpp_error (pfile, CPP_DL_WARNING, + "%s: created by a different GCC executable", name); + return 2; + } + + /* At this point, we know it's a PCH file created by this + executable, so it ought to be long enough that we can read a + c_pch_validity structure. */ + if (read (fd, &v, sizeof (v)) != sizeof (v)) + fatal_error ("can%'t read %s: %m", name); + + /* The allowable debug info combinations are that either the PCH file + was built with the same as is being used now, or the PCH file was + built for some kind of debug info but now none is in use. */ + if (v.debug_info_type != write_symbols + && write_symbols != NO_DEBUG) + { + if (cpp_get_options (pfile)->warn_invalid_pch) + cpp_error (pfile, CPP_DL_WARNING, + "%s: created with -g%s, but used with -g%s", name, + debug_type_names[v.debug_info_type], + debug_type_names[write_symbols]); + return 2; + } + + /* Check flags that must match exactly. */ + { + size_t i; + for (i = 0; i < MATCH_SIZE; i++) + if (*pch_matching[i].flag_var != v.match[i]) + { + if (cpp_get_options (pfile)->warn_invalid_pch) + cpp_error (pfile, CPP_DL_WARNING, + "%s: settings for %s do not match", name, + pch_matching[i].flag_name); + return 2; + } + } + + /* If the text segment was not loaded at the same address as it was + when the PCH file was created, function pointers loaded from the + PCH will not be valid. We could in theory remap all the function + pointers, but no support for that exists at present. + Since we have the same executable, it should only be necessary to + check one function. */ + if (v.pch_init != &pch_init) + { + if (cpp_get_options (pfile)->warn_invalid_pch) + cpp_error (pfile, CPP_DL_WARNING, + "%s: had text segment at different address", name); + return 2; + } + + /* Check the target-specific validity data. */ + { + void *this_file_data = xmalloc (v.target_data_length); + const char *msg; + + if ((size_t) read (fd, this_file_data, v.target_data_length) + != v.target_data_length) + fatal_error ("can%'t read %s: %m", name); + msg = targetm.pch_valid_p (this_file_data, v.target_data_length); + free (this_file_data); + if (msg != NULL) + { + if (cpp_get_options (pfile)->warn_invalid_pch) + cpp_error (pfile, CPP_DL_WARNING, "%s: %s", name, msg); + return 2; + } + } + + /* Check the preprocessor macros are the same as when the PCH was + generated. */ + + result = cpp_valid_state (pfile, name, fd); + if (result == -1) + return 2; + else + return result == 0; +} + +/* If non-NULL, this function is called after a precompile header file + is loaded. */ +void (*lang_post_pch_load) (void); + +/* Load in the PCH file NAME, open on FD. It was originally searched for + by ORIG_NAME. */ + +void +c_common_read_pch (cpp_reader *pfile, const char *name, + int fd, const char *orig_name ATTRIBUTE_UNUSED) +{ + FILE *f; + struct c_pch_header h; + struct save_macro_data *smd; + expanded_location saved_loc; + bool saved_trace_includes; + + timevar_push (TV_PCH_RESTORE); + + f = fdopen (fd, "rb"); + if (f == NULL) + { + cpp_errno (pfile, CPP_DL_ERROR, "calling fdopen"); + close (fd); + goto end; + } + + cpp_get_callbacks (parse_in)->valid_pch = NULL; + + if (fread (&h, sizeof (h), 1, f) != 1) + { + cpp_errno (pfile, CPP_DL_ERROR, "reading"); + fclose (f); + goto end; + } + + if (!flag_preprocess_only) + { + unsigned long written; + char * buf = XNEWVEC (char, 16384); + + for (written = 0; written < h.asm_size; ) + { + long size = h.asm_size - written; + if (size > 16384) + size = 16384; + if (fread (buf, size, 1, f) != 1 + || fwrite (buf, size, 1, asm_out_file) != 1) + cpp_errno (pfile, CPP_DL_ERROR, "reading"); + written += size; + } + free (buf); + } + else + { + /* If we're preprocessing, don't write to a NULL + asm_out_file. */ + if (fseek (f, h.asm_size, SEEK_CUR) != 0) + cpp_errno (pfile, CPP_DL_ERROR, "seeking"); + } + + /* Save the location and then restore it after reading the PCH. */ + saved_loc = expand_location (line_table->highest_line); + saved_trace_includes = line_table->trace_includes; + + timevar_push (TV_PCH_CPP_RESTORE); + cpp_prepare_state (pfile, &smd); + timevar_pop (TV_PCH_CPP_RESTORE); + + gt_pch_restore (f); + + timevar_push (TV_PCH_CPP_RESTORE); + if (cpp_read_state (pfile, name, f, smd) != 0) + { + fclose (f); + timevar_pop (TV_PCH_CPP_RESTORE); + goto end; + } + timevar_pop (TV_PCH_CPP_RESTORE); + + + fclose (f); + + line_table->trace_includes = saved_trace_includes; + cpp_set_line_map (pfile, line_table); + linemap_add (line_table, LC_RENAME, 0, saved_loc.file, saved_loc.line); + + /* Give the front end a chance to take action after a PCH file has + been loaded. */ + if (lang_post_pch_load) + (*lang_post_pch_load) (); + +end: + timevar_pop (TV_PCH_RESTORE); +} + +/* Indicate that no more PCH files should be read. */ + +void +c_common_no_more_pch (void) +{ + if (cpp_get_callbacks (parse_in)->valid_pch) + { + cpp_get_callbacks (parse_in)->valid_pch = NULL; + host_hooks.gt_pch_use_address (NULL, 0, -1, 0); + } +} + +/* Handle #pragma GCC pch_preprocess, to load in the PCH file. */ + +#ifndef O_BINARY +# define O_BINARY 0 +#endif + +void +c_common_pch_pragma (cpp_reader *pfile, const char *name) +{ + int fd; + + if (!cpp_get_options (pfile)->preprocessed) + { + error ("pch_preprocess pragma should only be used with -fpreprocessed"); + inform (input_location, "use #include instead"); + return; + } + + fd = open (name, O_RDONLY | O_BINARY, 0666); + if (fd == -1) + fatal_error ("%s: couldn%'t open PCH file: %m", name); + + if (c_common_valid_pch (pfile, name, fd) != 1) + { + if (!cpp_get_options (pfile)->warn_invalid_pch) + inform (input_location, "use -Winvalid-pch for more information"); + fatal_error ("%s: PCH file was invalid", name); + } + + c_common_read_pch (pfile, name, fd, name); + + close (fd); +} + +/* Print out executable_checksum[]. */ + +void +c_common_print_pch_checksum (FILE *f) +{ + int i; + fputs ("Compiler executable checksum: ", f); + for (i = 0; i < 16; i++) + fprintf (f, "%02x", executable_checksum[i]); + putc ('\n', f); +} diff --git a/gcc/c-family/c-ppoutput.c b/gcc/c-family/c-ppoutput.c new file mode 100644 index 00000000000..1700fae3ed0 --- /dev/null +++ b/gcc/c-family/c-ppoutput.c @@ -0,0 +1,625 @@ +/* Preprocess only, using cpplib. + Copyright (C) 1995, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2007, + 2008, 2009 Free Software Foundation, Inc. + Written by Per Bothner, 1994-95. + + This program is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by the + Free Software Foundation; either version 3, or (at your option) any + later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; see the file COPYING3. If not see + . */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "cpplib.h" +#include "../libcpp/internal.h" +#include "tree.h" +#include "c-common.h" /* For flags. */ +#include "c-pragma.h" /* For parse_in. */ + +/* Encapsulates state used to convert a stream of tokens into a text + file. */ +static struct +{ + FILE *outf; /* Stream to write to. */ + const cpp_token *prev; /* Previous token. */ + const cpp_token *source; /* Source token for spacing. */ + int src_line; /* Line number currently being written. */ + unsigned char printed; /* Nonzero if something output at line. */ + bool first_time; /* pp_file_change hasn't been called yet. */ +} print; + +/* Defined and undefined macros being queued for output with -dU at + the next newline. */ +typedef struct macro_queue +{ + struct macro_queue *next; /* Next macro in the list. */ + char *macro; /* The name of the macro if not + defined, the full definition if + defined. */ +} macro_queue; +static macro_queue *define_queue, *undef_queue; + +/* General output routines. */ +static void scan_translation_unit (cpp_reader *); +static void print_lines_directives_only (int, const void *, size_t); +static void scan_translation_unit_directives_only (cpp_reader *); +static void scan_translation_unit_trad (cpp_reader *); +static void account_for_newlines (const unsigned char *, size_t); +static int dump_macro (cpp_reader *, cpp_hashnode *, void *); +static void dump_queued_macros (cpp_reader *); + +static void print_line (source_location, const char *); +static void maybe_print_line (source_location); +static void do_line_change (cpp_reader *, const cpp_token *, + source_location, int); + +/* Callback routines for the parser. Most of these are active only + in specific modes. */ +static void cb_line_change (cpp_reader *, const cpp_token *, int); +static void cb_define (cpp_reader *, source_location, cpp_hashnode *); +static void cb_undef (cpp_reader *, source_location, cpp_hashnode *); +static void cb_used_define (cpp_reader *, source_location, cpp_hashnode *); +static void cb_used_undef (cpp_reader *, source_location, cpp_hashnode *); +static void cb_include (cpp_reader *, source_location, const unsigned char *, + const char *, int, const cpp_token **); +static void cb_ident (cpp_reader *, source_location, const cpp_string *); +static void cb_def_pragma (cpp_reader *, source_location); +static void cb_read_pch (cpp_reader *pfile, const char *name, + int fd, const char *orig_name); + +/* Preprocess and output. */ +void +preprocess_file (cpp_reader *pfile) +{ + /* A successful cpp_read_main_file guarantees that we can call + cpp_scan_nooutput or cpp_get_token next. */ + if (flag_no_output) + { + /* Scan -included buffers, then the main file. */ + while (pfile->buffer->prev) + cpp_scan_nooutput (pfile); + cpp_scan_nooutput (pfile); + } + else if (cpp_get_options (pfile)->traditional) + scan_translation_unit_trad (pfile); + else if (cpp_get_options (pfile)->directives_only + && !cpp_get_options (pfile)->preprocessed) + scan_translation_unit_directives_only (pfile); + else + scan_translation_unit (pfile); + + /* -dM command line option. Should this be elsewhere? */ + if (flag_dump_macros == 'M') + cpp_forall_identifiers (pfile, dump_macro, NULL); + + /* Flush any pending output. */ + if (print.printed) + putc ('\n', print.outf); +} + +/* Set up the callbacks as appropriate. */ +void +init_pp_output (FILE *out_stream) +{ + cpp_callbacks *cb = cpp_get_callbacks (parse_in); + + if (!flag_no_output) + { + cb->line_change = cb_line_change; + /* Don't emit #pragma or #ident directives if we are processing + assembly language; the assembler may choke on them. */ + if (cpp_get_options (parse_in)->lang != CLK_ASM) + { + cb->ident = cb_ident; + cb->def_pragma = cb_def_pragma; + } + } + + if (flag_dump_includes) + cb->include = cb_include; + + if (flag_pch_preprocess) + { + cb->valid_pch = c_common_valid_pch; + cb->read_pch = cb_read_pch; + } + + if (flag_dump_macros == 'N' || flag_dump_macros == 'D') + { + cb->define = cb_define; + cb->undef = cb_undef; + } + + if (flag_dump_macros == 'U') + { + cb->before_define = dump_queued_macros; + cb->used_define = cb_used_define; + cb->used_undef = cb_used_undef; + } + + /* Initialize the print structure. */ + print.src_line = 1; + print.printed = 0; + print.prev = 0; + print.outf = out_stream; + print.first_time = 1; +} + +/* Writes out the preprocessed file, handling spacing and paste + avoidance issues. */ +static void +scan_translation_unit (cpp_reader *pfile) +{ + bool avoid_paste = false; + bool do_line_adjustments + = cpp_get_options (parse_in)->lang != CLK_ASM + && !flag_no_line_commands; + bool in_pragma = false; + + print.source = NULL; + for (;;) + { + source_location loc; + const cpp_token *token = cpp_get_token_with_location (pfile, &loc); + + if (token->type == CPP_PADDING) + { + avoid_paste = true; + if (print.source == NULL + || (!(print.source->flags & PREV_WHITE) + && token->val.source == NULL)) + print.source = token->val.source; + continue; + } + + if (token->type == CPP_EOF) + break; + + /* Subtle logic to output a space if and only if necessary. */ + if (avoid_paste) + { + const struct line_map *map + = linemap_lookup (line_table, loc); + int src_line = SOURCE_LINE (map, loc); + + if (print.source == NULL) + print.source = token; + + if (src_line != print.src_line + && do_line_adjustments + && !in_pragma) + { + do_line_change (pfile, token, loc, false); + putc (' ', print.outf); + } + else if (print.source->flags & PREV_WHITE + || (print.prev + && cpp_avoid_paste (pfile, print.prev, token)) + || (print.prev == NULL && token->type == CPP_HASH)) + putc (' ', print.outf); + } + else if (token->flags & PREV_WHITE) + { + const struct line_map *map + = linemap_lookup (line_table, loc); + int src_line = SOURCE_LINE (map, loc); + + if (src_line != print.src_line + && do_line_adjustments + && !in_pragma) + do_line_change (pfile, token, loc, false); + putc (' ', print.outf); + } + + avoid_paste = false; + print.source = NULL; + print.prev = token; + if (token->type == CPP_PRAGMA) + { + const char *space; + const char *name; + + maybe_print_line (token->src_loc); + fputs ("#pragma ", print.outf); + c_pp_lookup_pragma (token->val.pragma, &space, &name); + if (space) + fprintf (print.outf, "%s %s", space, name); + else + fprintf (print.outf, "%s", name); + print.printed = 1; + in_pragma = true; + } + else if (token->type == CPP_PRAGMA_EOL) + { + maybe_print_line (token->src_loc); + in_pragma = false; + } + else + cpp_output_token (token, print.outf); + + if (token->type == CPP_COMMENT) + account_for_newlines (token->val.str.text, token->val.str.len); + } +} + +static void +print_lines_directives_only (int lines, const void *buf, size_t size) +{ + print.src_line += lines; + fwrite (buf, 1, size, print.outf); +} + +/* Writes out the preprocessed file, handling spacing and paste + avoidance issues. */ +static void +scan_translation_unit_directives_only (cpp_reader *pfile) +{ + struct _cpp_dir_only_callbacks cb; + + cb.print_lines = print_lines_directives_only; + cb.maybe_print_line = maybe_print_line; + + _cpp_preprocess_dir_only (pfile, &cb); +} + +/* Adjust print.src_line for newlines embedded in output. */ +static void +account_for_newlines (const unsigned char *str, size_t len) +{ + while (len--) + if (*str++ == '\n') + print.src_line++; +} + +/* Writes out a traditionally preprocessed file. */ +static void +scan_translation_unit_trad (cpp_reader *pfile) +{ + while (_cpp_read_logical_line_trad (pfile)) + { + size_t len = pfile->out.cur - pfile->out.base; + maybe_print_line (pfile->out.first_line); + fwrite (pfile->out.base, 1, len, print.outf); + print.printed = 1; + if (!CPP_OPTION (pfile, discard_comments)) + account_for_newlines (pfile->out.base, len); + } +} + +/* If the token read on logical line LINE needs to be output on a + different line to the current one, output the required newlines or + a line marker, and return 1. Otherwise return 0. */ +static void +maybe_print_line (source_location src_loc) +{ + const struct line_map *map = linemap_lookup (line_table, src_loc); + int src_line = SOURCE_LINE (map, src_loc); + /* End the previous line of text. */ + if (print.printed) + { + putc ('\n', print.outf); + print.src_line++; + print.printed = 0; + } + + if (src_line >= print.src_line && src_line < print.src_line + 8) + { + while (src_line > print.src_line) + { + putc ('\n', print.outf); + print.src_line++; + } + } + else + print_line (src_loc, ""); +} + +/* Output a line marker for logical line LINE. Special flags are "1" + or "2" indicating entering or leaving a file. */ +static void +print_line (source_location src_loc, const char *special_flags) +{ + /* End any previous line of text. */ + if (print.printed) + putc ('\n', print.outf); + print.printed = 0; + + if (!flag_no_line_commands) + { + const struct line_map *map = linemap_lookup (line_table, src_loc); + + size_t to_file_len = strlen (map->to_file); + unsigned char *to_file_quoted = + (unsigned char *) alloca (to_file_len * 4 + 1); + unsigned char *p; + + print.src_line = SOURCE_LINE (map, src_loc); + + /* cpp_quote_string does not nul-terminate, so we have to do it + ourselves. */ + p = cpp_quote_string (to_file_quoted, + (const unsigned char *) map->to_file, to_file_len); + *p = '\0'; + fprintf (print.outf, "# %u \"%s\"%s", + print.src_line == 0 ? 1 : print.src_line, + to_file_quoted, special_flags); + + if (map->sysp == 2) + fputs (" 3 4", print.outf); + else if (map->sysp == 1) + fputs (" 3", print.outf); + + putc ('\n', print.outf); + } +} + +/* Helper function for cb_line_change and scan_translation_unit. */ +static void +do_line_change (cpp_reader *pfile, const cpp_token *token, + source_location src_loc, int parsing_args) +{ + if (define_queue || undef_queue) + dump_queued_macros (pfile); + + if (token->type == CPP_EOF || parsing_args) + return; + + maybe_print_line (src_loc); + print.prev = 0; + print.source = 0; + + /* Supply enough spaces to put this token in its original column, + one space per column greater than 2, since scan_translation_unit + will provide a space if PREV_WHITE. Don't bother trying to + reconstruct tabs; we can't get it right in general, and nothing + ought to care. Some things do care; the fault lies with them. */ + if (!CPP_OPTION (pfile, traditional)) + { + const struct line_map *map = linemap_lookup (line_table, src_loc); + int spaces = SOURCE_COLUMN (map, src_loc) - 2; + print.printed = 1; + + while (-- spaces >= 0) + putc (' ', print.outf); + } +} + +/* Called when a line of output is started. TOKEN is the first token + of the line, and at end of file will be CPP_EOF. */ +static void +cb_line_change (cpp_reader *pfile, const cpp_token *token, + int parsing_args) +{ + do_line_change (pfile, token, token->src_loc, parsing_args); +} + +static void +cb_ident (cpp_reader *pfile ATTRIBUTE_UNUSED, source_location line, + const cpp_string *str) +{ + maybe_print_line (line); + fprintf (print.outf, "#ident %s\n", str->text); + print.src_line++; +} + +static void +cb_define (cpp_reader *pfile, source_location line, cpp_hashnode *node) +{ + maybe_print_line (line); + fputs ("#define ", print.outf); + + /* 'D' is whole definition; 'N' is name only. */ + if (flag_dump_macros == 'D') + fputs ((const char *) cpp_macro_definition (pfile, node), + print.outf); + else + fputs ((const char *) NODE_NAME (node), print.outf); + + putc ('\n', print.outf); + if (linemap_lookup (line_table, line)->to_line != 0) + print.src_line++; +} + +static void +cb_undef (cpp_reader *pfile ATTRIBUTE_UNUSED, source_location line, + cpp_hashnode *node) +{ + maybe_print_line (line); + fprintf (print.outf, "#undef %s\n", NODE_NAME (node)); + print.src_line++; +} + +static void +cb_used_define (cpp_reader *pfile, source_location line ATTRIBUTE_UNUSED, + cpp_hashnode *node) +{ + macro_queue *q; + if (node->flags & NODE_BUILTIN) + return; + q = XNEW (macro_queue); + q->macro = xstrdup ((const char *) cpp_macro_definition (pfile, node)); + q->next = define_queue; + define_queue = q; +} + +static void +cb_used_undef (cpp_reader *pfile ATTRIBUTE_UNUSED, + source_location line ATTRIBUTE_UNUSED, + cpp_hashnode *node) +{ + macro_queue *q; + q = XNEW (macro_queue); + q->macro = xstrdup ((const char *) NODE_NAME (node)); + q->next = undef_queue; + undef_queue = q; +} + +static void +dump_queued_macros (cpp_reader *pfile ATTRIBUTE_UNUSED) +{ + macro_queue *q; + + /* End the previous line of text. */ + if (print.printed) + { + putc ('\n', print.outf); + print.src_line++; + print.printed = 0; + } + + for (q = define_queue; q;) + { + macro_queue *oq; + fputs ("#define ", print.outf); + fputs (q->macro, print.outf); + putc ('\n', print.outf); + print.src_line++; + oq = q; + q = q->next; + free (oq->macro); + free (oq); + } + define_queue = NULL; + for (q = undef_queue; q;) + { + macro_queue *oq; + fprintf (print.outf, "#undef %s\n", q->macro); + print.src_line++; + oq = q; + q = q->next; + free (oq->macro); + free (oq); + } + undef_queue = NULL; +} + +static void +cb_include (cpp_reader *pfile ATTRIBUTE_UNUSED, source_location line, + const unsigned char *dir, const char *header, int angle_brackets, + const cpp_token **comments) +{ + maybe_print_line (line); + if (angle_brackets) + fprintf (print.outf, "#%s <%s>", dir, header); + else + fprintf (print.outf, "#%s \"%s\"", dir, header); + + if (comments != NULL) + { + while (*comments != NULL) + { + if ((*comments)->flags & PREV_WHITE) + putc (' ', print.outf); + cpp_output_token (*comments, print.outf); + ++comments; + } + } + + putc ('\n', print.outf); + print.src_line++; +} + +/* Callback called when -fworking-director and -E to emit working + directory in cpp output file. */ + +void +pp_dir_change (cpp_reader *pfile ATTRIBUTE_UNUSED, const char *dir) +{ + size_t to_file_len = strlen (dir); + unsigned char *to_file_quoted = + (unsigned char *) alloca (to_file_len * 4 + 1); + unsigned char *p; + + /* cpp_quote_string does not nul-terminate, so we have to do it ourselves. */ + p = cpp_quote_string (to_file_quoted, (const unsigned char *) dir, to_file_len); + *p = '\0'; + fprintf (print.outf, "# 1 \"%s//\"\n", to_file_quoted); +} + +/* The file name, line number or system header flags have changed, as + described in MAP. */ + +void +pp_file_change (const struct line_map *map) +{ + const char *flags = ""; + + if (flag_no_line_commands) + return; + + if (map != NULL) + { + input_location = map->start_location; + if (print.first_time) + { + /* Avoid printing foo.i when the main file is foo.c. */ + if (!cpp_get_options (parse_in)->preprocessed) + print_line (map->start_location, flags); + print.first_time = 0; + } + else + { + /* Bring current file to correct line when entering a new file. */ + if (map->reason == LC_ENTER) + { + const struct line_map *from = INCLUDED_FROM (line_table, map); + maybe_print_line (LAST_SOURCE_LINE_LOCATION (from)); + } + if (map->reason == LC_ENTER) + flags = " 1"; + else if (map->reason == LC_LEAVE) + flags = " 2"; + print_line (map->start_location, flags); + } + } +} + +/* Copy a #pragma directive to the preprocessed output. */ +static void +cb_def_pragma (cpp_reader *pfile, source_location line) +{ + maybe_print_line (line); + fputs ("#pragma ", print.outf); + cpp_output_line (pfile, print.outf); + print.src_line++; +} + +/* Dump out the hash table. */ +static int +dump_macro (cpp_reader *pfile, cpp_hashnode *node, void *v ATTRIBUTE_UNUSED) +{ + if (node->type == NT_MACRO && !(node->flags & NODE_BUILTIN)) + { + fputs ("#define ", print.outf); + fputs ((const char *) cpp_macro_definition (pfile, node), + print.outf); + putc ('\n', print.outf); + print.src_line++; + } + + return 1; +} + +/* Load in the PCH file NAME, open on FD. It was originally searched for + by ORIG_NAME. Also, print out a #include command so that the PCH + file can be loaded when the preprocessed output is compiled. */ + +static void +cb_read_pch (cpp_reader *pfile, const char *name, + int fd, const char *orig_name ATTRIBUTE_UNUSED) +{ + c_common_read_pch (pfile, name, fd, orig_name); + + fprintf (print.outf, "#pragma GCC pch_preprocess \"%s\"\n", name); + print.src_line++; +} diff --git a/gcc/c-family/c-pragma.c b/gcc/c-family/c-pragma.c new file mode 100644 index 00000000000..cea0b267b92 --- /dev/null +++ b/gcc/c-family/c-pragma.c @@ -0,0 +1,1340 @@ +/* Handle #pragma, system V.4 style. Supports #pragma weak and #pragma pack. + Copyright (C) 1992, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008 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 3, 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 COPYING3. If not see +. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tm.h" +#include "tree.h" +#include "function.h" /* For cfun. FIXME: Does the parser know + when it is inside a function, so that + we don't have to look at cfun? */ +#include "cpplib.h" +#include "c-pragma.h" +#include "flags.h" +#include "toplev.h" +#include "c-common.h" +#include "output.h" +#include "tm_p.h" /* For REGISTER_TARGET_PRAGMAS (why is + this not a target hook?). */ +#include "vec.h" +#include "vecprim.h" +#include "target.h" +#include "diagnostic.h" +#include "opts.h" +#include "plugin.h" + +#define GCC_BAD(gmsgid) \ + do { warning (OPT_Wpragmas, gmsgid); return; } while (0) +#define GCC_BAD2(gmsgid, arg) \ + do { warning (OPT_Wpragmas, gmsgid, arg); return; } while (0) + +typedef struct GTY(()) align_stack { + int alignment; + tree id; + struct align_stack * prev; +} align_stack; + +static GTY(()) struct align_stack * alignment_stack; + +#ifdef HANDLE_PRAGMA_PACK +static void handle_pragma_pack (cpp_reader *); + +#ifdef HANDLE_PRAGMA_PACK_PUSH_POP +/* If we have a "global" #pragma pack() in effect when the first + #pragma pack(push,) is encountered, this stores the value of + maximum_field_alignment in effect. When the final pop_alignment() + happens, we restore the value to this, not to a value of 0 for + maximum_field_alignment. Value is in bits. */ +static int default_alignment; +#define SET_GLOBAL_ALIGNMENT(ALIGN) (maximum_field_alignment = *(alignment_stack == NULL \ + ? &default_alignment \ + : &alignment_stack->alignment) = (ALIGN)) + +static void push_alignment (int, tree); +static void pop_alignment (tree); + +/* Push an alignment value onto the stack. */ +static void +push_alignment (int alignment, tree id) +{ + align_stack * entry; + + entry = ggc_alloc_align_stack (); + + entry->alignment = alignment; + entry->id = id; + entry->prev = alignment_stack; + + /* The current value of maximum_field_alignment is not necessarily + 0 since there may be a #pragma pack() in effect; remember it + so that we can restore it after the final #pragma pop(). */ + if (alignment_stack == NULL) + default_alignment = maximum_field_alignment; + + alignment_stack = entry; + + maximum_field_alignment = alignment; +} + +/* Undo a push of an alignment onto the stack. */ +static void +pop_alignment (tree id) +{ + align_stack * entry; + + if (alignment_stack == NULL) + GCC_BAD ("#pragma pack (pop) encountered without matching #pragma pack (push)"); + + /* If we got an identifier, strip away everything above the target + entry so that the next step will restore the state just below it. */ + if (id) + { + for (entry = alignment_stack; entry; entry = entry->prev) + if (entry->id == id) + { + alignment_stack = entry; + break; + } + if (entry == NULL) + warning (OPT_Wpragmas, "\ +#pragma pack(pop, %E) encountered without matching #pragma pack(push, %E)" + , id, id); + } + + entry = alignment_stack->prev; + + maximum_field_alignment = entry ? entry->alignment : default_alignment; + + alignment_stack = entry; +} +#else /* not HANDLE_PRAGMA_PACK_PUSH_POP */ +#define SET_GLOBAL_ALIGNMENT(ALIGN) (maximum_field_alignment = (ALIGN)) +#define push_alignment(ID, N) \ + GCC_BAD ("#pragma pack(push[, id], ) is not supported on this target") +#define pop_alignment(ID) \ + GCC_BAD ("#pragma pack(pop[, id], ) is not supported on this target") +#endif /* HANDLE_PRAGMA_PACK_PUSH_POP */ + +/* #pragma pack () + #pragma pack (N) + + #pragma pack (push) + #pragma pack (push, N) + #pragma pack (push, ID) + #pragma pack (push, ID, N) + #pragma pack (pop) + #pragma pack (pop, ID) */ +static void +handle_pragma_pack (cpp_reader * ARG_UNUSED (dummy)) +{ + tree x, id = 0; + int align = -1; + enum cpp_ttype token; + enum { set, push, pop } action; + + if (pragma_lex (&x) != CPP_OPEN_PAREN) + GCC_BAD ("missing %<(%> after %<#pragma pack%> - ignored"); + + token = pragma_lex (&x); + if (token == CPP_CLOSE_PAREN) + { + action = set; + align = initial_max_fld_align; + } + else if (token == CPP_NUMBER) + { + if (TREE_CODE (x) != INTEGER_CST) + GCC_BAD ("invalid constant in %<#pragma pack%> - ignored"); + align = TREE_INT_CST_LOW (x); + action = set; + if (pragma_lex (&x) != CPP_CLOSE_PAREN) + GCC_BAD ("malformed %<#pragma pack%> - ignored"); + } + else if (token == CPP_NAME) + { +#define GCC_BAD_ACTION do { if (action != pop) \ + GCC_BAD ("malformed %<#pragma pack(push[, id][, ])%> - ignored"); \ + else \ + GCC_BAD ("malformed %<#pragma pack(pop[, id])%> - ignored"); \ + } while (0) + + const char *op = IDENTIFIER_POINTER (x); + if (!strcmp (op, "push")) + action = push; + else if (!strcmp (op, "pop")) + action = pop; + else + GCC_BAD2 ("unknown action %qE for %<#pragma pack%> - ignored", x); + + while ((token = pragma_lex (&x)) == CPP_COMMA) + { + token = pragma_lex (&x); + if (token == CPP_NAME && id == 0) + { + id = x; + } + else if (token == CPP_NUMBER && action == push && align == -1) + { + if (TREE_CODE (x) != INTEGER_CST) + GCC_BAD ("invalid constant in %<#pragma pack%> - ignored"); + align = TREE_INT_CST_LOW (x); + if (align == -1) + action = set; + } + else + GCC_BAD_ACTION; + } + + if (token != CPP_CLOSE_PAREN) + GCC_BAD_ACTION; +#undef GCC_BAD_ACTION + } + else + GCC_BAD ("malformed %<#pragma pack%> - ignored"); + + if (pragma_lex (&x) != CPP_EOF) + warning (OPT_Wpragmas, "junk at end of %<#pragma pack%>"); + + if (flag_pack_struct) + GCC_BAD ("#pragma pack has no effect with -fpack-struct - ignored"); + + if (action != pop) + switch (align) + { + case 0: + case 1: + case 2: + case 4: + case 8: + case 16: + align *= BITS_PER_UNIT; + break; + case -1: + if (action == push) + { + align = maximum_field_alignment; + break; + } + default: + GCC_BAD2 ("alignment must be a small power of two, not %d", align); + } + + switch (action) + { + case set: SET_GLOBAL_ALIGNMENT (align); break; + case push: push_alignment (align, id); break; + case pop: pop_alignment (id); break; + } +} +#endif /* HANDLE_PRAGMA_PACK */ + +typedef struct GTY(()) pending_weak_d +{ + tree name; + tree value; +} pending_weak; + +DEF_VEC_O(pending_weak); +DEF_VEC_ALLOC_O(pending_weak,gc); + +static GTY(()) VEC(pending_weak,gc) *pending_weaks; + +#ifdef HANDLE_PRAGMA_WEAK +static void apply_pragma_weak (tree, tree); +static void handle_pragma_weak (cpp_reader *); + +static void +apply_pragma_weak (tree decl, tree value) +{ + if (value) + { + value = build_string (IDENTIFIER_LENGTH (value), + IDENTIFIER_POINTER (value)); + decl_attributes (&decl, build_tree_list (get_identifier ("alias"), + build_tree_list (NULL, value)), + 0); + } + + if (SUPPORTS_WEAK && DECL_EXTERNAL (decl) && TREE_USED (decl) + && !DECL_WEAK (decl) /* Don't complain about a redundant #pragma. */ + && TREE_SYMBOL_REFERENCED (DECL_ASSEMBLER_NAME (decl))) + warning (OPT_Wpragmas, "applying #pragma weak %q+D after first use " + "results in unspecified behavior", decl); + + declare_weak (decl); +} + +void +maybe_apply_pragma_weak (tree decl) +{ + tree id; + int i; + pending_weak *pe; + + /* Avoid asking for DECL_ASSEMBLER_NAME when it's not needed. */ + + /* No weak symbols pending, take the short-cut. */ + if (!pending_weaks) + return; + /* If it's not visible outside this file, it doesn't matter whether + it's weak. */ + if (!DECL_EXTERNAL (decl) && !TREE_PUBLIC (decl)) + return; + /* If it's not a function or a variable, it can't be weak. + FIXME: what kinds of things are visible outside this file but + aren't functions or variables? Should this be an assert instead? */ + if (TREE_CODE (decl) != FUNCTION_DECL && TREE_CODE (decl) != VAR_DECL) + return; + + id = DECL_ASSEMBLER_NAME (decl); + + for (i = 0; VEC_iterate (pending_weak, pending_weaks, i, pe); i++) + if (id == pe->name) + { + apply_pragma_weak (decl, pe->value); + VEC_unordered_remove (pending_weak, pending_weaks, i); + break; + } +} + +/* Process all "#pragma weak A = B" directives where we have not seen + a decl for A. */ +void +maybe_apply_pending_pragma_weaks (void) +{ + tree alias_id, id, decl; + int i; + pending_weak *pe; + + for (i = 0; VEC_iterate (pending_weak, pending_weaks, i, pe); i++) + { + alias_id = pe->name; + id = pe->value; + + if (id == NULL) + continue; + + decl = build_decl (UNKNOWN_LOCATION, + FUNCTION_DECL, alias_id, default_function_type); + + DECL_ARTIFICIAL (decl) = 1; + TREE_PUBLIC (decl) = 1; + DECL_EXTERNAL (decl) = 1; + DECL_WEAK (decl) = 1; + + assemble_alias (decl, id); + } +} + +/* #pragma weak name [= value] */ +static void +handle_pragma_weak (cpp_reader * ARG_UNUSED (dummy)) +{ + tree name, value, x, decl; + enum cpp_ttype t; + + value = 0; + + if (pragma_lex (&name) != CPP_NAME) + GCC_BAD ("malformed #pragma weak, ignored"); + t = pragma_lex (&x); + if (t == CPP_EQ) + { + if (pragma_lex (&value) != CPP_NAME) + GCC_BAD ("malformed #pragma weak, ignored"); + t = pragma_lex (&x); + } + if (t != CPP_EOF) + warning (OPT_Wpragmas, "junk at end of %<#pragma weak%>"); + + decl = identifier_global_value (name); + if (decl && DECL_P (decl)) + { + apply_pragma_weak (decl, value); + if (value) + assemble_alias (decl, value); + } + else + { + pending_weak *pe; + pe = VEC_safe_push (pending_weak, gc, pending_weaks, NULL); + pe->name = name; + pe->value = value; + } +} +#else +void +maybe_apply_pragma_weak (tree ARG_UNUSED (decl)) +{ +} + +void +maybe_apply_pending_pragma_weaks (void) +{ +} +#endif /* HANDLE_PRAGMA_WEAK */ + +/* GCC supports two #pragma directives for renaming the external + symbol associated with a declaration (DECL_ASSEMBLER_NAME), for + compatibility with the Solaris and Tru64 system headers. GCC also + has its own notation for this, __asm__("name") annotations. + + Corner cases of these features and their interaction: + + 1) Both pragmas silently apply only to declarations with external + linkage (that is, TREE_PUBLIC || DECL_EXTERNAL). Asm labels + do not have this restriction. + + 2) In C++, both #pragmas silently apply only to extern "C" declarations. + Asm labels do not have this restriction. + + 3) If any of the three ways of changing DECL_ASSEMBLER_NAME is + applied to a decl whose DECL_ASSEMBLER_NAME is already set, and the + new name is different, a warning issues and the name does not change. + + 4) The "source name" for #pragma redefine_extname is the DECL_NAME, + *not* the DECL_ASSEMBLER_NAME. + + 5) If #pragma extern_prefix is in effect and a declaration occurs + with an __asm__ name, the #pragma extern_prefix is silently + ignored for that declaration. + + 6) If #pragma extern_prefix and #pragma redefine_extname apply to + the same declaration, whichever triggered first wins, and a warning + is issued. (We would like to have #pragma redefine_extname always + win, but it can appear either before or after the declaration, and + if it appears afterward, we have no way of knowing whether a modified + DECL_ASSEMBLER_NAME is due to #pragma extern_prefix.) */ + +static GTY(()) tree pending_redefine_extname; + +static void handle_pragma_redefine_extname (cpp_reader *); + +/* #pragma redefine_extname oldname newname */ +static void +handle_pragma_redefine_extname (cpp_reader * ARG_UNUSED (dummy)) +{ + tree oldname, newname, decl, x; + enum cpp_ttype t; + + if (pragma_lex (&oldname) != CPP_NAME) + GCC_BAD ("malformed #pragma redefine_extname, ignored"); + if (pragma_lex (&newname) != CPP_NAME) + GCC_BAD ("malformed #pragma redefine_extname, ignored"); + t = pragma_lex (&x); + if (t != CPP_EOF) + warning (OPT_Wpragmas, "junk at end of %<#pragma redefine_extname%>"); + + decl = identifier_global_value (oldname); + if (decl + && (TREE_PUBLIC (decl) || DECL_EXTERNAL (decl)) + && (TREE_CODE (decl) == FUNCTION_DECL + || TREE_CODE (decl) == VAR_DECL) + && has_c_linkage (decl)) + { + if (DECL_ASSEMBLER_NAME_SET_P (decl)) + { + const char *name = IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (decl)); + name = targetm.strip_name_encoding (name); + + if (strcmp (name, IDENTIFIER_POINTER (newname))) + warning (OPT_Wpragmas, "#pragma redefine_extname ignored due to " + "conflict with previous rename"); + } + else + change_decl_assembler_name (decl, newname); + } + else + /* We have to add this to the rename list even if there's already + a global value that doesn't meet the above criteria, because in + C++ "struct foo {...};" puts "foo" in the current namespace but + does *not* conflict with a subsequent declaration of a function + or variable foo. See g++.dg/other/pragma-re-2.C. */ + add_to_renaming_pragma_list (oldname, newname); +} + +/* This is called from here and from ia64.c. */ +void +add_to_renaming_pragma_list (tree oldname, tree newname) +{ + tree previous = purpose_member (oldname, pending_redefine_extname); + if (previous) + { + if (TREE_VALUE (previous) != newname) + warning (OPT_Wpragmas, "#pragma redefine_extname ignored due to " + "conflict with previous #pragma redefine_extname"); + return; + } + + pending_redefine_extname + = tree_cons (oldname, newname, pending_redefine_extname); +} + +static GTY(()) tree pragma_extern_prefix; + +/* #pragma extern_prefix "prefix" */ +static void +handle_pragma_extern_prefix (cpp_reader * ARG_UNUSED (dummy)) +{ + tree prefix, x; + enum cpp_ttype t; + + if (pragma_lex (&prefix) != CPP_STRING) + GCC_BAD ("malformed #pragma extern_prefix, ignored"); + t = pragma_lex (&x); + if (t != CPP_EOF) + warning (OPT_Wpragmas, "junk at end of %<#pragma extern_prefix%>"); + + if (targetm.handle_pragma_extern_prefix) + /* Note that the length includes the null terminator. */ + pragma_extern_prefix = (TREE_STRING_LENGTH (prefix) > 1 ? prefix : NULL); + else if (warn_unknown_pragmas > in_system_header) + warning (OPT_Wunknown_pragmas, + "#pragma extern_prefix not supported on this target"); +} + +/* Hook from the front ends to apply the results of one of the preceding + pragmas that rename variables. */ + +tree +maybe_apply_renaming_pragma (tree decl, tree asmname) +{ + tree *p, t; + + /* The renaming pragmas are only applied to declarations with + external linkage. */ + if ((TREE_CODE (decl) != FUNCTION_DECL && TREE_CODE (decl) != VAR_DECL) + || (!TREE_PUBLIC (decl) && !DECL_EXTERNAL (decl)) + || !has_c_linkage (decl)) + return asmname; + + /* If the DECL_ASSEMBLER_NAME is already set, it does not change, + but we may warn about a rename that conflicts. */ + if (DECL_ASSEMBLER_NAME_SET_P (decl)) + { + const char *oldname = IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (decl)); + oldname = targetm.strip_name_encoding (oldname); + + if (asmname && strcmp (TREE_STRING_POINTER (asmname), oldname)) + warning (OPT_Wpragmas, "asm declaration ignored due to " + "conflict with previous rename"); + + /* Take any pending redefine_extname off the list. */ + for (p = &pending_redefine_extname; (t = *p); p = &TREE_CHAIN (t)) + if (DECL_NAME (decl) == TREE_PURPOSE (t)) + { + /* Only warn if there is a conflict. */ + if (strcmp (IDENTIFIER_POINTER (TREE_VALUE (t)), oldname)) + warning (OPT_Wpragmas, "#pragma redefine_extname ignored due to " + "conflict with previous rename"); + + *p = TREE_CHAIN (t); + break; + } + return 0; + } + + /* Find out if we have a pending #pragma redefine_extname. */ + for (p = &pending_redefine_extname; (t = *p); p = &TREE_CHAIN (t)) + if (DECL_NAME (decl) == TREE_PURPOSE (t)) + { + tree newname = TREE_VALUE (t); + *p = TREE_CHAIN (t); + + /* If we already have an asmname, #pragma redefine_extname is + ignored (with a warning if it conflicts). */ + if (asmname) + { + if (strcmp (TREE_STRING_POINTER (asmname), + IDENTIFIER_POINTER (newname)) != 0) + warning (OPT_Wpragmas, "#pragma redefine_extname ignored due to " + "conflict with __asm__ declaration"); + return asmname; + } + + /* Otherwise we use what we've got; #pragma extern_prefix is + silently ignored. */ + return build_string (IDENTIFIER_LENGTH (newname), + IDENTIFIER_POINTER (newname)); + } + + /* If we've got an asmname, #pragma extern_prefix is silently ignored. */ + if (asmname) + return asmname; + + /* If #pragma extern_prefix is in effect, apply it. */ + if (pragma_extern_prefix) + { + const char *prefix = TREE_STRING_POINTER (pragma_extern_prefix); + size_t plen = TREE_STRING_LENGTH (pragma_extern_prefix) - 1; + + const char *id = IDENTIFIER_POINTER (DECL_NAME (decl)); + size_t ilen = IDENTIFIER_LENGTH (DECL_NAME (decl)); + + char *newname = (char *) alloca (plen + ilen + 1); + + memcpy (newname, prefix, plen); + memcpy (newname + plen, id, ilen + 1); + + return build_string (plen + ilen, newname); + } + + /* Nada. */ + return 0; +} + + +#ifdef HANDLE_PRAGMA_VISIBILITY +static void handle_pragma_visibility (cpp_reader *); + +static VEC (int, heap) *visstack; + +/* Push the visibility indicated by STR onto the top of the #pragma + visibility stack. KIND is 0 for #pragma GCC visibility, 1 for + C++ namespace with visibility attribute and 2 for C++ builtin + ABI namespace. push_visibility/pop_visibility calls must have + matching KIND, it is not allowed to push visibility using one + KIND and pop using a different one. */ + +void +push_visibility (const char *str, int kind) +{ + VEC_safe_push (int, heap, visstack, + ((int) default_visibility) | (kind << 8)); + if (!strcmp (str, "default")) + default_visibility = VISIBILITY_DEFAULT; + else if (!strcmp (str, "internal")) + default_visibility = VISIBILITY_INTERNAL; + else if (!strcmp (str, "hidden")) + default_visibility = VISIBILITY_HIDDEN; + else if (!strcmp (str, "protected")) + default_visibility = VISIBILITY_PROTECTED; + else + GCC_BAD ("#pragma GCC visibility push() must specify default, internal, hidden or protected"); + visibility_options.inpragma = 1; +} + +/* Pop a level of the #pragma visibility stack. Return true if + successful. */ + +bool +pop_visibility (int kind) +{ + if (!VEC_length (int, visstack)) + return false; + if ((VEC_last (int, visstack) >> 8) != kind) + return false; + default_visibility + = (enum symbol_visibility) (VEC_pop (int, visstack) & 0xff); + visibility_options.inpragma + = VEC_length (int, visstack) != 0; + return true; +} + +/* Sets the default visibility for symbols to something other than that + specified on the command line. */ + +static void +handle_pragma_visibility (cpp_reader *dummy ATTRIBUTE_UNUSED) +{ + /* Form is #pragma GCC visibility push(hidden)|pop */ + tree x; + enum cpp_ttype token; + enum { bad, push, pop } action = bad; + + token = pragma_lex (&x); + if (token == CPP_NAME) + { + const char *op = IDENTIFIER_POINTER (x); + if (!strcmp (op, "push")) + action = push; + else if (!strcmp (op, "pop")) + action = pop; + } + if (bad == action) + GCC_BAD ("#pragma GCC visibility must be followed by push or pop"); + else + { + if (pop == action) + { + if (! pop_visibility (0)) + GCC_BAD ("no matching push for %<#pragma GCC visibility pop%>"); + } + else + { + if (pragma_lex (&x) != CPP_OPEN_PAREN) + GCC_BAD ("missing %<(%> after %<#pragma GCC visibility push%> - ignored"); + token = pragma_lex (&x); + if (token != CPP_NAME) + GCC_BAD ("malformed #pragma GCC visibility push"); + else + push_visibility (IDENTIFIER_POINTER (x), 0); + if (pragma_lex (&x) != CPP_CLOSE_PAREN) + GCC_BAD ("missing %<(%> after %<#pragma GCC visibility push%> - ignored"); + } + } + if (pragma_lex (&x) != CPP_EOF) + warning (OPT_Wpragmas, "junk at end of %<#pragma GCC visibility%>"); +} + +#endif + +static void +handle_pragma_diagnostic(cpp_reader *ARG_UNUSED(dummy)) +{ + const char *kind_string, *option_string; + unsigned int option_index; + enum cpp_ttype token; + diagnostic_t kind; + tree x; + + token = pragma_lex (&x); + if (token != CPP_NAME) + GCC_BAD ("missing [error|warning|ignored] after %<#pragma GCC diagnostic%>"); + kind_string = IDENTIFIER_POINTER (x); + if (strcmp (kind_string, "error") == 0) + kind = DK_ERROR; + else if (strcmp (kind_string, "warning") == 0) + kind = DK_WARNING; + else if (strcmp (kind_string, "ignored") == 0) + kind = DK_IGNORED; + else if (strcmp (kind_string, "push") == 0) + { + diagnostic_push_diagnostics (global_dc, input_location); + return; + } + else if (strcmp (kind_string, "pop") == 0) + { + diagnostic_pop_diagnostics (global_dc, input_location); + return; + } + else + GCC_BAD ("expected [error|warning|ignored|push|pop] after %<#pragma GCC diagnostic%>"); + + token = pragma_lex (&x); + if (token != CPP_STRING) + GCC_BAD ("missing option after %<#pragma GCC diagnostic%> kind"); + option_string = TREE_STRING_POINTER (x); + for (option_index = 0; option_index < cl_options_count; option_index++) + if (strcmp (cl_options[option_index].opt_text, option_string) == 0) + { + /* This overrides -Werror, for example. */ + diagnostic_classify_diagnostic (global_dc, option_index, kind, input_location); + /* This makes sure the option is enabled, like -Wfoo would do. */ + if (cl_options[option_index].var_type == CLVC_BOOLEAN + && cl_options[option_index].flag_var + && kind != DK_IGNORED) + *(int *) cl_options[option_index].flag_var = 1; + return; + } + GCC_BAD ("unknown option after %<#pragma GCC diagnostic%> kind"); +} + +/* Parse #pragma GCC target (xxx) to set target specific options. */ +static void +handle_pragma_target(cpp_reader *ARG_UNUSED(dummy)) +{ + enum cpp_ttype token; + tree x; + bool close_paren_needed_p = false; + + if (cfun) + { + error ("#pragma GCC option is not allowed inside functions"); + return; + } + + token = pragma_lex (&x); + if (token == CPP_OPEN_PAREN) + { + close_paren_needed_p = true; + token = pragma_lex (&x); + } + + if (token != CPP_STRING) + { + GCC_BAD ("%<#pragma GCC option%> is not a string"); + return; + } + + /* Strings are user options. */ + else + { + tree args = NULL_TREE; + + do + { + /* Build up the strings now as a tree linked list. Skip empty + strings. */ + if (TREE_STRING_LENGTH (x) > 0) + args = tree_cons (NULL_TREE, x, args); + + token = pragma_lex (&x); + while (token == CPP_COMMA) + token = pragma_lex (&x); + } + while (token == CPP_STRING); + + if (close_paren_needed_p) + { + if (token == CPP_CLOSE_PAREN) + token = pragma_lex (&x); + else + GCC_BAD ("%<#pragma GCC target (string [,string]...)%> does " + "not have a final %<)%>."); + } + + if (token != CPP_EOF) + { + error ("#pragma GCC target string... is badly formed"); + return; + } + + /* put arguments in the order the user typed them. */ + args = nreverse (args); + + if (targetm.target_option.pragma_parse (args, NULL_TREE)) + current_target_pragma = args; + } +} + +/* Handle #pragma GCC optimize to set optimization options. */ +static void +handle_pragma_optimize (cpp_reader *ARG_UNUSED(dummy)) +{ + enum cpp_ttype token; + tree x; + bool close_paren_needed_p = false; + tree optimization_previous_node = optimization_current_node; + + if (cfun) + { + error ("#pragma GCC optimize is not allowed inside functions"); + return; + } + + token = pragma_lex (&x); + if (token == CPP_OPEN_PAREN) + { + close_paren_needed_p = true; + token = pragma_lex (&x); + } + + if (token != CPP_STRING && token != CPP_NUMBER) + { + GCC_BAD ("%<#pragma GCC optimize%> is not a string or number"); + return; + } + + /* Strings/numbers are user options. */ + else + { + tree args = NULL_TREE; + + do + { + /* Build up the numbers/strings now as a list. */ + if (token != CPP_STRING || TREE_STRING_LENGTH (x) > 0) + args = tree_cons (NULL_TREE, x, args); + + token = pragma_lex (&x); + while (token == CPP_COMMA) + token = pragma_lex (&x); + } + while (token == CPP_STRING || token == CPP_NUMBER); + + if (close_paren_needed_p) + { + if (token == CPP_CLOSE_PAREN) + token = pragma_lex (&x); + else + GCC_BAD ("%<#pragma GCC optimize (string [,string]...)%> does " + "not have a final %<)%>."); + } + + if (token != CPP_EOF) + { + error ("#pragma GCC optimize string... is badly formed"); + return; + } + + /* put arguments in the order the user typed them. */ + args = nreverse (args); + + parse_optimize_options (args, false); + current_optimize_pragma = chainon (current_optimize_pragma, args); + optimization_current_node = build_optimization_node (); + c_cpp_builtins_optimize_pragma (parse_in, + optimization_previous_node, + optimization_current_node); + } +} + +/* Stack of the #pragma GCC options created with #pragma GCC push_option. Save + both the binary representation of the options and the TREE_LIST of + strings that will be added to the function's attribute list. */ +typedef struct GTY(()) opt_stack { + struct opt_stack *prev; + tree target_binary; + tree target_strings; + tree optimize_binary; + tree optimize_strings; +} opt_stack; + +static GTY(()) struct opt_stack * options_stack; + +/* Handle #pragma GCC push_options to save the current target and optimization + options. */ + +static void +handle_pragma_push_options (cpp_reader *ARG_UNUSED(dummy)) +{ + enum cpp_ttype token; + tree x = 0; + opt_stack *p; + + token = pragma_lex (&x); + if (token != CPP_EOF) + { + warning (OPT_Wpragmas, "junk at end of %<#pragma push_options%>"); + return; + } + + p = ggc_alloc_opt_stack (); + p->prev = options_stack; + options_stack = p; + + /* Save optimization and target flags in binary format. */ + p->optimize_binary = build_optimization_node (); + p->target_binary = build_target_option_node (); + + /* Save optimization and target flags in string list format. */ + p->optimize_strings = copy_list (current_optimize_pragma); + p->target_strings = copy_list (current_target_pragma); +} + +/* Handle #pragma GCC pop_options to restore the current target and + optimization options from a previous push_options. */ + +static void +handle_pragma_pop_options (cpp_reader *ARG_UNUSED(dummy)) +{ + enum cpp_ttype token; + tree x = 0; + opt_stack *p; + + token = pragma_lex (&x); + if (token != CPP_EOF) + { + warning (OPT_Wpragmas, "junk at end of %<#pragma pop_options%>"); + return; + } + + if (! options_stack) + { + warning (OPT_Wpragmas, + "%<#pragma GCC pop_options%> without a corresponding " + "%<#pragma GCC push_options%>"); + return; + } + + p = options_stack; + options_stack = p->prev; + + if (p->target_binary != target_option_current_node) + { + (void) targetm.target_option.pragma_parse (NULL_TREE, p->target_binary); + target_option_current_node = p->target_binary; + } + + if (p->optimize_binary != optimization_current_node) + { + tree old_optimize = optimization_current_node; + cl_optimization_restore (TREE_OPTIMIZATION (p->optimize_binary)); + c_cpp_builtins_optimize_pragma (parse_in, old_optimize, + p->optimize_binary); + optimization_current_node = p->optimize_binary; + } + + current_target_pragma = p->target_strings; + current_optimize_pragma = p->optimize_strings; +} + +/* Handle #pragma GCC reset_options to restore the current target and + optimization options to the original options used on the command line. */ + +static void +handle_pragma_reset_options (cpp_reader *ARG_UNUSED(dummy)) +{ + enum cpp_ttype token; + tree x = 0; + tree new_optimize = optimization_default_node; + tree new_target = target_option_default_node; + + token = pragma_lex (&x); + if (token != CPP_EOF) + { + warning (OPT_Wpragmas, "junk at end of %<#pragma reset_options%>"); + return; + } + + if (new_target != target_option_current_node) + { + (void) targetm.target_option.pragma_parse (NULL_TREE, new_target); + target_option_current_node = new_target; + } + + if (new_optimize != optimization_current_node) + { + tree old_optimize = optimization_current_node; + cl_optimization_restore (TREE_OPTIMIZATION (new_optimize)); + c_cpp_builtins_optimize_pragma (parse_in, old_optimize, new_optimize); + optimization_current_node = new_optimize; + } + + current_target_pragma = NULL_TREE; + current_optimize_pragma = NULL_TREE; +} + +/* Print a plain user-specified message. */ + +static void +handle_pragma_message (cpp_reader *ARG_UNUSED(dummy)) +{ + enum cpp_ttype token; + tree x, message = 0; + + token = pragma_lex (&x); + if (token == CPP_OPEN_PAREN) + { + token = pragma_lex (&x); + if (token == CPP_STRING) + message = x; + else + GCC_BAD ("expected a string after %<#pragma message%>"); + if (pragma_lex (&x) != CPP_CLOSE_PAREN) + GCC_BAD ("malformed %<#pragma message%>, ignored"); + } + else if (token == CPP_STRING) + message = x; + else + GCC_BAD ("expected a string after %<#pragma message%>"); + + gcc_assert (message); + + if (pragma_lex (&x) != CPP_EOF) + warning (OPT_Wpragmas, "junk at end of %<#pragma message%>"); + + if (TREE_STRING_LENGTH (message) > 1) + inform (input_location, "#pragma message: %s", TREE_STRING_POINTER (message)); +} + +/* Mark whether the current location is valid for a STDC pragma. */ + +static bool valid_location_for_stdc_pragma; + +void +mark_valid_location_for_stdc_pragma (bool flag) +{ + valid_location_for_stdc_pragma = flag; +} + +/* Return true if the current location is valid for a STDC pragma. */ + +bool +valid_location_for_stdc_pragma_p (void) +{ + return valid_location_for_stdc_pragma; +} + +enum pragma_switch_t { PRAGMA_ON, PRAGMA_OFF, PRAGMA_DEFAULT, PRAGMA_BAD }; + +/* A STDC pragma must appear outside of external declarations or + preceding all explicit declarations and statements inside a compound + statement; its behavior is undefined if used in any other context. + It takes a switch of ON, OFF, or DEFAULT. */ + +static enum pragma_switch_t +handle_stdc_pragma (const char *pname) +{ + const char *arg; + tree t; + enum pragma_switch_t ret; + + if (!valid_location_for_stdc_pragma_p ()) + { + warning (OPT_Wpragmas, "invalid location for %, ignored", + pname); + return PRAGMA_BAD; + } + + if (pragma_lex (&t) != CPP_NAME) + { + warning (OPT_Wpragmas, "malformed %<#pragma %s%>, ignored", pname); + return PRAGMA_BAD; + } + + arg = IDENTIFIER_POINTER (t); + + if (!strcmp (arg, "ON")) + ret = PRAGMA_ON; + else if (!strcmp (arg, "OFF")) + ret = PRAGMA_OFF; + else if (!strcmp (arg, "DEFAULT")) + ret = PRAGMA_DEFAULT; + else + { + warning (OPT_Wpragmas, "malformed %<#pragma %s%>, ignored", pname); + return PRAGMA_BAD; + } + + if (pragma_lex (&t) != CPP_EOF) + { + warning (OPT_Wpragmas, "junk at end of %<#pragma %s%>", pname); + return PRAGMA_BAD; + } + + return ret; +} + +/* #pragma STDC FLOAT_CONST_DECIMAL64 ON + #pragma STDC FLOAT_CONST_DECIMAL64 OFF + #pragma STDC FLOAT_CONST_DECIMAL64 DEFAULT */ + +static void +handle_pragma_float_const_decimal64 (cpp_reader *ARG_UNUSED (dummy)) +{ + if (c_dialect_cxx ()) + { + if (warn_unknown_pragmas > in_system_header) + warning (OPT_Wunknown_pragmas, + "%<#pragma STDC FLOAT_CONST_DECIMAL64%> is not supported" + " for C++"); + return; + } + + if (!targetm.decimal_float_supported_p ()) + { + if (warn_unknown_pragmas > in_system_header) + warning (OPT_Wunknown_pragmas, + "%<#pragma STDC FLOAT_CONST_DECIMAL64%> is not supported" + " on this target"); + return; + } + + pedwarn (input_location, OPT_pedantic, + "ISO C does not support %<#pragma STDC FLOAT_CONST_DECIMAL64%>"); + + switch (handle_stdc_pragma ("STDC FLOAT_CONST_DECIMAL64")) + { + case PRAGMA_ON: + set_float_const_decimal64 (); + break; + case PRAGMA_OFF: + case PRAGMA_DEFAULT: + clear_float_const_decimal64 (); + break; + case PRAGMA_BAD: + break; + } +} + +/* A vector of registered pragma callbacks. */ + +DEF_VEC_O (pragma_handler); +DEF_VEC_ALLOC_O (pragma_handler, heap); + +static VEC(pragma_handler, heap) *registered_pragmas; + +typedef struct +{ + const char *space; + const char *name; +} pragma_ns_name; + +DEF_VEC_O (pragma_ns_name); +DEF_VEC_ALLOC_O (pragma_ns_name, heap); + +static VEC(pragma_ns_name, heap) *registered_pp_pragmas; + +struct omp_pragma_def { const char *name; unsigned int id; }; +static const struct omp_pragma_def omp_pragmas[] = { + { "atomic", PRAGMA_OMP_ATOMIC }, + { "barrier", PRAGMA_OMP_BARRIER }, + { "critical", PRAGMA_OMP_CRITICAL }, + { "flush", PRAGMA_OMP_FLUSH }, + { "for", PRAGMA_OMP_FOR }, + { "master", PRAGMA_OMP_MASTER }, + { "ordered", PRAGMA_OMP_ORDERED }, + { "parallel", PRAGMA_OMP_PARALLEL }, + { "section", PRAGMA_OMP_SECTION }, + { "sections", PRAGMA_OMP_SECTIONS }, + { "single", PRAGMA_OMP_SINGLE }, + { "task", PRAGMA_OMP_TASK }, + { "taskwait", PRAGMA_OMP_TASKWAIT }, + { "threadprivate", PRAGMA_OMP_THREADPRIVATE } +}; + +void +c_pp_lookup_pragma (unsigned int id, const char **space, const char **name) +{ + const int n_omp_pragmas = sizeof (omp_pragmas) / sizeof (*omp_pragmas); + int i; + + for (i = 0; i < n_omp_pragmas; ++i) + if (omp_pragmas[i].id == id) + { + *space = "omp"; + *name = omp_pragmas[i].name; + return; + } + + if (id >= PRAGMA_FIRST_EXTERNAL + && (id < PRAGMA_FIRST_EXTERNAL + + VEC_length (pragma_ns_name, registered_pp_pragmas))) + { + *space = VEC_index (pragma_ns_name, registered_pp_pragmas, + id - PRAGMA_FIRST_EXTERNAL)->space; + *name = VEC_index (pragma_ns_name, registered_pp_pragmas, + id - PRAGMA_FIRST_EXTERNAL)->name; + return; + } + + gcc_unreachable (); +} + +/* Front-end wrappers for pragma registration to avoid dragging + cpplib.h in almost everywhere. */ + +static void +c_register_pragma_1 (const char *space, const char *name, + pragma_handler handler, bool allow_expansion) +{ + unsigned id; + + if (flag_preprocess_only) + { + pragma_ns_name ns_name; + + if (!allow_expansion) + return; + + ns_name.space = space; + ns_name.name = name; + VEC_safe_push (pragma_ns_name, heap, registered_pp_pragmas, &ns_name); + id = VEC_length (pragma_ns_name, registered_pp_pragmas); + id += PRAGMA_FIRST_EXTERNAL - 1; + } + else + { + VEC_safe_push (pragma_handler, heap, registered_pragmas, &handler); + id = VEC_length (pragma_handler, registered_pragmas); + id += PRAGMA_FIRST_EXTERNAL - 1; + + /* The C++ front end allocates 6 bits in cp_token; the C front end + allocates 7 bits in c_token. At present this is sufficient. */ + gcc_assert (id < 64); + } + + cpp_register_deferred_pragma (parse_in, space, name, id, + allow_expansion, false); +} + +void +c_register_pragma (const char *space, const char *name, pragma_handler handler) +{ + c_register_pragma_1 (space, name, handler, false); +} + +void +c_register_pragma_with_expansion (const char *space, const char *name, + pragma_handler handler) +{ + c_register_pragma_1 (space, name, handler, true); +} + +void +c_invoke_pragma_handler (unsigned int id) +{ + pragma_handler handler; + + id -= PRAGMA_FIRST_EXTERNAL; + handler = *VEC_index (pragma_handler, registered_pragmas, id); + + handler (parse_in); +} + +/* Set up front-end pragmas. */ +void +init_pragma (void) +{ + if (flag_openmp) + { + const int n_omp_pragmas = sizeof (omp_pragmas) / sizeof (*omp_pragmas); + int i; + + for (i = 0; i < n_omp_pragmas; ++i) + cpp_register_deferred_pragma (parse_in, "omp", omp_pragmas[i].name, + omp_pragmas[i].id, true, true); + } + + if (!flag_preprocess_only) + cpp_register_deferred_pragma (parse_in, "GCC", "pch_preprocess", + PRAGMA_GCC_PCH_PREPROCESS, false, false); + +#ifdef HANDLE_PRAGMA_PACK +#ifdef HANDLE_PRAGMA_PACK_WITH_EXPANSION + c_register_pragma_with_expansion (0, "pack", handle_pragma_pack); +#else + c_register_pragma (0, "pack", handle_pragma_pack); +#endif +#endif +#ifdef HANDLE_PRAGMA_WEAK + c_register_pragma (0, "weak", handle_pragma_weak); +#endif +#ifdef HANDLE_PRAGMA_VISIBILITY + c_register_pragma ("GCC", "visibility", handle_pragma_visibility); +#endif + + c_register_pragma ("GCC", "diagnostic", handle_pragma_diagnostic); + c_register_pragma ("GCC", "target", handle_pragma_target); + c_register_pragma ("GCC", "optimize", handle_pragma_optimize); + c_register_pragma ("GCC", "push_options", handle_pragma_push_options); + c_register_pragma ("GCC", "pop_options", handle_pragma_pop_options); + c_register_pragma ("GCC", "reset_options", handle_pragma_reset_options); + + c_register_pragma ("STDC", "FLOAT_CONST_DECIMAL64", + handle_pragma_float_const_decimal64); + + c_register_pragma_with_expansion (0, "redefine_extname", handle_pragma_redefine_extname); + c_register_pragma (0, "extern_prefix", handle_pragma_extern_prefix); + + c_register_pragma_with_expansion (0, "message", handle_pragma_message); + +#ifdef REGISTER_TARGET_PRAGMAS + REGISTER_TARGET_PRAGMAS (); +#endif + + /* Allow plugins to register their own pragmas. */ + invoke_plugin_callbacks (PLUGIN_PRAGMAS, NULL); +} + +#include "gt-c-family-c-pragma.h" diff --git a/gcc/c-family/c-pragma.h b/gcc/c-family/c-pragma.h new file mode 100644 index 00000000000..eab23db6cd9 --- /dev/null +++ b/gcc/c-family/c-pragma.h @@ -0,0 +1,133 @@ +/* Pragma related interfaces. + Copyright (C) 1995, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2007, 2008 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 3, 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 COPYING3. If not see +. */ + +#ifndef GCC_C_PRAGMA_H +#define GCC_C_PRAGMA_H + +#include /* For enum cpp_ttype. */ + +/* Pragma identifiers built in to the front end parsers. Identifiers + for ancillary handlers will follow these. */ +typedef enum pragma_kind { + PRAGMA_NONE = 0, + + PRAGMA_OMP_ATOMIC, + PRAGMA_OMP_BARRIER, + PRAGMA_OMP_CRITICAL, + PRAGMA_OMP_FLUSH, + PRAGMA_OMP_FOR, + PRAGMA_OMP_MASTER, + PRAGMA_OMP_ORDERED, + PRAGMA_OMP_PARALLEL, + PRAGMA_OMP_PARALLEL_FOR, + PRAGMA_OMP_PARALLEL_SECTIONS, + PRAGMA_OMP_SECTION, + PRAGMA_OMP_SECTIONS, + PRAGMA_OMP_SINGLE, + PRAGMA_OMP_TASK, + PRAGMA_OMP_TASKWAIT, + PRAGMA_OMP_THREADPRIVATE, + + PRAGMA_GCC_PCH_PREPROCESS, + + PRAGMA_FIRST_EXTERNAL +} pragma_kind; + + +/* All clauses defined by OpenMP 2.5 and 3.0. + Used internally by both C and C++ parsers. */ +typedef enum pragma_omp_clause { + PRAGMA_OMP_CLAUSE_NONE = 0, + + PRAGMA_OMP_CLAUSE_COLLAPSE, + PRAGMA_OMP_CLAUSE_COPYIN, + PRAGMA_OMP_CLAUSE_COPYPRIVATE, + PRAGMA_OMP_CLAUSE_DEFAULT, + PRAGMA_OMP_CLAUSE_FIRSTPRIVATE, + PRAGMA_OMP_CLAUSE_IF, + PRAGMA_OMP_CLAUSE_LASTPRIVATE, + PRAGMA_OMP_CLAUSE_NOWAIT, + PRAGMA_OMP_CLAUSE_NUM_THREADS, + PRAGMA_OMP_CLAUSE_ORDERED, + PRAGMA_OMP_CLAUSE_PRIVATE, + PRAGMA_OMP_CLAUSE_REDUCTION, + PRAGMA_OMP_CLAUSE_SCHEDULE, + PRAGMA_OMP_CLAUSE_SHARED, + PRAGMA_OMP_CLAUSE_UNTIED +} pragma_omp_clause; + +extern struct cpp_reader* parse_in; + +#define HANDLE_PRAGMA_WEAK SUPPORTS_WEAK + +#ifdef HANDLE_SYSV_PRAGMA +/* We always support #pragma pack for SYSV pragmas. */ +#ifndef HANDLE_PRAGMA_PACK +#define HANDLE_PRAGMA_PACK 1 +#endif +#endif /* HANDLE_SYSV_PRAGMA */ + + +#ifdef HANDLE_PRAGMA_PACK_PUSH_POP +/* If we are supporting #pragma pack(push... then we automatically + support #pragma pack() */ +#define HANDLE_PRAGMA_PACK 1 +#endif /* HANDLE_PRAGMA_PACK_PUSH_POP */ + +/* It's safe to always leave visibility pragma enabled as if + visibility is not supported on the host OS platform the + statements are ignored. */ +#define HANDLE_PRAGMA_VISIBILITY 1 +extern void push_visibility (const char *, int); +extern bool pop_visibility (int); + +extern void init_pragma (void); + +/* Front-end wrappers for pragma registration. */ +typedef void (*pragma_handler)(struct cpp_reader *); +extern void c_register_pragma (const char *, const char *, pragma_handler); +extern void c_register_pragma_with_expansion (const char *, const char *, + pragma_handler); +extern void c_invoke_pragma_handler (unsigned int); + +extern void maybe_apply_pragma_weak (tree); +extern void maybe_apply_pending_pragma_weaks (void); +extern tree maybe_apply_renaming_pragma (tree, tree); +extern void add_to_renaming_pragma_list (tree, tree); + +extern enum cpp_ttype pragma_lex (tree *); + +/* Flags for use with c_lex_with_flags. The values here were picked + so that 0 means to translate and join strings. */ +#define C_LEX_STRING_NO_TRANSLATE 1 /* Do not lex strings into + execution character set. */ +#define C_LEX_STRING_NO_JOIN 2 /* Do not concatenate strings + nor translate them into execution + character set. */ + +/* This is not actually available to pragma parsers. It's merely a + convenient location to declare this function for c-lex, after + having enum cpp_ttype declared. */ +extern enum cpp_ttype c_lex_with_flags (tree *, location_t *, unsigned char *, + int); + +extern void c_pp_lookup_pragma (unsigned int, const char **, const char **); + +#endif /* GCC_C_PRAGMA_H */ diff --git a/gcc/c-family/c-pretty-print.c b/gcc/c-family/c-pretty-print.c new file mode 100644 index 00000000000..7f4b2388f43 --- /dev/null +++ b/gcc/c-family/c-pretty-print.c @@ -0,0 +1,2282 @@ +/* Subroutines common to both C and C++ pretty-printers. + Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 + Free Software Foundation, Inc. + Contributed by Gabriel Dos Reis + +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 3, 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 COPYING3. If not see +. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tm.h" +#include "tree.h" +#include "intl.h" +#include "c-pretty-print.h" +#include "tree-pretty-print.h" +#include "tree-iterator.h" +#include "diagnostic.h" + +/* Translate if being used for diagnostics, but not for dump files or + __PRETTY_FUNCTION. */ +#define M_(msgid) (pp_translate_identifiers (pp) ? _(msgid) : (msgid)) + +/* The pretty-printer code is primarily designed to closely follow + (GNU) C and C++ grammars. That is to be contrasted with spaghetti + codes we used to have in the past. Following a structured + approach (preferably the official grammars) is believed to make it + much easier to add extensions and nifty pretty-printing effects that + takes expression or declaration contexts into account. */ + + +#define pp_c_maybe_whitespace(PP) \ + do { \ + if (pp_base (PP)->padding == pp_before) \ + pp_c_whitespace (PP); \ + } while (0) + +/* literal */ +static void pp_c_char (c_pretty_printer *, int); + +/* postfix-expression */ +static void pp_c_initializer_list (c_pretty_printer *, tree); +static void pp_c_brace_enclosed_initializer_list (c_pretty_printer *, tree); + +static void pp_c_multiplicative_expression (c_pretty_printer *, tree); +static void pp_c_additive_expression (c_pretty_printer *, tree); +static void pp_c_shift_expression (c_pretty_printer *, tree); +static void pp_c_relational_expression (c_pretty_printer *, tree); +static void pp_c_equality_expression (c_pretty_printer *, tree); +static void pp_c_and_expression (c_pretty_printer *, tree); +static void pp_c_exclusive_or_expression (c_pretty_printer *, tree); +static void pp_c_inclusive_or_expression (c_pretty_printer *, tree); +static void pp_c_logical_and_expression (c_pretty_printer *, tree); +static void pp_c_conditional_expression (c_pretty_printer *, tree); +static void pp_c_assignment_expression (c_pretty_printer *, tree); + +/* declarations. */ + + +/* Helper functions. */ + +void +pp_c_whitespace (c_pretty_printer *pp) +{ + pp_space (pp); + pp_base (pp)->padding = pp_none; +} + +void +pp_c_left_paren (c_pretty_printer *pp) +{ + pp_left_paren (pp); + pp_base (pp)->padding = pp_none; +} + +void +pp_c_right_paren (c_pretty_printer *pp) +{ + pp_right_paren (pp); + pp_base (pp)->padding = pp_none; +} + +void +pp_c_left_brace (c_pretty_printer *pp) +{ + pp_left_brace (pp); + pp_base (pp)->padding = pp_none; +} + +void +pp_c_right_brace (c_pretty_printer *pp) +{ + pp_right_brace (pp); + pp_base (pp)->padding = pp_none; +} + +void +pp_c_left_bracket (c_pretty_printer *pp) +{ + pp_left_bracket (pp); + pp_base (pp)->padding = pp_none; +} + +void +pp_c_right_bracket (c_pretty_printer *pp) +{ + pp_right_bracket (pp); + pp_base (pp)->padding = pp_none; +} + +void +pp_c_dot (c_pretty_printer *pp) +{ + pp_dot (pp); + pp_base (pp)->padding = pp_none; +} + +void +pp_c_ampersand (c_pretty_printer *pp) +{ + pp_ampersand (pp); + pp_base (pp)->padding = pp_none; +} + +void +pp_c_star (c_pretty_printer *pp) +{ + pp_star (pp); + pp_base (pp)->padding = pp_none; +} + +void +pp_c_arrow (c_pretty_printer *pp) +{ + pp_arrow (pp); + pp_base (pp)->padding = pp_none; +} + +void +pp_c_semicolon (c_pretty_printer *pp) +{ + pp_semicolon (pp); + pp_base (pp)->padding = pp_none; +} + +void +pp_c_complement (c_pretty_printer *pp) +{ + pp_complement (pp); + pp_base (pp)->padding = pp_none; +} + +void +pp_c_exclamation (c_pretty_printer *pp) +{ + pp_exclamation (pp); + pp_base (pp)->padding = pp_none; +} + +/* Print out the external representation of QUALIFIERS. */ + +void +pp_c_cv_qualifiers (c_pretty_printer *pp, int qualifiers, bool func_type) +{ + const char *p = pp_last_position_in_text (pp); + bool previous = false; + + if (!qualifiers) + return; + + /* The C programming language does not have references, but it is much + simpler to handle those here rather than going through the same + logic in the C++ pretty-printer. */ + if (p != NULL && (*p == '*' || *p == '&')) + pp_c_whitespace (pp); + + if (qualifiers & TYPE_QUAL_CONST) + { + pp_c_ws_string (pp, func_type ? "__attribute__((const))" : "const"); + previous = true; + } + + if (qualifiers & TYPE_QUAL_VOLATILE) + { + if (previous) + pp_c_whitespace (pp); + pp_c_ws_string (pp, func_type ? "__attribute__((noreturn))" : "volatile"); + previous = true; + } + + if (qualifiers & TYPE_QUAL_RESTRICT) + { + if (previous) + pp_c_whitespace (pp); + pp_c_ws_string (pp, flag_isoc99 ? "restrict" : "__restrict__"); + } +} + +/* Pretty-print T using the type-cast notation '( type-name )'. */ + +static void +pp_c_type_cast (c_pretty_printer *pp, tree t) +{ + pp_c_left_paren (pp); + pp_type_id (pp, t); + pp_c_right_paren (pp); +} + +/* We're about to pretty-print a pointer type as indicated by T. + Output a whitespace, if needed, preparing for subsequent output. */ + +void +pp_c_space_for_pointer_operator (c_pretty_printer *pp, tree t) +{ + if (POINTER_TYPE_P (t)) + { + tree pointee = strip_pointer_operator (TREE_TYPE (t)); + if (TREE_CODE (pointee) != ARRAY_TYPE + && TREE_CODE (pointee) != FUNCTION_TYPE) + pp_c_whitespace (pp); + } +} + + +/* Declarations. */ + +/* C++ cv-qualifiers are called type-qualifiers in C. Print out the + cv-qualifiers of T. If T is a declaration then it is the cv-qualifier + of its type. Take care of possible extensions. + + type-qualifier-list: + type-qualifier + type-qualifier-list type-qualifier + + type-qualifier: + const + restrict -- C99 + __restrict__ -- GNU C + address-space-qualifier -- GNU C + volatile + + address-space-qualifier: + identifier -- GNU C */ + +void +pp_c_type_qualifier_list (c_pretty_printer *pp, tree t) +{ + int qualifiers; + + if (!t || t == error_mark_node) + return; + + if (!TYPE_P (t)) + t = TREE_TYPE (t); + + qualifiers = TYPE_QUALS (t); + pp_c_cv_qualifiers (pp, qualifiers, + TREE_CODE (t) == FUNCTION_TYPE); + + if (!ADDR_SPACE_GENERIC_P (TYPE_ADDR_SPACE (t))) + { + const char *as = c_addr_space_name (TYPE_ADDR_SPACE (t)); + pp_c_identifier (pp, as); + } +} + +/* pointer: + * type-qualifier-list(opt) + * type-qualifier-list(opt) pointer */ + +static void +pp_c_pointer (c_pretty_printer *pp, tree t) +{ + if (!TYPE_P (t) && TREE_CODE (t) != TYPE_DECL) + t = TREE_TYPE (t); + switch (TREE_CODE (t)) + { + case POINTER_TYPE: + /* It is easier to handle C++ reference types here. */ + case REFERENCE_TYPE: + if (TREE_CODE (TREE_TYPE (t)) == POINTER_TYPE) + pp_c_pointer (pp, TREE_TYPE (t)); + if (TREE_CODE (t) == POINTER_TYPE) + pp_c_star (pp); + else + pp_c_ampersand (pp); + pp_c_type_qualifier_list (pp, t); + break; + + /* ??? This node is now in GENERIC and so shouldn't be here. But + we'll fix that later. */ + case DECL_EXPR: + pp_declaration (pp, DECL_EXPR_DECL (t)); + pp_needs_newline (pp) = true; + break; + + default: + pp_unsupported_tree (pp, t); + } +} + +/* type-specifier: + void + char + short + int + long + float + double + signed + unsigned + _Bool -- C99 + _Complex -- C99 + _Imaginary -- C99 + struct-or-union-specifier + enum-specifier + typedef-name. + + GNU extensions. + simple-type-specifier: + __complex__ + __vector__ */ + +void +pp_c_type_specifier (c_pretty_printer *pp, tree t) +{ + const enum tree_code code = TREE_CODE (t); + switch (code) + { + case ERROR_MARK: + pp_c_ws_string (pp, M_("")); + break; + + case IDENTIFIER_NODE: + pp_c_tree_decl_identifier (pp, t); + break; + + case VOID_TYPE: + case BOOLEAN_TYPE: + case INTEGER_TYPE: + case REAL_TYPE: + case FIXED_POINT_TYPE: + if (TYPE_NAME (t)) + { + t = TYPE_NAME (t); + pp_c_type_specifier (pp, t); + } + else + { + int prec = TYPE_PRECISION (t); + if (ALL_FIXED_POINT_MODE_P (TYPE_MODE (t))) + t = c_common_type_for_mode (TYPE_MODE (t), TYPE_SATURATING (t)); + else + t = c_common_type_for_mode (TYPE_MODE (t), TYPE_UNSIGNED (t)); + if (TYPE_NAME (t)) + { + pp_c_type_specifier (pp, t); + if (TYPE_PRECISION (t) != prec) + { + pp_string (pp, ":"); + pp_decimal_int (pp, prec); + } + } + else + { + switch (code) + { + case INTEGER_TYPE: + pp_string (pp, (TYPE_UNSIGNED (t) + ? M_(""); + } + } + break; + + case TYPE_DECL: + if (DECL_NAME (t)) + pp_id_expression (pp, t); + else + pp_c_ws_string (pp, M_("")); + break; + + case UNION_TYPE: + case RECORD_TYPE: + case ENUMERAL_TYPE: + if (code == UNION_TYPE) + pp_c_ws_string (pp, "union"); + else if (code == RECORD_TYPE) + pp_c_ws_string (pp, "struct"); + else if (code == ENUMERAL_TYPE) + pp_c_ws_string (pp, "enum"); + else + pp_c_ws_string (pp, M_("")); + + if (TYPE_NAME (t)) + pp_id_expression (pp, TYPE_NAME (t)); + else + pp_c_ws_string (pp, M_("")); + break; + + default: + pp_unsupported_tree (pp, t); + break; + } +} + +/* specifier-qualifier-list: + type-specifier specifier-qualifier-list-opt + type-qualifier specifier-qualifier-list-opt + + + Implementation note: Because of the non-linearities in array or + function declarations, this routine prints not just the + specifier-qualifier-list of such entities or types of such entities, + but also the 'pointer' production part of their declarators. The + remaining part is done by pp_declarator or pp_c_abstract_declarator. */ + +void +pp_c_specifier_qualifier_list (c_pretty_printer *pp, tree t) +{ + const enum tree_code code = TREE_CODE (t); + + if (TREE_CODE (t) != POINTER_TYPE) + pp_c_type_qualifier_list (pp, t); + switch (code) + { + case REFERENCE_TYPE: + case POINTER_TYPE: + { + /* Get the types-specifier of this type. */ + tree pointee = strip_pointer_operator (TREE_TYPE (t)); + pp_c_specifier_qualifier_list (pp, pointee); + if (TREE_CODE (pointee) == ARRAY_TYPE + || TREE_CODE (pointee) == FUNCTION_TYPE) + { + pp_c_whitespace (pp); + pp_c_left_paren (pp); + } + else if (!c_dialect_cxx ()) + pp_c_whitespace (pp); + pp_ptr_operator (pp, t); + } + break; + + case FUNCTION_TYPE: + case ARRAY_TYPE: + pp_c_specifier_qualifier_list (pp, TREE_TYPE (t)); + break; + + case VECTOR_TYPE: + case COMPLEX_TYPE: + if (code == COMPLEX_TYPE) + pp_c_ws_string (pp, flag_isoc99 ? "_Complex" : "__complex__"); + else if (code == VECTOR_TYPE) + { + pp_c_ws_string (pp, "__vector"); + pp_c_left_paren (pp); + pp_wide_integer (pp, TYPE_VECTOR_SUBPARTS (t)); + pp_c_right_paren (pp); + pp_c_whitespace (pp); + } + pp_c_specifier_qualifier_list (pp, TREE_TYPE (t)); + break; + + default: + pp_simple_type_specifier (pp, t); + break; + } +} + +/* parameter-type-list: + parameter-list + parameter-list , ... + + parameter-list: + parameter-declaration + parameter-list , parameter-declaration + + parameter-declaration: + declaration-specifiers declarator + declaration-specifiers abstract-declarator(opt) */ + +void +pp_c_parameter_type_list (c_pretty_printer *pp, tree t) +{ + bool want_parm_decl = DECL_P (t) && !(pp->flags & pp_c_flag_abstract); + tree parms = want_parm_decl ? DECL_ARGUMENTS (t) : TYPE_ARG_TYPES (t); + pp_c_left_paren (pp); + if (parms == void_list_node) + pp_c_ws_string (pp, "void"); + else + { + bool first = true; + for ( ; parms && parms != void_list_node; parms = TREE_CHAIN (parms)) + { + if (!first) + pp_separate_with (pp, ','); + first = false; + pp_declaration_specifiers + (pp, want_parm_decl ? parms : TREE_VALUE (parms)); + if (want_parm_decl) + pp_declarator (pp, parms); + else + pp_abstract_declarator (pp, TREE_VALUE (parms)); + } + } + pp_c_right_paren (pp); +} + +/* abstract-declarator: + pointer + pointer(opt) direct-abstract-declarator */ + +static void +pp_c_abstract_declarator (c_pretty_printer *pp, tree t) +{ + if (TREE_CODE (t) == POINTER_TYPE) + { + if (TREE_CODE (TREE_TYPE (t)) == ARRAY_TYPE + || TREE_CODE (TREE_TYPE (t)) == FUNCTION_TYPE) + pp_c_right_paren (pp); + t = TREE_TYPE (t); + } + + pp_direct_abstract_declarator (pp, t); +} + +/* direct-abstract-declarator: + ( abstract-declarator ) + direct-abstract-declarator(opt) [ assignment-expression(opt) ] + direct-abstract-declarator(opt) [ * ] + direct-abstract-declarator(opt) ( parameter-type-list(opt) ) */ + +void +pp_c_direct_abstract_declarator (c_pretty_printer *pp, tree t) +{ + switch (TREE_CODE (t)) + { + case POINTER_TYPE: + pp_abstract_declarator (pp, t); + break; + + case FUNCTION_TYPE: + pp_c_parameter_type_list (pp, t); + pp_direct_abstract_declarator (pp, TREE_TYPE (t)); + break; + + case ARRAY_TYPE: + pp_c_left_bracket (pp); + if (TYPE_DOMAIN (t) && TYPE_MAX_VALUE (TYPE_DOMAIN (t))) + { + tree maxval = TYPE_MAX_VALUE (TYPE_DOMAIN (t)); + tree type = TREE_TYPE (maxval); + + if (host_integerp (maxval, 0)) + pp_wide_integer (pp, tree_low_cst (maxval, 0) + 1); + else + pp_expression (pp, fold_build2 (PLUS_EXPR, type, maxval, + build_int_cst (type, 1))); + } + pp_c_right_bracket (pp); + pp_direct_abstract_declarator (pp, TREE_TYPE (t)); + break; + + case IDENTIFIER_NODE: + case VOID_TYPE: + case BOOLEAN_TYPE: + case INTEGER_TYPE: + case REAL_TYPE: + case FIXED_POINT_TYPE: + case ENUMERAL_TYPE: + case RECORD_TYPE: + case UNION_TYPE: + case VECTOR_TYPE: + case COMPLEX_TYPE: + case TYPE_DECL: + break; + + default: + pp_unsupported_tree (pp, t); + break; + } +} + +/* type-name: + specifier-qualifier-list abstract-declarator(opt) */ + +void +pp_c_type_id (c_pretty_printer *pp, tree t) +{ + pp_c_specifier_qualifier_list (pp, t); + pp_abstract_declarator (pp, t); +} + +/* storage-class-specifier: + typedef + extern + static + auto + register */ + +void +pp_c_storage_class_specifier (c_pretty_printer *pp, tree t) +{ + if (TREE_CODE (t) == TYPE_DECL) + pp_c_ws_string (pp, "typedef"); + else if (DECL_P (t)) + { + if (DECL_REGISTER (t)) + pp_c_ws_string (pp, "register"); + else if (TREE_STATIC (t) && TREE_CODE (t) == VAR_DECL) + pp_c_ws_string (pp, "static"); + } +} + +/* function-specifier: + inline */ + +void +pp_c_function_specifier (c_pretty_printer *pp, tree t) +{ + if (TREE_CODE (t) == FUNCTION_DECL && DECL_DECLARED_INLINE_P (t)) + pp_c_ws_string (pp, "inline"); +} + +/* declaration-specifiers: + storage-class-specifier declaration-specifiers(opt) + type-specifier declaration-specifiers(opt) + type-qualifier declaration-specifiers(opt) + function-specifier declaration-specifiers(opt) */ + +void +pp_c_declaration_specifiers (c_pretty_printer *pp, tree t) +{ + pp_storage_class_specifier (pp, t); + pp_function_specifier (pp, t); + pp_c_specifier_qualifier_list (pp, DECL_P (t) ? TREE_TYPE (t) : t); +} + +/* direct-declarator + identifier + ( declarator ) + direct-declarator [ type-qualifier-list(opt) assignment-expression(opt) ] + direct-declarator [ static type-qualifier-list(opt) assignment-expression(opt)] + direct-declarator [ type-qualifier-list static assignment-expression ] + direct-declarator [ type-qualifier-list * ] + direct-declarator ( parameter-type-list ) + direct-declarator ( identifier-list(opt) ) */ + +void +pp_c_direct_declarator (c_pretty_printer *pp, tree t) +{ + switch (TREE_CODE (t)) + { + case VAR_DECL: + case PARM_DECL: + case TYPE_DECL: + case FIELD_DECL: + case LABEL_DECL: + pp_c_space_for_pointer_operator (pp, TREE_TYPE (t)); + pp_c_tree_decl_identifier (pp, t); + break; + + case ARRAY_TYPE: + case POINTER_TYPE: + pp_abstract_declarator (pp, TREE_TYPE (t)); + break; + + case FUNCTION_TYPE: + pp_parameter_list (pp, t); + pp_abstract_declarator (pp, TREE_TYPE (t)); + break; + + case FUNCTION_DECL: + pp_c_space_for_pointer_operator (pp, TREE_TYPE (TREE_TYPE (t))); + pp_c_tree_decl_identifier (pp, t); + if (pp_c_base (pp)->flags & pp_c_flag_abstract) + pp_abstract_declarator (pp, TREE_TYPE (t)); + else + { + pp_parameter_list (pp, t); + pp_abstract_declarator (pp, TREE_TYPE (TREE_TYPE (t))); + } + break; + + case INTEGER_TYPE: + case REAL_TYPE: + case FIXED_POINT_TYPE: + case ENUMERAL_TYPE: + case UNION_TYPE: + case RECORD_TYPE: + break; + + default: + pp_unsupported_tree (pp, t); + break; + } +} + + +/* declarator: + pointer(opt) direct-declarator */ + +void +pp_c_declarator (c_pretty_printer *pp, tree t) +{ + switch (TREE_CODE (t)) + { + case INTEGER_TYPE: + case REAL_TYPE: + case FIXED_POINT_TYPE: + case ENUMERAL_TYPE: + case UNION_TYPE: + case RECORD_TYPE: + break; + + case VAR_DECL: + case PARM_DECL: + case FIELD_DECL: + case ARRAY_TYPE: + case FUNCTION_TYPE: + case FUNCTION_DECL: + case TYPE_DECL: + pp_direct_declarator (pp, t); + break; + + + default: + pp_unsupported_tree (pp, t); + break; + } +} + +/* declaration: + declaration-specifiers init-declarator-list(opt) ; */ + +void +pp_c_declaration (c_pretty_printer *pp, tree t) +{ + pp_declaration_specifiers (pp, t); + pp_c_init_declarator (pp, t); +} + +/* Pretty-print ATTRIBUTES using GNU C extension syntax. */ + +void +pp_c_attributes (c_pretty_printer *pp, tree attributes) +{ + if (attributes == NULL_TREE) + return; + + pp_c_ws_string (pp, "__attribute__"); + pp_c_left_paren (pp); + pp_c_left_paren (pp); + for (; attributes != NULL_TREE; attributes = TREE_CHAIN (attributes)) + { + pp_tree_identifier (pp, TREE_PURPOSE (attributes)); + if (TREE_VALUE (attributes)) + pp_c_call_argument_list (pp, TREE_VALUE (attributes)); + + if (TREE_CHAIN (attributes)) + pp_separate_with (pp, ','); + } + pp_c_right_paren (pp); + pp_c_right_paren (pp); +} + +/* function-definition: + declaration-specifiers declarator compound-statement */ + +void +pp_c_function_definition (c_pretty_printer *pp, tree t) +{ + pp_declaration_specifiers (pp, t); + pp_declarator (pp, t); + pp_needs_newline (pp) = true; + pp_statement (pp, DECL_SAVED_TREE (t)); + pp_newline (pp); + pp_flush (pp); +} + + +/* Expressions. */ + +/* Print out a c-char. This is called solely for characters which are + in the *target* execution character set. We ought to convert them + back to the *host* execution character set before printing, but we + have no way to do this at present. A decent compromise is to print + all characters as if they were in the host execution character set, + and not attempt to recover any named escape characters, but render + all unprintables as octal escapes. If the host and target character + sets are the same, this produces relatively readable output. If they + are not the same, strings may appear as gibberish, but that's okay + (in fact, it may well be what the reader wants, e.g. if they are looking + to see if conversion to the target character set happened correctly). + + A special case: we need to prefix \, ", and ' with backslashes. It is + correct to do so for the *host*'s \, ", and ', because the rest of the + file appears in the host character set. */ + +static void +pp_c_char (c_pretty_printer *pp, int c) +{ + if (ISPRINT (c)) + { + switch (c) + { + case '\\': pp_string (pp, "\\\\"); break; + case '\'': pp_string (pp, "\\\'"); break; + case '\"': pp_string (pp, "\\\""); break; + default: pp_character (pp, c); + } + } + else + pp_scalar (pp, "\\%03o", (unsigned) c); +} + +/* Print out a STRING literal. */ + +void +pp_c_string_literal (c_pretty_printer *pp, tree s) +{ + const char *p = TREE_STRING_POINTER (s); + int n = TREE_STRING_LENGTH (s) - 1; + int i; + pp_doublequote (pp); + for (i = 0; i < n; ++i) + pp_c_char (pp, p[i]); + pp_doublequote (pp); +} + +/* Pretty-print an INTEGER literal. */ + +static void +pp_c_integer_constant (c_pretty_printer *pp, tree i) +{ + tree type = TREE_TYPE (i); + + if (TREE_INT_CST_HIGH (i) == 0) + pp_wide_integer (pp, TREE_INT_CST_LOW (i)); + else + { + unsigned HOST_WIDE_INT low = TREE_INT_CST_LOW (i); + HOST_WIDE_INT high = TREE_INT_CST_HIGH (i); + if (tree_int_cst_sgn (i) < 0) + { + pp_character (pp, '-'); + high = ~high + !low; + low = -low; + } + sprintf (pp_buffer (pp)->digit_buffer, HOST_WIDE_INT_PRINT_DOUBLE_HEX, + (unsigned HOST_WIDE_INT) high, (unsigned HOST_WIDE_INT) low); + pp_string (pp, pp_buffer (pp)->digit_buffer); + } + if (TYPE_UNSIGNED (type)) + pp_character (pp, 'u'); + if (type == long_integer_type_node || type == long_unsigned_type_node) + pp_character (pp, 'l'); + else if (type == long_long_integer_type_node + || type == long_long_unsigned_type_node) + pp_string (pp, "ll"); + else if (type == int128_integer_type_node + || type == int128_unsigned_type_node) + pp_string (pp, "I128"); +} + +/* Print out a CHARACTER literal. */ + +static void +pp_c_character_constant (c_pretty_printer *pp, tree c) +{ + tree type = TREE_TYPE (c); + if (type == wchar_type_node) + pp_character (pp, 'L'); + pp_quote (pp); + if (host_integerp (c, TYPE_UNSIGNED (type))) + pp_c_char (pp, tree_low_cst (c, TYPE_UNSIGNED (type))); + else + pp_scalar (pp, "\\x%x", (unsigned) TREE_INT_CST_LOW (c)); + pp_quote (pp); +} + +/* Print out a BOOLEAN literal. */ + +static void +pp_c_bool_constant (c_pretty_printer *pp, tree b) +{ + if (b == boolean_false_node) + { + if (c_dialect_cxx ()) + pp_c_ws_string (pp, "false"); + else if (flag_isoc99) + pp_c_ws_string (pp, "_False"); + else + pp_unsupported_tree (pp, b); + } + else if (b == boolean_true_node) + { + if (c_dialect_cxx ()) + pp_c_ws_string (pp, "true"); + else if (flag_isoc99) + pp_c_ws_string (pp, "_True"); + else + pp_unsupported_tree (pp, b); + } + else if (TREE_CODE (b) == INTEGER_CST) + pp_c_integer_constant (pp, b); + else + pp_unsupported_tree (pp, b); +} + +/* Attempt to print out an ENUMERATOR. Return true on success. Else return + false; that means the value was obtained by a cast, in which case + print out the type-id part of the cast-expression -- the casted value + is then printed by pp_c_integer_literal. */ + +static bool +pp_c_enumeration_constant (c_pretty_printer *pp, tree e) +{ + bool value_is_named = true; + tree type = TREE_TYPE (e); + tree value; + + /* Find the name of this constant. */ + for (value = TYPE_VALUES (type); + value != NULL_TREE && !tree_int_cst_equal (TREE_VALUE (value), e); + value = TREE_CHAIN (value)) + ; + + if (value != NULL_TREE) + pp_id_expression (pp, TREE_PURPOSE (value)); + else + { + /* Value must have been cast. */ + pp_c_type_cast (pp, type); + value_is_named = false; + } + + return value_is_named; +} + +/* Print out a REAL value as a decimal-floating-constant. */ + +static void +pp_c_floating_constant (c_pretty_printer *pp, tree r) +{ + real_to_decimal (pp_buffer (pp)->digit_buffer, &TREE_REAL_CST (r), + sizeof (pp_buffer (pp)->digit_buffer), 0, 1); + pp_string (pp, pp_buffer(pp)->digit_buffer); + if (TREE_TYPE (r) == float_type_node) + pp_character (pp, 'f'); + else if (TREE_TYPE (r) == long_double_type_node) + pp_character (pp, 'l'); + else if (TREE_TYPE (r) == dfloat128_type_node) + pp_string (pp, "dl"); + else if (TREE_TYPE (r) == dfloat64_type_node) + pp_string (pp, "dd"); + else if (TREE_TYPE (r) == dfloat32_type_node) + pp_string (pp, "df"); +} + +/* Print out a FIXED value as a decimal-floating-constant. */ + +static void +pp_c_fixed_constant (c_pretty_printer *pp, tree r) +{ + fixed_to_decimal (pp_buffer (pp)->digit_buffer, &TREE_FIXED_CST (r), + sizeof (pp_buffer (pp)->digit_buffer)); + pp_string (pp, pp_buffer(pp)->digit_buffer); +} + +/* Pretty-print a compound literal expression. GNU extensions include + vector constants. */ + +static void +pp_c_compound_literal (c_pretty_printer *pp, tree e) +{ + tree type = TREE_TYPE (e); + pp_c_type_cast (pp, type); + + switch (TREE_CODE (type)) + { + case RECORD_TYPE: + case UNION_TYPE: + case ARRAY_TYPE: + case VECTOR_TYPE: + case COMPLEX_TYPE: + pp_c_brace_enclosed_initializer_list (pp, e); + break; + + default: + pp_unsupported_tree (pp, e); + break; + } +} + +/* Pretty-print a COMPLEX_EXPR expression. */ + +static void +pp_c_complex_expr (c_pretty_printer *pp, tree e) +{ + /* Handle a few common special cases, otherwise fallback + to printing it as compound literal. */ + tree type = TREE_TYPE (e); + tree realexpr = TREE_OPERAND (e, 0); + tree imagexpr = TREE_OPERAND (e, 1); + + /* Cast of an COMPLEX_TYPE expression to a different COMPLEX_TYPE. */ + if (TREE_CODE (realexpr) == NOP_EXPR + && TREE_CODE (imagexpr) == NOP_EXPR + && TREE_TYPE (realexpr) == TREE_TYPE (type) + && TREE_TYPE (imagexpr) == TREE_TYPE (type) + && TREE_CODE (TREE_OPERAND (realexpr, 0)) == REALPART_EXPR + && TREE_CODE (TREE_OPERAND (imagexpr, 0)) == IMAGPART_EXPR + && TREE_OPERAND (TREE_OPERAND (realexpr, 0), 0) + == TREE_OPERAND (TREE_OPERAND (imagexpr, 0), 0)) + { + pp_c_type_cast (pp, type); + pp_expression (pp, TREE_OPERAND (TREE_OPERAND (realexpr, 0), 0)); + return; + } + + /* Cast of an scalar expression to COMPLEX_TYPE. */ + if ((integer_zerop (imagexpr) || real_zerop (imagexpr)) + && TREE_TYPE (realexpr) == TREE_TYPE (type)) + { + pp_c_type_cast (pp, type); + if (TREE_CODE (realexpr) == NOP_EXPR) + realexpr = TREE_OPERAND (realexpr, 0); + pp_expression (pp, realexpr); + return; + } + + pp_c_compound_literal (pp, e); +} + +/* constant: + integer-constant + floating-constant + fixed-point-constant + enumeration-constant + character-constant */ + +void +pp_c_constant (c_pretty_printer *pp, tree e) +{ + const enum tree_code code = TREE_CODE (e); + + switch (code) + { + case INTEGER_CST: + { + tree type = TREE_TYPE (e); + if (type == boolean_type_node) + pp_c_bool_constant (pp, e); + else if (type == char_type_node) + pp_c_character_constant (pp, e); + else if (TREE_CODE (type) == ENUMERAL_TYPE + && pp_c_enumeration_constant (pp, e)) + ; + else + pp_c_integer_constant (pp, e); + } + break; + + case REAL_CST: + pp_c_floating_constant (pp, e); + break; + + case FIXED_CST: + pp_c_fixed_constant (pp, e); + break; + + case STRING_CST: + pp_c_string_literal (pp, e); + break; + + case COMPLEX_CST: + /* Sometimes, we are confused and we think a complex literal + is a constant. Such thing is a compound literal which + grammatically belongs to postfix-expr production. */ + pp_c_compound_literal (pp, e); + break; + + default: + pp_unsupported_tree (pp, e); + break; + } +} + +/* Pretty-print a string such as an identifier, without changing its + encoding, preceded by whitespace is necessary. */ + +void +pp_c_ws_string (c_pretty_printer *pp, const char *str) +{ + pp_c_maybe_whitespace (pp); + pp_string (pp, str); + pp_base (pp)->padding = pp_before; +} + +/* Pretty-print an IDENTIFIER_NODE, which may contain UTF-8 sequences + that need converting to the locale encoding, preceded by whitespace + is necessary. */ + +void +pp_c_identifier (c_pretty_printer *pp, const char *id) +{ + pp_c_maybe_whitespace (pp); + pp_identifier (pp, id); + pp_base (pp)->padding = pp_before; +} + +/* Pretty-print a C primary-expression. + primary-expression: + identifier + constant + string-literal + ( expression ) */ + +void +pp_c_primary_expression (c_pretty_printer *pp, tree e) +{ + switch (TREE_CODE (e)) + { + case VAR_DECL: + case PARM_DECL: + case FIELD_DECL: + case CONST_DECL: + case FUNCTION_DECL: + case LABEL_DECL: + pp_c_tree_decl_identifier (pp, e); + break; + + case IDENTIFIER_NODE: + pp_c_tree_identifier (pp, e); + break; + + case ERROR_MARK: + pp_c_ws_string (pp, M_("")); + break; + + case RESULT_DECL: + pp_c_ws_string (pp, M_("")); + break; + + case INTEGER_CST: + case REAL_CST: + case FIXED_CST: + case STRING_CST: + pp_c_constant (pp, e); + break; + + case TARGET_EXPR: + pp_c_ws_string (pp, "__builtin_memcpy"); + pp_c_left_paren (pp); + pp_ampersand (pp); + pp_primary_expression (pp, TREE_OPERAND (e, 0)); + pp_separate_with (pp, ','); + pp_ampersand (pp); + pp_initializer (pp, TREE_OPERAND (e, 1)); + if (TREE_OPERAND (e, 2)) + { + pp_separate_with (pp, ','); + pp_c_expression (pp, TREE_OPERAND (e, 2)); + } + pp_c_right_paren (pp); + break; + + default: + /* FIXME: Make sure we won't get into an infinite loop. */ + pp_c_left_paren (pp); + pp_expression (pp, e); + pp_c_right_paren (pp); + break; + } +} + +/* Print out a C initializer -- also support C compound-literals. + initializer: + assignment-expression: + { initializer-list } + { initializer-list , } */ + +static void +pp_c_initializer (c_pretty_printer *pp, tree e) +{ + if (TREE_CODE (e) == CONSTRUCTOR) + pp_c_brace_enclosed_initializer_list (pp, e); + else + pp_expression (pp, e); +} + +/* init-declarator: + declarator: + declarator = initializer */ + +void +pp_c_init_declarator (c_pretty_printer *pp, tree t) +{ + pp_declarator (pp, t); + /* We don't want to output function definitions here. There are handled + elsewhere (and the syntactic form is bogus anyway). */ + if (TREE_CODE (t) != FUNCTION_DECL && DECL_INITIAL (t)) + { + tree init = DECL_INITIAL (t); + /* This C++ bit is handled here because it is easier to do so. + In templates, the C++ parser builds a TREE_LIST for a + direct-initialization; the TREE_PURPOSE is the variable to + initialize and the TREE_VALUE is the initializer. */ + if (TREE_CODE (init) == TREE_LIST) + { + pp_c_left_paren (pp); + pp_expression (pp, TREE_VALUE (init)); + pp_right_paren (pp); + } + else + { + pp_space (pp); + pp_equal (pp); + pp_space (pp); + pp_c_initializer (pp, init); + } + } +} + +/* initializer-list: + designation(opt) initializer + initializer-list , designation(opt) initializer + + designation: + designator-list = + + designator-list: + designator + designator-list designator + + designator: + [ constant-expression ] + identifier */ + +static void +pp_c_initializer_list (c_pretty_printer *pp, tree e) +{ + tree type = TREE_TYPE (e); + const enum tree_code code = TREE_CODE (type); + + if (TREE_CODE (e) == CONSTRUCTOR) + { + pp_c_constructor_elts (pp, CONSTRUCTOR_ELTS (e)); + return; + } + + switch (code) + { + case RECORD_TYPE: + case UNION_TYPE: + case ARRAY_TYPE: + { + tree init = TREE_OPERAND (e, 0); + for (; init != NULL_TREE; init = TREE_CHAIN (init)) + { + if (code == RECORD_TYPE || code == UNION_TYPE) + { + pp_c_dot (pp); + pp_c_primary_expression (pp, TREE_PURPOSE (init)); + } + else + { + pp_c_left_bracket (pp); + if (TREE_PURPOSE (init)) + pp_c_constant (pp, TREE_PURPOSE (init)); + pp_c_right_bracket (pp); + } + pp_c_whitespace (pp); + pp_equal (pp); + pp_c_whitespace (pp); + pp_initializer (pp, TREE_VALUE (init)); + if (TREE_CHAIN (init)) + pp_separate_with (pp, ','); + } + } + return; + + case VECTOR_TYPE: + if (TREE_CODE (e) == VECTOR_CST) + pp_c_expression_list (pp, TREE_VECTOR_CST_ELTS (e)); + else + break; + return; + + case COMPLEX_TYPE: + if (TREE_CODE (e) == COMPLEX_CST || TREE_CODE (e) == COMPLEX_EXPR) + { + const bool cst = TREE_CODE (e) == COMPLEX_CST; + pp_expression (pp, cst ? TREE_REALPART (e) : TREE_OPERAND (e, 0)); + pp_separate_with (pp, ','); + pp_expression (pp, cst ? TREE_IMAGPART (e) : TREE_OPERAND (e, 1)); + } + else + break; + return; + + default: + break; + } + + pp_unsupported_tree (pp, type); +} + +/* Pretty-print a brace-enclosed initializer-list. */ + +static void +pp_c_brace_enclosed_initializer_list (c_pretty_printer *pp, tree l) +{ + pp_c_left_brace (pp); + pp_c_initializer_list (pp, l); + pp_c_right_brace (pp); +} + + +/* This is a convenient function, used to bridge gap between C and C++ + grammars. + + id-expression: + identifier */ + +void +pp_c_id_expression (c_pretty_printer *pp, tree t) +{ + switch (TREE_CODE (t)) + { + case VAR_DECL: + case PARM_DECL: + case CONST_DECL: + case TYPE_DECL: + case FUNCTION_DECL: + case FIELD_DECL: + case LABEL_DECL: + pp_c_tree_decl_identifier (pp, t); + break; + + case IDENTIFIER_NODE: + pp_c_tree_identifier (pp, t); + break; + + default: + pp_unsupported_tree (pp, t); + break; + } +} + +/* postfix-expression: + primary-expression + postfix-expression [ expression ] + postfix-expression ( argument-expression-list(opt) ) + postfix-expression . identifier + postfix-expression -> identifier + postfix-expression ++ + postfix-expression -- + ( type-name ) { initializer-list } + ( type-name ) { initializer-list , } */ + +void +pp_c_postfix_expression (c_pretty_printer *pp, tree e) +{ + enum tree_code code = TREE_CODE (e); + switch (code) + { + case POSTINCREMENT_EXPR: + case POSTDECREMENT_EXPR: + pp_postfix_expression (pp, TREE_OPERAND (e, 0)); + pp_string (pp, code == POSTINCREMENT_EXPR ? "++" : "--"); + break; + + case ARRAY_REF: + pp_postfix_expression (pp, TREE_OPERAND (e, 0)); + pp_c_left_bracket (pp); + pp_expression (pp, TREE_OPERAND (e, 1)); + pp_c_right_bracket (pp); + break; + + case CALL_EXPR: + { + call_expr_arg_iterator iter; + tree arg; + pp_postfix_expression (pp, CALL_EXPR_FN (e)); + pp_c_left_paren (pp); + FOR_EACH_CALL_EXPR_ARG (arg, iter, e) + { + pp_expression (pp, arg); + if (more_call_expr_args_p (&iter)) + pp_separate_with (pp, ','); + } + pp_c_right_paren (pp); + break; + } + + case UNORDERED_EXPR: + pp_c_ws_string (pp, flag_isoc99 + ? "isunordered" + : "__builtin_isunordered"); + goto two_args_fun; + + case ORDERED_EXPR: + pp_c_ws_string (pp, flag_isoc99 + ? "!isunordered" + : "!__builtin_isunordered"); + goto two_args_fun; + + case UNLT_EXPR: + pp_c_ws_string (pp, flag_isoc99 + ? "!isgreaterequal" + : "!__builtin_isgreaterequal"); + goto two_args_fun; + + case UNLE_EXPR: + pp_c_ws_string (pp, flag_isoc99 + ? "!isgreater" + : "!__builtin_isgreater"); + goto two_args_fun; + + case UNGT_EXPR: + pp_c_ws_string (pp, flag_isoc99 + ? "!islessequal" + : "!__builtin_islessequal"); + goto two_args_fun; + + case UNGE_EXPR: + pp_c_ws_string (pp, flag_isoc99 + ? "!isless" + : "!__builtin_isless"); + goto two_args_fun; + + case UNEQ_EXPR: + pp_c_ws_string (pp, flag_isoc99 + ? "!islessgreater" + : "!__builtin_islessgreater"); + goto two_args_fun; + + case LTGT_EXPR: + pp_c_ws_string (pp, flag_isoc99 + ? "islessgreater" + : "__builtin_islessgreater"); + goto two_args_fun; + + two_args_fun: + pp_c_left_paren (pp); + pp_expression (pp, TREE_OPERAND (e, 0)); + pp_separate_with (pp, ','); + pp_expression (pp, TREE_OPERAND (e, 1)); + pp_c_right_paren (pp); + break; + + case ABS_EXPR: + pp_c_ws_string (pp, "__builtin_abs"); + pp_c_left_paren (pp); + pp_expression (pp, TREE_OPERAND (e, 0)); + pp_c_right_paren (pp); + break; + + case COMPONENT_REF: + { + tree object = TREE_OPERAND (e, 0); + if (TREE_CODE (object) == INDIRECT_REF) + { + pp_postfix_expression (pp, TREE_OPERAND (object, 0)); + pp_c_arrow (pp); + } + else + { + pp_postfix_expression (pp, object); + pp_c_dot (pp); + } + pp_expression (pp, TREE_OPERAND (e, 1)); + } + break; + + case BIT_FIELD_REF: + { + tree type = TREE_TYPE (e); + + type = signed_or_unsigned_type_for (TYPE_UNSIGNED (type), type); + if (type + && tree_int_cst_equal (TYPE_SIZE (type), TREE_OPERAND (e, 1))) + { + HOST_WIDE_INT bitpos = tree_low_cst (TREE_OPERAND (e, 2), 0); + HOST_WIDE_INT size = tree_low_cst (TYPE_SIZE (type), 0); + if ((bitpos % size) == 0) + { + pp_c_left_paren (pp); + pp_c_left_paren (pp); + pp_type_id (pp, type); + pp_c_star (pp); + pp_c_right_paren (pp); + pp_c_ampersand (pp); + pp_expression (pp, TREE_OPERAND (e, 0)); + pp_c_right_paren (pp); + pp_c_left_bracket (pp); + pp_wide_integer (pp, bitpos / size); + pp_c_right_bracket (pp); + break; + } + } + pp_unsupported_tree (pp, e); + } + break; + + case COMPLEX_CST: + case VECTOR_CST: + pp_c_compound_literal (pp, e); + break; + + case COMPLEX_EXPR: + pp_c_complex_expr (pp, e); + break; + + case COMPOUND_LITERAL_EXPR: + e = DECL_INITIAL (COMPOUND_LITERAL_EXPR_DECL (e)); + /* Fall through. */ + case CONSTRUCTOR: + pp_initializer (pp, e); + break; + + case VA_ARG_EXPR: + pp_c_ws_string (pp, "__builtin_va_arg"); + pp_c_left_paren (pp); + pp_assignment_expression (pp, TREE_OPERAND (e, 0)); + pp_separate_with (pp, ','); + pp_type_id (pp, TREE_TYPE (e)); + pp_c_right_paren (pp); + break; + + case ADDR_EXPR: + if (TREE_CODE (TREE_OPERAND (e, 0)) == FUNCTION_DECL) + { + pp_c_id_expression (pp, TREE_OPERAND (e, 0)); + break; + } + /* else fall through. */ + + default: + pp_primary_expression (pp, e); + break; + } +} + +/* Print out an expression-list; E is expected to be a TREE_LIST. */ + +void +pp_c_expression_list (c_pretty_printer *pp, tree e) +{ + for (; e != NULL_TREE; e = TREE_CHAIN (e)) + { + pp_expression (pp, TREE_VALUE (e)); + if (TREE_CHAIN (e)) + pp_separate_with (pp, ','); + } +} + +/* Print out V, which contains the elements of a constructor. */ + +void +pp_c_constructor_elts (c_pretty_printer *pp, VEC(constructor_elt,gc) *v) +{ + unsigned HOST_WIDE_INT ix; + tree value; + + FOR_EACH_CONSTRUCTOR_VALUE (v, ix, value) + { + pp_expression (pp, value); + if (ix != VEC_length (constructor_elt, v) - 1) + pp_separate_with (pp, ','); + } +} + +/* Print out an expression-list in parens, as if it were the argument + list to a function. */ + +void +pp_c_call_argument_list (c_pretty_printer *pp, tree t) +{ + pp_c_left_paren (pp); + if (t && TREE_CODE (t) == TREE_LIST) + pp_c_expression_list (pp, t); + pp_c_right_paren (pp); +} + +/* unary-expression: + postfix-expression + ++ cast-expression + -- cast-expression + unary-operator cast-expression + sizeof unary-expression + sizeof ( type-id ) + + unary-operator: one of + * & + - ! ~ + + GNU extensions. + unary-expression: + __alignof__ unary-expression + __alignof__ ( type-id ) + __real__ unary-expression + __imag__ unary-expression */ + +void +pp_c_unary_expression (c_pretty_printer *pp, tree e) +{ + enum tree_code code = TREE_CODE (e); + switch (code) + { + case PREINCREMENT_EXPR: + case PREDECREMENT_EXPR: + pp_string (pp, code == PREINCREMENT_EXPR ? "++" : "--"); + pp_c_unary_expression (pp, TREE_OPERAND (e, 0)); + break; + + case ADDR_EXPR: + case INDIRECT_REF: + case NEGATE_EXPR: + case BIT_NOT_EXPR: + case TRUTH_NOT_EXPR: + case CONJ_EXPR: + /* String literal are used by address. */ + if (code == ADDR_EXPR && TREE_CODE (TREE_OPERAND (e, 0)) != STRING_CST) + pp_ampersand (pp); + else if (code == INDIRECT_REF) + pp_c_star (pp); + else if (code == NEGATE_EXPR) + pp_minus (pp); + else if (code == BIT_NOT_EXPR || code == CONJ_EXPR) + pp_complement (pp); + else if (code == TRUTH_NOT_EXPR) + pp_exclamation (pp); + pp_c_cast_expression (pp, TREE_OPERAND (e, 0)); + break; + + case REALPART_EXPR: + case IMAGPART_EXPR: + pp_c_ws_string (pp, code == REALPART_EXPR ? "__real__" : "__imag__"); + pp_c_whitespace (pp); + pp_unary_expression (pp, TREE_OPERAND (e, 0)); + break; + + default: + pp_postfix_expression (pp, e); + break; + } +} + +/* cast-expression: + unary-expression + ( type-name ) cast-expression */ + +void +pp_c_cast_expression (c_pretty_printer *pp, tree e) +{ + switch (TREE_CODE (e)) + { + case FLOAT_EXPR: + case FIX_TRUNC_EXPR: + CASE_CONVERT: + case VIEW_CONVERT_EXPR: + pp_c_type_cast (pp, TREE_TYPE (e)); + pp_c_cast_expression (pp, TREE_OPERAND (e, 0)); + break; + + default: + pp_unary_expression (pp, e); + } +} + +/* multiplicative-expression: + cast-expression + multiplicative-expression * cast-expression + multiplicative-expression / cast-expression + multiplicative-expression % cast-expression */ + +static void +pp_c_multiplicative_expression (c_pretty_printer *pp, tree e) +{ + enum tree_code code = TREE_CODE (e); + switch (code) + { + case MULT_EXPR: + case TRUNC_DIV_EXPR: + case TRUNC_MOD_EXPR: + pp_multiplicative_expression (pp, TREE_OPERAND (e, 0)); + pp_c_whitespace (pp); + if (code == MULT_EXPR) + pp_c_star (pp); + else if (code == TRUNC_DIV_EXPR) + pp_slash (pp); + else + pp_modulo (pp); + pp_c_whitespace (pp); + pp_c_cast_expression (pp, TREE_OPERAND (e, 1)); + break; + + default: + pp_c_cast_expression (pp, e); + break; + } +} + +/* additive-expression: + multiplicative-expression + additive-expression + multiplicative-expression + additive-expression - multiplicative-expression */ + +static void +pp_c_additive_expression (c_pretty_printer *pp, tree e) +{ + enum tree_code code = TREE_CODE (e); + switch (code) + { + case POINTER_PLUS_EXPR: + case PLUS_EXPR: + case MINUS_EXPR: + pp_c_additive_expression (pp, TREE_OPERAND (e, 0)); + pp_c_whitespace (pp); + if (code == PLUS_EXPR || code == POINTER_PLUS_EXPR) + pp_plus (pp); + else + pp_minus (pp); + pp_c_whitespace (pp); + pp_multiplicative_expression (pp, TREE_OPERAND (e, 1)); + break; + + default: + pp_multiplicative_expression (pp, e); + break; + } +} + +/* additive-expression: + additive-expression + shift-expression << additive-expression + shift-expression >> additive-expression */ + +static void +pp_c_shift_expression (c_pretty_printer *pp, tree e) +{ + enum tree_code code = TREE_CODE (e); + switch (code) + { + case LSHIFT_EXPR: + case RSHIFT_EXPR: + pp_c_shift_expression (pp, TREE_OPERAND (e, 0)); + pp_c_whitespace (pp); + pp_string (pp, code == LSHIFT_EXPR ? "<<" : ">>"); + pp_c_whitespace (pp); + pp_c_additive_expression (pp, TREE_OPERAND (e, 1)); + break; + + default: + pp_c_additive_expression (pp, e); + } +} + +/* relational-expression: + shift-expression + relational-expression < shift-expression + relational-expression > shift-expression + relational-expression <= shift-expression + relational-expression >= shift-expression */ + +static void +pp_c_relational_expression (c_pretty_printer *pp, tree e) +{ + enum tree_code code = TREE_CODE (e); + switch (code) + { + case LT_EXPR: + case GT_EXPR: + case LE_EXPR: + case GE_EXPR: + pp_c_relational_expression (pp, TREE_OPERAND (e, 0)); + pp_c_whitespace (pp); + if (code == LT_EXPR) + pp_less (pp); + else if (code == GT_EXPR) + pp_greater (pp); + else if (code == LE_EXPR) + pp_string (pp, "<="); + else if (code == GE_EXPR) + pp_string (pp, ">="); + pp_c_whitespace (pp); + pp_c_shift_expression (pp, TREE_OPERAND (e, 1)); + break; + + default: + pp_c_shift_expression (pp, e); + break; + } +} + +/* equality-expression: + relational-expression + equality-expression == relational-expression + equality-equality != relational-expression */ + +static void +pp_c_equality_expression (c_pretty_printer *pp, tree e) +{ + enum tree_code code = TREE_CODE (e); + switch (code) + { + case EQ_EXPR: + case NE_EXPR: + pp_c_equality_expression (pp, TREE_OPERAND (e, 0)); + pp_c_whitespace (pp); + pp_string (pp, code == EQ_EXPR ? "==" : "!="); + pp_c_whitespace (pp); + pp_c_relational_expression (pp, TREE_OPERAND (e, 1)); + break; + + default: + pp_c_relational_expression (pp, e); + break; + } +} + +/* AND-expression: + equality-expression + AND-expression & equality-equality */ + +static void +pp_c_and_expression (c_pretty_printer *pp, tree e) +{ + if (TREE_CODE (e) == BIT_AND_EXPR) + { + pp_c_and_expression (pp, TREE_OPERAND (e, 0)); + pp_c_whitespace (pp); + pp_ampersand (pp); + pp_c_whitespace (pp); + pp_c_equality_expression (pp, TREE_OPERAND (e, 1)); + } + else + pp_c_equality_expression (pp, e); +} + +/* exclusive-OR-expression: + AND-expression + exclusive-OR-expression ^ AND-expression */ + +static void +pp_c_exclusive_or_expression (c_pretty_printer *pp, tree e) +{ + if (TREE_CODE (e) == BIT_XOR_EXPR + || TREE_CODE (e) == TRUTH_XOR_EXPR) + { + pp_c_exclusive_or_expression (pp, TREE_OPERAND (e, 0)); + if (TREE_CODE (e) == BIT_XOR_EXPR) + pp_c_maybe_whitespace (pp); + else + pp_c_whitespace (pp); + pp_carret (pp); + pp_c_whitespace (pp); + pp_c_and_expression (pp, TREE_OPERAND (e, 1)); + } + else + pp_c_and_expression (pp, e); +} + +/* inclusive-OR-expression: + exclusive-OR-expression + inclusive-OR-expression | exclusive-OR-expression */ + +static void +pp_c_inclusive_or_expression (c_pretty_printer *pp, tree e) +{ + if (TREE_CODE (e) == BIT_IOR_EXPR) + { + pp_c_exclusive_or_expression (pp, TREE_OPERAND (e, 0)); + pp_c_whitespace (pp); + pp_bar (pp); + pp_c_whitespace (pp); + pp_c_exclusive_or_expression (pp, TREE_OPERAND (e, 1)); + } + else + pp_c_exclusive_or_expression (pp, e); +} + +/* logical-AND-expression: + inclusive-OR-expression + logical-AND-expression && inclusive-OR-expression */ + +static void +pp_c_logical_and_expression (c_pretty_printer *pp, tree e) +{ + if (TREE_CODE (e) == TRUTH_ANDIF_EXPR + || TREE_CODE (e) == TRUTH_AND_EXPR) + { + pp_c_logical_and_expression (pp, TREE_OPERAND (e, 0)); + pp_c_whitespace (pp); + pp_string (pp, "&&"); + pp_c_whitespace (pp); + pp_c_inclusive_or_expression (pp, TREE_OPERAND (e, 1)); + } + else + pp_c_inclusive_or_expression (pp, e); +} + +/* logical-OR-expression: + logical-AND-expression + logical-OR-expression || logical-AND-expression */ + +void +pp_c_logical_or_expression (c_pretty_printer *pp, tree e) +{ + if (TREE_CODE (e) == TRUTH_ORIF_EXPR + || TREE_CODE (e) == TRUTH_OR_EXPR) + { + pp_c_logical_or_expression (pp, TREE_OPERAND (e, 0)); + pp_c_whitespace (pp); + pp_string (pp, "||"); + pp_c_whitespace (pp); + pp_c_logical_and_expression (pp, TREE_OPERAND (e, 1)); + } + else + pp_c_logical_and_expression (pp, e); +} + +/* conditional-expression: + logical-OR-expression + logical-OR-expression ? expression : conditional-expression */ + +static void +pp_c_conditional_expression (c_pretty_printer *pp, tree e) +{ + if (TREE_CODE (e) == COND_EXPR) + { + pp_c_logical_or_expression (pp, TREE_OPERAND (e, 0)); + pp_c_whitespace (pp); + pp_question (pp); + pp_c_whitespace (pp); + pp_expression (pp, TREE_OPERAND (e, 1)); + pp_c_whitespace (pp); + pp_colon (pp); + pp_c_whitespace (pp); + pp_c_conditional_expression (pp, TREE_OPERAND (e, 2)); + } + else + pp_c_logical_or_expression (pp, e); +} + + +/* assignment-expression: + conditional-expression + unary-expression assignment-operator assignment-expression + + assignment-expression: one of + = *= /= %= += -= >>= <<= &= ^= |= */ + +static void +pp_c_assignment_expression (c_pretty_printer *pp, tree e) +{ + if (TREE_CODE (e) == MODIFY_EXPR + || TREE_CODE (e) == INIT_EXPR) + { + pp_c_unary_expression (pp, TREE_OPERAND (e, 0)); + pp_c_whitespace (pp); + pp_equal (pp); + pp_space (pp); + pp_c_expression (pp, TREE_OPERAND (e, 1)); + } + else + pp_c_conditional_expression (pp, e); +} + +/* expression: + assignment-expression + expression , assignment-expression + + Implementation note: instead of going through the usual recursion + chain, I take the liberty of dispatching nodes to the appropriate + functions. This makes some redundancy, but it worths it. That also + prevents a possible infinite recursion between pp_c_primary_expression () + and pp_c_expression (). */ + +void +pp_c_expression (c_pretty_printer *pp, tree e) +{ + switch (TREE_CODE (e)) + { + case INTEGER_CST: + pp_c_integer_constant (pp, e); + break; + + case REAL_CST: + pp_c_floating_constant (pp, e); + break; + + case FIXED_CST: + pp_c_fixed_constant (pp, e); + break; + + case STRING_CST: + pp_c_string_literal (pp, e); + break; + + case IDENTIFIER_NODE: + case FUNCTION_DECL: + case VAR_DECL: + case CONST_DECL: + case PARM_DECL: + case RESULT_DECL: + case FIELD_DECL: + case LABEL_DECL: + case ERROR_MARK: + pp_primary_expression (pp, e); + break; + + case POSTINCREMENT_EXPR: + case POSTDECREMENT_EXPR: + case ARRAY_REF: + case CALL_EXPR: + case COMPONENT_REF: + case BIT_FIELD_REF: + case COMPLEX_CST: + case COMPLEX_EXPR: + case VECTOR_CST: + case ORDERED_EXPR: + case UNORDERED_EXPR: + case LTGT_EXPR: + case UNEQ_EXPR: + case UNLE_EXPR: + case UNLT_EXPR: + case UNGE_EXPR: + case UNGT_EXPR: + case ABS_EXPR: + case CONSTRUCTOR: + case COMPOUND_LITERAL_EXPR: + case VA_ARG_EXPR: + pp_postfix_expression (pp, e); + break; + + case CONJ_EXPR: + case ADDR_EXPR: + case INDIRECT_REF: + case NEGATE_EXPR: + case BIT_NOT_EXPR: + case TRUTH_NOT_EXPR: + case PREINCREMENT_EXPR: + case PREDECREMENT_EXPR: + case REALPART_EXPR: + case IMAGPART_EXPR: + pp_c_unary_expression (pp, e); + break; + + case FLOAT_EXPR: + case FIX_TRUNC_EXPR: + CASE_CONVERT: + case VIEW_CONVERT_EXPR: + pp_c_cast_expression (pp, e); + break; + + case MULT_EXPR: + case TRUNC_MOD_EXPR: + case TRUNC_DIV_EXPR: + pp_multiplicative_expression (pp, e); + break; + + case LSHIFT_EXPR: + case RSHIFT_EXPR: + pp_c_shift_expression (pp, e); + break; + + case LT_EXPR: + case GT_EXPR: + case LE_EXPR: + case GE_EXPR: + pp_c_relational_expression (pp, e); + break; + + case BIT_AND_EXPR: + pp_c_and_expression (pp, e); + break; + + case BIT_XOR_EXPR: + case TRUTH_XOR_EXPR: + pp_c_exclusive_or_expression (pp, e); + break; + + case BIT_IOR_EXPR: + pp_c_inclusive_or_expression (pp, e); + break; + + case TRUTH_ANDIF_EXPR: + case TRUTH_AND_EXPR: + pp_c_logical_and_expression (pp, e); + break; + + case TRUTH_ORIF_EXPR: + case TRUTH_OR_EXPR: + pp_c_logical_or_expression (pp, e); + break; + + case EQ_EXPR: + case NE_EXPR: + pp_c_equality_expression (pp, e); + break; + + case COND_EXPR: + pp_conditional_expression (pp, e); + break; + + case POINTER_PLUS_EXPR: + case PLUS_EXPR: + case MINUS_EXPR: + pp_c_additive_expression (pp, e); + break; + + case MODIFY_EXPR: + case INIT_EXPR: + pp_assignment_expression (pp, e); + break; + + case COMPOUND_EXPR: + pp_c_left_paren (pp); + pp_expression (pp, TREE_OPERAND (e, 0)); + pp_separate_with (pp, ','); + pp_assignment_expression (pp, TREE_OPERAND (e, 1)); + pp_c_right_paren (pp); + break; + + case NON_LVALUE_EXPR: + case SAVE_EXPR: + pp_expression (pp, TREE_OPERAND (e, 0)); + break; + + case TARGET_EXPR: + pp_postfix_expression (pp, TREE_OPERAND (e, 1)); + break; + + case BIND_EXPR: + case GOTO_EXPR: + /* We don't yet have a way of dumping statements in a + human-readable format. */ + pp_string (pp, "({...})"); + break; + + default: + pp_unsupported_tree (pp, e); + break; + } +} + + + +/* Statements. */ + +void +pp_c_statement (c_pretty_printer *pp, tree stmt) +{ + if (stmt == NULL) + return; + + if (pp_needs_newline (pp)) + pp_newline_and_indent (pp, 0); + + dump_generic_node (pp_base (pp), stmt, pp_indentation (pp), 0, true); +} + + +/* Initialize the PRETTY-PRINTER for handling C codes. */ + +void +pp_c_pretty_printer_init (c_pretty_printer *pp) +{ + pp->offset_list = 0; + + pp->declaration = pp_c_declaration; + pp->declaration_specifiers = pp_c_declaration_specifiers; + pp->declarator = pp_c_declarator; + pp->direct_declarator = pp_c_direct_declarator; + pp->type_specifier_seq = pp_c_specifier_qualifier_list; + pp->abstract_declarator = pp_c_abstract_declarator; + pp->direct_abstract_declarator = pp_c_direct_abstract_declarator; + pp->ptr_operator = pp_c_pointer; + pp->parameter_list = pp_c_parameter_type_list; + pp->type_id = pp_c_type_id; + pp->simple_type_specifier = pp_c_type_specifier; + pp->function_specifier = pp_c_function_specifier; + pp->storage_class_specifier = pp_c_storage_class_specifier; + + pp->statement = pp_c_statement; + + pp->constant = pp_c_constant; + pp->id_expression = pp_c_id_expression; + pp->primary_expression = pp_c_primary_expression; + pp->postfix_expression = pp_c_postfix_expression; + pp->unary_expression = pp_c_unary_expression; + pp->initializer = pp_c_initializer; + pp->multiplicative_expression = pp_c_multiplicative_expression; + pp->conditional_expression = pp_c_conditional_expression; + pp->assignment_expression = pp_c_assignment_expression; + pp->expression = pp_c_expression; +} + + +/* Print the tree T in full, on file FILE. */ + +void +print_c_tree (FILE *file, tree t) +{ + static c_pretty_printer pp_rec; + static bool initialized = 0; + c_pretty_printer *pp = &pp_rec; + + if (!initialized) + { + initialized = 1; + pp_construct (pp_base (pp), NULL, 0); + pp_c_pretty_printer_init (pp); + pp_needs_newline (pp) = true; + } + pp_base (pp)->buffer->stream = file; + + pp_statement (pp, t); + + pp_newline (pp); + pp_flush (pp); +} + +/* Print the tree T in full, on stderr. */ + +DEBUG_FUNCTION void +debug_c_tree (tree t) +{ + print_c_tree (stderr, t); + fputc ('\n', stderr); +} + +/* Output the DECL_NAME of T. If T has no DECL_NAME, output a string made + up of T's memory address. */ + +void +pp_c_tree_decl_identifier (c_pretty_printer *pp, tree t) +{ + const char *name; + + gcc_assert (DECL_P (t)); + + if (DECL_NAME (t)) + name = IDENTIFIER_POINTER (DECL_NAME (t)); + else + { + static char xname[8]; + sprintf (xname, "", ((unsigned)((uintptr_t)(t) & 0xffff))); + name = xname; + } + + pp_c_identifier (pp, name); +} diff --git a/gcc/c-family/c-pretty-print.h b/gcc/c-family/c-pretty-print.h new file mode 100644 index 00000000000..60ef0bc375e --- /dev/null +++ b/gcc/c-family/c-pretty-print.h @@ -0,0 +1,213 @@ +/* Various declarations for the C and C++ pretty-printers. + Copyright (C) 2002, 2003, 2004, 2007, 2009 Free Software Foundation, Inc. + Contributed by Gabriel Dos Reis + +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 3, 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 COPYING3. If not see +. */ + +#ifndef GCC_C_PRETTY_PRINTER +#define GCC_C_PRETTY_PRINTER + +#include "tree.h" +#include "c-common.h" +#include "pretty-print.h" + + +typedef enum + { + pp_c_flag_abstract = 1 << 1, + pp_c_flag_last_bit = 2 + } pp_c_pretty_print_flags; + + +/* The data type used to bundle information necessary for pretty-printing + a C or C++ entity. */ +typedef struct c_pretty_print_info c_pretty_printer; + +/* The type of a C pretty-printer 'member' function. */ +typedef void (*c_pretty_print_fn) (c_pretty_printer *, tree); + +/* The datatype that contains information necessary for pretty-printing + a tree that represents a C construct. Any pretty-printer for a + language using C/c++ syntax can derive from this datatype and reuse + facilities provided here. It can do so by having a subobject of type + c_pretty_printer and override the macro pp_c_base to return a pointer + to that subobject. Such a pretty-printer has the responsibility to + initialize the pp_base() part, then call pp_c_pretty_printer_init + to set up the components that are specific to the C pretty-printer. + A derived pretty-printer can override any function listed in the + vtable below. See cp/cxx-pretty-print.h and cp/cxx-pretty-print.c + for an example of derivation. */ +struct c_pretty_print_info +{ + pretty_printer base; + /* Points to the first element of an array of offset-list. + Not used yet. */ + int *offset_list; + + pp_flags flags; + + /* These must be overridden by each of the C and C++ front-end to + reflect their understanding of syntactic productions when they differ. */ + c_pretty_print_fn declaration; + c_pretty_print_fn declaration_specifiers; + c_pretty_print_fn declarator; + c_pretty_print_fn abstract_declarator; + c_pretty_print_fn direct_abstract_declarator; + c_pretty_print_fn type_specifier_seq; + c_pretty_print_fn direct_declarator; + c_pretty_print_fn ptr_operator; + c_pretty_print_fn parameter_list; + c_pretty_print_fn type_id; + c_pretty_print_fn simple_type_specifier; + c_pretty_print_fn function_specifier; + c_pretty_print_fn storage_class_specifier; + c_pretty_print_fn initializer; + + c_pretty_print_fn statement; + + c_pretty_print_fn constant; + c_pretty_print_fn id_expression; + c_pretty_print_fn primary_expression; + c_pretty_print_fn postfix_expression; + c_pretty_print_fn unary_expression; + c_pretty_print_fn multiplicative_expression; + c_pretty_print_fn conditional_expression; + c_pretty_print_fn assignment_expression; + c_pretty_print_fn expression; +}; + +/* Override the pp_base macro. Derived pretty-printers should not + touch this macro. Instead they should override pp_c_base instead. */ +#undef pp_base +#define pp_base(PP) (&pp_c_base (PP)->base) + + +#define pp_c_tree_identifier(PPI, ID) \ + pp_c_identifier (PPI, IDENTIFIER_POINTER (ID)) + +#define pp_declaration(PPI, T) \ + pp_c_base (PPI)->declaration (pp_c_base (PPI), T) +#define pp_declaration_specifiers(PPI, D) \ + pp_c_base (PPI)->declaration_specifiers (pp_c_base (PPI), D) +#define pp_abstract_declarator(PP, D) \ + pp_c_base (PP)->abstract_declarator (pp_c_base (PP), D) +#define pp_type_specifier_seq(PPI, D) \ + pp_c_base (PPI)->type_specifier_seq (pp_c_base (PPI), D) +#define pp_declarator(PPI, D) \ + pp_c_base (PPI)->declarator (pp_c_base (PPI), D) +#define pp_direct_declarator(PPI, D) \ + pp_c_base (PPI)->direct_declarator (pp_c_base (PPI), D) +#define pp_direct_abstract_declarator(PP, D) \ + pp_c_base (PP)->direct_abstract_declarator (pp_c_base (PP), D) +#define pp_ptr_operator(PP, D) \ + pp_c_base (PP)->ptr_operator (pp_c_base (PP), D) +#define pp_parameter_list(PPI, T) \ + pp_c_base (PPI)->parameter_list (pp_c_base (PPI), T) +#define pp_type_id(PPI, D) \ + pp_c_base (PPI)->type_id (pp_c_base (PPI), D) +#define pp_simple_type_specifier(PP, T) \ + pp_c_base (PP)->simple_type_specifier (pp_c_base (PP), T) +#define pp_function_specifier(PP, D) \ + pp_c_base (PP)->function_specifier (pp_c_base (PP), D) +#define pp_storage_class_specifier(PP, D) \ + pp_c_base (PP)->storage_class_specifier (pp_c_base (PP), D); + +#define pp_statement(PPI, S) \ + pp_c_base (PPI)->statement (pp_c_base (PPI), S) + +#define pp_constant(PP, E) \ + pp_c_base (PP)->constant (pp_c_base (PP), E) +#define pp_id_expression(PP, E) \ + pp_c_base (PP)->id_expression (pp_c_base (PP), E) +#define pp_primary_expression(PPI, E) \ + pp_c_base (PPI)->primary_expression (pp_c_base (PPI), E) +#define pp_postfix_expression(PPI, E) \ + pp_c_base (PPI)->postfix_expression (pp_c_base (PPI), E) +#define pp_unary_expression(PPI, E) \ + pp_c_base (PPI)->unary_expression (pp_c_base (PPI), E) +#define pp_initializer(PPI, E) \ + pp_c_base (PPI)->initializer (pp_c_base (PPI), E) +#define pp_multiplicative_expression(PPI, E) \ + pp_c_base (PPI)->multiplicative_expression (pp_c_base (PPI), E) +#define pp_conditional_expression(PPI, E) \ + pp_c_base (PPI)->conditional_expression (pp_c_base (PPI), E) +#define pp_assignment_expression(PPI, E) \ + pp_c_base (PPI)->assignment_expression (pp_c_base (PPI), E) +#define pp_expression(PP, E) \ + pp_c_base (PP)->expression (pp_c_base (PP), E) + + +/* Returns the c_pretty_printer base object of PRETTY-PRINTER. This + macro must be overridden by any subclass of c_pretty_print_info. */ +#define pp_c_base(PP) (PP) + +extern void pp_c_pretty_printer_init (c_pretty_printer *); +void pp_c_whitespace (c_pretty_printer *); +void pp_c_left_paren (c_pretty_printer *); +void pp_c_right_paren (c_pretty_printer *); +void pp_c_left_brace (c_pretty_printer *); +void pp_c_right_brace (c_pretty_printer *); +void pp_c_left_bracket (c_pretty_printer *); +void pp_c_right_bracket (c_pretty_printer *); +void pp_c_dot (c_pretty_printer *); +void pp_c_ampersand (c_pretty_printer *); +void pp_c_star (c_pretty_printer *); +void pp_c_arrow (c_pretty_printer *); +void pp_c_semicolon (c_pretty_printer *); +void pp_c_complement (c_pretty_printer *); +void pp_c_exclamation (c_pretty_printer *); +void pp_c_space_for_pointer_operator (c_pretty_printer *, tree); + +/* Declarations. */ +void pp_c_tree_decl_identifier (c_pretty_printer *, tree); +void pp_c_function_definition (c_pretty_printer *, tree); +void pp_c_attributes (c_pretty_printer *, tree); +void pp_c_cv_qualifiers (c_pretty_printer *pp, int qualifiers, bool func_type); +void pp_c_type_qualifier_list (c_pretty_printer *, tree); +void pp_c_parameter_type_list (c_pretty_printer *, tree); +void pp_c_declaration (c_pretty_printer *, tree); +void pp_c_declaration_specifiers (c_pretty_printer *, tree); +void pp_c_declarator (c_pretty_printer *, tree); +void pp_c_direct_declarator (c_pretty_printer *, tree); +void pp_c_specifier_qualifier_list (c_pretty_printer *, tree); +void pp_c_function_specifier (c_pretty_printer *, tree); +void pp_c_type_id (c_pretty_printer *, tree); +void pp_c_direct_abstract_declarator (c_pretty_printer *, tree); +void pp_c_type_specifier (c_pretty_printer *, tree); +void pp_c_storage_class_specifier (c_pretty_printer *, tree); +/* Statements. */ +void pp_c_statement (c_pretty_printer *, tree); +/* Expressions. */ +void pp_c_expression (c_pretty_printer *, tree); +void pp_c_logical_or_expression (c_pretty_printer *, tree); +void pp_c_expression_list (c_pretty_printer *, tree); +void pp_c_constructor_elts (c_pretty_printer *, VEC(constructor_elt,gc) *); +void pp_c_call_argument_list (c_pretty_printer *, tree); +void pp_c_unary_expression (c_pretty_printer *, tree); +void pp_c_cast_expression (c_pretty_printer *, tree); +void pp_c_postfix_expression (c_pretty_printer *, tree); +void pp_c_primary_expression (c_pretty_printer *, tree); +void pp_c_init_declarator (c_pretty_printer *, tree); +void pp_c_constant (c_pretty_printer *, tree); +void pp_c_id_expression (c_pretty_printer *, tree); +void pp_c_ws_string (c_pretty_printer *, const char *); +void pp_c_identifier (c_pretty_printer *, const char *); +void pp_c_string_literal (c_pretty_printer *, tree); + +void print_c_tree (FILE *file, tree t); + +#endif /* GCC_C_PRETTY_PRINTER */ diff --git a/gcc/c-family/c-semantics.c b/gcc/c-family/c-semantics.c new file mode 100644 index 00000000000..683655f77c0 --- /dev/null +++ b/gcc/c-family/c-semantics.c @@ -0,0 +1,146 @@ +/* This file contains subroutine used by the C front-end to construct GENERIC. + Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008 + Free Software Foundation, Inc. + Written by Benjamin Chelf (chelf@codesourcery.com). + +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 3, 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 COPYING3. If not see +. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tm.h" +#include "tree.h" +#include "function.h" +#include "splay-tree.h" +#include "c-common.h" +/* In order for the format checking to accept the C frontend + diagnostic framework extensions, you must define this token before + including toplev.h. */ +#define GCC_DIAG_STYLE __gcc_cdiag__ +#include "toplev.h" +#include "flags.h" +#include "output.h" +#include "tree-iterator.h" + +/* Create an empty statement tree rooted at T. */ + +tree +push_stmt_list (void) +{ + tree t; + t = alloc_stmt_list (); + TREE_CHAIN (t) = cur_stmt_list; + cur_stmt_list = t; + return t; +} + +/* Finish the statement tree rooted at T. */ + +tree +pop_stmt_list (tree t) +{ + tree u = cur_stmt_list, chain; + + /* Pop statement lists until we reach the target level. The extra + nestings will be due to outstanding cleanups. */ + while (1) + { + chain = TREE_CHAIN (u); + TREE_CHAIN (u) = NULL_TREE; + if (chain) + STATEMENT_LIST_HAS_LABEL (chain) |= STATEMENT_LIST_HAS_LABEL (u); + if (t == u) + break; + u = chain; + } + cur_stmt_list = chain; + + /* If the statement list is completely empty, just return it. This is + just as good small as build_empty_stmt, with the advantage that + statement lists are merged when they appended to one another. So + using the STATEMENT_LIST avoids pathological buildup of EMPTY_STMT_P + statements. */ + if (TREE_SIDE_EFFECTS (t)) + { + tree_stmt_iterator i = tsi_start (t); + + /* If the statement list contained exactly one statement, then + extract it immediately. */ + if (tsi_one_before_end_p (i)) + { + u = tsi_stmt (i); + tsi_delink (&i); + free_stmt_list (t); + t = u; + } + } + + return t; +} + +/* Build a generic statement based on the given type of node and + arguments. Similar to `build_nt', except that we set + EXPR_LOCATION to LOC. */ +/* ??? This should be obsolete with the lineno_stmt productions + in the grammar. */ + +tree +build_stmt (location_t loc, enum tree_code code, ...) +{ + tree ret; + int length, i; + va_list p; + bool side_effects; + + /* This function cannot be used to construct variably-sized nodes. */ + gcc_assert (TREE_CODE_CLASS (code) != tcc_vl_exp); + + va_start (p, code); + + ret = make_node (code); + TREE_TYPE (ret) = void_type_node; + length = TREE_CODE_LENGTH (code); + SET_EXPR_LOCATION (ret, loc); + + /* TREE_SIDE_EFFECTS will already be set for statements with + implicit side effects. Here we make sure it is set for other + expressions by checking whether the parameters have side + effects. */ + + side_effects = false; + for (i = 0; i < length; i++) + { + tree t = va_arg (p, tree); + if (t && !TYPE_P (t)) + side_effects |= TREE_SIDE_EFFECTS (t); + TREE_OPERAND (ret, i) = t; + } + + TREE_SIDE_EFFECTS (ret) |= side_effects; + + va_end (p); + return ret; +} + +/* Create a CASE_LABEL_EXPR tree node and return it. */ + +tree +build_case_label (location_t loc, + tree low_value, tree high_value, tree label_decl) +{ + return build_stmt (loc, CASE_LABEL_EXPR, low_value, high_value, label_decl); +} diff --git a/gcc/c-family/c.opt b/gcc/c-family/c.opt new file mode 100644 index 00000000000..ade444a8dcc --- /dev/null +++ b/gcc/c-family/c.opt @@ -0,0 +1,1061 @@ +; Options for the C, ObjC, C++ and ObjC++ front ends. +; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 +; 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 3, 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 COPYING3. If not see +; . + +; See the GCC internals manual for a description of this file's format. + +; Please try to keep this file in ASCII collating order. + +Language +C + +Language +ObjC + +Language +C++ + +Language +ObjC++ + +-output-pch= +C ObjC C++ ObjC++ Joined Separate + +A +C ObjC C++ ObjC++ Joined Separate +-A= Assert the to . Putting '-' before disables the to + +C +C ObjC C++ ObjC++ +Do not discard comments + +CC +C ObjC C++ ObjC++ +Do not discard comments in macro expansions + +D +C ObjC C++ ObjC++ Joined Separate +-D[=] Define a with as its value. If just is given, is taken to be 1 + +E +C ObjC C++ ObjC++ Undocumented Var(flag_preprocess_only) + +F +C ObjC C++ ObjC++ Joined Separate +-F Add to the end of the main framework include path + +H +C ObjC C++ ObjC++ +Print the name of header files as they are used + +I +C ObjC C++ ObjC++ Joined Separate +-I Add to the end of the main include path + +M +C ObjC C++ ObjC++ +Generate make dependencies + +MD +C ObjC C++ ObjC++ Separate +Generate make dependencies and compile + +MF +C ObjC C++ ObjC++ Joined Separate +-MF Write dependency output to the given file + +MG +C ObjC C++ ObjC++ +Treat missing header files as generated files + +MM +C ObjC C++ ObjC++ +Like -M but ignore system header files + +MMD +C ObjC C++ ObjC++ Separate +Like -MD but ignore system header files + +MP +C ObjC C++ ObjC++ +Generate phony targets for all headers + +MQ +C ObjC C++ ObjC++ Joined Separate +-MQ Add a MAKE-quoted target + +MT +C ObjC C++ ObjC++ Joined Separate +-MT Add an unquoted target + +P +C ObjC C++ ObjC++ +Do not generate #line directives + +U +C ObjC C++ ObjC++ Joined Separate +-U Undefine + +Wabi +C ObjC C++ ObjC++ LTO Var(warn_abi) Warning +Warn about things that will change when compiling with an ABI-compliant compiler + +Wpsabi +C ObjC C++ ObjC++ LTO Var(warn_psabi) Init(1) Undocumented + +Waddress +C ObjC C++ ObjC++ Var(warn_address) Warning +Warn about suspicious uses of memory addresses + +Wall +C ObjC C++ ObjC++ Warning +Enable most warning messages + +Wassign-intercept +ObjC ObjC++ Var(warn_assign_intercept) Warning +Warn whenever an Objective-C assignment is being intercepted by the garbage collector + +Wbad-function-cast +C ObjC Var(warn_bad_function_cast) Warning +Warn about casting functions to incompatible types + +Wbuiltin-macro-redefined +C ObjC C++ ObjC++ Warning +Warn when a built-in preprocessor macro is undefined or redefined + +Wc++-compat +C ObjC Var(warn_cxx_compat) Warning +Warn about C constructs that are not in the common subset of C and C++ + +Wc++0x-compat +C++ ObjC++ Var(warn_cxx0x_compat) Warning +Warn about C++ constructs whose meaning differs between ISO C++ 1998 and ISO C++ 200x + +Wcast-qual +C ObjC C++ ObjC++ Var(warn_cast_qual) Warning +Warn about casts which discard qualifiers + +Wchar-subscripts +C ObjC C++ ObjC++ Var(warn_char_subscripts) Warning +Warn about subscripts whose type is \"char\" + +Wclobbered +C ObjC C++ ObjC++ Var(warn_clobbered) Init(-1) Warning +Warn about variables that might be changed by \"longjmp\" or \"vfork\" + +Wcomment +C ObjC C++ ObjC++ Warning +Warn about possibly nested block comments, and C++ comments spanning more than one physical line + +Wcomments +C ObjC C++ ObjC++ Warning +Synonym for -Wcomment + +Wconversion +C ObjC C++ ObjC++ Var(warn_conversion) Warning +Warn for implicit type conversions that may change a value + +Wconversion-null +C++ ObjC++ Var(warn_conversion_null) Init(1) Warning +Warn for converting NULL from/to a non-pointer type + +Wsign-conversion +C ObjC C++ ObjC++ Var(warn_sign_conversion) Init(-1) +Warn for implicit type conversions between signed and unsigned integers + +Wctor-dtor-privacy +C++ ObjC++ Var(warn_ctor_dtor_privacy) Warning +Warn when all constructors and destructors are private + +Wdeclaration-after-statement +C ObjC Var(warn_declaration_after_statement) Warning +Warn when a declaration is found after a statement + +Wdeprecated +C C++ ObjC ObjC++ Var(warn_deprecated) Init(1) Warning +Warn if a deprecated compiler feature, class, method, or field is used + +Wdiv-by-zero +C ObjC C++ ObjC++ Var(warn_div_by_zero) Init(1) Warning +Warn about compile-time integer division by zero + +Weffc++ +C++ ObjC++ Var(warn_ecpp) Warning +Warn about violations of Effective C++ style rules + +Wempty-body +C ObjC C++ ObjC++ Var(warn_empty_body) Init(-1) Warning +Warn about an empty body in an if or else statement + +Wendif-labels +C ObjC C++ ObjC++ Warning +Warn about stray tokens after #elif and #endif + +Wenum-compare +C ObjC C++ ObjC++ Var(warn_enum_compare) Init(-1) Warning +Warn about comparison of different enum types + +Werror +C ObjC C++ ObjC++ +; Documented in common.opt + +Werror-implicit-function-declaration +C ObjC RejectNegative Warning +This switch is deprecated; use -Werror=implicit-function-declaration instead + +Wfloat-equal +C ObjC C++ ObjC++ Var(warn_float_equal) Warning +Warn if testing floating point numbers for equality + +Wformat +C ObjC C++ ObjC++ Warning +Warn about printf/scanf/strftime/strfmon format string anomalies + +Wformat-extra-args +C ObjC C++ ObjC++ Var(warn_format_extra_args) Warning +Warn if passing too many arguments to a function for its format string + +Wformat-nonliteral +C ObjC C++ ObjC++ Var(warn_format_nonliteral) Warning +Warn about format strings that are not literals + +Wformat-contains-nul +C ObjC C++ ObjC++ Var(warn_format_contains_nul) Warning +Warn about format strings that contain NUL bytes + +Wformat-security +C ObjC C++ ObjC++ Var(warn_format_security) Warning +Warn about possible security problems with format functions + +Wformat-y2k +C ObjC C++ ObjC++ Var(warn_format_y2k) Warning +Warn about strftime formats yielding 2-digit years + +Wformat-zero-length +C ObjC Var(warn_format_zero_length) Warning +Warn about zero-length formats + +Wformat= +C ObjC C++ ObjC++ Joined Warning + +Wignored-qualifiers +C C++ Var(warn_ignored_qualifiers) Init(-1) Warning +Warn whenever type qualifiers are ignored. + +Winit-self +C ObjC C++ ObjC++ Var(warn_init_self) Warning +Warn about variables which are initialized to themselves + +Wimplicit +C ObjC Var(warn_implicit) Init(-1) Warning +Warn about implicit declarations + +Wimplicit-function-declaration +C ObjC Var(warn_implicit_function_declaration) Init(-1) Warning +Warn about implicit function declarations + +Wimplicit-int +C ObjC Var(warn_implicit_int) Init(-1) Warning +Warn when a declaration does not specify a type + +Wimport +C ObjC C++ ObjC++ Undocumented + +Wint-to-pointer-cast +C ObjC C++ ObjC++ Var(warn_int_to_pointer_cast) Init(1) Warning +Warn when there is a cast to a pointer from an integer of a different size + +Winvalid-offsetof +C++ ObjC++ Var(warn_invalid_offsetof) Init(1) Warning +Warn about invalid uses of the \"offsetof\" macro + +Winvalid-pch +C ObjC C++ ObjC++ Warning +Warn about PCH files that are found but not used + +Wjump-misses-init +C ObjC Var(warn_jump_misses_init) Init(-1) Warning +Warn when a jump misses a variable initialization + +Wlogical-op +C ObjC C++ ObjC++ Var(warn_logical_op) Init(0) Warning +Warn when a logical operator is suspiciously always evaluating to true or false + +Wlong-long +C ObjC C++ ObjC++ Var(warn_long_long) Init(-1) Warning +Do not warn about using \"long long\" when -pedantic + +Wmain +C ObjC C++ ObjC++ Var(warn_main) Init(-1) Warning +Warn about suspicious declarations of \"main\" + +Wmissing-braces +C ObjC C++ ObjC++ Var(warn_missing_braces) Warning +Warn about possibly missing braces around initializers + +Wmissing-declarations +C ObjC C++ ObjC++ Var(warn_missing_declarations) Warning +Warn about global functions without previous declarations + +Wmissing-field-initializers +C ObjC C++ ObjC++ Var(warn_missing_field_initializers) Init(-1) Warning +Warn about missing fields in struct initializers + +Wmissing-format-attribute +C ObjC C++ ObjC++ Var(warn_missing_format_attribute) Warning +Warn about functions which might be candidates for format attributes + +Wmissing-include-dirs +C ObjC C++ ObjC++ Warning +Warn about user-specified include directories that do not exist + +Wmissing-parameter-type +C ObjC Var(warn_missing_parameter_type) Init(-1) Warning +Warn about function parameters declared without a type specifier in K&R-style functions + +Wmissing-prototypes +C ObjC Var(warn_missing_prototypes) Warning +Warn about global functions without prototypes + +Wmultichar +C ObjC C++ ObjC++ Warning +Warn about use of multi-character character constants + +Wnested-externs +C ObjC Var(warn_nested_externs) Warning +Warn about \"extern\" declarations not at file scope + +Wnoexcept +C++ ObjC++ Var(warn_noexcept) Warning +Warn when a noexcept expression evaluates to false even though the expression can't actually throw + +Wnon-template-friend +C++ ObjC++ Var(warn_nontemplate_friend) Init(1) Warning +Warn when non-templatized friend functions are declared within a template + +Wnon-virtual-dtor +C++ ObjC++ Var(warn_nonvdtor) Warning +Warn about non-virtual destructors + +Wnonnull +C ObjC Var(warn_nonnull) Warning +Warn about NULL being passed to argument slots marked as requiring non-NULL + +Wnormalized= +C ObjC C++ ObjC++ Joined Warning +-Wnormalized= Warn about non-normalised Unicode strings + +Wold-style-cast +C++ ObjC++ Var(warn_old_style_cast) Warning +Warn if a C-style cast is used in a program + +Wold-style-declaration +C ObjC Var(warn_old_style_declaration) Init(-1) Warning +Warn for obsolescent usage in a declaration + +Wold-style-definition +C ObjC Var(warn_old_style_definition) Warning +Warn if an old-style parameter definition is used + +Woverlength-strings +C ObjC C++ ObjC++ Var(warn_overlength_strings) Init(-1) Warning +Warn if a string is longer than the maximum portable length specified by the standard + +Woverloaded-virtual +C++ ObjC++ Var(warn_overloaded_virtual) Warning +Warn about overloaded virtual function names + +Woverride-init +C ObjC Var(warn_override_init) Init(-1) Warning +Warn about overriding initializers without side effects + +Wpacked-bitfield-compat +C ObjC C++ ObjC++ Var(warn_packed_bitfield_compat) Init(-1) Warning +Warn about packed bit-fields whose offset changed in GCC 4.4 + +Wparentheses +C ObjC C++ ObjC++ Var(warn_parentheses) Warning +Warn about possibly missing parentheses + +Wpmf-conversions +C++ ObjC++ Var(warn_pmf2ptr) Init(1) Warning +Warn when converting the type of pointers to member functions + +Wpointer-arith +C ObjC C++ ObjC++ Var(warn_pointer_arith) Warning +Warn about function pointer arithmetic + +Wpointer-to-int-cast +C ObjC Var(warn_pointer_to_int_cast) Init(1) Warning +Warn when a pointer is cast to an integer of a different size + +Wpragmas +C ObjC C++ ObjC++ Var(warn_pragmas) Init(1) Warning +Warn about misuses of pragmas + +Wprotocol +ObjC ObjC++ Var(warn_protocol) Init(1) Warning +Warn if inherited methods are unimplemented + +Wredundant-decls +C ObjC C++ ObjC++ Var(warn_redundant_decls) Warning +Warn about multiple declarations of the same object + +Wreorder +C++ ObjC++ Var(warn_reorder) Warning +Warn when the compiler reorders code + +Wreturn-type +C ObjC C++ ObjC++ Var(warn_return_type) Warning +Warn whenever a function's return type defaults to \"int\" (C), or about inconsistent return types (C++) + +Wselector +ObjC ObjC++ Var(warn_selector) Warning +Warn if a selector has multiple methods + +Wsequence-point +C ObjC C++ ObjC++ Var(warn_sequence_point) Warning +Warn about possible violations of sequence point rules + +Wsign-compare +C ObjC C++ ObjC++ Var(warn_sign_compare) Init(-1) Warning +Warn about signed-unsigned comparisons + +Wsign-promo +C++ ObjC++ Var(warn_sign_promo) Warning +Warn when overload promotes from unsigned to signed + +Wstrict-null-sentinel +C++ ObjC++ Warning Var(warn_strict_null_sentinel) +Warn about uncasted NULL used as sentinel + +Wstrict-prototypes +C ObjC Var(warn_strict_prototypes) Warning +Warn about unprototyped function declarations + +Wstrict-selector-match +ObjC ObjC++ Var(warn_strict_selector_match) Warning +Warn if type signatures of candidate methods do not match exactly + +Wsync-nand +C C++ Var(warn_sync_nand) Init(1) Warning +Warn when __sync_fetch_and_nand and __sync_nand_and_fetch built-in functions are used + +Wsynth +C++ ObjC++ Var(warn_synth) Warning +Deprecated. This switch has no effect + +Wsystem-headers +C ObjC C++ ObjC++ Warning +; Documented in common.opt + +Wtraditional +C ObjC Var(warn_traditional) Warning +Warn about features not present in traditional C + +Wtraditional-conversion +C ObjC Var(warn_traditional_conversion) Warning +Warn of prototypes causing type conversions different from what would happen in the absence of prototype + +Wtrigraphs +C ObjC C++ ObjC++ Warning +Warn if trigraphs are encountered that might affect the meaning of the program + +Wundeclared-selector +ObjC ObjC++ Var(warn_undeclared_selector) Warning +Warn about @selector()s without previously declared methods + +Wundef +C ObjC C++ ObjC++ Warning +Warn if an undefined macro is used in an #if directive + +Wunknown-pragmas +C ObjC C++ ObjC++ Warning +Warn about unrecognized pragmas + +Wunsuffixed-float-constants +C ObjC Var(warn_unsuffixed_float_constants) Warning +Warn about unsuffixed float constants + +Wunused-macros +C ObjC C++ ObjC++ Warning +Warn about macros defined in the main file that are not used + +Wunused-result +C ObjC C++ ObjC++ Var(warn_unused_result) Init(1) Warning +Warn if a caller of a function, marked with attribute warn_unused_result, does not use its return value + +Wvariadic-macros +C ObjC C++ ObjC++ Warning +Do not warn about using variadic macros when -pedantic + +Wvla +C ObjC C++ ObjC++ Var(warn_vla) Init(-1) Warning +Warn if a variable length array is used + +Wvolatile-register-var +C ObjC C++ ObjC++ Var(warn_volatile_register_var) Warning +Warn when a register variable is declared volatile + +Wwrite-strings +C ObjC C++ ObjC++ Var(warn_write_strings) Warning +In C++, nonzero means warn about deprecated conversion from string literals to `char *'. In C, similar warning, except that the conversion is of course not deprecated by the ISO C standard. + +Wpointer-sign +C ObjC Var(warn_pointer_sign) Init(-1) Warning +Warn when a pointer differs in signedness in an assignment + +ansi +C ObjC C++ ObjC++ +A synonym for -std=c89 (for C) or -std=c++98 (for C++) + +d +C ObjC C++ ObjC++ Joined +; Documented in common.opt. FIXME - what about -dI, -dD, -dN and -dD? + +faccess-control +C++ ObjC++ Var(flag_access_control) Init(1) +Enforce class member access control semantics + +fall-virtual +C++ ObjC++ + +falt-external-templates +C++ ObjC++ +Change when template instances are emitted + +fasm +C ObjC C++ ObjC++ Var(flag_no_asm, 0) +Recognize the \"asm\" keyword + +fbuiltin +C ObjC C++ ObjC++ Var(flag_no_builtin, 0) +Recognize built-in functions + +fbuiltin- +C ObjC C++ ObjC++ Joined + +fcheck-new +C++ ObjC++ Var(flag_check_new) +Check the return value of new + +fcond-mismatch +C ObjC C++ ObjC++ +Allow the arguments of the '?' operator to have different types + +fconserve-space +C++ ObjC++ Var(flag_conserve_space) +Reduce the size of object files + +fconstant-string-class= +ObjC ObjC++ Joined +-fconst-string-class= Use class for constant strings + +fdeduce-init-list +C++ ObjC++ Var(flag_deduce_init_list) Init(1) +-fno-deduce-init-list disable deduction of std::initializer_list for a template type parameter from a brace-enclosed initializer-list + +fdefault-inline +C++ ObjC++ +Does nothing. Preserved for backward compatibility. + +fdirectives-only +C ObjC C++ ObjC++ +Preprocess directives only. + +fdollars-in-identifiers +C ObjC C++ ObjC++ +Permit '$' as an identifier character + +felide-constructors +C++ ObjC++ Var(flag_elide_constructors) Init(1) + +fenforce-eh-specs +C++ ObjC++ Var(flag_enforce_eh_specs) Init(1) +Generate code to check exception specifications + +fenum-int-equiv +C++ ObjC++ + +fexec-charset= +C ObjC C++ ObjC++ Joined RejectNegative +-fexec-charset= Convert all strings and character constants to character set + +fextended-identifiers +C ObjC C++ ObjC++ +Permit universal character names (\\u and \\U) in identifiers + +finput-charset= +C ObjC C++ ObjC++ Joined RejectNegative +-finput-charset= Specify the default character set for source files + + +fexternal-templates +C++ ObjC++ + +ffor-scope +C++ ObjC++ Var(flag_new_for_scope) Init(1) +Scope of for-init-statement variables is local to the loop + +ffreestanding +C ObjC C++ ObjC++ +Do not assume that standard C libraries and \"main\" exist + +fgnu-keywords +C++ ObjC++ Var(flag_no_gnu_keywords, 0) +Recognize GNU-defined keywords + +fgnu-runtime +ObjC ObjC++ +Generate code for GNU runtime environment + +fgnu89-inline +C ObjC Var(flag_gnu89_inline) Init(-1) +Use traditional GNU semantics for inline functions + +fguiding-decls +C++ ObjC++ + +fhandle-exceptions +C++ ObjC++ Optimization + +fhonor-std +C++ ObjC++ + +fhosted +C ObjC +Assume normal C execution environment + +fhuge-objects +C++ ObjC++ +Enable support for huge objects + +fimplement-inlines +C++ ObjC++ Var(flag_implement_inlines) Init(1) +Export functions even if they can be inlined + +fimplicit-inline-templates +C++ ObjC++ Var(flag_implicit_inline_templates) Init(1) +Emit implicit instantiations of inline templates + +fimplicit-templates +C++ ObjC++ Var(flag_implicit_templates) Init(1) +Emit implicit instantiations of templates + +ffriend-injection +C++ ObjC++ Var(flag_friend_injection) +Inject friend functions into enclosing namespace + +flabels-ok +C++ ObjC++ + +flax-vector-conversions +C ObjC C++ ObjC++ Var(flag_lax_vector_conversions) +Allow implicit conversions between vectors with differing numbers of subparts and/or differing element types. + +fms-extensions +C ObjC C++ ObjC++ Var(flag_ms_extensions) +Don't warn about uses of Microsoft extensions + +fname-mangling-version- +C++ ObjC++ Joined + +fnew-abi +C++ ObjC++ + +fnext-runtime +ObjC ObjC++ +Generate code for NeXT (Apple Mac OS X) runtime environment + +fnil-receivers +ObjC ObjC++ Var(flag_nil_receivers) Init(1) +Assume that receivers of Objective-C messages may be nil + +fnonansi-builtins +C++ ObjC++ Var(flag_no_nonansi_builtin, 0) + +fnonnull-objects +C++ ObjC++ + +fnothrow-opt +C++ ObjC++ Optimization Var(flag_nothrow_opt) +Treat a throw() exception specification as noexcept to improve code size + +; Generate special '- .cxx_construct' and '- .cxx_destruct' methods +; to initialize any non-POD ivars in Objective-C++ classes. +fobjc-call-cxx-cdtors +ObjC++ Var(flag_objc_call_cxx_cdtors) +Generate special Objective-C methods to initialize/destroy non-POD C++ ivars, if needed + +fobjc-direct-dispatch +ObjC ObjC++ Var(flag_objc_direct_dispatch) +Allow fast jumps to the message dispatcher + +; Nonzero means that we will allow new ObjC exception syntax (@throw, +; @try, etc.) in source code. +fobjc-exceptions +ObjC ObjC++ Var(flag_objc_exceptions) +Enable Objective-C exception and synchronization syntax + +fobjc-gc +ObjC ObjC++ Var(flag_objc_gc) +Enable garbage collection (GC) in Objective-C/Objective-C++ programs + +; Nonzero means that we generate NeXT setjmp based exceptions. +fobjc-sjlj-exceptions +ObjC ObjC++ Var(flag_objc_sjlj_exceptions) Init(-1) +Enable Objective-C setjmp exception handling runtime + +fopenmp +C ObjC C++ ObjC++ Var(flag_openmp) +Enable OpenMP (implies -frecursive in Fortran) + +foperator-names +C++ ObjC++ +Recognize C++ keywords like \"compl\" and \"xor\" + +foptional-diags +C++ ObjC++ +Does nothing. Preserved for backward compatibility. + +fpch-deps +C ObjC C++ ObjC++ + +fpch-preprocess +C ObjC C++ ObjC++ +Look for and use PCH files even when preprocessing + +fpermissive +C++ ObjC++ +Downgrade conformance errors to warnings + +fpreprocessed +C ObjC C++ ObjC++ +Treat the input file as already preprocessed + +fpretty-templates +C++ ObjC++ Var(flag_pretty_templates) Init(1) +-fno-pretty-templates Do not pretty-print template specializations as the template signature followed by the arguments + +freplace-objc-classes +ObjC ObjC++ Var(flag_replace_objc_classes) +Used in Fix-and-Continue mode to indicate that object files may be swapped in at runtime + +frepo +C++ ObjC++ +Enable automatic template instantiation + +frtti +C++ ObjC++ Optimization Var(flag_rtti) Init(1) +Generate run time type descriptor information + +fshort-double +C ObjC C++ ObjC++ Optimization Var(flag_short_double) +Use the same size for double as for float + +fshort-enums +C ObjC C++ ObjC++ Optimization Var(flag_short_enums) +Use the narrowest integer type possible for enumeration types + +fshort-wchar +C ObjC C++ ObjC++ Optimization Var(flag_short_wchar) +Force the underlying type for \"wchar_t\" to be \"unsigned short\" + +fsigned-bitfields +C ObjC C++ ObjC++ Var(flag_signed_bitfields) Init(1) +When \"signed\" or \"unsigned\" is not given make the bitfield signed + +fsigned-char +C ObjC C++ ObjC++ LTO Var(flag_signed_char) +Make \"char\" signed by default + +fsquangle +C++ ObjC++ + +fstats +C++ ObjC++ Var(flag_detailed_statistics) +Display statistics accumulated during compilation + +fstrict-enums +C++ ObjC++ Optimization Var(flag_strict_enums) +Assume that values of enumeration type are always within the minimum range of that type + +fstrict-prototype +C++ ObjC++ + +ftabstop= +C ObjC C++ ObjC++ Joined RejectNegative UInteger +-ftabstop= Distance between tab stops for column reporting + +ftemplate-depth- +C++ ObjC++ Joined RejectNegative UInteger Undocumented + +ftemplate-depth= +C++ ObjC++ Joined RejectNegative UInteger +-ftemplate-depth= Specify maximum template instantiation depth + +fthis-is-variable +C++ ObjC++ + +fthreadsafe-statics +C++ ObjC++ Optimization Var(flag_threadsafe_statics) Init(1) +-fno-threadsafe-statics Do not generate thread-safe code for initializing local statics + +funsigned-bitfields +C ObjC C++ ObjC++ Var(flag_signed_bitfields, 0) VarExists +When \"signed\" or \"unsigned\" is not given make the bitfield unsigned + +funsigned-char +C ObjC C++ ObjC++ LTO Var(flag_signed_char, 0) VarExists +Make \"char\" unsigned by default + +fuse-cxa-atexit +C++ ObjC++ Var(flag_use_cxa_atexit) Init(DEFAULT_USE_CXA_ATEXIT) +Use __cxa_atexit to register destructors + +fuse-cxa-get-exception-ptr +C++ ObjC++ Var(flag_use_cxa_get_exception_ptr) Init(2) +Use __cxa_get_exception_ptr in exception handling + +fvisibility-inlines-hidden +C++ ObjC++ +Marks all inlined methods as having hidden visibility + +fvisibility-ms-compat +C++ ObjC++ Var(flag_visibility_ms_compat) +Changes visibility to match Microsoft Visual Studio by default + +fvtable-gc +C++ ObjC++ +Discard unused virtual functions + +fvtable-thunks +C++ ObjC++ +Implement vtables using thunks + +fweak +C++ ObjC++ Var(flag_weak) Init(1) +Emit common-like symbols as weak symbols + +fwide-exec-charset= +C ObjC C++ ObjC++ Joined RejectNegative +-fwide-exec-charset= Convert all wide strings and character constants to character set + +fworking-directory +C ObjC C++ ObjC++ Var(flag_working_directory) Init(-1) +Generate a #line directive pointing at the current working directory + +fxref +C++ ObjC++ +Emit cross referencing information + +fzero-link +ObjC ObjC++ Var(flag_zero_link) +Generate lazy class lookup (via objc_getClass()) for use in Zero-Link mode + +gen-decls +ObjC ObjC++ Var(flag_gen_declaration) +Dump declarations to a .decl file + +femit-struct-debug-baseonly +C ObjC C++ ObjC++ +-femit-struct-debug-baseonly Aggressive reduced debug info for structs + +femit-struct-debug-reduced +C ObjC C++ ObjC++ +-femit-struct-debug-reduced Conservative reduced debug info for structs + +femit-struct-debug-detailed= +C ObjC C++ ObjC++ Joined +-femit-struct-debug-detailed= Detailed reduced debug info for structs + +idirafter +C ObjC C++ ObjC++ Joined Separate +-idirafter Add to the end of the system include path + +imacros +C ObjC C++ ObjC++ Joined Separate +-imacros Accept definition of macros in + +imultilib +C ObjC C++ ObjC++ Joined Separate +-imultilib Set to be the multilib include subdirectory + +include +C ObjC C++ ObjC++ Joined Separate +-include Include the contents of before other files + +iprefix +C ObjC C++ ObjC++ Joined Separate +-iprefix Specify as a prefix for next two options + +isysroot +C ObjC C++ ObjC++ Joined Separate +-isysroot Set to be the system root directory + +isystem +C ObjC C++ ObjC++ Joined Separate +-isystem Add to the start of the system include path + +iquote +C ObjC C++ ObjC++ Joined Separate +-iquote Add to the end of the quote include path + +iwithprefix +C ObjC C++ ObjC++ Joined Separate +-iwithprefix Add to the end of the system include path + +iwithprefixbefore +C ObjC C++ ObjC++ Joined Separate +-iwithprefixbefore Add to the end of the main include path + +lang-asm +C Undocumented + +nostdinc +C ObjC C++ ObjC++ +Do not search standard system include directories (those specified with -isystem will still be used) + +nostdinc++ +C++ ObjC++ +Do not search standard system include directories for C++ + +o +C ObjC C++ ObjC++ Joined Separate +; Documented in common.opt + +pedantic +C ObjC C++ ObjC++ +; Documented in common.opt + +pedantic-errors +C ObjC C++ ObjC++ +; Documented in common.opt + +print-objc-runtime-info +ObjC ObjC++ +Generate C header of platform-specific features + +print-pch-checksum +C ObjC C++ ObjC++ +Print a checksum of the executable for PCH validity checking, and stop + +remap +C ObjC C++ ObjC++ +Remap file names when including files + +std=c++98 +C++ ObjC++ +Conform to the ISO 1998 C++ standard + +std=c++0x +C++ ObjC++ +Conform to the ISO 1998 C++ standard, with extensions that are likely to +become a part of the upcoming ISO C++ standard, dubbed C++0x. Note that the +extensions enabled by this mode are experimental and may be removed in +future releases of GCC. + +std=c1x +C ObjC +Conform to the ISO 201X C standard draft (experimental and incomplete support) + +std=c89 +C ObjC +Conform to the ISO 1990 C standard + +std=c90 +C ObjC +Conform to the ISO 1990 C standard + +std=c99 +C ObjC +Conform to the ISO 1999 C standard + +std=c9x +C ObjC +Deprecated in favor of -std=c99 + +std=gnu++98 +C++ ObjC++ +Conform to the ISO 1998 C++ standard with GNU extensions + +std=gnu++0x +C++ ObjC++ +Conform to the ISO 1998 C++ standard, with GNU extensions and +extensions that are likely to become a part of the upcoming ISO C++ +standard, dubbed C++0x. Note that the extensions enabled by this mode +are experimental and may be removed in future releases of GCC. + +std=gnu1x +C ObjC +Conform to the ISO 201X C standard draft with GNU extensions (experimental and incomplete support) + +std=gnu89 +C ObjC +Conform to the ISO 1990 C standard with GNU extensions + +std=gnu90 +C ObjC +Conform to the ISO 1990 C standard with GNU extensions + +std=gnu99 +C ObjC +Conform to the ISO 1999 C standard with GNU extensions + +std=gnu9x +C ObjC +Deprecated in favor of -std=gnu99 + +std=iso9899:1990 +C ObjC +Conform to the ISO 1990 C standard + +std=iso9899:199409 +C ObjC +Conform to the ISO 1990 C standard as amended in 1994 + +std=iso9899:1999 +C ObjC +Conform to the ISO 1999 C standard + +std=iso9899:199x +C ObjC +Deprecated in favor of -std=iso9899:1999 + +traditional-cpp +C ObjC C++ ObjC++ +Enable traditional preprocessing + +trigraphs +C ObjC C++ ObjC++ +-trigraphs Support ISO C trigraphs + +undef +C ObjC C++ ObjC++ Var(flag_undef) +Do not predefine system-specific and GCC-specific macros + +v +Common C ObjC C++ ObjC++ +Enable verbose output + +w +C ObjC C++ ObjC++ +; Documented in common.opt + +; This comment is to ensure we retain the blank line above. diff --git a/gcc/c-family/stub-objc.c b/gcc/c-family/stub-objc.c new file mode 100644 index 00000000000..b7748f79c6e --- /dev/null +++ b/gcc/c-family/stub-objc.c @@ -0,0 +1,327 @@ +/* Stub functions for Objective-C and Objective-C++ routines + that are called from within the C and C++ front-ends, + respectively. + Copyright (C) 1991, 1995, 1997, 1998, 1999, 2000, 2001, 2002, 2003, + 2004, 2005, 2007, 2009 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 3, 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 COPYING3. If not see +. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tree.h" +#include "c-common.h" + +tree +objc_is_class_name (tree ARG_UNUSED (arg)) +{ + return 0; +} + +tree +objc_is_id (tree ARG_UNUSED (arg)) +{ + return 0; +} + +tree +objc_is_object_ptr (tree ARG_UNUSED (arg)) +{ + return 0; +} + +tree +objc_lookup_ivar (tree other, tree ARG_UNUSED (arg)) +{ + /* Just use whatever C/C++ found. */ + return other; +} + +void +objc_check_decl (tree ARG_UNUSED (decl)) +{ +} + +int +objc_is_reserved_word (tree ARG_UNUSED (ident)) +{ + return 0; +} + +bool +objc_compare_types (tree ARG_UNUSED (ltyp), tree ARG_UNUSED (rtyp), + int ARG_UNUSED (argno), tree ARG_UNUSED (callee)) +{ + return false; +} + +void +objc_volatilize_decl (tree ARG_UNUSED (decl)) +{ +} + +bool +objc_type_quals_match (tree ARG_UNUSED (ltyp), tree ARG_UNUSED (rtyp)) +{ + return false; +} + +tree +objc_rewrite_function_call (tree function, tree ARG_UNUSED (first_param)) +{ + return function; +} + +tree +objc_message_selector (void) +{ + return 0; +} + +void +objc_declare_alias (tree ARG_UNUSED (alias), tree ARG_UNUSED (orig)) +{ +} + +void +objc_declare_class (tree ARG_UNUSED (list)) +{ +} + +void +objc_declare_protocols (tree ARG_UNUSED (list)) +{ +} + +void +objc_start_protocol (tree ARG_UNUSED (proto), + tree ARG_UNUSED (protorefs)) +{ +} + +void +objc_start_class_interface (tree ARG_UNUSED (name), + tree ARG_UNUSED (super), + tree ARG_UNUSED (protos)) +{ +} + +void +objc_start_category_interface (tree ARG_UNUSED (name), + tree ARG_UNUSED (categ), + tree ARG_UNUSED (protos)) +{ +} + +void +objc_continue_interface (void) +{ +} + +void +objc_finish_interface (void) +{ +} + +void +objc_add_instance_variable (tree ARG_UNUSED (decl)) +{ +} + +void +objc_set_visibility (int ARG_UNUSED (vis)) +{ +} + +void +objc_set_method_type (enum tree_code ARG_UNUSED (code)) +{ +} + +void +objc_start_class_implementation (tree ARG_UNUSED (name), + tree ARG_UNUSED (super)) +{ +} + +void +objc_start_category_implementation (tree ARG_UNUSED (name), + tree ARG_UNUSED (categ)) +{ +} + +void +objc_continue_implementation (void) +{ +} + +void +objc_clear_super_receiver (void) +{ +} + +void +objc_finish_implementation (void) +{ +} + +void +objc_add_method_declaration (tree ARG_UNUSED (signature)) +{ +} + +void +objc_start_method_definition (tree ARG_UNUSED (signature)) +{ +} + +void +objc_finish_method_definition (tree ARG_UNUSED (fndecl)) +{ +} + +tree +objc_build_keyword_decl (tree ARG_UNUSED (selector), + tree ARG_UNUSED (type), + tree ARG_UNUSED (identifier)) +{ + return 0; +} + +tree +objc_build_method_signature (tree ARG_UNUSED (rettype), + tree ARG_UNUSED (selectors), + tree ARG_UNUSED (optparms), + bool ARG_UNUSED (ellipsis)) +{ + return 0; +} + +tree +objc_build_encode_expr (tree ARG_UNUSED (expr)) +{ + return 0; +} + +tree +objc_build_protocol_expr (tree ARG_UNUSED (expr)) +{ + return 0; +} + +tree +objc_build_selector_expr (location_t ARG_UNUSED (loc), tree ARG_UNUSED (expr)) +{ + return 0; +} + +tree +objc_build_message_expr (tree ARG_UNUSED (expr)) +{ + return 0; +} + +tree +objc_build_string_object (tree ARG_UNUSED (str)) +{ + return 0; +} + +tree +objc_get_class_reference (tree ARG_UNUSED (name)) +{ + return 0; +} + +tree +objc_get_protocol_qualified_type (tree ARG_UNUSED (name), + tree ARG_UNUSED (protos)) +{ + return 0; +} + +int +objc_static_init_needed_p (void) +{ + return 0; +} + +tree +objc_generate_static_init_call (tree ARG_UNUSED (ctors)) +{ + return 0; +} + +int +objc_is_public (tree ARG_UNUSED (expr), tree ARG_UNUSED (identifier)) +{ + return 1; +} + +tree +objc_get_class_ivars (tree ARG_UNUSED (name)) +{ + return 0; +} + +tree +objc_build_throw_stmt (location_t ARG_UNUSED (loc), tree ARG_UNUSED (expr)) +{ + return 0; +} + +tree +objc_build_synchronized (location_t ARG_UNUSED (start_locus), + tree ARG_UNUSED (mutex), tree ARG_UNUSED (body)) +{ + return 0; +} + +void +objc_begin_try_stmt (location_t ARG_UNUSED (try_locus), tree ARG_UNUSED (body)) +{ +} + +void +objc_begin_catch_clause (tree ARG_UNUSED (decl)) +{ +} + +void +objc_finish_catch_clause (void) +{ +} + +void +objc_build_finally_clause (location_t ARG_UNUSED (finally_locus), + tree ARG_UNUSED (body)) +{ +} + +tree +objc_finish_try_stmt (void) +{ + return 0; +} + +tree +objc_generate_write_barrier (tree ARG_UNUSED (lhs), + enum tree_code ARG_UNUSED (modifycode), + tree ARG_UNUSED (rhs)) +{ + return 0; +} diff --git a/gcc/c-format.c b/gcc/c-format.c deleted file mode 100644 index 0522d2925c2..00000000000 --- a/gcc/c-format.c +++ /dev/null @@ -1,2872 +0,0 @@ -/* Check calls to formatted I/O functions (-Wformat). - Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, - 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009, 2010 - 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 3, 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 COPYING3. If not see -. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "tm.h" -#include "tree.h" -#include "flags.h" -#include "c-common.h" -#include "toplev.h" -#include "intl.h" -#include "diagnostic-core.h" -#include "langhooks.h" -#include "c-format.h" -#include "alloc-pool.h" - -/* Set format warning options according to a -Wformat=n option. */ - -void -set_Wformat (int setting) -{ - warn_format = setting; - warn_format_extra_args = setting; - warn_format_zero_length = setting; - warn_format_contains_nul = setting; - if (setting != 1) - { - warn_format_nonliteral = setting; - warn_format_security = setting; - warn_format_y2k = setting; - } - /* Make sure not to disable -Wnonnull if -Wformat=0 is specified. */ - if (setting) - warn_nonnull = setting; -} - - -/* Handle attributes associated with format checking. */ - -/* This must be in the same order as format_types, except for - format_type_error. Target-specific format types do not have - matching enum values. */ -enum format_type { printf_format_type, asm_fprintf_format_type, - gcc_diag_format_type, gcc_tdiag_format_type, - gcc_cdiag_format_type, - gcc_cxxdiag_format_type, gcc_gfc_format_type, - format_type_error = -1}; - -typedef struct function_format_info -{ - int format_type; /* type of format (printf, scanf, etc.) */ - unsigned HOST_WIDE_INT format_num; /* number of format argument */ - unsigned HOST_WIDE_INT first_arg_num; /* number of first arg (zero for varargs) */ -} function_format_info; - -static bool decode_format_attr (tree, function_format_info *, int); -static int decode_format_type (const char *); - -static bool check_format_string (tree argument, - unsigned HOST_WIDE_INT format_num, - int flags, bool *no_add_attrs); -static bool get_constant (tree expr, unsigned HOST_WIDE_INT *value, - int validated_p); -static const char *convert_format_name_to_system_name (const char *attr_name); -static bool cmp_attribs (const char *tattr_name, const char *attr_name); - -/* Handle a "format_arg" attribute; arguments as in - struct attribute_spec.handler. */ -tree -handle_format_arg_attribute (tree *node, tree ARG_UNUSED (name), - tree args, int flags, bool *no_add_attrs) -{ - tree type = *node; - tree format_num_expr = TREE_VALUE (args); - unsigned HOST_WIDE_INT format_num = 0; - tree argument; - - if (!get_constant (format_num_expr, &format_num, 0)) - { - error ("format string has invalid operand number"); - *no_add_attrs = true; - return NULL_TREE; - } - - argument = TYPE_ARG_TYPES (type); - if (argument) - { - if (!check_format_string (argument, format_num, flags, no_add_attrs)) - return NULL_TREE; - } - - if (TREE_CODE (TREE_TYPE (type)) != POINTER_TYPE - || (TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (type))) - != char_type_node)) - { - if (!(flags & (int) ATTR_FLAG_BUILT_IN)) - error ("function does not return string type"); - *no_add_attrs = true; - return NULL_TREE; - } - - return NULL_TREE; -} - -/* Verify that the format_num argument is actually a string, in case - the format attribute is in error. */ -static bool -check_format_string (tree argument, unsigned HOST_WIDE_INT format_num, - int flags, bool *no_add_attrs) -{ - unsigned HOST_WIDE_INT i; - - for (i = 1; i != format_num; i++) - { - if (argument == 0) - break; - argument = TREE_CHAIN (argument); - } - - if (!argument - || TREE_CODE (TREE_VALUE (argument)) != POINTER_TYPE - || (TYPE_MAIN_VARIANT (TREE_TYPE (TREE_VALUE (argument))) - != char_type_node)) - { - if (!(flags & (int) ATTR_FLAG_BUILT_IN)) - error ("format string argument not a string type"); - *no_add_attrs = true; - return false; - } - - return true; -} - -/* Verify EXPR is a constant, and store its value. - If validated_p is true there should be no errors. - Returns true on success, false otherwise. */ -static bool -get_constant (tree expr, unsigned HOST_WIDE_INT *value, int validated_p) -{ - if (TREE_CODE (expr) != INTEGER_CST || TREE_INT_CST_HIGH (expr) != 0) - { - gcc_assert (!validated_p); - return false; - } - - *value = TREE_INT_CST_LOW (expr); - - return true; -} - -/* Decode the arguments to a "format" attribute into a - function_format_info structure. It is already known that the list - is of the right length. If VALIDATED_P is true, then these - attributes have already been validated and must not be erroneous; - if false, it will give an error message. Returns true if the - attributes are successfully decoded, false otherwise. */ - -static bool -decode_format_attr (tree args, function_format_info *info, int validated_p) -{ - tree format_type_id = TREE_VALUE (args); - tree format_num_expr = TREE_VALUE (TREE_CHAIN (args)); - tree first_arg_num_expr - = TREE_VALUE (TREE_CHAIN (TREE_CHAIN (args))); - - if (TREE_CODE (format_type_id) != IDENTIFIER_NODE) - { - gcc_assert (!validated_p); - error ("unrecognized format specifier"); - return false; - } - else - { - const char *p = IDENTIFIER_POINTER (format_type_id); - - p = convert_format_name_to_system_name (p); - - info->format_type = decode_format_type (p); - - if (info->format_type == format_type_error) - { - gcc_assert (!validated_p); - warning (OPT_Wformat, "%qE is an unrecognized format function type", - format_type_id); - return false; - } - } - - if (!get_constant (format_num_expr, &info->format_num, validated_p)) - { - error ("format string has invalid operand number"); - return false; - } - - if (!get_constant (first_arg_num_expr, &info->first_arg_num, validated_p)) - { - error ("%<...%> has invalid operand number"); - return false; - } - - if (info->first_arg_num != 0 && info->first_arg_num <= info->format_num) - { - gcc_assert (!validated_p); - error ("format string argument follows the args to be formatted"); - return false; - } - - return true; -} - -/* Check a call to a format function against a parameter list. */ - -/* The C standard version C++ is treated as equivalent to - or inheriting from, for the purpose of format features supported. */ -#define CPLUSPLUS_STD_VER STD_C94 -/* The C standard version we are checking formats against when pedantic. */ -#define C_STD_VER ((int) (c_dialect_cxx () \ - ? CPLUSPLUS_STD_VER \ - : (flag_isoc99 \ - ? STD_C99 \ - : (flag_isoc94 ? STD_C94 : STD_C89)))) -/* The name to give to the standard version we are warning about when - pedantic. FEATURE_VER is the version in which the feature warned out - appeared, which is higher than C_STD_VER. */ -#define C_STD_NAME(FEATURE_VER) (c_dialect_cxx () \ - ? "ISO C++" \ - : ((FEATURE_VER) == STD_EXT \ - ? "ISO C" \ - : "ISO C90")) -/* Adjust a C standard version, which may be STD_C9L, to account for - -Wno-long-long. Returns other standard versions unchanged. */ -#define ADJ_STD(VER) ((int) ((VER) == STD_C9L \ - ? (warn_long_long ? STD_C99 : STD_C89) \ - : (VER))) - -/* Structure describing details of a type expected in format checking, - and the type to check against it. */ -typedef struct format_wanted_type -{ - /* The type wanted. */ - tree wanted_type; - /* The name of this type to use in diagnostics. */ - const char *wanted_type_name; - /* Should be type checked just for scalar width identity. */ - int scalar_identity_flag; - /* The level of indirection through pointers at which this type occurs. */ - int pointer_count; - /* Whether, when pointer_count is 1, to allow any character type when - pedantic, rather than just the character or void type specified. */ - int char_lenient_flag; - /* Whether the argument, dereferenced once, is written into and so the - argument must not be a pointer to a const-qualified type. */ - int writing_in_flag; - /* Whether the argument, dereferenced once, is read from and so - must not be a NULL pointer. */ - int reading_from_flag; - /* If warnings should be of the form "field precision should have - type 'int'", the name to use (in this case "field precision"), - otherwise NULL, for "format expects type 'long'" type - messages. */ - const char *name; - /* The actual parameter to check against the wanted type. */ - tree param; - /* The argument number of that parameter. */ - int arg_num; - /* The next type to check for this format conversion, or NULL if none. */ - struct format_wanted_type *next; -} format_wanted_type; - -/* Convenience macro for format_length_info meaning unused. */ -#define NO_FMT NULL, FMT_LEN_none, STD_C89 - -static const format_length_info printf_length_specs[] = -{ - { "h", FMT_LEN_h, STD_C89, "hh", FMT_LEN_hh, STD_C99, 0 }, - { "l", FMT_LEN_l, STD_C89, "ll", FMT_LEN_ll, STD_C9L, 0 }, - { "q", FMT_LEN_ll, STD_EXT, NO_FMT, 0 }, - { "L", FMT_LEN_L, STD_C89, NO_FMT, 0 }, - { "z", FMT_LEN_z, STD_C99, NO_FMT, 0 }, - { "Z", FMT_LEN_z, STD_EXT, NO_FMT, 0 }, - { "t", FMT_LEN_t, STD_C99, NO_FMT, 0 }, - { "j", FMT_LEN_j, STD_C99, NO_FMT, 0 }, - { "H", FMT_LEN_H, STD_EXT, NO_FMT, 0 }, - { "D", FMT_LEN_D, STD_EXT, "DD", FMT_LEN_DD, STD_EXT, 0 }, - { NO_FMT, NO_FMT, 0 } -}; - -/* Length specifiers valid for asm_fprintf. */ -static const format_length_info asm_fprintf_length_specs[] = -{ - { "l", FMT_LEN_l, STD_C89, "ll", FMT_LEN_ll, STD_C89, 0 }, - { "w", FMT_LEN_none, STD_C89, NO_FMT, 0 }, - { NO_FMT, NO_FMT, 0 } -}; - -/* Length specifiers valid for GCC diagnostics. */ -static const format_length_info gcc_diag_length_specs[] = -{ - { "l", FMT_LEN_l, STD_C89, "ll", FMT_LEN_ll, STD_C89, 0 }, - { "w", FMT_LEN_none, STD_C89, NO_FMT, 0 }, - { NO_FMT, NO_FMT, 0 } -}; - -/* The custom diagnostics all accept the same length specifiers. */ -#define gcc_tdiag_length_specs gcc_diag_length_specs -#define gcc_cdiag_length_specs gcc_diag_length_specs -#define gcc_cxxdiag_length_specs gcc_diag_length_specs - -/* This differs from printf_length_specs only in that "Z" is not accepted. */ -static const format_length_info scanf_length_specs[] = -{ - { "h", FMT_LEN_h, STD_C89, "hh", FMT_LEN_hh, STD_C99, 0 }, - { "l", FMT_LEN_l, STD_C89, "ll", FMT_LEN_ll, STD_C9L, 0 }, - { "q", FMT_LEN_ll, STD_EXT, NO_FMT, 0 }, - { "L", FMT_LEN_L, STD_C89, NO_FMT, 0 }, - { "z", FMT_LEN_z, STD_C99, NO_FMT, 0 }, - { "t", FMT_LEN_t, STD_C99, NO_FMT, 0 }, - { "j", FMT_LEN_j, STD_C99, NO_FMT, 0 }, - { "H", FMT_LEN_H, STD_EXT, NO_FMT, 0 }, - { "D", FMT_LEN_D, STD_EXT, "DD", FMT_LEN_DD, STD_EXT, 0 }, - { NO_FMT, NO_FMT, 0 } -}; - - -/* All tables for strfmon use STD_C89 everywhere, since -pedantic warnings - make no sense for a format type not part of any C standard version. */ -static const format_length_info strfmon_length_specs[] = -{ - /* A GNU extension. */ - { "L", FMT_LEN_L, STD_C89, NO_FMT, 0 }, - { NO_FMT, NO_FMT, 0 } -}; - - -/* For now, the Fortran front-end routines only use l as length modifier. */ -static const format_length_info gcc_gfc_length_specs[] = -{ - { "l", FMT_LEN_l, STD_C89, NO_FMT, 0 }, - { NO_FMT, NO_FMT, 0 } -}; - - -static const format_flag_spec printf_flag_specs[] = -{ - { ' ', 0, 0, N_("' ' flag"), N_("the ' ' printf flag"), STD_C89 }, - { '+', 0, 0, N_("'+' flag"), N_("the '+' printf flag"), STD_C89 }, - { '#', 0, 0, N_("'#' flag"), N_("the '#' printf flag"), STD_C89 }, - { '0', 0, 0, N_("'0' flag"), N_("the '0' printf flag"), STD_C89 }, - { '-', 0, 0, N_("'-' flag"), N_("the '-' printf flag"), STD_C89 }, - { '\'', 0, 0, N_("''' flag"), N_("the ''' printf flag"), STD_EXT }, - { 'I', 0, 0, N_("'I' flag"), N_("the 'I' printf flag"), STD_EXT }, - { 'w', 0, 0, N_("field width"), N_("field width in printf format"), STD_C89 }, - { 'p', 0, 0, N_("precision"), N_("precision in printf format"), STD_C89 }, - { 'L', 0, 0, N_("length modifier"), N_("length modifier in printf format"), STD_C89 }, - { 0, 0, 0, NULL, NULL, STD_C89 } -}; - - -static const format_flag_pair printf_flag_pairs[] = -{ - { ' ', '+', 1, 0 }, - { '0', '-', 1, 0 }, - { '0', 'p', 1, 'i' }, - { 0, 0, 0, 0 } -}; - -static const format_flag_spec asm_fprintf_flag_specs[] = -{ - { ' ', 0, 0, N_("' ' flag"), N_("the ' ' printf flag"), STD_C89 }, - { '+', 0, 0, N_("'+' flag"), N_("the '+' printf flag"), STD_C89 }, - { '#', 0, 0, N_("'#' flag"), N_("the '#' printf flag"), STD_C89 }, - { '0', 0, 0, N_("'0' flag"), N_("the '0' printf flag"), STD_C89 }, - { '-', 0, 0, N_("'-' flag"), N_("the '-' printf flag"), STD_C89 }, - { 'w', 0, 0, N_("field width"), N_("field width in printf format"), STD_C89 }, - { 'p', 0, 0, N_("precision"), N_("precision in printf format"), STD_C89 }, - { 'L', 0, 0, N_("length modifier"), N_("length modifier in printf format"), STD_C89 }, - { 0, 0, 0, NULL, NULL, STD_C89 } -}; - -static const format_flag_pair asm_fprintf_flag_pairs[] = -{ - { ' ', '+', 1, 0 }, - { '0', '-', 1, 0 }, - { '0', 'p', 1, 'i' }, - { 0, 0, 0, 0 } -}; - -static const format_flag_pair gcc_diag_flag_pairs[] = -{ - { 0, 0, 0, 0 } -}; - -#define gcc_tdiag_flag_pairs gcc_diag_flag_pairs -#define gcc_cdiag_flag_pairs gcc_diag_flag_pairs -#define gcc_cxxdiag_flag_pairs gcc_diag_flag_pairs - -static const format_flag_pair gcc_gfc_flag_pairs[] = -{ - { 0, 0, 0, 0 } -}; - -static const format_flag_spec gcc_diag_flag_specs[] = -{ - { '+', 0, 0, N_("'+' flag"), N_("the '+' printf flag"), STD_C89 }, - { 'q', 0, 0, N_("'q' flag"), N_("the 'q' diagnostic flag"), STD_C89 }, - { 'p', 0, 0, N_("precision"), N_("precision in printf format"), STD_C89 }, - { 'L', 0, 0, N_("length modifier"), N_("length modifier in printf format"), STD_C89 }, - { 0, 0, 0, NULL, NULL, STD_C89 } -}; - -#define gcc_tdiag_flag_specs gcc_diag_flag_specs -#define gcc_cdiag_flag_specs gcc_diag_flag_specs - -static const format_flag_spec gcc_cxxdiag_flag_specs[] = -{ - { '+', 0, 0, N_("'+' flag"), N_("the '+' printf flag"), STD_C89 }, - { '#', 0, 0, N_("'#' flag"), N_("the '#' printf flag"), STD_C89 }, - { 'q', 0, 0, N_("'q' flag"), N_("the 'q' diagnostic flag"), STD_C89 }, - { 'p', 0, 0, N_("precision"), N_("precision in printf format"), STD_C89 }, - { 'L', 0, 0, N_("length modifier"), N_("length modifier in printf format"), STD_C89 }, - { 0, 0, 0, NULL, NULL, STD_C89 } -}; - -static const format_flag_spec scanf_flag_specs[] = -{ - { '*', 0, 0, N_("assignment suppression"), N_("the assignment suppression scanf feature"), STD_C89 }, - { 'a', 0, 0, N_("'a' flag"), N_("the 'a' scanf flag"), STD_EXT }, - { 'm', 0, 0, N_("'m' flag"), N_("the 'm' scanf flag"), STD_EXT }, - { 'w', 0, 0, N_("field width"), N_("field width in scanf format"), STD_C89 }, - { 'L', 0, 0, N_("length modifier"), N_("length modifier in scanf format"), STD_C89 }, - { '\'', 0, 0, N_("''' flag"), N_("the ''' scanf flag"), STD_EXT }, - { 'I', 0, 0, N_("'I' flag"), N_("the 'I' scanf flag"), STD_EXT }, - { 0, 0, 0, NULL, NULL, STD_C89 } -}; - - -static const format_flag_pair scanf_flag_pairs[] = -{ - { '*', 'L', 0, 0 }, - { 'a', 'm', 0, 0 }, - { 0, 0, 0, 0 } -}; - - -static const format_flag_spec strftime_flag_specs[] = -{ - { '_', 0, 0, N_("'_' flag"), N_("the '_' strftime flag"), STD_EXT }, - { '-', 0, 0, N_("'-' flag"), N_("the '-' strftime flag"), STD_EXT }, - { '0', 0, 0, N_("'0' flag"), N_("the '0' strftime flag"), STD_EXT }, - { '^', 0, 0, N_("'^' flag"), N_("the '^' strftime flag"), STD_EXT }, - { '#', 0, 0, N_("'#' flag"), N_("the '#' strftime flag"), STD_EXT }, - { 'w', 0, 0, N_("field width"), N_("field width in strftime format"), STD_EXT }, - { 'E', 0, 0, N_("'E' modifier"), N_("the 'E' strftime modifier"), STD_C99 }, - { 'O', 0, 0, N_("'O' modifier"), N_("the 'O' strftime modifier"), STD_C99 }, - { 'O', 'o', 0, NULL, N_("the 'O' modifier"), STD_EXT }, - { 0, 0, 0, NULL, NULL, STD_C89 } -}; - - -static const format_flag_pair strftime_flag_pairs[] = -{ - { 'E', 'O', 0, 0 }, - { '_', '-', 0, 0 }, - { '_', '0', 0, 0 }, - { '-', '0', 0, 0 }, - { '^', '#', 0, 0 }, - { 0, 0, 0, 0 } -}; - - -static const format_flag_spec strfmon_flag_specs[] = -{ - { '=', 0, 1, N_("fill character"), N_("fill character in strfmon format"), STD_C89 }, - { '^', 0, 0, N_("'^' flag"), N_("the '^' strfmon flag"), STD_C89 }, - { '+', 0, 0, N_("'+' flag"), N_("the '+' strfmon flag"), STD_C89 }, - { '(', 0, 0, N_("'(' flag"), N_("the '(' strfmon flag"), STD_C89 }, - { '!', 0, 0, N_("'!' flag"), N_("the '!' strfmon flag"), STD_C89 }, - { '-', 0, 0, N_("'-' flag"), N_("the '-' strfmon flag"), STD_C89 }, - { 'w', 0, 0, N_("field width"), N_("field width in strfmon format"), STD_C89 }, - { '#', 0, 0, N_("left precision"), N_("left precision in strfmon format"), STD_C89 }, - { 'p', 0, 0, N_("right precision"), N_("right precision in strfmon format"), STD_C89 }, - { 'L', 0, 0, N_("length modifier"), N_("length modifier in strfmon format"), STD_C89 }, - { 0, 0, 0, NULL, NULL, STD_C89 } -}; - -static const format_flag_pair strfmon_flag_pairs[] = -{ - { '+', '(', 0, 0 }, - { 0, 0, 0, 0 } -}; - - -static const format_char_info print_char_table[] = -{ - /* C89 conversion specifiers. */ - { "di", 0, STD_C89, { T89_I, T99_SC, T89_S, T89_L, T9L_LL, TEX_LL, T99_SST, T99_PD, T99_IM, BADLEN, BADLEN, BADLEN }, "-wp0 +'I", "i", NULL }, - { "oxX", 0, STD_C89, { T89_UI, T99_UC, T89_US, T89_UL, T9L_ULL, TEX_ULL, T99_ST, T99_UPD, T99_UIM, BADLEN, BADLEN, BADLEN }, "-wp0#", "i", NULL }, - { "u", 0, STD_C89, { T89_UI, T99_UC, T89_US, T89_UL, T9L_ULL, TEX_ULL, T99_ST, T99_UPD, T99_UIM, BADLEN, BADLEN, BADLEN }, "-wp0'I", "i", NULL }, - { "fgG", 0, STD_C89, { T89_D, BADLEN, BADLEN, T99_D, BADLEN, T89_LD, BADLEN, BADLEN, BADLEN, TEX_D32, TEX_D64, TEX_D128 }, "-wp0 +#'I", "", NULL }, - { "eE", 0, STD_C89, { T89_D, BADLEN, BADLEN, T99_D, BADLEN, T89_LD, BADLEN, BADLEN, BADLEN, TEX_D32, TEX_D64, TEX_D128 }, "-wp0 +#I", "", NULL }, - { "c", 0, STD_C89, { T89_I, BADLEN, BADLEN, T94_WI, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "-w", "", NULL }, - { "s", 1, STD_C89, { T89_C, BADLEN, BADLEN, T94_W, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "-wp", "cR", NULL }, - { "p", 1, STD_C89, { T89_V, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "-w", "c", NULL }, - { "n", 1, STD_C89, { T89_I, T99_SC, T89_S, T89_L, T9L_LL, BADLEN, T99_SST, T99_PD, T99_IM, BADLEN, BADLEN, BADLEN }, "", "W", NULL }, - /* C99 conversion specifiers. */ - { "F", 0, STD_C99, { T99_D, BADLEN, BADLEN, T99_D, BADLEN, T99_LD, BADLEN, BADLEN, BADLEN, TEX_D32, TEX_D64, TEX_D128 }, "-wp0 +#'I", "", NULL }, - { "aA", 0, STD_C99, { T99_D, BADLEN, BADLEN, T99_D, BADLEN, T99_LD, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "-wp0 +#", "", NULL }, - /* X/Open conversion specifiers. */ - { "C", 0, STD_EXT, { TEX_WI, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "-w", "", NULL }, - { "S", 1, STD_EXT, { TEX_W, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "-wp", "R", NULL }, - /* GNU conversion specifiers. */ - { "m", 0, STD_EXT, { T89_V, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "-wp", "", NULL }, - { NULL, 0, STD_C89, NOLENGTHS, NULL, NULL, NULL } -}; - -static const format_char_info asm_fprintf_char_table[] = -{ - /* C89 conversion specifiers. */ - { "di", 0, STD_C89, { T89_I, BADLEN, BADLEN, T89_L, T9L_LL, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "-wp0 +", "i", NULL }, - { "oxX", 0, STD_C89, { T89_UI, BADLEN, BADLEN, T89_UL, T9L_ULL, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "-wp0#", "i", NULL }, - { "u", 0, STD_C89, { T89_UI, BADLEN, BADLEN, T89_UL, T9L_ULL, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "-wp0", "i", NULL }, - { "c", 0, STD_C89, { T89_I, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "-w", "", NULL }, - { "s", 1, STD_C89, { T89_C, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "-wp", "cR", NULL }, - - /* asm_fprintf conversion specifiers. */ - { "O", 0, STD_C89, NOARGUMENTS, "", "", NULL }, - { "R", 0, STD_C89, NOARGUMENTS, "", "", NULL }, - { "I", 0, STD_C89, NOARGUMENTS, "", "", NULL }, - { "L", 0, STD_C89, NOARGUMENTS, "", "", NULL }, - { "U", 0, STD_C89, NOARGUMENTS, "", "", NULL }, - { "r", 0, STD_C89, { T89_I, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "", "", NULL }, - { "@", 0, STD_C89, NOARGUMENTS, "", "", NULL }, - { NULL, 0, STD_C89, NOLENGTHS, NULL, NULL, NULL } -}; - -static const format_char_info gcc_diag_char_table[] = -{ - /* C89 conversion specifiers. */ - { "di", 0, STD_C89, { T89_I, BADLEN, BADLEN, T89_L, T9L_LL, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "", NULL }, - { "ox", 0, STD_C89, { T89_UI, BADLEN, BADLEN, T89_UL, T9L_ULL, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "", NULL }, - { "u", 0, STD_C89, { T89_UI, BADLEN, BADLEN, T89_UL, T9L_ULL, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "", NULL }, - { "c", 0, STD_C89, { T89_I, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "", NULL }, - { "s", 1, STD_C89, { T89_C, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "pq", "cR", NULL }, - { "p", 1, STD_C89, { T89_V, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "c", NULL }, - - /* Custom conversion specifiers. */ - - /* These will require a "tree" at runtime. */ - { "K", 0, STD_C89, { T89_V, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "", NULL }, - - { "<>'", 0, STD_C89, NOARGUMENTS, "", "", NULL }, - { "m", 0, STD_C89, NOARGUMENTS, "q", "", NULL }, - { NULL, 0, STD_C89, NOLENGTHS, NULL, NULL, NULL } -}; - -static const format_char_info gcc_tdiag_char_table[] = -{ - /* C89 conversion specifiers. */ - { "di", 0, STD_C89, { T89_I, BADLEN, BADLEN, T89_L, T9L_LL, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "", NULL }, - { "ox", 0, STD_C89, { T89_UI, BADLEN, BADLEN, T89_UL, T9L_ULL, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "", NULL }, - { "u", 0, STD_C89, { T89_UI, BADLEN, BADLEN, T89_UL, T9L_ULL, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "", NULL }, - { "c", 0, STD_C89, { T89_I, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "", NULL }, - { "s", 1, STD_C89, { T89_C, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "pq", "cR", NULL }, - { "p", 1, STD_C89, { T89_V, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "c", NULL }, - - /* Custom conversion specifiers. */ - - /* These will require a "tree" at runtime. */ - { "DFKTE", 0, STD_C89, { T89_V, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q+", "", NULL }, - - { "<>'", 0, STD_C89, NOARGUMENTS, "", "", NULL }, - { "m", 0, STD_C89, NOARGUMENTS, "q", "", NULL }, - { NULL, 0, STD_C89, NOLENGTHS, NULL, NULL, NULL } -}; - -static const format_char_info gcc_cdiag_char_table[] = -{ - /* C89 conversion specifiers. */ - { "di", 0, STD_C89, { T89_I, BADLEN, BADLEN, T89_L, T9L_LL, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "", NULL }, - { "ox", 0, STD_C89, { T89_UI, BADLEN, BADLEN, T89_UL, T9L_ULL, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "", NULL }, - { "u", 0, STD_C89, { T89_UI, BADLEN, BADLEN, T89_UL, T9L_ULL, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "", NULL }, - { "c", 0, STD_C89, { T89_I, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "", NULL }, - { "s", 1, STD_C89, { T89_C, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "pq", "cR", NULL }, - { "p", 1, STD_C89, { T89_V, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "c", NULL }, - - /* Custom conversion specifiers. */ - - /* These will require a "tree" at runtime. */ - { "DEFKT", 0, STD_C89, { T89_V, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q+", "", NULL }, - - { "<>'", 0, STD_C89, NOARGUMENTS, "", "", NULL }, - { "m", 0, STD_C89, NOARGUMENTS, "q", "", NULL }, - { NULL, 0, STD_C89, NOLENGTHS, NULL, NULL, NULL } -}; - -static const format_char_info gcc_cxxdiag_char_table[] = -{ - /* C89 conversion specifiers. */ - { "di", 0, STD_C89, { T89_I, BADLEN, BADLEN, T89_L, T9L_LL, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "", NULL }, - { "ox", 0, STD_C89, { T89_UI, BADLEN, BADLEN, T89_UL, T9L_ULL, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "", NULL }, - { "u", 0, STD_C89, { T89_UI, BADLEN, BADLEN, T89_UL, T9L_ULL, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "", NULL }, - { "c", 0, STD_C89, { T89_I, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "", NULL }, - { "s", 1, STD_C89, { T89_C, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "pq", "cR", NULL }, - { "p", 1, STD_C89, { T89_V, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "c", NULL }, - - /* Custom conversion specifiers. */ - - /* These will require a "tree" at runtime. */ - { "ADEFKTV",0,STD_C89,{ T89_V, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q+#", "", NULL }, - - /* These accept either an 'int' or an 'enum tree_code' (which is handled as an 'int'.) */ - { "CLOPQ",0,STD_C89, { T89_I, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "q", "", NULL }, - - { "<>'", 0, STD_C89, NOARGUMENTS, "", "", NULL }, - { "m", 0, STD_C89, NOARGUMENTS, "q", "", NULL }, - { NULL, 0, STD_C89, NOLENGTHS, NULL, NULL, NULL } -}; - -static const format_char_info gcc_gfc_char_table[] = -{ - /* C89 conversion specifiers. */ - { "di", 0, STD_C89, { T89_I, BADLEN, BADLEN, T89_L, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "", "", NULL }, - { "u", 0, STD_C89, { T89_UI, BADLEN, BADLEN, T89_UL, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "", "", NULL }, - { "c", 0, STD_C89, { T89_I, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "", "", NULL }, - { "s", 1, STD_C89, { T89_C, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "", "cR", NULL }, - - /* gfc conversion specifiers. */ - - { "C", 0, STD_C89, NOARGUMENTS, "", "", NULL }, - - /* This will require a "locus" at runtime. */ - { "L", 0, STD_C89, { T89_V, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "", "R", NULL }, - - { NULL, 0, STD_C89, NOLENGTHS, NULL, NULL, NULL } -}; - -static const format_char_info scan_char_table[] = -{ - /* C89 conversion specifiers. */ - { "di", 1, STD_C89, { T89_I, T99_SC, T89_S, T89_L, T9L_LL, TEX_LL, T99_SST, T99_PD, T99_IM, BADLEN, BADLEN, BADLEN }, "*w'I", "W", NULL }, - { "u", 1, STD_C89, { T89_UI, T99_UC, T89_US, T89_UL, T9L_ULL, TEX_ULL, T99_ST, T99_UPD, T99_UIM, BADLEN, BADLEN, BADLEN }, "*w'I", "W", NULL }, - { "oxX", 1, STD_C89, { T89_UI, T99_UC, T89_US, T89_UL, T9L_ULL, TEX_ULL, T99_ST, T99_UPD, T99_UIM, BADLEN, BADLEN, BADLEN }, "*w", "W", NULL }, - { "efgEG", 1, STD_C89, { T89_F, BADLEN, BADLEN, T89_D, BADLEN, T89_LD, BADLEN, BADLEN, BADLEN, TEX_D32, TEX_D64, TEX_D128 }, "*w'", "W", NULL }, - { "c", 1, STD_C89, { T89_C, BADLEN, BADLEN, T94_W, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "*mw", "cW", NULL }, - { "s", 1, STD_C89, { T89_C, BADLEN, BADLEN, T94_W, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "*amw", "cW", NULL }, - { "[", 1, STD_C89, { T89_C, BADLEN, BADLEN, T94_W, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "*amw", "cW[", NULL }, - { "p", 2, STD_C89, { T89_V, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "*w", "W", NULL }, - { "n", 1, STD_C89, { T89_I, T99_SC, T89_S, T89_L, T9L_LL, BADLEN, T99_SST, T99_PD, T99_IM, BADLEN, BADLEN, BADLEN }, "", "W", NULL }, - /* C99 conversion specifiers. */ - { "F", 1, STD_C99, { T99_F, BADLEN, BADLEN, T99_D, BADLEN, T99_LD, BADLEN, BADLEN, BADLEN, TEX_D32, TEX_D64, TEX_D128 }, "*w'", "W", NULL }, - { "aA", 1, STD_C99, { T99_F, BADLEN, BADLEN, T99_D, BADLEN, T99_LD, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "*w'", "W", NULL }, - /* X/Open conversion specifiers. */ - { "C", 1, STD_EXT, { TEX_W, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "*mw", "W", NULL }, - { "S", 1, STD_EXT, { TEX_W, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "*amw", "W", NULL }, - { NULL, 0, STD_C89, NOLENGTHS, NULL, NULL, NULL } -}; - -static const format_char_info time_char_table[] = -{ - /* C89 conversion specifiers. */ - { "ABZab", 0, STD_C89, NOLENGTHS, "^#", "", NULL }, - { "cx", 0, STD_C89, NOLENGTHS, "E", "3", NULL }, - { "HIMSUWdmw", 0, STD_C89, NOLENGTHS, "-_0Ow", "", NULL }, - { "j", 0, STD_C89, NOLENGTHS, "-_0Ow", "o", NULL }, - { "p", 0, STD_C89, NOLENGTHS, "#", "", NULL }, - { "X", 0, STD_C89, NOLENGTHS, "E", "", NULL }, - { "y", 0, STD_C89, NOLENGTHS, "EO-_0w", "4", NULL }, - { "Y", 0, STD_C89, NOLENGTHS, "-_0EOw", "o", NULL }, - { "%", 0, STD_C89, NOLENGTHS, "", "", NULL }, - /* C99 conversion specifiers. */ - { "C", 0, STD_C99, NOLENGTHS, "-_0EOw", "o", NULL }, - { "D", 0, STD_C99, NOLENGTHS, "", "2", NULL }, - { "eVu", 0, STD_C99, NOLENGTHS, "-_0Ow", "", NULL }, - { "FRTnrt", 0, STD_C99, NOLENGTHS, "", "", NULL }, - { "g", 0, STD_C99, NOLENGTHS, "O-_0w", "2o", NULL }, - { "G", 0, STD_C99, NOLENGTHS, "-_0Ow", "o", NULL }, - { "h", 0, STD_C99, NOLENGTHS, "^#", "", NULL }, - { "z", 0, STD_C99, NOLENGTHS, "O", "o", NULL }, - /* GNU conversion specifiers. */ - { "kls", 0, STD_EXT, NOLENGTHS, "-_0Ow", "", NULL }, - { "P", 0, STD_EXT, NOLENGTHS, "", "", NULL }, - { NULL, 0, STD_C89, NOLENGTHS, NULL, NULL, NULL } -}; - -static const format_char_info monetary_char_table[] = -{ - { "in", 0, STD_C89, { T89_D, BADLEN, BADLEN, BADLEN, BADLEN, T89_LD, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN }, "=^+(!-w#p", "", NULL }, - { NULL, 0, STD_C89, NOLENGTHS, NULL, NULL, NULL } -}; - -/* This must be in the same order as enum format_type. */ -static const format_kind_info format_types_orig[] = -{ - { "gnu_printf", printf_length_specs, print_char_table, " +#0-'I", NULL, - printf_flag_specs, printf_flag_pairs, - FMT_FLAG_ARG_CONVERT|FMT_FLAG_DOLLAR_MULTIPLE|FMT_FLAG_USE_DOLLAR|FMT_FLAG_EMPTY_PREC_OK, - 'w', 0, 'p', 0, 'L', 0, - &integer_type_node, &integer_type_node - }, - { "asm_fprintf", asm_fprintf_length_specs, asm_fprintf_char_table, " +#0-", NULL, - asm_fprintf_flag_specs, asm_fprintf_flag_pairs, - FMT_FLAG_ARG_CONVERT|FMT_FLAG_EMPTY_PREC_OK, - 'w', 0, 'p', 0, 'L', 0, - NULL, NULL - }, - { "gcc_diag", gcc_diag_length_specs, gcc_diag_char_table, "q+", NULL, - gcc_diag_flag_specs, gcc_diag_flag_pairs, - FMT_FLAG_ARG_CONVERT, - 0, 0, 'p', 0, 'L', 0, - NULL, &integer_type_node - }, - { "gcc_tdiag", gcc_tdiag_length_specs, gcc_tdiag_char_table, "q+", NULL, - gcc_tdiag_flag_specs, gcc_tdiag_flag_pairs, - FMT_FLAG_ARG_CONVERT, - 0, 0, 'p', 0, 'L', 0, - NULL, &integer_type_node - }, - { "gcc_cdiag", gcc_cdiag_length_specs, gcc_cdiag_char_table, "q+", NULL, - gcc_cdiag_flag_specs, gcc_cdiag_flag_pairs, - FMT_FLAG_ARG_CONVERT, - 0, 0, 'p', 0, 'L', 0, - NULL, &integer_type_node - }, - { "gcc_cxxdiag", gcc_cxxdiag_length_specs, gcc_cxxdiag_char_table, "q+#", NULL, - gcc_cxxdiag_flag_specs, gcc_cxxdiag_flag_pairs, - FMT_FLAG_ARG_CONVERT, - 0, 0, 'p', 0, 'L', 0, - NULL, &integer_type_node - }, - { "gcc_gfc", gcc_gfc_length_specs, gcc_gfc_char_table, "", NULL, - NULL, gcc_gfc_flag_pairs, - FMT_FLAG_ARG_CONVERT, - 0, 0, 0, 0, 0, 0, - NULL, NULL - }, - { "gnu_scanf", scanf_length_specs, scan_char_table, "*'I", NULL, - scanf_flag_specs, scanf_flag_pairs, - FMT_FLAG_ARG_CONVERT|FMT_FLAG_SCANF_A_KLUDGE|FMT_FLAG_USE_DOLLAR|FMT_FLAG_ZERO_WIDTH_BAD|FMT_FLAG_DOLLAR_GAP_POINTER_OK, - 'w', 0, 0, '*', 'L', 'm', - NULL, NULL - }, - { "gnu_strftime", NULL, time_char_table, "_-0^#", "EO", - strftime_flag_specs, strftime_flag_pairs, - FMT_FLAG_FANCY_PERCENT_OK, 'w', 0, 0, 0, 0, 0, - NULL, NULL - }, - { "gnu_strfmon", strfmon_length_specs, monetary_char_table, "=^+(!-", NULL, - strfmon_flag_specs, strfmon_flag_pairs, - FMT_FLAG_ARG_CONVERT, 'w', '#', 'p', 0, 'L', 0, - NULL, NULL - } -}; - -/* This layer of indirection allows GCC to reassign format_types with - new data if necessary, while still allowing the original data to be - const. */ -static const format_kind_info *format_types = format_types_orig; -/* We can modify this one. We also add target-specific format types - to the end of the array. */ -static format_kind_info *dynamic_format_types; - -static int n_format_types = ARRAY_SIZE (format_types_orig); - -/* Structure detailing the results of checking a format function call - where the format expression may be a conditional expression with - many leaves resulting from nested conditional expressions. */ -typedef struct -{ - /* Number of leaves of the format argument that could not be checked - as they were not string literals. */ - int number_non_literal; - /* Number of leaves of the format argument that were null pointers or - string literals, but had extra format arguments. */ - int number_extra_args; - /* Number of leaves of the format argument that were null pointers or - string literals, but had extra format arguments and used $ operand - numbers. */ - int number_dollar_extra_args; - /* Number of leaves of the format argument that were wide string - literals. */ - int number_wide; - /* Number of leaves of the format argument that were empty strings. */ - int number_empty; - /* Number of leaves of the format argument that were unterminated - strings. */ - int number_unterminated; - /* Number of leaves of the format argument that were not counted above. */ - int number_other; -} format_check_results; - -typedef struct -{ - format_check_results *res; - function_format_info *info; - tree params; -} format_check_context; - -static void check_format_info (function_format_info *, tree); -static void check_format_arg (void *, tree, unsigned HOST_WIDE_INT); -static void check_format_info_main (format_check_results *, - function_format_info *, - const char *, int, tree, - unsigned HOST_WIDE_INT, alloc_pool); - -static void init_dollar_format_checking (int, tree); -static int maybe_read_dollar_number (const char **, int, - tree, tree *, const format_kind_info *); -static bool avoid_dollar_number (const char *); -static void finish_dollar_format_checking (format_check_results *, int); - -static const format_flag_spec *get_flag_spec (const format_flag_spec *, - int, const char *); - -static void check_format_types (format_wanted_type *, const char *, int); -static void format_type_warning (const char *, const char *, int, tree, - int, const char *, tree, int); - -/* Decode a format type from a string, returning the type, or - format_type_error if not valid, in which case the caller should print an - error message. */ -static int -decode_format_type (const char *s) -{ - int i; - int slen; - - s = convert_format_name_to_system_name (s); - slen = strlen (s); - for (i = 0; i < n_format_types; i++) - { - int alen; - if (!strcmp (s, format_types[i].name)) - return i; - alen = strlen (format_types[i].name); - if (slen == alen + 4 && s[0] == '_' && s[1] == '_' - && s[slen - 1] == '_' && s[slen - 2] == '_' - && !strncmp (s + 2, format_types[i].name, alen)) - return i; - } - return format_type_error; -} - - -/* Check the argument list of a call to printf, scanf, etc. - ATTRS are the attributes on the function type. There are NARGS argument - values in the array ARGARRAY. - Also, if -Wmissing-format-attribute, - warn for calls to vprintf or vscanf in functions with no such format - attribute themselves. */ - -void -check_function_format (tree attrs, int nargs, tree *argarray) -{ - tree a; - - /* See if this function has any format attributes. */ - for (a = attrs; a; a = TREE_CHAIN (a)) - { - if (is_attribute_p ("format", TREE_PURPOSE (a))) - { - /* Yup; check it. */ - function_format_info info; - decode_format_attr (TREE_VALUE (a), &info, 1); - if (warn_format) - { - /* FIXME: Rewrite all the internal functions in this file - to use the ARGARRAY directly instead of constructing this - temporary list. */ - tree params = NULL_TREE; - int i; - for (i = nargs - 1; i >= 0; i--) - params = tree_cons (NULL_TREE, argarray[i], params); - check_format_info (&info, params); - } - if (warn_missing_format_attribute && info.first_arg_num == 0 - && (format_types[info.format_type].flags - & (int) FMT_FLAG_ARG_CONVERT)) - { - tree c; - for (c = TYPE_ATTRIBUTES (TREE_TYPE (current_function_decl)); - c; - c = TREE_CHAIN (c)) - if (is_attribute_p ("format", TREE_PURPOSE (c)) - && (decode_format_type (IDENTIFIER_POINTER - (TREE_VALUE (TREE_VALUE (c)))) - == info.format_type)) - break; - if (c == NULL_TREE) - { - /* Check if the current function has a parameter to which - the format attribute could be attached; if not, it - can't be a candidate for a format attribute, despite - the vprintf-like or vscanf-like call. */ - tree args; - for (args = DECL_ARGUMENTS (current_function_decl); - args != 0; - args = TREE_CHAIN (args)) - { - if (TREE_CODE (TREE_TYPE (args)) == POINTER_TYPE - && (TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (args))) - == char_type_node)) - break; - } - if (args != 0) - warning (OPT_Wmissing_format_attribute, "function might " - "be possible candidate for %qs format attribute", - format_types[info.format_type].name); - } - } - } - } -} - - -/* Variables used by the checking of $ operand number formats. */ -static char *dollar_arguments_used = NULL; -static char *dollar_arguments_pointer_p = NULL; -static int dollar_arguments_alloc = 0; -static int dollar_arguments_count; -static int dollar_first_arg_num; -static int dollar_max_arg_used; -static int dollar_format_warned; - -/* Initialize the checking for a format string that may contain $ - parameter number specifications; we will need to keep track of whether - each parameter has been used. FIRST_ARG_NUM is the number of the first - argument that is a parameter to the format, or 0 for a vprintf-style - function; PARAMS is the list of arguments starting at this argument. */ - -static void -init_dollar_format_checking (int first_arg_num, tree params) -{ - tree oparams = params; - - dollar_first_arg_num = first_arg_num; - dollar_arguments_count = 0; - dollar_max_arg_used = 0; - dollar_format_warned = 0; - if (first_arg_num > 0) - { - while (params) - { - dollar_arguments_count++; - params = TREE_CHAIN (params); - } - } - if (dollar_arguments_alloc < dollar_arguments_count) - { - if (dollar_arguments_used) - free (dollar_arguments_used); - if (dollar_arguments_pointer_p) - free (dollar_arguments_pointer_p); - dollar_arguments_alloc = dollar_arguments_count; - dollar_arguments_used = XNEWVEC (char, dollar_arguments_alloc); - dollar_arguments_pointer_p = XNEWVEC (char, dollar_arguments_alloc); - } - if (dollar_arguments_alloc) - { - memset (dollar_arguments_used, 0, dollar_arguments_alloc); - if (first_arg_num > 0) - { - int i = 0; - params = oparams; - while (params) - { - dollar_arguments_pointer_p[i] = (TREE_CODE (TREE_TYPE (TREE_VALUE (params))) - == POINTER_TYPE); - params = TREE_CHAIN (params); - i++; - } - } - } -} - - -/* Look for a decimal number followed by a $ in *FORMAT. If DOLLAR_NEEDED - is set, it is an error if one is not found; otherwise, it is OK. If - such a number is found, check whether it is within range and mark that - numbered operand as being used for later checking. Returns the operand - number if found and within range, zero if no such number was found and - this is OK, or -1 on error. PARAMS points to the first operand of the - format; PARAM_PTR is made to point to the parameter referred to. If - a $ format is found, *FORMAT is updated to point just after it. */ - -static int -maybe_read_dollar_number (const char **format, - int dollar_needed, tree params, tree *param_ptr, - const format_kind_info *fki) -{ - int argnum; - int overflow_flag; - const char *fcp = *format; - if (!ISDIGIT (*fcp)) - { - if (dollar_needed) - { - warning (OPT_Wformat, "missing $ operand number in format"); - return -1; - } - else - return 0; - } - argnum = 0; - overflow_flag = 0; - while (ISDIGIT (*fcp)) - { - int nargnum; - nargnum = 10 * argnum + (*fcp - '0'); - if (nargnum < 0 || nargnum / 10 != argnum) - overflow_flag = 1; - argnum = nargnum; - fcp++; - } - if (*fcp != '$') - { - if (dollar_needed) - { - warning (OPT_Wformat, "missing $ operand number in format"); - return -1; - } - else - return 0; - } - *format = fcp + 1; - if (pedantic && !dollar_format_warned) - { - warning (OPT_Wformat, "%s does not support %%n$ operand number formats", - C_STD_NAME (STD_EXT)); - dollar_format_warned = 1; - } - if (overflow_flag || argnum == 0 - || (dollar_first_arg_num && argnum > dollar_arguments_count)) - { - warning (OPT_Wformat, "operand number out of range in format"); - return -1; - } - if (argnum > dollar_max_arg_used) - dollar_max_arg_used = argnum; - /* For vprintf-style functions we may need to allocate more memory to - track which arguments are used. */ - while (dollar_arguments_alloc < dollar_max_arg_used) - { - int nalloc; - nalloc = 2 * dollar_arguments_alloc + 16; - dollar_arguments_used = XRESIZEVEC (char, dollar_arguments_used, - nalloc); - dollar_arguments_pointer_p = XRESIZEVEC (char, dollar_arguments_pointer_p, - nalloc); - memset (dollar_arguments_used + dollar_arguments_alloc, 0, - nalloc - dollar_arguments_alloc); - dollar_arguments_alloc = nalloc; - } - if (!(fki->flags & (int) FMT_FLAG_DOLLAR_MULTIPLE) - && dollar_arguments_used[argnum - 1] == 1) - { - dollar_arguments_used[argnum - 1] = 2; - warning (OPT_Wformat, "format argument %d used more than once in %s format", - argnum, fki->name); - } - else - dollar_arguments_used[argnum - 1] = 1; - if (dollar_first_arg_num) - { - int i; - *param_ptr = params; - for (i = 1; i < argnum && *param_ptr != 0; i++) - *param_ptr = TREE_CHAIN (*param_ptr); - - /* This case shouldn't be caught here. */ - gcc_assert (*param_ptr); - } - else - *param_ptr = 0; - return argnum; -} - -/* Ensure that FORMAT does not start with a decimal number followed by - a $; give a diagnostic and return true if it does, false otherwise. */ - -static bool -avoid_dollar_number (const char *format) -{ - if (!ISDIGIT (*format)) - return false; - while (ISDIGIT (*format)) - format++; - if (*format == '$') - { - warning (OPT_Wformat, "$ operand number used after format without operand number"); - return true; - } - return false; -} - - -/* Finish the checking for a format string that used $ operand number formats - instead of non-$ formats. We check for unused operands before used ones - (a serious error, since the implementation of the format function - can't know what types to pass to va_arg to find the later arguments). - and for unused operands at the end of the format (if we know how many - arguments the format had, so not for vprintf). If there were operand - numbers out of range on a non-vprintf-style format, we won't have reached - here. If POINTER_GAP_OK, unused arguments are OK if all arguments are - pointers. */ - -static void -finish_dollar_format_checking (format_check_results *res, int pointer_gap_ok) -{ - int i; - bool found_pointer_gap = false; - for (i = 0; i < dollar_max_arg_used; i++) - { - if (!dollar_arguments_used[i]) - { - if (pointer_gap_ok && (dollar_first_arg_num == 0 - || dollar_arguments_pointer_p[i])) - found_pointer_gap = true; - else - warning (OPT_Wformat, - "format argument %d unused before used argument %d in $-style format", - i + 1, dollar_max_arg_used); - } - } - if (found_pointer_gap - || (dollar_first_arg_num - && dollar_max_arg_used < dollar_arguments_count)) - { - res->number_other--; - res->number_dollar_extra_args++; - } -} - - -/* Retrieve the specification for a format flag. SPEC contains the - specifications for format flags for the applicable kind of format. - FLAG is the flag in question. If PREDICATES is NULL, the basic - spec for that flag must be retrieved and must exist. If - PREDICATES is not NULL, it is a string listing possible predicates - for the spec entry; if an entry predicated on any of these is - found, it is returned, otherwise NULL is returned. */ - -static const format_flag_spec * -get_flag_spec (const format_flag_spec *spec, int flag, const char *predicates) -{ - int i; - for (i = 0; spec[i].flag_char != 0; i++) - { - if (spec[i].flag_char != flag) - continue; - if (predicates != NULL) - { - if (spec[i].predicate != 0 - && strchr (predicates, spec[i].predicate) != 0) - return &spec[i]; - } - else if (spec[i].predicate == 0) - return &spec[i]; - } - gcc_assert (predicates); - return NULL; -} - - -/* Check the argument list of a call to printf, scanf, etc. - INFO points to the function_format_info structure. - PARAMS is the list of argument values. */ - -static void -check_format_info (function_format_info *info, tree params) -{ - format_check_context format_ctx; - unsigned HOST_WIDE_INT arg_num; - tree format_tree; - format_check_results res; - /* Skip to format argument. If the argument isn't available, there's - no work for us to do; prototype checking will catch the problem. */ - for (arg_num = 1; ; ++arg_num) - { - if (params == 0) - return; - if (arg_num == info->format_num) - break; - params = TREE_CHAIN (params); - } - format_tree = TREE_VALUE (params); - params = TREE_CHAIN (params); - if (format_tree == 0) - return; - - res.number_non_literal = 0; - res.number_extra_args = 0; - res.number_dollar_extra_args = 0; - res.number_wide = 0; - res.number_empty = 0; - res.number_unterminated = 0; - res.number_other = 0; - - format_ctx.res = &res; - format_ctx.info = info; - format_ctx.params = params; - - check_function_arguments_recurse (check_format_arg, &format_ctx, - format_tree, arg_num); - - if (res.number_non_literal > 0) - { - /* Functions taking a va_list normally pass a non-literal format - string. These functions typically are declared with - first_arg_num == 0, so avoid warning in those cases. */ - if (!(format_types[info->format_type].flags & (int) FMT_FLAG_ARG_CONVERT)) - { - /* For strftime-like formats, warn for not checking the format - string; but there are no arguments to check. */ - warning (OPT_Wformat_nonliteral, - "format not a string literal, format string not checked"); - } - else if (info->first_arg_num != 0) - { - /* If there are no arguments for the format at all, we may have - printf (foo) which is likely to be a security hole. */ - while (arg_num + 1 < info->first_arg_num) - { - if (params == 0) - break; - params = TREE_CHAIN (params); - ++arg_num; - } - if (params == 0 && warn_format_security) - warning (OPT_Wformat_security, - "format not a string literal and no format arguments"); - else if (params == 0 && warn_format_nonliteral) - warning (OPT_Wformat_nonliteral, - "format not a string literal and no format arguments"); - else - warning (OPT_Wformat_nonliteral, - "format not a string literal, argument types not checked"); - } - } - - /* If there were extra arguments to the format, normally warn. However, - the standard does say extra arguments are ignored, so in the specific - case where we have multiple leaves (conditional expressions or - ngettext) allow extra arguments if at least one leaf didn't have extra - arguments, but was otherwise OK (either non-literal or checked OK). - If the format is an empty string, this should be counted similarly to the - case of extra format arguments. */ - if (res.number_extra_args > 0 && res.number_non_literal == 0 - && res.number_other == 0) - warning (OPT_Wformat_extra_args, "too many arguments for format"); - if (res.number_dollar_extra_args > 0 && res.number_non_literal == 0 - && res.number_other == 0) - warning (OPT_Wformat_extra_args, "unused arguments in $-style format"); - if (res.number_empty > 0 && res.number_non_literal == 0 - && res.number_other == 0) - warning (OPT_Wformat_zero_length, "zero-length %s format string", - format_types[info->format_type].name); - - if (res.number_wide > 0) - warning (OPT_Wformat, "format is a wide character string"); - - if (res.number_unterminated > 0) - warning (OPT_Wformat, "unterminated format string"); -} - -/* Callback from check_function_arguments_recurse to check a - format string. FORMAT_TREE is the format parameter. ARG_NUM - is the number of the format argument. CTX points to a - format_check_context. */ - -static void -check_format_arg (void *ctx, tree format_tree, - unsigned HOST_WIDE_INT arg_num) -{ - format_check_context *format_ctx = (format_check_context *) ctx; - format_check_results *res = format_ctx->res; - function_format_info *info = format_ctx->info; - tree params = format_ctx->params; - - int format_length; - HOST_WIDE_INT offset; - const char *format_chars; - tree array_size = 0; - tree array_init; - alloc_pool fwt_pool; - - if (integer_zerop (format_tree)) - { - /* Skip to first argument to check, so we can see if this format - has any arguments (it shouldn't). */ - while (arg_num + 1 < info->first_arg_num) - { - if (params == 0) - return; - params = TREE_CHAIN (params); - ++arg_num; - } - - if (params == 0) - res->number_other++; - else - res->number_extra_args++; - - return; - } - - offset = 0; - if (TREE_CODE (format_tree) == POINTER_PLUS_EXPR) - { - tree arg0, arg1; - - arg0 = TREE_OPERAND (format_tree, 0); - arg1 = TREE_OPERAND (format_tree, 1); - STRIP_NOPS (arg0); - STRIP_NOPS (arg1); - if (TREE_CODE (arg1) == INTEGER_CST) - format_tree = arg0; - else - { - res->number_non_literal++; - return; - } - if (!host_integerp (arg1, 0) - || (offset = tree_low_cst (arg1, 0)) < 0) - { - res->number_non_literal++; - return; - } - } - if (TREE_CODE (format_tree) != ADDR_EXPR) - { - res->number_non_literal++; - return; - } - format_tree = TREE_OPERAND (format_tree, 0); - if (TREE_CODE (format_tree) == ARRAY_REF - && host_integerp (TREE_OPERAND (format_tree, 1), 0) - && (offset += tree_low_cst (TREE_OPERAND (format_tree, 1), 0)) >= 0) - format_tree = TREE_OPERAND (format_tree, 0); - if (TREE_CODE (format_tree) == VAR_DECL - && TREE_CODE (TREE_TYPE (format_tree)) == ARRAY_TYPE - && (array_init = decl_constant_value (format_tree)) != format_tree - && TREE_CODE (array_init) == STRING_CST) - { - /* Extract the string constant initializer. Note that this may include - a trailing NUL character that is not in the array (e.g. - const char a[3] = "foo";). */ - array_size = DECL_SIZE_UNIT (format_tree); - format_tree = array_init; - } - if (TREE_CODE (format_tree) != STRING_CST) - { - res->number_non_literal++; - return; - } - if (TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (format_tree))) != char_type_node) - { - res->number_wide++; - return; - } - format_chars = TREE_STRING_POINTER (format_tree); - format_length = TREE_STRING_LENGTH (format_tree); - if (array_size != 0) - { - /* Variable length arrays can't be initialized. */ - gcc_assert (TREE_CODE (array_size) == INTEGER_CST); - - if (host_integerp (array_size, 0)) - { - HOST_WIDE_INT array_size_value = TREE_INT_CST_LOW (array_size); - if (array_size_value > 0 - && array_size_value == (int) array_size_value - && format_length > array_size_value) - format_length = array_size_value; - } - } - if (offset) - { - if (offset >= format_length) - { - res->number_non_literal++; - return; - } - format_chars += offset; - format_length -= offset; - } - if (format_length < 1 || format_chars[--format_length] != 0) - { - res->number_unterminated++; - return; - } - if (format_length == 0) - { - res->number_empty++; - return; - } - - /* Skip to first argument to check. */ - while (arg_num + 1 < info->first_arg_num) - { - if (params == 0) - return; - params = TREE_CHAIN (params); - ++arg_num; - } - /* Provisionally increment res->number_other; check_format_info_main - will decrement it if it finds there are extra arguments, but this way - need not adjust it for every return. */ - res->number_other++; - fwt_pool = create_alloc_pool ("format_wanted_type pool", - sizeof (format_wanted_type), 10); - check_format_info_main (res, info, format_chars, format_length, - params, arg_num, fwt_pool); - free_alloc_pool (fwt_pool); -} - - -/* Do the main part of checking a call to a format function. FORMAT_CHARS - is the NUL-terminated format string (which at this point may contain - internal NUL characters); FORMAT_LENGTH is its length (excluding the - terminating NUL character). ARG_NUM is one less than the number of - the first format argument to check; PARAMS points to that format - argument in the list of arguments. */ - -static void -check_format_info_main (format_check_results *res, - function_format_info *info, const char *format_chars, - int format_length, tree params, - unsigned HOST_WIDE_INT arg_num, alloc_pool fwt_pool) -{ - const char *orig_format_chars = format_chars; - tree first_fillin_param = params; - - const format_kind_info *fki = &format_types[info->format_type]; - const format_flag_spec *flag_specs = fki->flag_specs; - const format_flag_pair *bad_flag_pairs = fki->bad_flag_pairs; - - /* -1 if no conversions taking an operand have been found; 0 if one has - and it didn't use $; 1 if $ formats are in use. */ - int has_operand_number = -1; - - init_dollar_format_checking (info->first_arg_num, first_fillin_param); - - while (1) - { - int i; - int suppressed = FALSE; - const char *length_chars = NULL; - enum format_lengths length_chars_val = FMT_LEN_none; - enum format_std_version length_chars_std = STD_C89; - int format_char; - tree cur_param; - tree wanted_type; - int main_arg_num = 0; - tree main_arg_params = 0; - enum format_std_version wanted_type_std; - const char *wanted_type_name; - format_wanted_type width_wanted_type; - format_wanted_type precision_wanted_type; - format_wanted_type main_wanted_type; - format_wanted_type *first_wanted_type = NULL; - format_wanted_type *last_wanted_type = NULL; - const format_length_info *fli = NULL; - const format_char_info *fci = NULL; - char flag_chars[256]; - int alloc_flag = 0; - int scalar_identity_flag = 0; - const char *format_start = format_chars; - if (*format_chars == 0) - { - if (format_chars - orig_format_chars != format_length) - warning (OPT_Wformat_contains_nul, "embedded %<\\0%> in format"); - if (info->first_arg_num != 0 && params != 0 - && has_operand_number <= 0) - { - res->number_other--; - res->number_extra_args++; - } - if (has_operand_number > 0) - finish_dollar_format_checking (res, fki->flags & (int) FMT_FLAG_DOLLAR_GAP_POINTER_OK); - return; - } - if (*format_chars++ != '%') - continue; - if (*format_chars == 0) - { - warning (OPT_Wformat, "spurious trailing %<%%%> in format"); - continue; - } - if (*format_chars == '%') - { - ++format_chars; - continue; - } - flag_chars[0] = 0; - - if ((fki->flags & (int) FMT_FLAG_USE_DOLLAR) && has_operand_number != 0) - { - /* Possibly read a $ operand number at the start of the format. - If one was previously used, one is required here. If one - is not used here, we can't immediately conclude this is a - format without them, since it could be printf %m or scanf %*. */ - int opnum; - opnum = maybe_read_dollar_number (&format_chars, 0, - first_fillin_param, - &main_arg_params, fki); - if (opnum == -1) - return; - else if (opnum > 0) - { - has_operand_number = 1; - main_arg_num = opnum + info->first_arg_num - 1; - } - } - else if (fki->flags & FMT_FLAG_USE_DOLLAR) - { - if (avoid_dollar_number (format_chars)) - return; - } - - /* Read any format flags, but do not yet validate them beyond removing - duplicates, since in general validation depends on the rest of - the format. */ - while (*format_chars != 0 - && strchr (fki->flag_chars, *format_chars) != 0) - { - const format_flag_spec *s = get_flag_spec (flag_specs, - *format_chars, NULL); - if (strchr (flag_chars, *format_chars) != 0) - { - warning (OPT_Wformat, "repeated %s in format", _(s->name)); - } - else - { - i = strlen (flag_chars); - flag_chars[i++] = *format_chars; - flag_chars[i] = 0; - } - if (s->skip_next_char) - { - ++format_chars; - if (*format_chars == 0) - { - warning (OPT_Wformat, "missing fill character at end of strfmon format"); - return; - } - } - ++format_chars; - } - - /* Read any format width, possibly * or *m$. */ - if (fki->width_char != 0) - { - if (fki->width_type != NULL && *format_chars == '*') - { - i = strlen (flag_chars); - flag_chars[i++] = fki->width_char; - flag_chars[i] = 0; - /* "...a field width...may be indicated by an asterisk. - In this case, an int argument supplies the field width..." */ - ++format_chars; - if (has_operand_number != 0) - { - int opnum; - opnum = maybe_read_dollar_number (&format_chars, - has_operand_number == 1, - first_fillin_param, - ¶ms, fki); - if (opnum == -1) - return; - else if (opnum > 0) - { - has_operand_number = 1; - arg_num = opnum + info->first_arg_num - 1; - } - else - has_operand_number = 0; - } - else - { - if (avoid_dollar_number (format_chars)) - return; - } - if (info->first_arg_num != 0) - { - if (params == 0) - { - warning (OPT_Wformat, "too few arguments for format"); - return; - } - cur_param = TREE_VALUE (params); - if (has_operand_number <= 0) - { - params = TREE_CHAIN (params); - ++arg_num; - } - width_wanted_type.wanted_type = *fki->width_type; - width_wanted_type.wanted_type_name = NULL; - width_wanted_type.pointer_count = 0; - width_wanted_type.char_lenient_flag = 0; - width_wanted_type.scalar_identity_flag = 0; - width_wanted_type.writing_in_flag = 0; - width_wanted_type.reading_from_flag = 0; - width_wanted_type.name = _("field width"); - width_wanted_type.param = cur_param; - width_wanted_type.arg_num = arg_num; - width_wanted_type.next = NULL; - if (last_wanted_type != 0) - last_wanted_type->next = &width_wanted_type; - if (first_wanted_type == 0) - first_wanted_type = &width_wanted_type; - last_wanted_type = &width_wanted_type; - } - } - else - { - /* Possibly read a numeric width. If the width is zero, - we complain if appropriate. */ - int non_zero_width_char = FALSE; - int found_width = FALSE; - while (ISDIGIT (*format_chars)) - { - found_width = TRUE; - if (*format_chars != '0') - non_zero_width_char = TRUE; - ++format_chars; - } - if (found_width && !non_zero_width_char && - (fki->flags & (int) FMT_FLAG_ZERO_WIDTH_BAD)) - warning (OPT_Wformat, "zero width in %s format", fki->name); - if (found_width) - { - i = strlen (flag_chars); - flag_chars[i++] = fki->width_char; - flag_chars[i] = 0; - } - } - } - - /* Read any format left precision (must be a number, not *). */ - if (fki->left_precision_char != 0 && *format_chars == '#') - { - ++format_chars; - i = strlen (flag_chars); - flag_chars[i++] = fki->left_precision_char; - flag_chars[i] = 0; - if (!ISDIGIT (*format_chars)) - warning (OPT_Wformat, "empty left precision in %s format", fki->name); - while (ISDIGIT (*format_chars)) - ++format_chars; - } - - /* Read any format precision, possibly * or *m$. */ - if (fki->precision_char != 0 && *format_chars == '.') - { - ++format_chars; - i = strlen (flag_chars); - flag_chars[i++] = fki->precision_char; - flag_chars[i] = 0; - if (fki->precision_type != NULL && *format_chars == '*') - { - /* "...a...precision...may be indicated by an asterisk. - In this case, an int argument supplies the...precision." */ - ++format_chars; - if (has_operand_number != 0) - { - int opnum; - opnum = maybe_read_dollar_number (&format_chars, - has_operand_number == 1, - first_fillin_param, - ¶ms, fki); - if (opnum == -1) - return; - else if (opnum > 0) - { - has_operand_number = 1; - arg_num = opnum + info->first_arg_num - 1; - } - else - has_operand_number = 0; - } - else - { - if (avoid_dollar_number (format_chars)) - return; - } - if (info->first_arg_num != 0) - { - if (params == 0) - { - warning (OPT_Wformat, "too few arguments for format"); - return; - } - cur_param = TREE_VALUE (params); - if (has_operand_number <= 0) - { - params = TREE_CHAIN (params); - ++arg_num; - } - precision_wanted_type.wanted_type = *fki->precision_type; - precision_wanted_type.wanted_type_name = NULL; - precision_wanted_type.pointer_count = 0; - precision_wanted_type.char_lenient_flag = 0; - precision_wanted_type.scalar_identity_flag = 0; - precision_wanted_type.writing_in_flag = 0; - precision_wanted_type.reading_from_flag = 0; - precision_wanted_type.name = _("field precision"); - precision_wanted_type.param = cur_param; - precision_wanted_type.arg_num = arg_num; - precision_wanted_type.next = NULL; - if (last_wanted_type != 0) - last_wanted_type->next = &precision_wanted_type; - if (first_wanted_type == 0) - first_wanted_type = &precision_wanted_type; - last_wanted_type = &precision_wanted_type; - } - } - else - { - if (!(fki->flags & (int) FMT_FLAG_EMPTY_PREC_OK) - && !ISDIGIT (*format_chars)) - warning (OPT_Wformat, "empty precision in %s format", fki->name); - while (ISDIGIT (*format_chars)) - ++format_chars; - } - } - - if (fki->alloc_char && fki->alloc_char == *format_chars) - { - i = strlen (flag_chars); - flag_chars[i++] = fki->alloc_char; - flag_chars[i] = 0; - format_chars++; - } - - /* Handle the scanf allocation kludge. */ - if (fki->flags & (int) FMT_FLAG_SCANF_A_KLUDGE) - { - if (*format_chars == 'a' && !flag_isoc99) - { - if (format_chars[1] == 's' || format_chars[1] == 'S' - || format_chars[1] == '[') - { - /* 'a' is used as a flag. */ - i = strlen (flag_chars); - flag_chars[i++] = 'a'; - flag_chars[i] = 0; - format_chars++; - } - } - } - - /* Read any length modifier, if this kind of format has them. */ - fli = fki->length_char_specs; - length_chars = NULL; - length_chars_val = FMT_LEN_none; - length_chars_std = STD_C89; - scalar_identity_flag = 0; - if (fli) - { - while (fli->name != 0 - && strncmp (fli->name, format_chars, strlen (fli->name))) - fli++; - if (fli->name != 0) - { - format_chars += strlen (fli->name); - if (fli->double_name != 0 && fli->name[0] == *format_chars) - { - format_chars++; - length_chars = fli->double_name; - length_chars_val = fli->double_index; - length_chars_std = fli->double_std; - } - else - { - length_chars = fli->name; - length_chars_val = fli->index; - length_chars_std = fli->std; - scalar_identity_flag = fli->scalar_identity_flag; - } - i = strlen (flag_chars); - flag_chars[i++] = fki->length_code_char; - flag_chars[i] = 0; - } - if (pedantic) - { - /* Warn if the length modifier is non-standard. */ - if (ADJ_STD (length_chars_std) > C_STD_VER) - warning (OPT_Wformat, - "%s does not support the %qs %s length modifier", - C_STD_NAME (length_chars_std), length_chars, - fki->name); - } - } - - /* Read any modifier (strftime E/O). */ - if (fki->modifier_chars != NULL) - { - while (*format_chars != 0 - && strchr (fki->modifier_chars, *format_chars) != 0) - { - if (strchr (flag_chars, *format_chars) != 0) - { - const format_flag_spec *s = get_flag_spec (flag_specs, - *format_chars, NULL); - warning (OPT_Wformat, "repeated %s in format", _(s->name)); - } - else - { - i = strlen (flag_chars); - flag_chars[i++] = *format_chars; - flag_chars[i] = 0; - } - ++format_chars; - } - } - - format_char = *format_chars; - if (format_char == 0 - || (!(fki->flags & (int) FMT_FLAG_FANCY_PERCENT_OK) - && format_char == '%')) - { - warning (OPT_Wformat, "conversion lacks type at end of format"); - continue; - } - format_chars++; - fci = fki->conversion_specs; - while (fci->format_chars != 0 - && strchr (fci->format_chars, format_char) == 0) - ++fci; - if (fci->format_chars == 0) - { - if (ISGRAPH (format_char)) - warning (OPT_Wformat, "unknown conversion type character %qc in format", - format_char); - else - warning (OPT_Wformat, "unknown conversion type character 0x%x in format", - format_char); - continue; - } - if (pedantic) - { - if (ADJ_STD (fci->std) > C_STD_VER) - warning (OPT_Wformat, "%s does not support the %<%%%c%> %s format", - C_STD_NAME (fci->std), format_char, fki->name); - } - - /* Validate the individual flags used, removing any that are invalid. */ - { - int d = 0; - for (i = 0; flag_chars[i] != 0; i++) - { - const format_flag_spec *s = get_flag_spec (flag_specs, - flag_chars[i], NULL); - flag_chars[i - d] = flag_chars[i]; - if (flag_chars[i] == fki->length_code_char) - continue; - if (strchr (fci->flag_chars, flag_chars[i]) == 0) - { - warning (OPT_Wformat, "%s used with %<%%%c%> %s format", - _(s->name), format_char, fki->name); - d++; - continue; - } - if (pedantic) - { - const format_flag_spec *t; - if (ADJ_STD (s->std) > C_STD_VER) - warning (OPT_Wformat, "%s does not support %s", - C_STD_NAME (s->std), _(s->long_name)); - t = get_flag_spec (flag_specs, flag_chars[i], fci->flags2); - if (t != NULL && ADJ_STD (t->std) > ADJ_STD (s->std)) - { - const char *long_name = (t->long_name != NULL - ? t->long_name - : s->long_name); - if (ADJ_STD (t->std) > C_STD_VER) - warning (OPT_Wformat, - "%s does not support %s with the %<%%%c%> %s format", - C_STD_NAME (t->std), _(long_name), - format_char, fki->name); - } - } - } - flag_chars[i - d] = 0; - } - - if ((fki->flags & (int) FMT_FLAG_SCANF_A_KLUDGE) - && strchr (flag_chars, 'a') != 0) - alloc_flag = 1; - if (fki->alloc_char && strchr (flag_chars, fki->alloc_char) != 0) - alloc_flag = 1; - - if (fki->suppression_char - && strchr (flag_chars, fki->suppression_char) != 0) - suppressed = 1; - - /* Validate the pairs of flags used. */ - for (i = 0; bad_flag_pairs[i].flag_char1 != 0; i++) - { - const format_flag_spec *s, *t; - if (strchr (flag_chars, bad_flag_pairs[i].flag_char1) == 0) - continue; - if (strchr (flag_chars, bad_flag_pairs[i].flag_char2) == 0) - continue; - if (bad_flag_pairs[i].predicate != 0 - && strchr (fci->flags2, bad_flag_pairs[i].predicate) == 0) - continue; - s = get_flag_spec (flag_specs, bad_flag_pairs[i].flag_char1, NULL); - t = get_flag_spec (flag_specs, bad_flag_pairs[i].flag_char2, NULL); - if (bad_flag_pairs[i].ignored) - { - if (bad_flag_pairs[i].predicate != 0) - warning (OPT_Wformat, - "%s ignored with %s and %<%%%c%> %s format", - _(s->name), _(t->name), format_char, - fki->name); - else - warning (OPT_Wformat, "%s ignored with %s in %s format", - _(s->name), _(t->name), fki->name); - } - else - { - if (bad_flag_pairs[i].predicate != 0) - warning (OPT_Wformat, - "use of %s and %s together with %<%%%c%> %s format", - _(s->name), _(t->name), format_char, - fki->name); - else - warning (OPT_Wformat, "use of %s and %s together in %s format", - _(s->name), _(t->name), fki->name); - } - } - - /* Give Y2K warnings. */ - if (warn_format_y2k) - { - int y2k_level = 0; - if (strchr (fci->flags2, '4') != 0) - if (strchr (flag_chars, 'E') != 0) - y2k_level = 3; - else - y2k_level = 2; - else if (strchr (fci->flags2, '3') != 0) - y2k_level = 3; - else if (strchr (fci->flags2, '2') != 0) - y2k_level = 2; - if (y2k_level == 3) - warning (OPT_Wformat_y2k, "%<%%%c%> yields only last 2 digits of " - "year in some locales", format_char); - else if (y2k_level == 2) - warning (OPT_Wformat_y2k, "%<%%%c%> yields only last 2 digits of " - "year", format_char); - } - - if (strchr (fci->flags2, '[') != 0) - { - /* Skip over scan set, in case it happens to have '%' in it. */ - if (*format_chars == '^') - ++format_chars; - /* Find closing bracket; if one is hit immediately, then - it's part of the scan set rather than a terminator. */ - if (*format_chars == ']') - ++format_chars; - while (*format_chars && *format_chars != ']') - ++format_chars; - if (*format_chars != ']') - /* The end of the format string was reached. */ - warning (OPT_Wformat, "no closing %<]%> for %<%%[%> format"); - } - - wanted_type = 0; - wanted_type_name = 0; - if (fki->flags & (int) FMT_FLAG_ARG_CONVERT) - { - wanted_type = (fci->types[length_chars_val].type - ? *fci->types[length_chars_val].type : 0); - wanted_type_name = fci->types[length_chars_val].name; - wanted_type_std = fci->types[length_chars_val].std; - if (wanted_type == 0) - { - warning (OPT_Wformat, - "use of %qs length modifier with %qc type character", - length_chars, format_char); - /* Heuristic: skip one argument when an invalid length/type - combination is encountered. */ - arg_num++; - if (params == 0) - { - warning (OPT_Wformat, "too few arguments for format"); - return; - } - params = TREE_CHAIN (params); - continue; - } - else if (pedantic - /* Warn if non-standard, provided it is more non-standard - than the length and type characters that may already - have been warned for. */ - && ADJ_STD (wanted_type_std) > ADJ_STD (length_chars_std) - && ADJ_STD (wanted_type_std) > ADJ_STD (fci->std)) - { - if (ADJ_STD (wanted_type_std) > C_STD_VER) - warning (OPT_Wformat, - "%s does not support the %<%%%s%c%> %s format", - C_STD_NAME (wanted_type_std), length_chars, - format_char, fki->name); - } - } - - main_wanted_type.next = NULL; - - /* Finally. . .check type of argument against desired type! */ - if (info->first_arg_num == 0) - continue; - if ((fci->pointer_count == 0 && wanted_type == void_type_node) - || suppressed) - { - if (main_arg_num != 0) - { - if (suppressed) - warning (OPT_Wformat, "operand number specified with " - "suppressed assignment"); - else - warning (OPT_Wformat, "operand number specified for format " - "taking no argument"); - } - } - else - { - format_wanted_type *wanted_type_ptr; - - if (main_arg_num != 0) - { - arg_num = main_arg_num; - params = main_arg_params; - } - else - { - ++arg_num; - if (has_operand_number > 0) - { - warning (OPT_Wformat, "missing $ operand number in format"); - return; - } - else - has_operand_number = 0; - } - - wanted_type_ptr = &main_wanted_type; - while (fci) - { - if (params == 0) - { - warning (OPT_Wformat, "too few arguments for format"); - return; - } - - cur_param = TREE_VALUE (params); - params = TREE_CHAIN (params); - - wanted_type_ptr->wanted_type = wanted_type; - wanted_type_ptr->wanted_type_name = wanted_type_name; - wanted_type_ptr->pointer_count = fci->pointer_count + alloc_flag; - wanted_type_ptr->char_lenient_flag = 0; - if (strchr (fci->flags2, 'c') != 0) - wanted_type_ptr->char_lenient_flag = 1; - wanted_type_ptr->scalar_identity_flag = 0; - if (scalar_identity_flag) - wanted_type_ptr->scalar_identity_flag = 1; - wanted_type_ptr->writing_in_flag = 0; - wanted_type_ptr->reading_from_flag = 0; - if (alloc_flag) - wanted_type_ptr->writing_in_flag = 1; - else - { - if (strchr (fci->flags2, 'W') != 0) - wanted_type_ptr->writing_in_flag = 1; - if (strchr (fci->flags2, 'R') != 0) - wanted_type_ptr->reading_from_flag = 1; - } - wanted_type_ptr->name = NULL; - wanted_type_ptr->param = cur_param; - wanted_type_ptr->arg_num = arg_num; - wanted_type_ptr->next = NULL; - if (last_wanted_type != 0) - last_wanted_type->next = wanted_type_ptr; - if (first_wanted_type == 0) - first_wanted_type = wanted_type_ptr; - last_wanted_type = wanted_type_ptr; - - fci = fci->chain; - if (fci) - { - wanted_type_ptr = (format_wanted_type *) - pool_alloc (fwt_pool); - arg_num++; - wanted_type = *fci->types[length_chars_val].type; - wanted_type_name = fci->types[length_chars_val].name; - } - } - } - - if (first_wanted_type != 0) - check_format_types (first_wanted_type, format_start, - format_chars - format_start); - } -} - - -/* Check the argument types from a single format conversion (possibly - including width and precision arguments). */ -static void -check_format_types (format_wanted_type *types, const char *format_start, - int format_length) -{ - for (; types != 0; types = types->next) - { - tree cur_param; - tree cur_type; - tree orig_cur_type; - tree wanted_type; - int arg_num; - int i; - int char_type_flag; - cur_param = types->param; - cur_type = TREE_TYPE (cur_param); - if (cur_type == error_mark_node) - continue; - orig_cur_type = cur_type; - char_type_flag = 0; - wanted_type = types->wanted_type; - arg_num = types->arg_num; - - /* The following should not occur here. */ - gcc_assert (wanted_type); - gcc_assert (wanted_type != void_type_node || types->pointer_count); - - if (types->pointer_count == 0) - wanted_type = lang_hooks.types.type_promotes_to (wanted_type); - - wanted_type = TYPE_MAIN_VARIANT (wanted_type); - - STRIP_NOPS (cur_param); - - /* Check the types of any additional pointer arguments - that precede the "real" argument. */ - for (i = 0; i < types->pointer_count; ++i) - { - if (TREE_CODE (cur_type) == POINTER_TYPE) - { - cur_type = TREE_TYPE (cur_type); - if (cur_type == error_mark_node) - break; - - /* Check for writing through a NULL pointer. */ - if (types->writing_in_flag - && i == 0 - && cur_param != 0 - && integer_zerop (cur_param)) - warning (OPT_Wformat, "writing through null pointer " - "(argument %d)", arg_num); - - /* Check for reading through a NULL pointer. */ - if (types->reading_from_flag - && i == 0 - && cur_param != 0 - && integer_zerop (cur_param)) - warning (OPT_Wformat, "reading through null pointer " - "(argument %d)", arg_num); - - if (cur_param != 0 && TREE_CODE (cur_param) == ADDR_EXPR) - cur_param = TREE_OPERAND (cur_param, 0); - else - cur_param = 0; - - /* See if this is an attempt to write into a const type with - scanf or with printf "%n". Note: the writing in happens - at the first indirection only, if for example - void * const * is passed to scanf %p; passing - const void ** is simply passing an incompatible type. */ - if (types->writing_in_flag - && i == 0 - && (TYPE_READONLY (cur_type) - || (cur_param != 0 - && (CONSTANT_CLASS_P (cur_param) - || (DECL_P (cur_param) - && TREE_READONLY (cur_param)))))) - warning (OPT_Wformat, "writing into constant object " - "(argument %d)", arg_num); - - /* If there are extra type qualifiers beyond the first - indirection, then this makes the types technically - incompatible. */ - if (i > 0 - && pedantic - && (TYPE_READONLY (cur_type) - || TYPE_VOLATILE (cur_type) - || TYPE_RESTRICT (cur_type))) - warning (OPT_Wformat, "extra type qualifiers in format " - "argument (argument %d)", - arg_num); - - } - else - { - format_type_warning (types->name, format_start, format_length, - wanted_type, types->pointer_count, - types->wanted_type_name, orig_cur_type, - arg_num); - break; - } - } - - if (i < types->pointer_count) - continue; - - cur_type = TYPE_MAIN_VARIANT (cur_type); - - /* Check whether the argument type is a character type. This leniency - only applies to certain formats, flagged with 'c'. - */ - if (types->char_lenient_flag) - char_type_flag = (cur_type == char_type_node - || cur_type == signed_char_type_node - || cur_type == unsigned_char_type_node); - - /* Check the type of the "real" argument, if there's a type we want. */ - if (lang_hooks.types_compatible_p (wanted_type, cur_type)) - continue; - /* If we want 'void *', allow any pointer type. - (Anything else would already have got a warning.) - With -pedantic, only allow pointers to void and to character - types. */ - if (wanted_type == void_type_node - && (!pedantic || (i == 1 && char_type_flag))) - continue; - /* Don't warn about differences merely in signedness, unless - -pedantic. With -pedantic, warn if the type is a pointer - target and not a character type, and for character types at - a second level of indirection. */ - if (TREE_CODE (wanted_type) == INTEGER_TYPE - && TREE_CODE (cur_type) == INTEGER_TYPE - && (!pedantic || i == 0 || (i == 1 && char_type_flag)) - && (TYPE_UNSIGNED (wanted_type) - ? wanted_type == c_common_unsigned_type (cur_type) - : wanted_type == c_common_signed_type (cur_type))) - continue; - /* Likewise, "signed char", "unsigned char" and "char" are - equivalent but the above test won't consider them equivalent. */ - if (wanted_type == char_type_node - && (!pedantic || i < 2) - && char_type_flag) - continue; - if (types->scalar_identity_flag - && (TREE_CODE (cur_type) == TREE_CODE (wanted_type) - || (INTEGRAL_TYPE_P (cur_type) - && INTEGRAL_TYPE_P (wanted_type))) - && TYPE_PRECISION (cur_type) == TYPE_PRECISION (wanted_type)) - continue; - /* Now we have a type mismatch. */ - format_type_warning (types->name, format_start, format_length, - wanted_type, types->pointer_count, - types->wanted_type_name, orig_cur_type, arg_num); - } -} - - -/* Give a warning about a format argument of different type from that - expected. DESCR is a description such as "field precision", or - NULL for an ordinary format. For an ordinary format, FORMAT_START - points to where the format starts in the format string and - FORMAT_LENGTH is its length. WANTED_TYPE is the type the argument - should have after POINTER_COUNT pointer dereferences. - WANTED_NAME_NAME is a possibly more friendly name of WANTED_TYPE, - or NULL if the ordinary name of the type should be used. ARG_TYPE - is the type of the actual argument. ARG_NUM is the number of that - argument. */ -static void -format_type_warning (const char *descr, const char *format_start, - int format_length, tree wanted_type, int pointer_count, - const char *wanted_type_name, tree arg_type, int arg_num) -{ - char *p; - /* If ARG_TYPE is a typedef with a misleading name (for example, - size_t but not the standard size_t expected by printf %zu), avoid - printing the typedef name. */ - if (wanted_type_name - && TYPE_NAME (arg_type) - && TREE_CODE (TYPE_NAME (arg_type)) == TYPE_DECL - && DECL_NAME (TYPE_NAME (arg_type)) - && !strcmp (wanted_type_name, - lang_hooks.decl_printable_name (TYPE_NAME (arg_type), 2))) - arg_type = TYPE_MAIN_VARIANT (arg_type); - /* The format type and name exclude any '*' for pointers, so those - must be formatted manually. For all the types we currently have, - this is adequate, but formats taking pointers to functions or - arrays would require the full type to be built up in order to - print it with %T. */ - p = (char *) alloca (pointer_count + 2); - if (pointer_count == 0) - p[0] = 0; - else if (c_dialect_cxx ()) - { - memset (p, '*', pointer_count); - p[pointer_count] = 0; - } - else - { - p[0] = ' '; - memset (p + 1, '*', pointer_count); - p[pointer_count + 1] = 0; - } - if (wanted_type_name) - { - if (descr) - warning (OPT_Wformat, "%s should have type %<%s%s%>, " - "but argument %d has type %qT", - descr, wanted_type_name, p, arg_num, arg_type); - else - warning (OPT_Wformat, "format %q.*s expects type %<%s%s%>, " - "but argument %d has type %qT", - format_length, format_start, wanted_type_name, p, - arg_num, arg_type); - } - else - { - if (descr) - warning (OPT_Wformat, "%s should have type %<%T%s%>, " - "but argument %d has type %qT", - descr, wanted_type, p, arg_num, arg_type); - else - warning (OPT_Wformat, "format %q.*s expects type %<%T%s%>, " - "but argument %d has type %qT", - format_length, format_start, wanted_type, p, arg_num, arg_type); - } -} - - -/* Given a format_char_info array FCI, and a character C, this function - returns the index into the conversion_specs where that specifier's - data is located. The character must exist. */ -static unsigned int -find_char_info_specifier_index (const format_char_info *fci, int c) -{ - unsigned i; - - for (i = 0; fci->format_chars; i++, fci++) - if (strchr (fci->format_chars, c)) - return i; - - /* We shouldn't be looking for a non-existent specifier. */ - gcc_unreachable (); -} - -/* Given a format_length_info array FLI, and a character C, this - function returns the index into the conversion_specs where that - modifier's data is located. The character must exist. */ -static unsigned int -find_length_info_modifier_index (const format_length_info *fli, int c) -{ - unsigned i; - - for (i = 0; fli->name; i++, fli++) - if (strchr (fli->name, c)) - return i; - - /* We shouldn't be looking for a non-existent modifier. */ - gcc_unreachable (); -} - -/* Determine the type of HOST_WIDE_INT in the code being compiled for - use in GCC's __asm_fprintf__ custom format attribute. You must - have set dynamic_format_types before calling this function. */ -static void -init_dynamic_asm_fprintf_info (void) -{ - static tree hwi; - - if (!hwi) - { - format_length_info *new_asm_fprintf_length_specs; - unsigned int i; - - /* Find the underlying type for HOST_WIDE_INT. For the %w - length modifier to work, one must have issued: "typedef - HOST_WIDE_INT __gcc_host_wide_int__;" in one's source code - prior to using that modifier. */ - hwi = maybe_get_identifier ("__gcc_host_wide_int__"); - if (!hwi) - { - error ("%<__gcc_host_wide_int__%> is not defined as a type"); - return; - } - hwi = identifier_global_value (hwi); - if (!hwi || TREE_CODE (hwi) != TYPE_DECL) - { - error ("%<__gcc_host_wide_int__%> is not defined as a type"); - return; - } - hwi = DECL_ORIGINAL_TYPE (hwi); - gcc_assert (hwi); - if (hwi != long_integer_type_node && hwi != long_long_integer_type_node) - { - error ("%<__gcc_host_wide_int__%> is not defined as %" - " or %"); - return; - } - - /* Create a new (writable) copy of asm_fprintf_length_specs. */ - new_asm_fprintf_length_specs = (format_length_info *) - xmemdup (asm_fprintf_length_specs, - sizeof (asm_fprintf_length_specs), - sizeof (asm_fprintf_length_specs)); - - /* HOST_WIDE_INT must be one of 'long' or 'long long'. */ - i = find_length_info_modifier_index (new_asm_fprintf_length_specs, 'w'); - if (hwi == long_integer_type_node) - new_asm_fprintf_length_specs[i].index = FMT_LEN_l; - else if (hwi == long_long_integer_type_node) - new_asm_fprintf_length_specs[i].index = FMT_LEN_ll; - else - gcc_unreachable (); - - /* Assign the new data for use. */ - dynamic_format_types[asm_fprintf_format_type].length_char_specs = - new_asm_fprintf_length_specs; - } -} - -/* Determine the type of a "locus" in the code being compiled for use - in GCC's __gcc_gfc__ custom format attribute. You must have set - dynamic_format_types before calling this function. */ -static void -init_dynamic_gfc_info (void) -{ - static tree locus; - - if (!locus) - { - static format_char_info *gfc_fci; - - /* For the GCC __gcc_gfc__ custom format specifier to work, one - must have declared 'locus' prior to using this attribute. If - we haven't seen this declarations then you shouldn't use the - specifier requiring that type. */ - if ((locus = maybe_get_identifier ("locus"))) - { - locus = identifier_global_value (locus); - if (locus) - { - if (TREE_CODE (locus) != TYPE_DECL - || TREE_TYPE (locus) == error_mark_node) - { - error ("% is not defined as a type"); - locus = 0; - } - else - locus = TREE_TYPE (locus); - } - } - - /* Assign the new data for use. */ - - /* Handle the __gcc_gfc__ format specifics. */ - if (!gfc_fci) - dynamic_format_types[gcc_gfc_format_type].conversion_specs = - gfc_fci = (format_char_info *) - xmemdup (gcc_gfc_char_table, - sizeof (gcc_gfc_char_table), - sizeof (gcc_gfc_char_table)); - if (locus) - { - const unsigned i = find_char_info_specifier_index (gfc_fci, 'L'); - gfc_fci[i].types[0].type = &locus; - gfc_fci[i].pointer_count = 1; - } - } -} - -/* Determine the types of "tree" and "location_t" in the code being - compiled for use in GCC's diagnostic custom format attributes. You - must have set dynamic_format_types before calling this function. */ -static void -init_dynamic_diag_info (void) -{ - static tree t, loc, hwi; - - if (!loc || !t || !hwi) - { - static format_char_info *diag_fci, *tdiag_fci, *cdiag_fci, *cxxdiag_fci; - static format_length_info *diag_ls; - unsigned int i; - - /* For the GCC-diagnostics custom format specifiers to work, one - must have declared 'tree' and/or 'location_t' prior to using - those attributes. If we haven't seen these declarations then - you shouldn't use the specifiers requiring these types. - However we don't force a hard ICE because we may see only one - or the other type. */ - if ((loc = maybe_get_identifier ("location_t"))) - { - loc = identifier_global_value (loc); - if (loc) - { - if (TREE_CODE (loc) != TYPE_DECL) - { - error ("% is not defined as a type"); - loc = 0; - } - else - loc = TREE_TYPE (loc); - } - } - - /* We need to grab the underlying 'union tree_node' so peek into - an extra type level. */ - if ((t = maybe_get_identifier ("tree"))) - { - t = identifier_global_value (t); - if (t) - { - if (TREE_CODE (t) != TYPE_DECL) - { - error ("% is not defined as a type"); - t = 0; - } - else if (TREE_CODE (TREE_TYPE (t)) != POINTER_TYPE) - { - error ("% is not defined as a pointer type"); - t = 0; - } - else - t = TREE_TYPE (TREE_TYPE (t)); - } - } - - /* Find the underlying type for HOST_WIDE_INT. For the %w - length modifier to work, one must have issued: "typedef - HOST_WIDE_INT __gcc_host_wide_int__;" in one's source code - prior to using that modifier. */ - if ((hwi = maybe_get_identifier ("__gcc_host_wide_int__"))) - { - hwi = identifier_global_value (hwi); - if (hwi) - { - if (TREE_CODE (hwi) != TYPE_DECL) - { - error ("%<__gcc_host_wide_int__%> is not defined as a type"); - hwi = 0; - } - else - { - hwi = DECL_ORIGINAL_TYPE (hwi); - gcc_assert (hwi); - if (hwi != long_integer_type_node - && hwi != long_long_integer_type_node) - { - error ("%<__gcc_host_wide_int__%> is not defined" - " as % or %"); - hwi = 0; - } - } - } - } - - /* Assign the new data for use. */ - - /* All the GCC diag formats use the same length specs. */ - if (!diag_ls) - dynamic_format_types[gcc_diag_format_type].length_char_specs = - dynamic_format_types[gcc_tdiag_format_type].length_char_specs = - dynamic_format_types[gcc_cdiag_format_type].length_char_specs = - dynamic_format_types[gcc_cxxdiag_format_type].length_char_specs = - diag_ls = (format_length_info *) - xmemdup (gcc_diag_length_specs, - sizeof (gcc_diag_length_specs), - sizeof (gcc_diag_length_specs)); - if (hwi) - { - /* HOST_WIDE_INT must be one of 'long' or 'long long'. */ - i = find_length_info_modifier_index (diag_ls, 'w'); - if (hwi == long_integer_type_node) - diag_ls[i].index = FMT_LEN_l; - else if (hwi == long_long_integer_type_node) - diag_ls[i].index = FMT_LEN_ll; - else - gcc_unreachable (); - } - - /* Handle the __gcc_diag__ format specifics. */ - if (!diag_fci) - dynamic_format_types[gcc_diag_format_type].conversion_specs = - diag_fci = (format_char_info *) - xmemdup (gcc_diag_char_table, - sizeof (gcc_diag_char_table), - sizeof (gcc_diag_char_table)); - if (t) - { - i = find_char_info_specifier_index (diag_fci, 'K'); - diag_fci[i].types[0].type = &t; - diag_fci[i].pointer_count = 1; - } - - /* Handle the __gcc_tdiag__ format specifics. */ - if (!tdiag_fci) - dynamic_format_types[gcc_tdiag_format_type].conversion_specs = - tdiag_fci = (format_char_info *) - xmemdup (gcc_tdiag_char_table, - sizeof (gcc_tdiag_char_table), - sizeof (gcc_tdiag_char_table)); - if (t) - { - /* All specifiers taking a tree share the same struct. */ - i = find_char_info_specifier_index (tdiag_fci, 'D'); - tdiag_fci[i].types[0].type = &t; - tdiag_fci[i].pointer_count = 1; - i = find_char_info_specifier_index (tdiag_fci, 'K'); - tdiag_fci[i].types[0].type = &t; - tdiag_fci[i].pointer_count = 1; - } - - /* Handle the __gcc_cdiag__ format specifics. */ - if (!cdiag_fci) - dynamic_format_types[gcc_cdiag_format_type].conversion_specs = - cdiag_fci = (format_char_info *) - xmemdup (gcc_cdiag_char_table, - sizeof (gcc_cdiag_char_table), - sizeof (gcc_cdiag_char_table)); - if (t) - { - /* All specifiers taking a tree share the same struct. */ - i = find_char_info_specifier_index (cdiag_fci, 'D'); - cdiag_fci[i].types[0].type = &t; - cdiag_fci[i].pointer_count = 1; - i = find_char_info_specifier_index (cdiag_fci, 'K'); - cdiag_fci[i].types[0].type = &t; - cdiag_fci[i].pointer_count = 1; - } - - /* Handle the __gcc_cxxdiag__ format specifics. */ - if (!cxxdiag_fci) - dynamic_format_types[gcc_cxxdiag_format_type].conversion_specs = - cxxdiag_fci = (format_char_info *) - xmemdup (gcc_cxxdiag_char_table, - sizeof (gcc_cxxdiag_char_table), - sizeof (gcc_cxxdiag_char_table)); - if (t) - { - /* All specifiers taking a tree share the same struct. */ - i = find_char_info_specifier_index (cxxdiag_fci, 'D'); - cxxdiag_fci[i].types[0].type = &t; - cxxdiag_fci[i].pointer_count = 1; - i = find_char_info_specifier_index (cxxdiag_fci, 'K'); - cxxdiag_fci[i].types[0].type = &t; - cxxdiag_fci[i].pointer_count = 1; - } - } -} - -#ifdef TARGET_FORMAT_TYPES -extern const format_kind_info TARGET_FORMAT_TYPES[]; -#endif - -#ifdef TARGET_OVERRIDES_FORMAT_ATTRIBUTES -extern const target_ovr_attr TARGET_OVERRIDES_FORMAT_ATTRIBUTES[]; -#endif -#ifdef TARGET_OVERRIDES_FORMAT_INIT - extern void TARGET_OVERRIDES_FORMAT_INIT (void); -#endif - -/* Attributes such as "printf" are equivalent to those such as - "gnu_printf" unless this is overridden by a target. */ -static const target_ovr_attr gnu_target_overrides_format_attributes[] = -{ - { "gnu_printf", "printf" }, - { "gnu_scanf", "scanf" }, - { "gnu_strftime", "strftime" }, - { "gnu_strfmon", "strfmon" }, - { NULL, NULL } -}; - -/* Translate to unified attribute name. This is used in decode_format_type and - decode_format_attr. In attr_name the user specified argument is passed. It - returns the unified format name from TARGET_OVERRIDES_FORMAT_ATTRIBUTES - or the attr_name passed to this function, if there is no matching entry. */ -static const char * -convert_format_name_to_system_name (const char *attr_name) -{ - int i; - - if (attr_name == NULL || *attr_name == 0 - || strncmp (attr_name, "gcc_", 4) == 0) - return attr_name; -#ifdef TARGET_OVERRIDES_FORMAT_INIT - TARGET_OVERRIDES_FORMAT_INIT (); -#endif - -#ifdef TARGET_OVERRIDES_FORMAT_ATTRIBUTES - /* Check if format attribute is overridden by target. */ - if (TARGET_OVERRIDES_FORMAT_ATTRIBUTES != NULL - && TARGET_OVERRIDES_FORMAT_ATTRIBUTES_COUNT > 0) - { - for (i = 0; i < TARGET_OVERRIDES_FORMAT_ATTRIBUTES_COUNT; ++i) - { - if (cmp_attribs (TARGET_OVERRIDES_FORMAT_ATTRIBUTES[i].named_attr_src, - attr_name)) - return attr_name; - if (cmp_attribs (TARGET_OVERRIDES_FORMAT_ATTRIBUTES[i].named_attr_dst, - attr_name)) - return TARGET_OVERRIDES_FORMAT_ATTRIBUTES[i].named_attr_src; - } - } -#endif - /* Otherwise default to gnu format. */ - for (i = 0; - gnu_target_overrides_format_attributes[i].named_attr_src != NULL; - ++i) - { - if (cmp_attribs (gnu_target_overrides_format_attributes[i].named_attr_src, - attr_name)) - return attr_name; - if (cmp_attribs (gnu_target_overrides_format_attributes[i].named_attr_dst, - attr_name)) - return gnu_target_overrides_format_attributes[i].named_attr_src; - } - - return attr_name; -} - -/* Return true if TATTR_NAME and ATTR_NAME are the same format attribute, - counting "name" and "__name__" as the same, false otherwise. */ -static bool -cmp_attribs (const char *tattr_name, const char *attr_name) -{ - int alen = strlen (attr_name); - int slen = (tattr_name ? strlen (tattr_name) : 0); - if (alen > 4 && attr_name[0] == '_' && attr_name[1] == '_' - && attr_name[alen - 1] == '_' && attr_name[alen - 2] == '_') - { - attr_name += 2; - alen -= 4; - } - if (alen != slen || strncmp (tattr_name, attr_name, alen) != 0) - return false; - return true; -} - -/* Handle a "format" attribute; arguments as in - struct attribute_spec.handler. */ -tree -handle_format_attribute (tree *node, tree ARG_UNUSED (name), tree args, - int flags, bool *no_add_attrs) -{ - tree type = *node; - function_format_info info; - tree argument; - -#ifdef TARGET_FORMAT_TYPES - /* If the target provides additional format types, we need to - add them to FORMAT_TYPES at first use. */ - if (TARGET_FORMAT_TYPES != NULL && !dynamic_format_types) - { - dynamic_format_types = XNEWVEC (format_kind_info, - n_format_types + TARGET_N_FORMAT_TYPES); - memcpy (dynamic_format_types, format_types_orig, - sizeof (format_types_orig)); - memcpy (&dynamic_format_types[n_format_types], TARGET_FORMAT_TYPES, - TARGET_N_FORMAT_TYPES * sizeof (dynamic_format_types[0])); - - format_types = dynamic_format_types; - n_format_types += TARGET_N_FORMAT_TYPES; - } -#endif - - if (!decode_format_attr (args, &info, 0)) - { - *no_add_attrs = true; - return NULL_TREE; - } - - argument = TYPE_ARG_TYPES (type); - if (argument) - { - if (!check_format_string (argument, info.format_num, flags, - no_add_attrs)) - return NULL_TREE; - - if (info.first_arg_num != 0) - { - unsigned HOST_WIDE_INT arg_num = 1; - - /* Verify that first_arg_num points to the last arg, - the ... */ - while (argument) - arg_num++, argument = TREE_CHAIN (argument); - - if (arg_num != info.first_arg_num) - { - if (!(flags & (int) ATTR_FLAG_BUILT_IN)) - error ("args to be formatted is not %<...%>"); - *no_add_attrs = true; - return NULL_TREE; - } - } - } - - /* Check if this is a strftime variant. Just for this variant - FMT_FLAG_ARG_CONVERT is not set. */ - if ((format_types[info.format_type].flags & (int) FMT_FLAG_ARG_CONVERT) == 0 - && info.first_arg_num != 0) - { - error ("strftime formats cannot format arguments"); - *no_add_attrs = true; - return NULL_TREE; - } - - /* If this is a custom GCC-internal format type, we have to - initialize certain bits at runtime. */ - if (info.format_type == asm_fprintf_format_type - || info.format_type == gcc_gfc_format_type - || info.format_type == gcc_diag_format_type - || info.format_type == gcc_tdiag_format_type - || info.format_type == gcc_cdiag_format_type - || info.format_type == gcc_cxxdiag_format_type) - { - /* Our first time through, we have to make sure that our - format_type data is allocated dynamically and is modifiable. */ - if (!dynamic_format_types) - format_types = dynamic_format_types = (format_kind_info *) - xmemdup (format_types_orig, sizeof (format_types_orig), - sizeof (format_types_orig)); - - /* If this is format __asm_fprintf__, we have to initialize - GCC's notion of HOST_WIDE_INT for checking %wd. */ - if (info.format_type == asm_fprintf_format_type) - init_dynamic_asm_fprintf_info (); - /* If this is format __gcc_gfc__, we have to initialize GCC's - notion of 'locus' at runtime for %L. */ - else if (info.format_type == gcc_gfc_format_type) - init_dynamic_gfc_info (); - /* If this is one of the diagnostic attributes, then we have to - initialize 'location_t' and 'tree' at runtime. */ - else if (info.format_type == gcc_diag_format_type - || info.format_type == gcc_tdiag_format_type - || info.format_type == gcc_cdiag_format_type - || info.format_type == gcc_cxxdiag_format_type) - init_dynamic_diag_info (); - else - gcc_unreachable (); - } - - return NULL_TREE; -} diff --git a/gcc/c-format.h b/gcc/c-format.h deleted file mode 100644 index 9d01f0af495..00000000000 --- a/gcc/c-format.h +++ /dev/null @@ -1,326 +0,0 @@ -/* Check calls to formatted I/O functions (-Wformat). - Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, - 2001, 2002, 2003, 2004, 2007, 2008 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 3, 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 COPYING3. If not see -. */ - -#ifndef GCC_C_FORMAT_H -#define GCC_C_FORMAT_H - -/* The meaningfully distinct length modifiers for format checking recognized - by GCC. */ -enum format_lengths -{ - FMT_LEN_none, - FMT_LEN_hh, - FMT_LEN_h, - FMT_LEN_l, - FMT_LEN_ll, - FMT_LEN_L, - FMT_LEN_z, - FMT_LEN_t, - FMT_LEN_j, - FMT_LEN_H, - FMT_LEN_D, - FMT_LEN_DD, - FMT_LEN_MAX -}; - - -/* The standard versions in which various format features appeared. */ -enum format_std_version -{ - STD_C89, - STD_C94, - STD_C9L, /* C99, but treat as C89 if -Wno-long-long. */ - STD_C99, - STD_EXT -}; - -/* Flags that may apply to a particular kind of format checked by GCC. */ -enum -{ - /* This format converts arguments of types determined by the - format string. */ - FMT_FLAG_ARG_CONVERT = 1, - /* The scanf allocation 'a' kludge applies to this format kind. */ - FMT_FLAG_SCANF_A_KLUDGE = 2, - /* A % during parsing a specifier is allowed to be a modified % rather - that indicating the format is broken and we are out-of-sync. */ - FMT_FLAG_FANCY_PERCENT_OK = 4, - /* With $ operand numbers, it is OK to reference the same argument more - than once. */ - FMT_FLAG_DOLLAR_MULTIPLE = 8, - /* This format type uses $ operand numbers (strfmon doesn't). */ - FMT_FLAG_USE_DOLLAR = 16, - /* Zero width is bad in this type of format (scanf). */ - FMT_FLAG_ZERO_WIDTH_BAD = 32, - /* Empty precision specification is OK in this type of format (printf). */ - FMT_FLAG_EMPTY_PREC_OK = 64, - /* Gaps are allowed in the arguments with $ operand numbers if all - arguments are pointers (scanf). */ - FMT_FLAG_DOLLAR_GAP_POINTER_OK = 128 - /* Not included here: details of whether width or precision may occur - (controlled by width_char and precision_char); details of whether - '*' can be used for these (width_type and precision_type); details - of whether length modifiers can occur (length_char_specs). */ -}; - -/* Structure describing a length modifier supported in format checking, and - possibly a doubled version such as "hh". */ -typedef struct -{ - /* Name of the single-character length modifier. If prefixed by - a zero character, it describes a multi character length - modifier, like I64, I32, etc. */ - const char *name; - /* Index into a format_char_info.types array. */ - enum format_lengths index; - /* Standard version this length appears in. */ - enum format_std_version std; - /* Same, if the modifier can be repeated, or NULL if it can't. */ - const char *double_name; - enum format_lengths double_index; - enum format_std_version double_std; - - /* If this flag is set, just scalar width identity is checked, and - not the type identity itself. */ - int scalar_identity_flag; -} format_length_info; - - -/* Structure describing the combination of a conversion specifier - (or a set of specifiers which act identically) and a length modifier. */ -typedef struct -{ - /* The standard version this combination of length and type appeared in. - This is only relevant if greater than those for length and type - individually; otherwise it is ignored. */ - enum format_std_version std; - /* The name to use for the type, if different from that generated internally - (e.g., "signed size_t"). */ - const char *name; - /* The type itself. */ - tree *type; -} format_type_detail; - - -/* Macros to fill out tables of these. */ -#define NOARGUMENTS { T89_V, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN } -#define BADLEN { STD_C89, NULL, NULL } -#define NOLENGTHS { BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN, BADLEN } - - -/* Structure describing a format conversion specifier (or a set of specifiers - which act identically), and the length modifiers used with it. */ -typedef struct format_char_info -{ - const char *format_chars; - int pointer_count; - enum format_std_version std; - /* Types accepted for each length modifier. */ - format_type_detail types[FMT_LEN_MAX]; - /* List of other modifier characters allowed with these specifiers. - This lists flags, and additionally "w" for width, "p" for precision - (right precision, for strfmon), "#" for left precision (strfmon), - "a" for scanf "a" allocation extension (not applicable in C99 mode), - "*" for scanf suppression, and "E" and "O" for those strftime - modifiers. */ - const char *flag_chars; - /* List of additional flags describing these conversion specifiers. - "c" for generic character pointers being allowed, "2" for strftime - two digit year formats, "3" for strftime formats giving two digit - years in some locales, "4" for "2" which becomes "3" with an "E" modifier, - "o" if use of strftime "O" is a GNU extension beyond C99, - "W" if the argument is a pointer which is dereferenced and written into, - "R" if the argument is a pointer which is dereferenced and read from, - "i" for printf integer formats where the '0' flag is ignored with - precision, and "[" for the starting character of a scanf scanset. */ - const char *flags2; - /* If this format conversion character consumes more than one argument, - CHAIN points to information about the next argument. For later - arguments, only POINTER_COUNT, TYPES, and the "c", "R", and "W" flags - in FLAGS2 are used. */ - const struct format_char_info *chain; -} format_char_info; - - -/* Structure describing a flag accepted by some kind of format. */ -typedef struct -{ - /* The flag character in question (0 for end of array). */ - int flag_char; - /* Zero if this entry describes the flag character in general, or a - nonzero character that may be found in flags2 if it describes the - flag when used with certain formats only. If the latter, only - the first such entry found that applies to the current conversion - specifier is used; the values of 'name' and 'long_name' it supplies - will be used, if non-NULL and the standard version is higher than - the unpredicated one, for any pedantic warning. For example, 'o' - for strftime formats (meaning 'O' is an extension over C99). */ - int predicate; - /* Nonzero if the next character after this flag in the format should - be skipped ('=' in strfmon), zero otherwise. */ - int skip_next_char; - /* The name to use for this flag in diagnostic messages. For example, - N_("'0' flag"), N_("field width"). */ - const char *name; - /* Long name for this flag in diagnostic messages; currently only used for - "ISO C does not support ...". For example, N_("the 'I' printf flag"). */ - const char *long_name; - /* The standard version in which it appeared. */ - enum format_std_version std; -} format_flag_spec; - - -/* Structure describing a combination of flags that is bad for some kind - of format. */ -typedef struct -{ - /* The first flag character in question (0 for end of array). */ - int flag_char1; - /* The second flag character. */ - int flag_char2; - /* Nonzero if the message should say that the first flag is ignored with - the second, zero if the combination should simply be objected to. */ - int ignored; - /* Zero if this entry applies whenever this flag combination occurs, - a nonzero character from flags2 if it only applies in some - circumstances (e.g. 'i' for printf formats ignoring 0 with precision). */ - int predicate; -} format_flag_pair; - - -/* Structure describing a particular kind of format processed by GCC. */ -typedef struct -{ - /* The name of this kind of format, for use in diagnostics. Also - the name of the attribute (without preceding and following __). */ - const char *name; - /* Specifications of the length modifiers accepted; possibly NULL. */ - const format_length_info *length_char_specs; - /* Details of the conversion specification characters accepted. */ - const format_char_info *conversion_specs; - /* String listing the flag characters that are accepted. */ - const char *flag_chars; - /* String listing modifier characters (strftime) accepted. May be NULL. */ - const char *modifier_chars; - /* Details of the flag characters, including pseudo-flags. */ - const format_flag_spec *flag_specs; - /* Details of bad combinations of flags. */ - const format_flag_pair *bad_flag_pairs; - /* Flags applicable to this kind of format. */ - int flags; - /* Flag character to treat a width as, or 0 if width not used. */ - int width_char; - /* Flag character to treat a left precision (strfmon) as, - or 0 if left precision not used. */ - int left_precision_char; - /* Flag character to treat a precision (for strfmon, right precision) as, - or 0 if precision not used. */ - int precision_char; - /* If a flag character has the effect of suppressing the conversion of - an argument ('*' in scanf), that flag character, otherwise 0. */ - int suppression_char; - /* Flag character to treat a length modifier as (ignored if length - modifiers not used). Need not be placed in flag_chars for conversion - specifiers, but is used to check for bad combinations such as length - modifier with assignment suppression in scanf. */ - int length_code_char; - /* Assignment-allocation flag character ('m' in scanf), otherwise 0. */ - int alloc_char; - /* Pointer to type of argument expected if '*' is used for a width, - or NULL if '*' not used for widths. */ - tree *width_type; - /* Pointer to type of argument expected if '*' is used for a precision, - or NULL if '*' not used for precisions. */ - tree *precision_type; -} format_kind_info; - -#define T_I &integer_type_node -#define T89_I { STD_C89, NULL, T_I } -#define T_L &long_integer_type_node -#define T89_L { STD_C89, NULL, T_L } -#define T_LL &long_long_integer_type_node -#define T9L_LL { STD_C9L, NULL, T_LL } -#define TEX_LL { STD_EXT, NULL, T_LL } -#define T_S &short_integer_type_node -#define T89_S { STD_C89, NULL, T_S } -#define T_UI &unsigned_type_node -#define T89_UI { STD_C89, NULL, T_UI } -#define T_UL &long_unsigned_type_node -#define T89_UL { STD_C89, NULL, T_UL } -#define T_ULL &long_long_unsigned_type_node -#define T9L_ULL { STD_C9L, NULL, T_ULL } -#define TEX_ULL { STD_EXT, NULL, T_ULL } -#define T_US &short_unsigned_type_node -#define T89_US { STD_C89, NULL, T_US } -#define T_F &float_type_node -#define T89_F { STD_C89, NULL, T_F } -#define T99_F { STD_C99, NULL, T_F } -#define T_D &double_type_node -#define T89_D { STD_C89, NULL, T_D } -#define T99_D { STD_C99, NULL, T_D } -#define T_LD &long_double_type_node -#define T89_LD { STD_C89, NULL, T_LD } -#define T99_LD { STD_C99, NULL, T_LD } -#define T_C &char_type_node -#define T89_C { STD_C89, NULL, T_C } -#define T_SC &signed_char_type_node -#define T99_SC { STD_C99, NULL, T_SC } -#define T_UC &unsigned_char_type_node -#define T99_UC { STD_C99, NULL, T_UC } -#define T_V &void_type_node -#define T89_V { STD_C89, NULL, T_V } -#define T_W &wchar_type_node -#define T94_W { STD_C94, "wchar_t", T_W } -#define TEX_W { STD_EXT, "wchar_t", T_W } -#define T_WI &wint_type_node -#define T94_WI { STD_C94, "wint_t", T_WI } -#define TEX_WI { STD_EXT, "wint_t", T_WI } -#define T_ST &size_type_node -#define T99_ST { STD_C99, "size_t", T_ST } -#define T_SST &signed_size_type_node -#define T99_SST { STD_C99, "signed size_t", T_SST } -#define T_PD &ptrdiff_type_node -#define T99_PD { STD_C99, "ptrdiff_t", T_PD } -#define T_UPD &unsigned_ptrdiff_type_node -#define T99_UPD { STD_C99, "unsigned ptrdiff_t", T_UPD } -#define T_IM &intmax_type_node -#define T99_IM { STD_C99, "intmax_t", T_IM } -#define T_UIM &uintmax_type_node -#define T99_UIM { STD_C99, "uintmax_t", T_UIM } -#define T_D32 &dfloat32_type_node -#define TEX_D32 { STD_EXT, "_Decimal32", T_D32 } -#define T_D64 &dfloat64_type_node -#define TEX_D64 { STD_EXT, "_Decimal64", T_D64 } -#define T_D128 &dfloat128_type_node -#define TEX_D128 { STD_EXT, "_Decimal128", T_D128 } - -/* Structure describing how format attributes such as "printf" are - interpreted as "gnu_printf" or "ms_printf" on a particular system. - TARGET_OVERRIDES_FORMAT_ATTRIBUTES is used to specify target-specific - defaults. */ -typedef struct -{ - /* The name of the to be copied format attribute. */ - const char *named_attr_src; - /* The name of the to be overridden format attribute. */ - const char *named_attr_dst; -} target_ovr_attr; - -#endif /* GCC_C_FORMAT_H */ diff --git a/gcc/c-gimplify.c b/gcc/c-gimplify.c deleted file mode 100644 index 06963a05e71..00000000000 --- a/gcc/c-gimplify.c +++ /dev/null @@ -1,190 +0,0 @@ -/* Tree lowering pass. This pass gimplifies the tree representation built - by the C-based front ends. The structure of gimplified, or - language-independent, trees is dictated by the grammar described in this - file. - Copyright (C) 2002, 2003, 2004, 2005, 2007, 2008, 2009, 2010 - Free Software Foundation, Inc. - Lowering of expressions contributed by Sebastian Pop - Re-written to support lowering of whole function trees, documentation - and miscellaneous cleanups by Diego Novillo - -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 3, 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 COPYING3. If not see -. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "tm.h" -#include "tree.h" -#include "c-common.h" -#include "gimple.h" -#include "basic-block.h" -#include "tree-flow.h" -#include "tree-inline.h" -#include "diagnostic-core.h" -#include "langhooks.h" -#include "langhooks-def.h" -#include "flags.h" -#include "toplev.h" -#include "tree-dump.h" -#include "c-pretty-print.h" -#include "cgraph.h" - - -/* The gimplification pass converts the language-dependent trees - (ld-trees) emitted by the parser into language-independent trees - (li-trees) that are the target of SSA analysis and transformations. - - Language-independent trees are based on the SIMPLE intermediate - representation used in the McCAT compiler framework: - - "Designing the McCAT Compiler Based on a Family of Structured - Intermediate Representations," - L. Hendren, C. Donawa, M. Emami, G. Gao, Justiani, and B. Sridharan, - Proceedings of the 5th International Workshop on Languages and - Compilers for Parallel Computing, no. 757 in Lecture Notes in - Computer Science, New Haven, Connecticut, pp. 406-420, - Springer-Verlag, August 3-5, 1992. - - http://www-acaps.cs.mcgill.ca/info/McCAT/McCAT.html - - Basically, we walk down gimplifying the nodes that we encounter. As we - walk back up, we check that they fit our constraints, and copy them - into temporaries if not. */ - -/* Gimplification of statement trees. */ - -/* Convert the tree representation of FNDECL from C frontend trees to - GENERIC. */ - -void -c_genericize (tree fndecl) -{ - FILE *dump_orig; - int local_dump_flags; - struct cgraph_node *cgn; - - /* Dump the C-specific tree IR. */ - dump_orig = dump_begin (TDI_original, &local_dump_flags); - if (dump_orig) - { - fprintf (dump_orig, "\n;; Function %s", - lang_hooks.decl_printable_name (fndecl, 2)); - fprintf (dump_orig, " (%s)\n", - (!DECL_ASSEMBLER_NAME_SET_P (fndecl) ? "null" - : IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (fndecl)))); - fprintf (dump_orig, ";; enabled by -%s\n", dump_flag_name (TDI_original)); - fprintf (dump_orig, "\n"); - - if (local_dump_flags & TDF_RAW) - dump_node (DECL_SAVED_TREE (fndecl), - TDF_SLIM | local_dump_flags, dump_orig); - else - print_c_tree (dump_orig, DECL_SAVED_TREE (fndecl)); - fprintf (dump_orig, "\n"); - - dump_end (TDI_original, dump_orig); - } - - /* Dump all nested functions now. */ - cgn = cgraph_node (fndecl); - for (cgn = cgn->nested; cgn ; cgn = cgn->next_nested) - c_genericize (cgn->decl); -} - -static void -add_block_to_enclosing (tree block) -{ - unsigned i; - tree enclosing; - gimple bind; - VEC(gimple, heap) *stack = gimple_bind_expr_stack (); - - for (i = 0; VEC_iterate (gimple, stack, i, bind); i++) - if (gimple_bind_block (bind)) - break; - - enclosing = gimple_bind_block (bind); - BLOCK_SUBBLOCKS (enclosing) = chainon (BLOCK_SUBBLOCKS (enclosing), block); -} - -/* Genericize a scope by creating a new BIND_EXPR. - BLOCK is either a BLOCK representing the scope or a chain of _DECLs. - In the latter case, we need to create a new BLOCK and add it to the - BLOCK_SUBBLOCKS of the enclosing block. - BODY is a chain of C _STMT nodes for the contents of the scope, to be - genericized. */ - -tree -c_build_bind_expr (location_t loc, tree block, tree body) -{ - tree decls, bind; - - if (block == NULL_TREE) - decls = NULL_TREE; - else if (TREE_CODE (block) == BLOCK) - decls = BLOCK_VARS (block); - else - { - decls = block; - if (DECL_ARTIFICIAL (decls)) - block = NULL_TREE; - else - { - block = make_node (BLOCK); - BLOCK_VARS (block) = decls; - add_block_to_enclosing (block); - } - } - - if (!body) - body = build_empty_stmt (loc); - if (decls || block) - { - bind = build3 (BIND_EXPR, void_type_node, decls, body, block); - TREE_SIDE_EFFECTS (bind) = 1; - SET_EXPR_LOCATION (bind, loc); - } - else - bind = body; - - return bind; -} - -/* Gimplification of expression trees. */ - -/* Do C-specific gimplification on *EXPR_P. PRE_P and POST_P are as in - gimplify_expr. */ - -int -c_gimplify_expr (tree *expr_p, gimple_seq *pre_p ATTRIBUTE_UNUSED, - gimple_seq *post_p ATTRIBUTE_UNUSED) -{ - enum tree_code code = TREE_CODE (*expr_p); - - /* This is handled mostly by gimplify.c, but we have to deal with - not warning about int x = x; as it is a GCC extension to turn off - this warning but only if warn_init_self is zero. */ - if (code == DECL_EXPR - && TREE_CODE (DECL_EXPR_DECL (*expr_p)) == VAR_DECL - && !DECL_EXTERNAL (DECL_EXPR_DECL (*expr_p)) - && !TREE_STATIC (DECL_EXPR_DECL (*expr_p)) - && (DECL_INITIAL (DECL_EXPR_DECL (*expr_p)) == DECL_EXPR_DECL (*expr_p)) - && !warn_init_self) - TREE_NO_WARNING (DECL_EXPR_DECL (*expr_p)) = 1; - - return GS_UNHANDLED; -} diff --git a/gcc/c-lang.c b/gcc/c-lang.c index 14d4eacf366..45a764f20e2 100644 --- a/gcc/c-lang.c +++ b/gcc/c-lang.c @@ -26,13 +26,13 @@ along with GCC; see the file COPYING3. If not see #include "tm.h" #include "tree.h" #include "c-tree.h" -#include "c-common.h" +#include "c-family/c-common.h" #include "langhooks.h" #include "langhooks-def.h" #include "tree-inline.h" #include "diagnostic-core.h" #include "c-objc-common.h" -#include "c-pragma.h" +#include "c-family/c-pragma.h" enum c_language_kind c_language = clk_c; diff --git a/gcc/c-lang.h b/gcc/c-lang.h index beed5071c66..c0bdc7cb9e5 100644 --- a/gcc/c-lang.h +++ b/gcc/c-lang.h @@ -21,7 +21,7 @@ along with GCC; see the file COPYING3. If not see #ifndef GCC_C_LANG_H #define GCC_C_LANG_H -#include "c-common.h" +#include "c-family/c-common.h" #include "ggc.h" struct GTY(()) lang_type { diff --git a/gcc/c-lex.c b/gcc/c-lex.c deleted file mode 100644 index 5af574db226..00000000000 --- a/gcc/c-lex.c +++ /dev/null @@ -1,1058 +0,0 @@ -/* Mainly the interface between cpplib and the C front ends. - Copyright (C) 1987, 1988, 1989, 1992, 1994, 1995, 1996, 1997 - 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009, 2010 - 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 3, 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 COPYING3. If not see -. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "tm.h" - -#include "tree.h" -#include "input.h" -#include "output.h" -#include "c-common.h" -#include "flags.h" -#include "timevar.h" -#include "cpplib.h" -#include "c-pragma.h" -#include "toplev.h" -#include "intl.h" -#include "splay-tree.h" -#include "debug.h" -#include "target.h" - -/* We may keep statistics about how long which files took to compile. */ -static int header_time, body_time; -static splay_tree file_info_tree; - -int pending_lang_change; /* If we need to switch languages - C++ only */ -int c_header_level; /* depth in C headers - C++ only */ - -static tree interpret_integer (const cpp_token *, unsigned int); -static tree interpret_float (const cpp_token *, unsigned int); -static tree interpret_fixed (const cpp_token *, unsigned int); -static enum integer_type_kind narrowest_unsigned_type - (unsigned HOST_WIDE_INT, unsigned HOST_WIDE_INT, unsigned int); -static enum integer_type_kind narrowest_signed_type - (unsigned HOST_WIDE_INT, unsigned HOST_WIDE_INT, unsigned int); -static enum cpp_ttype lex_string (const cpp_token *, tree *, bool, bool); -static tree lex_charconst (const cpp_token *); -static void update_header_times (const char *); -static int dump_one_header (splay_tree_node, void *); -static void cb_line_change (cpp_reader *, const cpp_token *, int); -static void cb_ident (cpp_reader *, unsigned int, const cpp_string *); -static void cb_def_pragma (cpp_reader *, unsigned int); -static void cb_define (cpp_reader *, unsigned int, cpp_hashnode *); -static void cb_undef (cpp_reader *, unsigned int, cpp_hashnode *); - -void -init_c_lex (void) -{ - struct cpp_callbacks *cb; - struct c_fileinfo *toplevel; - - /* The get_fileinfo data structure must be initialized before - cpp_read_main_file is called. */ - toplevel = get_fileinfo (""); - if (flag_detailed_statistics) - { - header_time = 0; - body_time = get_run_time (); - toplevel->time = body_time; - } - - cb = cpp_get_callbacks (parse_in); - - cb->line_change = cb_line_change; - cb->ident = cb_ident; - cb->def_pragma = cb_def_pragma; - cb->valid_pch = c_common_valid_pch; - cb->read_pch = c_common_read_pch; - - /* Set the debug callbacks if we can use them. */ - if (debug_info_level == DINFO_LEVEL_VERBOSE - && (write_symbols == DWARF2_DEBUG - || write_symbols == VMS_AND_DWARF2_DEBUG)) - { - cb->define = cb_define; - cb->undef = cb_undef; - } -} - -struct c_fileinfo * -get_fileinfo (const char *name) -{ - splay_tree_node n; - struct c_fileinfo *fi; - - if (!file_info_tree) - file_info_tree = splay_tree_new ((splay_tree_compare_fn) strcmp, - 0, - (splay_tree_delete_value_fn) free); - - n = splay_tree_lookup (file_info_tree, (splay_tree_key) name); - if (n) - return (struct c_fileinfo *) n->value; - - fi = XNEW (struct c_fileinfo); - fi->time = 0; - fi->interface_only = 0; - fi->interface_unknown = 1; - splay_tree_insert (file_info_tree, (splay_tree_key) name, - (splay_tree_value) fi); - return fi; -} - -static void -update_header_times (const char *name) -{ - /* Changing files again. This means currently collected time - is charged against header time, and body time starts back at 0. */ - if (flag_detailed_statistics) - { - int this_time = get_run_time (); - struct c_fileinfo *file = get_fileinfo (name); - header_time += this_time - body_time; - file->time += this_time - body_time; - body_time = this_time; - } -} - -static int -dump_one_header (splay_tree_node n, void * ARG_UNUSED (dummy)) -{ - print_time ((const char *) n->key, - ((struct c_fileinfo *) n->value)->time); - return 0; -} - -void -dump_time_statistics (void) -{ - struct c_fileinfo *file = get_fileinfo (input_filename); - int this_time = get_run_time (); - file->time += this_time - body_time; - - fprintf (stderr, "\n******\n"); - print_time ("header files (total)", header_time); - print_time ("main file (total)", this_time - body_time); - fprintf (stderr, "ratio = %g : 1\n", - (double) header_time / (double) (this_time - body_time)); - fprintf (stderr, "\n******\n"); - - splay_tree_foreach (file_info_tree, dump_one_header, 0); -} - -static void -cb_ident (cpp_reader * ARG_UNUSED (pfile), - unsigned int ARG_UNUSED (line), - const cpp_string * ARG_UNUSED (str)) -{ -#ifdef ASM_OUTPUT_IDENT - if (!flag_no_ident) - { - /* Convert escapes in the string. */ - cpp_string cstr = { 0, 0 }; - if (cpp_interpret_string (pfile, str, 1, &cstr, CPP_STRING)) - { - ASM_OUTPUT_IDENT (asm_out_file, (const char *) cstr.text); - free (CONST_CAST (unsigned char *, cstr.text)); - } - } -#endif -} - -/* Called at the start of every non-empty line. TOKEN is the first - lexed token on the line. Used for diagnostic line numbers. */ -static void -cb_line_change (cpp_reader * ARG_UNUSED (pfile), const cpp_token *token, - int parsing_args) -{ - if (token->type != CPP_EOF && !parsing_args) - input_location = token->src_loc; -} - -void -fe_file_change (const struct line_map *new_map) -{ - if (new_map == NULL) - return; - - if (new_map->reason == LC_ENTER) - { - /* Don't stack the main buffer on the input stack; - we already did in compile_file. */ - if (!MAIN_FILE_P (new_map)) - { - unsigned int included_at = LAST_SOURCE_LINE_LOCATION (new_map - 1); - int line = 0; - if (included_at > BUILTINS_LOCATION) - line = SOURCE_LINE (new_map - 1, included_at); - - input_location = new_map->start_location; - (*debug_hooks->start_source_file) (line, new_map->to_file); -#ifndef NO_IMPLICIT_EXTERN_C - if (c_header_level) - ++c_header_level; - else if (new_map->sysp == 2) - { - c_header_level = 1; - ++pending_lang_change; - } -#endif - } - } - else if (new_map->reason == LC_LEAVE) - { -#ifndef NO_IMPLICIT_EXTERN_C - if (c_header_level && --c_header_level == 0) - { - if (new_map->sysp == 2) - warning (0, "badly nested C headers from preprocessor"); - --pending_lang_change; - } -#endif - input_location = new_map->start_location; - - (*debug_hooks->end_source_file) (new_map->to_line); - } - - update_header_times (new_map->to_file); - input_location = new_map->start_location; -} - -static void -cb_def_pragma (cpp_reader *pfile, source_location loc) -{ - /* Issue a warning message if we have been asked to do so. Ignore - unknown pragmas in system headers unless an explicit - -Wunknown-pragmas has been given. */ - if (warn_unknown_pragmas > in_system_header) - { - const unsigned char *space, *name; - const cpp_token *s; - location_t fe_loc = loc; - - space = name = (const unsigned char *) ""; - s = cpp_get_token (pfile); - if (s->type != CPP_EOF) - { - space = cpp_token_as_text (pfile, s); - s = cpp_get_token (pfile); - if (s->type == CPP_NAME) - name = cpp_token_as_text (pfile, s); - } - - warning_at (fe_loc, OPT_Wunknown_pragmas, "ignoring #pragma %s %s", - space, name); - } -} - -/* #define callback for DWARF and DWARF2 debug info. */ -static void -cb_define (cpp_reader *pfile, source_location loc, cpp_hashnode *node) -{ - const struct line_map *map = linemap_lookup (line_table, loc); - (*debug_hooks->define) (SOURCE_LINE (map, loc), - (const char *) cpp_macro_definition (pfile, node)); -} - -/* #undef callback for DWARF and DWARF2 debug info. */ -static void -cb_undef (cpp_reader * ARG_UNUSED (pfile), source_location loc, - cpp_hashnode *node) -{ - const struct line_map *map = linemap_lookup (line_table, loc); - (*debug_hooks->undef) (SOURCE_LINE (map, loc), - (const char *) NODE_NAME (node)); -} - -/* Read a token and return its type. Fill *VALUE with its value, if - applicable. Fill *CPP_FLAGS with the token's flags, if it is - non-NULL. */ - -enum cpp_ttype -c_lex_with_flags (tree *value, location_t *loc, unsigned char *cpp_flags, - int lex_flags) -{ - static bool no_more_pch; - const cpp_token *tok; - enum cpp_ttype type; - unsigned char add_flags = 0; - - timevar_push (TV_CPP); - retry: - tok = cpp_get_token_with_location (parse_in, loc); - type = tok->type; - - retry_after_at: - switch (type) - { - case CPP_PADDING: - goto retry; - - case CPP_NAME: - *value = HT_IDENT_TO_GCC_IDENT (HT_NODE (tok->val.node.node)); - break; - - case CPP_NUMBER: - { - unsigned int flags = cpp_classify_number (parse_in, tok); - - switch (flags & CPP_N_CATEGORY) - { - case CPP_N_INVALID: - /* cpplib has issued an error. */ - *value = error_mark_node; - break; - - case CPP_N_INTEGER: - /* C++ uses '0' to mark virtual functions as pure. - Set PURE_ZERO to pass this information to the C++ parser. */ - if (tok->val.str.len == 1 && *tok->val.str.text == '0') - add_flags = PURE_ZERO; - *value = interpret_integer (tok, flags); - break; - - case CPP_N_FLOATING: - *value = interpret_float (tok, flags); - break; - - default: - gcc_unreachable (); - } - } - break; - - case CPP_ATSIGN: - /* An @ may give the next token special significance in Objective-C. */ - if (c_dialect_objc ()) - { - location_t atloc = *loc; - location_t newloc; - - retry_at: - tok = cpp_get_token_with_location (parse_in, &newloc); - type = tok->type; - switch (type) - { - case CPP_PADDING: - goto retry_at; - - case CPP_STRING: - case CPP_WSTRING: - case CPP_STRING16: - case CPP_STRING32: - case CPP_UTF8STRING: - type = lex_string (tok, value, true, true); - break; - - case CPP_NAME: - *value = HT_IDENT_TO_GCC_IDENT (HT_NODE (tok->val.node.node)); - if (objc_is_reserved_word (*value)) - { - type = CPP_AT_NAME; - break; - } - /* FALLTHROUGH */ - - default: - /* ... or not. */ - error_at (atloc, "stray %<@%> in program"); - *loc = newloc; - goto retry_after_at; - } - break; - } - - /* FALLTHROUGH */ - case CPP_HASH: - case CPP_PASTE: - { - unsigned char name[8]; - - *cpp_spell_token (parse_in, tok, name, true) = 0; - - error ("stray %qs in program", name); - } - - goto retry; - - case CPP_OTHER: - { - cppchar_t c = tok->val.str.text[0]; - - if (c == '"' || c == '\'') - error ("missing terminating %c character", (int) c); - else if (ISGRAPH (c)) - error ("stray %qc in program", (int) c); - else - error ("stray %<\\%o%> in program", (int) c); - } - goto retry; - - case CPP_CHAR: - case CPP_WCHAR: - case CPP_CHAR16: - case CPP_CHAR32: - *value = lex_charconst (tok); - break; - - case CPP_STRING: - case CPP_WSTRING: - case CPP_STRING16: - case CPP_STRING32: - case CPP_UTF8STRING: - if ((lex_flags & C_LEX_STRING_NO_JOIN) == 0) - { - type = lex_string (tok, value, false, - (lex_flags & C_LEX_STRING_NO_TRANSLATE) == 0); - break; - } - *value = build_string (tok->val.str.len, (const char *) tok->val.str.text); - break; - - case CPP_PRAGMA: - *value = build_int_cst (NULL, tok->val.pragma); - break; - - /* These tokens should not be visible outside cpplib. */ - case CPP_HEADER_NAME: - case CPP_MACRO_ARG: - gcc_unreachable (); - - /* CPP_COMMENT will appear when compiling with -C and should be - ignored. */ - case CPP_COMMENT: - goto retry; - - default: - *value = NULL_TREE; - break; - } - - if (cpp_flags) - *cpp_flags = tok->flags | add_flags; - - if (!no_more_pch) - { - no_more_pch = true; - c_common_no_more_pch (); - } - - timevar_pop (TV_CPP); - - return type; -} - -/* Returns the narrowest C-visible unsigned type, starting with the - minimum specified by FLAGS, that can fit HIGH:LOW, or itk_none if - there isn't one. */ - -static enum integer_type_kind -narrowest_unsigned_type (unsigned HOST_WIDE_INT low, - unsigned HOST_WIDE_INT high, - unsigned int flags) -{ - int itk; - - if ((flags & CPP_N_WIDTH) == CPP_N_SMALL) - itk = itk_unsigned_int; - else if ((flags & CPP_N_WIDTH) == CPP_N_MEDIUM) - itk = itk_unsigned_long; - else - itk = itk_unsigned_long_long; - - for (; itk < itk_none; itk += 2 /* skip unsigned types */) - { - tree upper; - - if (integer_types[itk] == NULL_TREE) - continue; - upper = TYPE_MAX_VALUE (integer_types[itk]); - - if ((unsigned HOST_WIDE_INT) TREE_INT_CST_HIGH (upper) > high - || ((unsigned HOST_WIDE_INT) TREE_INT_CST_HIGH (upper) == high - && TREE_INT_CST_LOW (upper) >= low)) - return (enum integer_type_kind) itk; - } - - return itk_none; -} - -/* Ditto, but narrowest signed type. */ -static enum integer_type_kind -narrowest_signed_type (unsigned HOST_WIDE_INT low, - unsigned HOST_WIDE_INT high, unsigned int flags) -{ - int itk; - - if ((flags & CPP_N_WIDTH) == CPP_N_SMALL) - itk = itk_int; - else if ((flags & CPP_N_WIDTH) == CPP_N_MEDIUM) - itk = itk_long; - else - itk = itk_long_long; - - - for (; itk < itk_none; itk += 2 /* skip signed types */) - { - tree upper; - - if (integer_types[itk] == NULL_TREE) - continue; - upper = TYPE_MAX_VALUE (integer_types[itk]); - - if ((unsigned HOST_WIDE_INT) TREE_INT_CST_HIGH (upper) > high - || ((unsigned HOST_WIDE_INT) TREE_INT_CST_HIGH (upper) == high - && TREE_INT_CST_LOW (upper) >= low)) - return (enum integer_type_kind) itk; - } - - return itk_none; -} - -/* Interpret TOKEN, an integer with FLAGS as classified by cpplib. */ -static tree -interpret_integer (const cpp_token *token, unsigned int flags) -{ - tree value, type; - enum integer_type_kind itk; - cpp_num integer; - cpp_options *options = cpp_get_options (parse_in); - - integer = cpp_interpret_integer (parse_in, token, flags); - integer = cpp_num_sign_extend (integer, options->precision); - - /* The type of a constant with a U suffix is straightforward. */ - if (flags & CPP_N_UNSIGNED) - itk = narrowest_unsigned_type (integer.low, integer.high, flags); - else - { - /* The type of a potentially-signed integer constant varies - depending on the base it's in, the standard in use, and the - length suffixes. */ - enum integer_type_kind itk_u - = narrowest_unsigned_type (integer.low, integer.high, flags); - enum integer_type_kind itk_s - = narrowest_signed_type (integer.low, integer.high, flags); - - /* In both C89 and C99, octal and hex constants may be signed or - unsigned, whichever fits tighter. We do not warn about this - choice differing from the traditional choice, as the constant - is probably a bit pattern and either way will work. */ - if ((flags & CPP_N_RADIX) != CPP_N_DECIMAL) - itk = MIN (itk_u, itk_s); - else - { - /* In C99, decimal constants are always signed. - In C89, decimal constants that don't fit in long have - undefined behavior; we try to make them unsigned long. - In GCC's extended C89, that last is true of decimal - constants that don't fit in long long, too. */ - - itk = itk_s; - if (itk_s > itk_u && itk_s > itk_long) - { - if (!flag_isoc99) - { - if (itk_u < itk_unsigned_long) - itk_u = itk_unsigned_long; - itk = itk_u; - warning (0, "this decimal constant is unsigned only in ISO C90"); - } - else - warning (OPT_Wtraditional, - "this decimal constant would be unsigned in ISO C90"); - } - } - } - - if (itk == itk_none) - /* cpplib has already issued a warning for overflow. */ - type = ((flags & CPP_N_UNSIGNED) - ? widest_unsigned_literal_type_node - : widest_integer_literal_type_node); - else - { - type = integer_types[itk]; - if (itk > itk_unsigned_long - && (flags & CPP_N_WIDTH) != CPP_N_LARGE) - emit_diagnostic - ((c_dialect_cxx () ? cxx_dialect == cxx98 : !flag_isoc99) - ? DK_PEDWARN : DK_WARNING, - input_location, OPT_Wlong_long, - (flags & CPP_N_UNSIGNED) - ? "integer constant is too large for % type" - : "integer constant is too large for % type"); - } - - value = build_int_cst_wide (type, integer.low, integer.high); - - /* Convert imaginary to a complex type. */ - if (flags & CPP_N_IMAGINARY) - value = build_complex (NULL_TREE, build_int_cst (type, 0), value); - - return value; -} - -/* Interpret TOKEN, a floating point number with FLAGS as classified - by cpplib. */ -static tree -interpret_float (const cpp_token *token, unsigned int flags) -{ - tree type; - tree const_type; - tree value; - REAL_VALUE_TYPE real; - REAL_VALUE_TYPE real_trunc; - char *copy; - size_t copylen; - - /* Default (no suffix) depends on whether the FLOAT_CONST_DECIMAL64 - pragma has been used and is either double or _Decimal64. Types - that are not allowed with decimal float default to double. */ - if (flags & CPP_N_DEFAULT) - { - flags ^= CPP_N_DEFAULT; - flags |= CPP_N_MEDIUM; - - if (((flags & CPP_N_HEX) == 0) && ((flags & CPP_N_IMAGINARY) == 0)) - { - warning (OPT_Wunsuffixed_float_constants, - "unsuffixed float constant"); - if (float_const_decimal64_p ()) - flags |= CPP_N_DFLOAT; - } - } - - /* Decode _Fract and _Accum. */ - if (flags & CPP_N_FRACT || flags & CPP_N_ACCUM) - return interpret_fixed (token, flags); - - /* Decode type based on width and properties. */ - if (flags & CPP_N_DFLOAT) - if ((flags & CPP_N_WIDTH) == CPP_N_LARGE) - type = dfloat128_type_node; - else if ((flags & CPP_N_WIDTH) == CPP_N_SMALL) - type = dfloat32_type_node; - else - type = dfloat64_type_node; - else - if (flags & CPP_N_WIDTH_MD) - { - char suffix; - enum machine_mode mode; - - if ((flags & CPP_N_WIDTH_MD) == CPP_N_MD_W) - suffix = 'w'; - else - suffix = 'q'; - - mode = targetm.c.mode_for_suffix (suffix); - if (mode == VOIDmode) - { - error ("unsupported non-standard suffix on floating constant"); - - return error_mark_node; - } - else - pedwarn (input_location, OPT_pedantic, "non-standard suffix on floating constant"); - - type = c_common_type_for_mode (mode, 0); - gcc_assert (type); - } - else if ((flags & CPP_N_WIDTH) == CPP_N_LARGE) - type = long_double_type_node; - else if ((flags & CPP_N_WIDTH) == CPP_N_SMALL - || flag_single_precision_constant) - type = float_type_node; - else - type = double_type_node; - - const_type = excess_precision_type (type); - if (!const_type) - const_type = type; - - /* Copy the constant to a nul-terminated buffer. If the constant - has any suffixes, cut them off; REAL_VALUE_ATOF/ REAL_VALUE_HTOF - can't handle them. */ - copylen = token->val.str.len; - if (flags & CPP_N_DFLOAT) - copylen -= 2; - else - { - if ((flags & CPP_N_WIDTH) != CPP_N_MEDIUM) - /* Must be an F or L or machine defined suffix. */ - copylen--; - if (flags & CPP_N_IMAGINARY) - /* I or J suffix. */ - copylen--; - } - - copy = (char *) alloca (copylen + 1); - memcpy (copy, token->val.str.text, copylen); - copy[copylen] = '\0'; - - real_from_string3 (&real, copy, TYPE_MODE (const_type)); - if (const_type != type) - /* Diagnosing if the result of converting the value with excess - precision to the semantic type would overflow (with associated - double rounding) is more appropriate than diagnosing if the - result of converting the string directly to the semantic type - would overflow. */ - real_convert (&real_trunc, TYPE_MODE (type), &real); - - /* Both C and C++ require a diagnostic for a floating constant - outside the range of representable values of its type. Since we - have __builtin_inf* to produce an infinity, this is now a - mandatory pedwarn if the target does not support infinities. */ - if (REAL_VALUE_ISINF (real) - || (const_type != type && REAL_VALUE_ISINF (real_trunc))) - { - if (!MODE_HAS_INFINITIES (TYPE_MODE (type))) - pedwarn (input_location, 0, "floating constant exceeds range of %qT", type); - else - warning (OPT_Woverflow, "floating constant exceeds range of %qT", type); - } - /* We also give a warning if the value underflows. */ - else if (REAL_VALUES_EQUAL (real, dconst0) - || (const_type != type && REAL_VALUES_EQUAL (real_trunc, dconst0))) - { - REAL_VALUE_TYPE realvoidmode; - int overflow = real_from_string (&realvoidmode, copy); - if (overflow < 0 || !REAL_VALUES_EQUAL (realvoidmode, dconst0)) - warning (OPT_Woverflow, "floating constant truncated to zero"); - } - - /* Create a node with determined type and value. */ - value = build_real (const_type, real); - if (flags & CPP_N_IMAGINARY) - value = build_complex (NULL_TREE, convert (const_type, integer_zero_node), - value); - - if (type != const_type) - value = build1 (EXCESS_PRECISION_EXPR, type, value); - - return value; -} - -/* Interpret TOKEN, a fixed-point number with FLAGS as classified - by cpplib. */ - -static tree -interpret_fixed (const cpp_token *token, unsigned int flags) -{ - tree type; - tree value; - FIXED_VALUE_TYPE fixed; - char *copy; - size_t copylen; - - copylen = token->val.str.len; - - if (flags & CPP_N_FRACT) /* _Fract. */ - { - if (flags & CPP_N_UNSIGNED) /* Unsigned _Fract. */ - { - if ((flags & CPP_N_WIDTH) == CPP_N_LARGE) - { - type = unsigned_long_long_fract_type_node; - copylen -= 4; - } - else if ((flags & CPP_N_WIDTH) == CPP_N_MEDIUM) - { - type = unsigned_long_fract_type_node; - copylen -= 3; - } - else if ((flags & CPP_N_WIDTH) == CPP_N_SMALL) - { - type = unsigned_short_fract_type_node; - copylen -= 3; - } - else - { - type = unsigned_fract_type_node; - copylen -= 2; - } - } - else /* Signed _Fract. */ - { - if ((flags & CPP_N_WIDTH) == CPP_N_LARGE) - { - type = long_long_fract_type_node; - copylen -= 3; - } - else if ((flags & CPP_N_WIDTH) == CPP_N_MEDIUM) - { - type = long_fract_type_node; - copylen -= 2; - } - else if ((flags & CPP_N_WIDTH) == CPP_N_SMALL) - { - type = short_fract_type_node; - copylen -= 2; - } - else - { - type = fract_type_node; - copylen --; - } - } - } - else /* _Accum. */ - { - if (flags & CPP_N_UNSIGNED) /* Unsigned _Accum. */ - { - if ((flags & CPP_N_WIDTH) == CPP_N_LARGE) - { - type = unsigned_long_long_accum_type_node; - copylen -= 4; - } - else if ((flags & CPP_N_WIDTH) == CPP_N_MEDIUM) - { - type = unsigned_long_accum_type_node; - copylen -= 3; - } - else if ((flags & CPP_N_WIDTH) == CPP_N_SMALL) - { - type = unsigned_short_accum_type_node; - copylen -= 3; - } - else - { - type = unsigned_accum_type_node; - copylen -= 2; - } - } - else /* Signed _Accum. */ - { - if ((flags & CPP_N_WIDTH) == CPP_N_LARGE) - { - type = long_long_accum_type_node; - copylen -= 3; - } - else if ((flags & CPP_N_WIDTH) == CPP_N_MEDIUM) - { - type = long_accum_type_node; - copylen -= 2; - } - else if ((flags & CPP_N_WIDTH) == CPP_N_SMALL) - { - type = short_accum_type_node; - copylen -= 2; - } - else - { - type = accum_type_node; - copylen --; - } - } - } - - copy = (char *) alloca (copylen + 1); - memcpy (copy, token->val.str.text, copylen); - copy[copylen] = '\0'; - - fixed_from_string (&fixed, copy, TYPE_MODE (type)); - - /* Create a node with determined type and value. */ - value = build_fixed (type, fixed); - - return value; -} - -/* Convert a series of STRING, WSTRING, STRING16, STRING32 and/or - UTF8STRING tokens into a tree, performing string constant - concatenation. TOK is the first of these. VALP is the location - to write the string into. OBJC_STRING indicates whether an '@' token - preceded the incoming token. - Returns the CPP token type of the result (CPP_STRING, CPP_WSTRING, - CPP_STRING32, CPP_STRING16, CPP_UTF8STRING, or CPP_OBJC_STRING). - - This is unfortunately more work than it should be. If any of the - strings in the series has an L prefix, the result is a wide string - (6.4.5p4). Whether or not the result is a wide string affects the - meaning of octal and hexadecimal escapes (6.4.4.4p6,9). But escape - sequences do not continue across the boundary between two strings in - a series (6.4.5p7), so we must not lose the boundaries. Therefore - cpp_interpret_string takes a vector of cpp_string structures, which - we must arrange to provide. */ - -static enum cpp_ttype -lex_string (const cpp_token *tok, tree *valp, bool objc_string, bool translate) -{ - tree value; - size_t concats = 0; - struct obstack str_ob; - cpp_string istr; - enum cpp_ttype type = tok->type; - - /* Try to avoid the overhead of creating and destroying an obstack - for the common case of just one string. */ - cpp_string str = tok->val.str; - cpp_string *strs = &str; - - retry: - tok = cpp_get_token (parse_in); - switch (tok->type) - { - case CPP_PADDING: - goto retry; - case CPP_ATSIGN: - if (c_dialect_objc ()) - { - objc_string = true; - goto retry; - } - /* FALLTHROUGH */ - - default: - break; - - case CPP_WSTRING: - case CPP_STRING16: - case CPP_STRING32: - case CPP_UTF8STRING: - if (type != tok->type) - { - if (type == CPP_STRING) - type = tok->type; - else - error ("unsupported non-standard concatenation of string literals"); - } - - case CPP_STRING: - if (!concats) - { - gcc_obstack_init (&str_ob); - obstack_grow (&str_ob, &str, sizeof (cpp_string)); - } - - concats++; - obstack_grow (&str_ob, &tok->val.str, sizeof (cpp_string)); - goto retry; - } - - /* We have read one more token than we want. */ - _cpp_backup_tokens (parse_in, 1); - if (concats) - strs = XOBFINISH (&str_ob, cpp_string *); - - if (concats && !objc_string && !in_system_header) - warning (OPT_Wtraditional, - "traditional C rejects string constant concatenation"); - - if ((translate - ? cpp_interpret_string : cpp_interpret_string_notranslate) - (parse_in, strs, concats + 1, &istr, type)) - { - value = build_string (istr.len, (const char *) istr.text); - free (CONST_CAST (unsigned char *, istr.text)); - } - else - { - /* Callers cannot generally handle error_mark_node in this context, - so return the empty string instead. cpp_interpret_string has - issued an error. */ - switch (type) - { - default: - case CPP_STRING: - case CPP_UTF8STRING: - value = build_string (1, ""); - break; - case CPP_STRING16: - value = build_string (TYPE_PRECISION (char16_type_node) - / TYPE_PRECISION (char_type_node), - "\0"); /* char16_t is 16 bits */ - break; - case CPP_STRING32: - value = build_string (TYPE_PRECISION (char32_type_node) - / TYPE_PRECISION (char_type_node), - "\0\0\0"); /* char32_t is 32 bits */ - break; - case CPP_WSTRING: - value = build_string (TYPE_PRECISION (wchar_type_node) - / TYPE_PRECISION (char_type_node), - "\0\0\0"); /* widest supported wchar_t - is 32 bits */ - break; - } - } - - switch (type) - { - default: - case CPP_STRING: - case CPP_UTF8STRING: - TREE_TYPE (value) = char_array_type_node; - break; - case CPP_STRING16: - TREE_TYPE (value) = char16_array_type_node; - break; - case CPP_STRING32: - TREE_TYPE (value) = char32_array_type_node; - break; - case CPP_WSTRING: - TREE_TYPE (value) = wchar_array_type_node; - } - *valp = fix_string_type (value); - - if (concats) - obstack_free (&str_ob, 0); - - return objc_string ? CPP_OBJC_STRING : type; -} - -/* Converts a (possibly wide) character constant token into a tree. */ -static tree -lex_charconst (const cpp_token *token) -{ - cppchar_t result; - tree type, value; - unsigned int chars_seen; - int unsignedp = 0; - - result = cpp_interpret_charconst (parse_in, token, - &chars_seen, &unsignedp); - - if (token->type == CPP_WCHAR) - type = wchar_type_node; - else if (token->type == CPP_CHAR32) - type = char32_type_node; - else if (token->type == CPP_CHAR16) - type = char16_type_node; - /* In C, a character constant has type 'int'. - In C++ 'char', but multi-char charconsts have type 'int'. */ - else if (!c_dialect_cxx () || chars_seen > 1) - type = integer_type_node; - else - type = char_type_node; - - /* Cast to cppchar_signed_t to get correct sign-extension of RESULT - before possibly widening to HOST_WIDE_INT for build_int_cst. */ - if (unsignedp || (cppchar_signed_t) result >= 0) - value = build_int_cst_wide (type, result, 0); - else - value = build_int_cst_wide (type, (cppchar_signed_t) result, -1); - - return value; -} diff --git a/gcc/c-objc-common.c b/gcc/c-objc-common.c index fccc2635fa8..d1cac99d562 100644 --- a/gcc/c-objc-common.c +++ b/gcc/c-objc-common.c @@ -24,7 +24,7 @@ along with GCC; see the file COPYING3. If not see #include "tree.h" #include "c-tree.h" #include "intl.h" -#include "c-pretty-print.h" +#include "c-family/c-pretty-print.h" #include "flags.h" #include "diagnostic.h" #include "tree-pretty-print.h" @@ -79,21 +79,22 @@ c_objc_common_init (void) %E: an identifier or expression, %F: a function declaration, %T: a type. + %V: a list of type qualifiers from a tree. + %v: an explicit list of type qualifiers + %#v: an explicit list of type qualifiers of a function type. - These format specifiers form a subset of the format specifiers set used - by the C++ front-end. Please notice when called, the `%' part was already skipped by the diagnostic machinery. */ static bool c_tree_printer (pretty_printer *pp, text_info *text, const char *spec, int precision, bool wide, bool set_locus, bool hash) { - tree t; + tree t = NULL_TREE; tree name; c_pretty_printer *cpp = (c_pretty_printer *) pp; pp->padding = pp_none; - if (precision != 0 || wide || hash) + if (precision != 0 || wide) return false; if (*spec == 'K') @@ -102,10 +103,12 @@ c_tree_printer (pretty_printer *pp, text_info *text, const char *spec, return true; } - t = va_arg (*text->args_ptr, tree); - - if (set_locus && text->locus) - *text->locus = DECL_SOURCE_LOCATION (t); + if (*spec != 'v') + { + t = va_arg (*text->args_ptr, tree); + if (set_locus && text->locus) + *text->locus = DECL_SOURCE_LOCATION (t); + } switch (*spec) { @@ -155,6 +158,14 @@ c_tree_printer (pretty_printer *pp, text_info *text, const char *spec, pp_expression (cpp, t); return true; + case 'V': + pp_c_type_qualifier_list (cpp, t); + return true; + + case 'v': + pp_c_cv_qualifiers (cpp, va_arg (*text->args_ptr, int), hash); + return true; + default: return false; } diff --git a/gcc/c-omp.c b/gcc/c-omp.c deleted file mode 100644 index 31970bdeaee..00000000000 --- a/gcc/c-omp.c +++ /dev/null @@ -1,531 +0,0 @@ -/* This file contains routines to construct GNU OpenMP constructs, - called from parsing in the C and C++ front ends. - - Copyright (C) 2005, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. - Contributed by Richard Henderson , - Diego Novillo . - -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 3, 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 COPYING3. If not see -. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "tree.h" -#include "c-common.h" -#include "toplev.h" -#include "gimple.h" /* For create_tmp_var_raw. */ -#include "langhooks.h" - - -/* Complete a #pragma omp master construct. STMT is the structured-block - that follows the pragma. LOC is the l*/ - -tree -c_finish_omp_master (location_t loc, tree stmt) -{ - tree t = add_stmt (build1 (OMP_MASTER, void_type_node, stmt)); - SET_EXPR_LOCATION (t, loc); - return t; -} - -/* Complete a #pragma omp critical construct. STMT is the structured-block - that follows the pragma, NAME is the identifier in the pragma, or null - if it was omitted. LOC is the location of the #pragma. */ - -tree -c_finish_omp_critical (location_t loc, tree body, tree name) -{ - tree stmt = make_node (OMP_CRITICAL); - TREE_TYPE (stmt) = void_type_node; - OMP_CRITICAL_BODY (stmt) = body; - OMP_CRITICAL_NAME (stmt) = name; - SET_EXPR_LOCATION (stmt, loc); - return add_stmt (stmt); -} - -/* Complete a #pragma omp ordered construct. STMT is the structured-block - that follows the pragma. LOC is the location of the #pragma. */ - -tree -c_finish_omp_ordered (location_t loc, tree stmt) -{ - tree t = build1 (OMP_ORDERED, void_type_node, stmt); - SET_EXPR_LOCATION (t, loc); - return add_stmt (t); -} - - -/* Complete a #pragma omp barrier construct. LOC is the location of - the #pragma. */ - -void -c_finish_omp_barrier (location_t loc) -{ - tree x; - - x = built_in_decls[BUILT_IN_GOMP_BARRIER]; - x = build_call_expr_loc (loc, x, 0); - add_stmt (x); -} - - -/* Complete a #pragma omp taskwait construct. LOC is the location of the - pragma. */ - -void -c_finish_omp_taskwait (location_t loc) -{ - tree x; - - x = built_in_decls[BUILT_IN_GOMP_TASKWAIT]; - x = build_call_expr_loc (loc, x, 0); - add_stmt (x); -} - - -/* Complete a #pragma omp atomic construct. The expression to be - implemented atomically is LHS code= RHS. LOC is the location of - the atomic statement. The value returned is either error_mark_node - (if the construct was erroneous) or an OMP_ATOMIC node which should - be added to the current statement tree with add_stmt.*/ - -tree -c_finish_omp_atomic (location_t loc, enum tree_code code, tree lhs, tree rhs) -{ - tree x, type, addr; - - if (lhs == error_mark_node || rhs == error_mark_node) - return error_mark_node; - - /* ??? According to one reading of the OpenMP spec, complex type are - supported, but there are no atomic stores for any architecture. - But at least icc 9.0 doesn't support complex types here either. - And lets not even talk about vector types... */ - type = TREE_TYPE (lhs); - if (!INTEGRAL_TYPE_P (type) - && !POINTER_TYPE_P (type) - && !SCALAR_FLOAT_TYPE_P (type)) - { - error_at (loc, "invalid expression type for %<#pragma omp atomic%>"); - return error_mark_node; - } - - /* ??? Validate that rhs does not overlap lhs. */ - - /* Take and save the address of the lhs. From then on we'll reference it - via indirection. */ - addr = build_unary_op (loc, ADDR_EXPR, lhs, 0); - if (addr == error_mark_node) - return error_mark_node; - addr = save_expr (addr); - if (TREE_CODE (addr) != SAVE_EXPR - && (TREE_CODE (addr) != ADDR_EXPR - || TREE_CODE (TREE_OPERAND (addr, 0)) != VAR_DECL)) - { - /* Make sure LHS is simple enough so that goa_lhs_expr_p can recognize - it even after unsharing function body. */ - tree var = create_tmp_var_raw (TREE_TYPE (addr), NULL); - DECL_CONTEXT (var) = current_function_decl; - addr = build4 (TARGET_EXPR, TREE_TYPE (addr), var, addr, NULL, NULL); - } - lhs = build_indirect_ref (loc, addr, RO_NULL); - - /* There are lots of warnings, errors, and conversions that need to happen - in the course of interpreting a statement. Use the normal mechanisms - to do this, and then take it apart again. */ - x = build_modify_expr (input_location, lhs, NULL_TREE, code, - input_location, rhs, NULL_TREE); - if (x == error_mark_node) - return error_mark_node; - gcc_assert (TREE_CODE (x) == MODIFY_EXPR); - rhs = TREE_OPERAND (x, 1); - - /* Punt the actual generation of atomic operations to common code. */ - x = build2 (OMP_ATOMIC, void_type_node, addr, rhs); - SET_EXPR_LOCATION (x, loc); - return x; -} - - -/* Complete a #pragma omp flush construct. We don't do anything with - the variable list that the syntax allows. LOC is the location of - the #pragma. */ - -void -c_finish_omp_flush (location_t loc) -{ - tree x; - - x = built_in_decls[BUILT_IN_SYNCHRONIZE]; - x = build_call_expr_loc (loc, x, 0); - add_stmt (x); -} - - -/* Check and canonicalize #pragma omp for increment expression. - Helper function for c_finish_omp_for. */ - -static tree -check_omp_for_incr_expr (location_t loc, tree exp, tree decl) -{ - tree t; - - if (!INTEGRAL_TYPE_P (TREE_TYPE (exp)) - || TYPE_PRECISION (TREE_TYPE (exp)) < TYPE_PRECISION (TREE_TYPE (decl))) - return error_mark_node; - - if (exp == decl) - return build_int_cst (TREE_TYPE (exp), 0); - - switch (TREE_CODE (exp)) - { - CASE_CONVERT: - t = check_omp_for_incr_expr (loc, TREE_OPERAND (exp, 0), decl); - if (t != error_mark_node) - return fold_convert_loc (loc, TREE_TYPE (exp), t); - break; - case MINUS_EXPR: - t = check_omp_for_incr_expr (loc, TREE_OPERAND (exp, 0), decl); - if (t != error_mark_node) - return fold_build2_loc (loc, MINUS_EXPR, - TREE_TYPE (exp), t, TREE_OPERAND (exp, 1)); - break; - case PLUS_EXPR: - t = check_omp_for_incr_expr (loc, TREE_OPERAND (exp, 0), decl); - if (t != error_mark_node) - return fold_build2_loc (loc, PLUS_EXPR, - TREE_TYPE (exp), t, TREE_OPERAND (exp, 1)); - t = check_omp_for_incr_expr (loc, TREE_OPERAND (exp, 1), decl); - if (t != error_mark_node) - return fold_build2_loc (loc, PLUS_EXPR, - TREE_TYPE (exp), TREE_OPERAND (exp, 0), t); - break; - default: - break; - } - - return error_mark_node; -} - -/* Validate and emit code for the OpenMP directive #pragma omp for. - DECLV is a vector of iteration variables, for each collapsed loop. - INITV, CONDV and INCRV are vectors containing initialization - expressions, controlling predicates and increment expressions. - BODY is the body of the loop and PRE_BODY statements that go before - the loop. */ - -tree -c_finish_omp_for (location_t locus, tree declv, tree initv, tree condv, - tree incrv, tree body, tree pre_body) -{ - location_t elocus; - bool fail = false; - int i; - - gcc_assert (TREE_VEC_LENGTH (declv) == TREE_VEC_LENGTH (initv)); - gcc_assert (TREE_VEC_LENGTH (declv) == TREE_VEC_LENGTH (condv)); - gcc_assert (TREE_VEC_LENGTH (declv) == TREE_VEC_LENGTH (incrv)); - for (i = 0; i < TREE_VEC_LENGTH (declv); i++) - { - tree decl = TREE_VEC_ELT (declv, i); - tree init = TREE_VEC_ELT (initv, i); - tree cond = TREE_VEC_ELT (condv, i); - tree incr = TREE_VEC_ELT (incrv, i); - - elocus = locus; - if (EXPR_HAS_LOCATION (init)) - elocus = EXPR_LOCATION (init); - - /* Validate the iteration variable. */ - if (!INTEGRAL_TYPE_P (TREE_TYPE (decl)) - && TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE) - { - error_at (elocus, "invalid type for iteration variable %qE", decl); - fail = true; - } - - /* In the case of "for (int i = 0...)", init will be a decl. It should - have a DECL_INITIAL that we can turn into an assignment. */ - if (init == decl) - { - elocus = DECL_SOURCE_LOCATION (decl); - - init = DECL_INITIAL (decl); - if (init == NULL) - { - error_at (elocus, "%qE is not initialized", decl); - init = integer_zero_node; - fail = true; - } - - init = build_modify_expr (elocus, decl, NULL_TREE, NOP_EXPR, - /* FIXME diagnostics: This should - be the location of the INIT. */ - elocus, - init, - NULL_TREE); - } - gcc_assert (TREE_CODE (init) == MODIFY_EXPR); - gcc_assert (TREE_OPERAND (init, 0) == decl); - - if (cond == NULL_TREE) - { - error_at (elocus, "missing controlling predicate"); - fail = true; - } - else - { - bool cond_ok = false; - - if (EXPR_HAS_LOCATION (cond)) - elocus = EXPR_LOCATION (cond); - - if (TREE_CODE (cond) == LT_EXPR - || TREE_CODE (cond) == LE_EXPR - || TREE_CODE (cond) == GT_EXPR - || TREE_CODE (cond) == GE_EXPR - || TREE_CODE (cond) == NE_EXPR - || TREE_CODE (cond) == EQ_EXPR) - { - tree op0 = TREE_OPERAND (cond, 0); - tree op1 = TREE_OPERAND (cond, 1); - - /* 2.5.1. The comparison in the condition is computed in - the type of DECL, otherwise the behavior is undefined. - - For example: - long n; int i; - i < n; - - according to ISO will be evaluated as: - (long)i < n; - - We want to force: - i < (int)n; */ - if (TREE_CODE (op0) == NOP_EXPR - && decl == TREE_OPERAND (op0, 0)) - { - TREE_OPERAND (cond, 0) = TREE_OPERAND (op0, 0); - TREE_OPERAND (cond, 1) - = fold_build1_loc (elocus, NOP_EXPR, TREE_TYPE (decl), - TREE_OPERAND (cond, 1)); - } - else if (TREE_CODE (op1) == NOP_EXPR - && decl == TREE_OPERAND (op1, 0)) - { - TREE_OPERAND (cond, 1) = TREE_OPERAND (op1, 0); - TREE_OPERAND (cond, 0) - = fold_build1_loc (elocus, NOP_EXPR, TREE_TYPE (decl), - TREE_OPERAND (cond, 0)); - } - - if (decl == TREE_OPERAND (cond, 0)) - cond_ok = true; - else if (decl == TREE_OPERAND (cond, 1)) - { - TREE_SET_CODE (cond, - swap_tree_comparison (TREE_CODE (cond))); - TREE_OPERAND (cond, 1) = TREE_OPERAND (cond, 0); - TREE_OPERAND (cond, 0) = decl; - cond_ok = true; - } - - if (TREE_CODE (cond) == NE_EXPR - || TREE_CODE (cond) == EQ_EXPR) - { - if (!INTEGRAL_TYPE_P (TREE_TYPE (decl))) - cond_ok = false; - else if (operand_equal_p (TREE_OPERAND (cond, 1), - TYPE_MIN_VALUE (TREE_TYPE (decl)), - 0)) - TREE_SET_CODE (cond, TREE_CODE (cond) == NE_EXPR - ? GT_EXPR : LE_EXPR); - else if (operand_equal_p (TREE_OPERAND (cond, 1), - TYPE_MAX_VALUE (TREE_TYPE (decl)), - 0)) - TREE_SET_CODE (cond, TREE_CODE (cond) == NE_EXPR - ? LT_EXPR : GE_EXPR); - else - cond_ok = false; - } - } - - if (!cond_ok) - { - error_at (elocus, "invalid controlling predicate"); - fail = true; - } - } - - if (incr == NULL_TREE) - { - error_at (elocus, "missing increment expression"); - fail = true; - } - else - { - bool incr_ok = false; - - if (EXPR_HAS_LOCATION (incr)) - elocus = EXPR_LOCATION (incr); - - /* Check all the valid increment expressions: v++, v--, ++v, --v, - v = v + incr, v = incr + v and v = v - incr. */ - switch (TREE_CODE (incr)) - { - case POSTINCREMENT_EXPR: - case PREINCREMENT_EXPR: - case POSTDECREMENT_EXPR: - case PREDECREMENT_EXPR: - if (TREE_OPERAND (incr, 0) != decl) - break; - - incr_ok = true; - if (POINTER_TYPE_P (TREE_TYPE (decl)) - && TREE_OPERAND (incr, 1)) - { - tree t = fold_convert_loc (elocus, - sizetype, TREE_OPERAND (incr, 1)); - - if (TREE_CODE (incr) == POSTDECREMENT_EXPR - || TREE_CODE (incr) == PREDECREMENT_EXPR) - t = fold_build1_loc (elocus, NEGATE_EXPR, sizetype, t); - t = build2 (POINTER_PLUS_EXPR, TREE_TYPE (decl), decl, t); - incr = build2 (MODIFY_EXPR, void_type_node, decl, t); - } - break; - - case MODIFY_EXPR: - if (TREE_OPERAND (incr, 0) != decl) - break; - if (TREE_OPERAND (incr, 1) == decl) - break; - if (TREE_CODE (TREE_OPERAND (incr, 1)) == PLUS_EXPR - && (TREE_OPERAND (TREE_OPERAND (incr, 1), 0) == decl - || TREE_OPERAND (TREE_OPERAND (incr, 1), 1) == decl)) - incr_ok = true; - else if ((TREE_CODE (TREE_OPERAND (incr, 1)) == MINUS_EXPR - || (TREE_CODE (TREE_OPERAND (incr, 1)) - == POINTER_PLUS_EXPR)) - && TREE_OPERAND (TREE_OPERAND (incr, 1), 0) == decl) - incr_ok = true; - else - { - tree t = check_omp_for_incr_expr (elocus, - TREE_OPERAND (incr, 1), - decl); - if (t != error_mark_node) - { - incr_ok = true; - t = build2 (PLUS_EXPR, TREE_TYPE (decl), decl, t); - incr = build2 (MODIFY_EXPR, void_type_node, decl, t); - } - } - break; - - default: - break; - } - if (!incr_ok) - { - error_at (elocus, "invalid increment expression"); - fail = true; - } - } - - TREE_VEC_ELT (initv, i) = init; - TREE_VEC_ELT (incrv, i) = incr; - } - - if (fail) - return NULL; - else - { - tree t = make_node (OMP_FOR); - - TREE_TYPE (t) = void_type_node; - OMP_FOR_INIT (t) = initv; - OMP_FOR_COND (t) = condv; - OMP_FOR_INCR (t) = incrv; - OMP_FOR_BODY (t) = body; - OMP_FOR_PRE_BODY (t) = pre_body; - - SET_EXPR_LOCATION (t, locus); - return add_stmt (t); - } -} - - -/* Divide CLAUSES into two lists: those that apply to a parallel - construct, and those that apply to a work-sharing construct. Place - the results in *PAR_CLAUSES and *WS_CLAUSES respectively. In - addition, add a nowait clause to the work-sharing list. LOC is the - location of the OMP_PARALLEL*. */ - -void -c_split_parallel_clauses (location_t loc, tree clauses, - tree *par_clauses, tree *ws_clauses) -{ - tree next; - - *par_clauses = NULL; - *ws_clauses = build_omp_clause (loc, OMP_CLAUSE_NOWAIT); - - for (; clauses ; clauses = next) - { - next = OMP_CLAUSE_CHAIN (clauses); - - switch (OMP_CLAUSE_CODE (clauses)) - { - case OMP_CLAUSE_PRIVATE: - case OMP_CLAUSE_SHARED: - case OMP_CLAUSE_FIRSTPRIVATE: - case OMP_CLAUSE_LASTPRIVATE: - case OMP_CLAUSE_REDUCTION: - case OMP_CLAUSE_COPYIN: - case OMP_CLAUSE_IF: - case OMP_CLAUSE_NUM_THREADS: - case OMP_CLAUSE_DEFAULT: - OMP_CLAUSE_CHAIN (clauses) = *par_clauses; - *par_clauses = clauses; - break; - - case OMP_CLAUSE_SCHEDULE: - case OMP_CLAUSE_ORDERED: - case OMP_CLAUSE_COLLAPSE: - OMP_CLAUSE_CHAIN (clauses) = *ws_clauses; - *ws_clauses = clauses; - break; - - default: - gcc_unreachable (); - } - } -} - -/* True if OpenMP sharing attribute of DECL is predetermined. */ - -enum omp_clause_default_kind -c_omp_predetermined_sharing (tree decl) -{ - /* Variables with const-qualified type having no mutable member - are predetermined shared. */ - if (TREE_READONLY (decl)) - return OMP_CLAUSE_DEFAULT_SHARED; - - return OMP_CLAUSE_DEFAULT_UNSPECIFIED; -} diff --git a/gcc/c-opts.c b/gcc/c-opts.c deleted file mode 100644 index 08592f58e4b..00000000000 --- a/gcc/c-opts.c +++ /dev/null @@ -1,1815 +0,0 @@ -/* C/ObjC/C++ command line option handling. - Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 - Free Software Foundation, Inc. - Contributed by Neil Booth. - -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 3, 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 COPYING3. If not see -. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "tree.h" -#include "c-common.h" -#include "c-pragma.h" -#include "flags.h" -#include "toplev.h" -#include "langhooks.h" -#include "diagnostic.h" -#include "intl.h" -#include "cppdefault.h" -#include "incpath.h" -#include "debug.h" /* For debug_hooks. */ -#include "opts.h" -#include "options.h" -#include "mkdeps.h" -#include "target.h" /* For gcc_targetcm. */ - -#ifndef DOLLARS_IN_IDENTIFIERS -# define DOLLARS_IN_IDENTIFIERS true -#endif - -#ifndef TARGET_SYSTEM_ROOT -# define TARGET_SYSTEM_ROOT NULL -#endif - -#ifndef TARGET_OPTF -#define TARGET_OPTF(ARG) -#endif - -/* CPP's options. */ -cpp_options *cpp_opts; - -/* Input filename. */ -static const char *this_input_filename; - -/* Filename and stream for preprocessed output. */ -static const char *out_fname; -static FILE *out_stream; - -/* Append dependencies to deps_file. */ -static bool deps_append; - -/* If dependency switches (-MF etc.) have been given. */ -static bool deps_seen; - -/* If -v seen. */ -static bool verbose; - -/* Dependency output file. */ -static const char *deps_file; - -/* The prefix given by -iprefix, if any. */ -static const char *iprefix; - -/* The multilib directory given by -imultilib, if any. */ -static const char *imultilib; - -/* The system root, if any. Overridden by -isysroot. */ -static const char *sysroot = TARGET_SYSTEM_ROOT; - -/* Zero disables all standard directories for headers. */ -static bool std_inc = true; - -/* Zero disables the C++-specific standard directories for headers. */ -static bool std_cxx_inc = true; - -/* If the quote chain has been split by -I-. */ -static bool quote_chain_split; - -/* If -Wunused-macros. */ -static bool warn_unused_macros; - -/* If -Wvariadic-macros. */ -static bool warn_variadic_macros = true; - -/* Number of deferred options. */ -static size_t deferred_count; - -/* Number of deferred options scanned for -include. */ -static size_t include_cursor; - -static void handle_OPT_d (const char *); -static void set_std_cxx98 (int); -static void set_std_cxx0x (int); -static void set_std_c89 (int, int); -static void set_std_c99 (int); -static void set_std_c1x (int); -static void check_deps_environment_vars (void); -static void handle_deferred_opts (void); -static void sanitize_cpp_opts (void); -static void add_prefixed_path (const char *, size_t); -static void push_command_line_include (void); -static void cb_file_change (cpp_reader *, const struct line_map *); -static void cb_dir_change (cpp_reader *, const char *); -static void finish_options (void); - -#ifndef STDC_0_IN_SYSTEM_HEADERS -#define STDC_0_IN_SYSTEM_HEADERS 0 -#endif - -/* Holds switches parsed by c_common_handle_option (), but whose - handling is deferred to c_common_post_options (). */ -static void defer_opt (enum opt_code, const char *); -static struct deferred_opt -{ - enum opt_code code; - const char *arg; -} *deferred_opts; - - -static const unsigned int -c_family_lang_mask = (CL_C | CL_CXX | CL_ObjC | CL_ObjCXX); - -/* Complain that switch CODE expects an argument but none was - provided. OPT was the command-line option. Return FALSE to get - the default message in opts.c, TRUE if we provide a specialized - one. */ -bool -c_common_missing_argument (const char *opt, size_t code) -{ - switch (code) - { - default: - /* Pick up the default message. */ - return false; - - case OPT_fconstant_string_class_: - error ("no class name specified with %qs", opt); - break; - - case OPT_A: - error ("assertion missing after %qs", opt); - break; - - case OPT_D: - case OPT_U: - error ("macro name missing after %qs", opt); - break; - - case OPT_F: - case OPT_I: - case OPT_idirafter: - case OPT_isysroot: - case OPT_isystem: - case OPT_iquote: - error ("missing path after %qs", opt); - break; - - case OPT_MF: - case OPT_MD: - case OPT_MMD: - case OPT_include: - case OPT_imacros: - case OPT_o: - error ("missing filename after %qs", opt); - break; - - case OPT_MQ: - case OPT_MT: - error ("missing makefile target after %qs", opt); - break; - } - - return true; -} - -/* Defer option CODE with argument ARG. */ -static void -defer_opt (enum opt_code code, const char *arg) -{ - deferred_opts[deferred_count].code = code; - deferred_opts[deferred_count].arg = arg; - deferred_count++; -} - -/* -Werror= may set a warning option to enable a warning that is emitted - by the preprocessor. Set any corresponding flag in cpp_opts. */ - -static void -warning_as_error_callback (int option_index) -{ - switch (option_index) - { - default: - /* Ignore options not associated with the preprocessor. */ - break; - - case OPT_Wdeprecated: - cpp_opts->warn_deprecated = 1; - break; - - case OPT_Wcomment: - case OPT_Wcomments: - cpp_opts->warn_comments = 1; - break; - - case OPT_Wtrigraphs: - cpp_opts->warn_trigraphs = 1; - break; - - case OPT_Wmultichar: - cpp_opts->warn_multichar = 1; - break; - - case OPT_Wtraditional: - cpp_opts->warn_traditional = 1; - break; - - case OPT_Wlong_long: - cpp_opts->warn_long_long = 1; - break; - - case OPT_Wendif_labels: - cpp_opts->warn_endif_labels = 1; - break; - - case OPT_Wvariadic_macros: - /* Set the local flag that is used later to update cpp_opts. */ - warn_variadic_macros = 1; - break; - - case OPT_Wbuiltin_macro_redefined: - cpp_opts->warn_builtin_macro_redefined = 1; - break; - - case OPT_Wundef: - cpp_opts->warn_undef = 1; - break; - - case OPT_Wunused_macros: - /* Set the local flag that is used later to update cpp_opts. */ - warn_unused_macros = 1; - break; - - case OPT_Wc___compat: - /* Add warnings in the same way as c_common_handle_option below. */ - if (warn_enum_compare == -1) - warn_enum_compare = 1; - if (warn_jump_misses_init == -1) - warn_jump_misses_init = 1; - cpp_opts->warn_cxx_operator_names = 1; - break; - - case OPT_Wnormalized_: - inform (input_location, "-Werror=normalized=: Set -Wnormalized=nfc"); - cpp_opts->warn_normalize = normalized_C; - break; - - case OPT_Winvalid_pch: - cpp_opts->warn_invalid_pch = 1; - break; - - case OPT_Wcpp: - /* Handled by standard diagnostics using the option's associated - boolean variable. */ - break; - } -} - -/* Common initialization before parsing options. */ -unsigned int -c_common_init_options (unsigned int argc, const char **argv) -{ - static const unsigned int lang_flags[] = {CL_C, CL_ObjC, CL_CXX, CL_ObjCXX}; - unsigned int i, result; - struct cpp_callbacks *cb; - - /* Register callback for warnings enabled by -Werror=. */ - register_warning_as_error_callback (warning_as_error_callback); - - /* This is conditionalized only because that is the way the front - ends used to do it. Maybe this should be unconditional? */ - if (c_dialect_cxx ()) - { - /* By default wrap lines at 80 characters. Is getenv - ("COLUMNS") preferable? */ - diagnostic_line_cutoff (global_dc) = 80; - /* By default, emit location information once for every - diagnostic message. */ - diagnostic_prefixing_rule (global_dc) = DIAGNOSTICS_SHOW_PREFIX_ONCE; - } - - global_dc->opt_permissive = OPT_fpermissive; - - parse_in = cpp_create_reader (c_dialect_cxx () ? CLK_GNUCXX: CLK_GNUC89, - ident_hash, line_table); - cb = cpp_get_callbacks (parse_in); - cb->error = c_cpp_error; - - cpp_opts = cpp_get_options (parse_in); - cpp_opts->dollars_in_ident = DOLLARS_IN_IDENTIFIERS; - cpp_opts->objc = c_dialect_objc (); - - /* Reset to avoid warnings on internal definitions. We set it just - before passing on command-line options to cpplib. */ - cpp_opts->warn_dollars = 0; - - flag_exceptions = c_dialect_cxx (); - warn_pointer_arith = c_dialect_cxx (); - warn_write_strings = c_dialect_cxx(); - flag_warn_unused_result = true; - - /* By default, C99-like requirements for complex multiply and divide. */ - flag_complex_method = 2; - - deferred_opts = XNEWVEC (struct deferred_opt, argc); - - result = lang_flags[c_language]; - - if (c_language == clk_c) - { - /* If preprocessing assembly language, accept any of the C-family - front end options since the driver may pass them through. */ - for (i = 1; i < argc; i++) - if (! strcmp (argv[i], "-lang-asm")) - { - result |= CL_C | CL_ObjC | CL_CXX | CL_ObjCXX; - break; - } - } - - return result; -} - -/* Handle switch SCODE with argument ARG. VALUE is true, unless no- - form of an -f or -W option was given. Returns 0 if the switch was - invalid, a negative number to prevent language-independent - processing in toplev.c (a hack necessary for the short-term). */ -int -c_common_handle_option (size_t scode, const char *arg, int value, - int kind) -{ - const struct cl_option *option = &cl_options[scode]; - enum opt_code code = (enum opt_code) scode; - int result = 1; - - /* Prevent resetting the language standard to a C dialect when the driver - has already determined that we're looking at assembler input. */ - bool preprocessing_asm_p = (cpp_get_options (parse_in)->lang == CLK_ASM); - - switch (code) - { - default: - if (cl_options[code].flags & c_family_lang_mask) - { - if ((option->flags & CL_TARGET) - && ! targetcm.handle_c_option (scode, arg, value)) - result = 0; - break; - } - result = 0; - break; - - case OPT__output_pch_: - pch_file = arg; - break; - - case OPT_A: - defer_opt (code, arg); - break; - - case OPT_C: - cpp_opts->discard_comments = 0; - break; - - case OPT_CC: - cpp_opts->discard_comments = 0; - cpp_opts->discard_comments_in_macro_exp = 0; - break; - - case OPT_D: - defer_opt (code, arg); - break; - - case OPT_E: - flag_preprocess_only = 1; - break; - - case OPT_H: - cpp_opts->print_include_names = 1; - break; - - case OPT_F: - TARGET_OPTF (xstrdup (arg)); - break; - - case OPT_I: - if (strcmp (arg, "-")) - add_path (xstrdup (arg), BRACKET, 0, true); - else - { - if (quote_chain_split) - error ("-I- specified twice"); - quote_chain_split = true; - split_quote_chain (); - inform (input_location, "obsolete option -I- used, please use -iquote instead"); - } - break; - - case OPT_M: - case OPT_MM: - /* When doing dependencies with -M or -MM, suppress normal - preprocessed output, but still do -dM etc. as software - depends on this. Preprocessed output does occur if -MD, -MMD - or environment var dependency generation is used. */ - cpp_opts->deps.style = (code == OPT_M ? DEPS_SYSTEM: DEPS_USER); - flag_no_output = 1; - break; - - case OPT_MD: - case OPT_MMD: - cpp_opts->deps.style = (code == OPT_MD ? DEPS_SYSTEM: DEPS_USER); - cpp_opts->deps.need_preprocessor_output = true; - deps_file = arg; - break; - - case OPT_MF: - deps_seen = true; - deps_file = arg; - break; - - case OPT_MG: - deps_seen = true; - cpp_opts->deps.missing_files = true; - break; - - case OPT_MP: - deps_seen = true; - cpp_opts->deps.phony_targets = true; - break; - - case OPT_MQ: - case OPT_MT: - deps_seen = true; - defer_opt (code, arg); - break; - - case OPT_P: - flag_no_line_commands = 1; - break; - - case OPT_fworking_directory: - flag_working_directory = value; - break; - - case OPT_U: - defer_opt (code, arg); - break; - - case OPT_Wall: - warn_unused = value; - set_Wformat (value); - handle_option (OPT_Wimplicit, value, NULL, c_family_lang_mask, kind); - warn_char_subscripts = value; - warn_missing_braces = value; - warn_parentheses = value; - warn_return_type = value; - warn_sequence_point = value; /* Was C only. */ - warn_switch = value; - if (warn_strict_aliasing == -1) - set_Wstrict_aliasing (value); - warn_address = value; - if (warn_strict_overflow == -1) - warn_strict_overflow = value; - warn_array_bounds = value; - warn_volatile_register_var = value; - - /* Only warn about unknown pragmas that are not in system - headers. */ - warn_unknown_pragmas = value; - - warn_uninitialized = value; - - if (!c_dialect_cxx ()) - { - /* We set this to 2 here, but 1 in -Wmain, so -ffreestanding - can turn it off only if it's not explicit. */ - if (warn_main == -1) - warn_main = (value ? 2 : 0); - - /* In C, -Wall turns on -Wenum-compare, which we do here. - In C++ it is on by default, which is done in - c_common_post_options. */ - if (warn_enum_compare == -1) - warn_enum_compare = value; - } - else - { - /* C++-specific warnings. */ - warn_sign_compare = value; - warn_reorder = value; - warn_cxx0x_compat = value; - } - - cpp_opts->warn_trigraphs = value; - cpp_opts->warn_comments = value; - cpp_opts->warn_num_sign_change = value; - - if (warn_pointer_sign == -1) - warn_pointer_sign = value; - break; - - case OPT_Wbuiltin_macro_redefined: - cpp_opts->warn_builtin_macro_redefined = value; - break; - - case OPT_Wcomment: - case OPT_Wcomments: - cpp_opts->warn_comments = value; - break; - - case OPT_Wc___compat: - /* Because -Wenum-compare is the default in C++, -Wc++-compat - implies -Wenum-compare. */ - if (warn_enum_compare == -1 && value) - warn_enum_compare = value; - /* Because C++ always warns about a goto which misses an - initialization, -Wc++-compat turns on -Wjump-misses-init. */ - if (warn_jump_misses_init == -1 && value) - warn_jump_misses_init = value; - cpp_opts->warn_cxx_operator_names = value; - break; - - case OPT_Wdeprecated: - cpp_opts->warn_deprecated = value; - break; - - case OPT_Wendif_labels: - cpp_opts->warn_endif_labels = value; - break; - - case OPT_Werror: - global_dc->warning_as_error_requested = value; - break; - - case OPT_Werror_implicit_function_declaration: - /* For backward compatibility, this is the same as - -Werror=implicit-function-declaration. */ - enable_warning_as_error ("implicit-function-declaration", value, CL_C | CL_ObjC); - break; - - case OPT_Wformat: - set_Wformat (value); - break; - - case OPT_Wformat_: - set_Wformat (atoi (arg)); - break; - - case OPT_Wimplicit: - gcc_assert (value == 0 || value == 1); - if (warn_implicit_int == -1) - handle_option (OPT_Wimplicit_int, value, NULL, - c_family_lang_mask, kind); - if (warn_implicit_function_declaration == -1) - handle_option (OPT_Wimplicit_function_declaration, value, NULL, - c_family_lang_mask, kind); - break; - - case OPT_Wimport: - /* Silently ignore for now. */ - break; - - case OPT_Winvalid_pch: - cpp_opts->warn_invalid_pch = value; - break; - - case OPT_Wmissing_include_dirs: - cpp_opts->warn_missing_include_dirs = value; - break; - - case OPT_Wmultichar: - cpp_opts->warn_multichar = value; - break; - - case OPT_Wnormalized_: - if (!value || (arg && strcasecmp (arg, "none") == 0)) - cpp_opts->warn_normalize = normalized_none; - else if (!arg || strcasecmp (arg, "nfkc") == 0) - cpp_opts->warn_normalize = normalized_KC; - else if (strcasecmp (arg, "id") == 0) - cpp_opts->warn_normalize = normalized_identifier_C; - else if (strcasecmp (arg, "nfc") == 0) - cpp_opts->warn_normalize = normalized_C; - else - error ("argument %qs to %<-Wnormalized%> not recognized", arg); - break; - - case OPT_Wreturn_type: - warn_return_type = value; - break; - - case OPT_Wstrict_null_sentinel: - warn_strict_null_sentinel = value; - break; - - case OPT_Wtraditional: - cpp_opts->warn_traditional = value; - break; - - case OPT_Wtrigraphs: - cpp_opts->warn_trigraphs = value; - break; - - case OPT_Wundef: - cpp_opts->warn_undef = value; - break; - - case OPT_Wunknown_pragmas: - /* Set to greater than 1, so that even unknown pragmas in - system headers will be warned about. */ - warn_unknown_pragmas = value * 2; - break; - - case OPT_Wunused_macros: - warn_unused_macros = value; - break; - - case OPT_Wvariadic_macros: - warn_variadic_macros = value; - break; - - case OPT_Wwrite_strings: - warn_write_strings = value; - break; - - case OPT_Weffc__: - warn_ecpp = value; - if (value) - warn_nonvdtor = true; - break; - - case OPT_ansi: - if (!c_dialect_cxx ()) - set_std_c89 (false, true); - else - set_std_cxx98 (true); - break; - - case OPT_d: - handle_OPT_d (arg); - break; - - case OPT_fcond_mismatch: - if (!c_dialect_cxx ()) - { - flag_cond_mismatch = value; - break; - } - /* Fall through. */ - - case OPT_fall_virtual: - case OPT_falt_external_templates: - case OPT_fenum_int_equiv: - case OPT_fexternal_templates: - case OPT_fguiding_decls: - case OPT_fhonor_std: - case OPT_fhuge_objects: - case OPT_flabels_ok: - case OPT_fname_mangling_version_: - case OPT_fnew_abi: - case OPT_fnonnull_objects: - case OPT_fsquangle: - case OPT_fstrict_prototype: - case OPT_fthis_is_variable: - case OPT_fvtable_thunks: - case OPT_fxref: - case OPT_fvtable_gc: - warning (0, "switch %qs is no longer supported", option->opt_text); - break; - - case OPT_faccess_control: - flag_access_control = value; - break; - - case OPT_fasm: - flag_no_asm = !value; - break; - - case OPT_fbuiltin: - flag_no_builtin = !value; - break; - - case OPT_fbuiltin_: - if (value) - result = 0; - else - disable_builtin_function (arg); - break; - - case OPT_fdirectives_only: - cpp_opts->directives_only = value; - break; - - case OPT_fdollars_in_identifiers: - cpp_opts->dollars_in_ident = value; - break; - - case OPT_ffreestanding: - value = !value; - /* Fall through.... */ - case OPT_fhosted: - flag_hosted = value; - flag_no_builtin = !value; - break; - - case OPT_fshort_double: - flag_short_double = value; - break; - - case OPT_fshort_enums: - flag_short_enums = value; - break; - - case OPT_fshort_wchar: - flag_short_wchar = value; - break; - - case OPT_fsigned_bitfields: - flag_signed_bitfields = value; - break; - - case OPT_fsigned_char: - flag_signed_char = value; - break; - - case OPT_funsigned_bitfields: - flag_signed_bitfields = !value; - break; - - case OPT_funsigned_char: - flag_signed_char = !value; - break; - - case OPT_fcheck_new: - flag_check_new = value; - break; - - case OPT_fconserve_space: - flag_conserve_space = value; - break; - - case OPT_fconstant_string_class_: - constant_string_class_name = arg; - break; - - case OPT_fdefault_inline: - flag_default_inline = value; - break; - - case OPT_felide_constructors: - flag_elide_constructors = value; - break; - - case OPT_fenforce_eh_specs: - flag_enforce_eh_specs = value; - break; - - case OPT_fextended_identifiers: - cpp_opts->extended_identifiers = value; - break; - - case OPT_ffor_scope: - flag_new_for_scope = value; - break; - - case OPT_fgnu_keywords: - flag_no_gnu_keywords = !value; - break; - - case OPT_fgnu_runtime: - flag_next_runtime = !value; - break; - - case OPT_fhandle_exceptions: - warning (0, "-fhandle-exceptions has been renamed -fexceptions (and is now on by default)"); - flag_exceptions = value; - break; - - case OPT_fimplement_inlines: - flag_implement_inlines = value; - break; - - case OPT_fimplicit_inline_templates: - flag_implicit_inline_templates = value; - break; - - case OPT_fimplicit_templates: - flag_implicit_templates = value; - break; - - case OPT_flax_vector_conversions: - flag_lax_vector_conversions = value; - break; - - case OPT_fms_extensions: - flag_ms_extensions = value; - break; - - case OPT_fnext_runtime: - flag_next_runtime = value; - break; - - case OPT_fnil_receivers: - flag_nil_receivers = value; - break; - - case OPT_fnonansi_builtins: - flag_no_nonansi_builtin = !value; - break; - - case OPT_foperator_names: - cpp_opts->operator_names = value; - break; - - case OPT_foptional_diags: - flag_optional_diags = value; - break; - - case OPT_fpch_deps: - cpp_opts->restore_pch_deps = value; - break; - - case OPT_fpch_preprocess: - flag_pch_preprocess = value; - break; - - case OPT_fpermissive: - flag_permissive = value; - global_dc->permissive = value; - break; - - case OPT_fpreprocessed: - cpp_opts->preprocessed = value; - break; - - case OPT_freplace_objc_classes: - flag_replace_objc_classes = value; - break; - - case OPT_frepo: - flag_use_repository = value; - if (value) - flag_implicit_templates = 0; - break; - - case OPT_frtti: - flag_rtti = value; - break; - - case OPT_fshow_column: - cpp_opts->show_column = value; - break; - - case OPT_fstats: - flag_detailed_statistics = value; - break; - - case OPT_ftabstop_: - /* It is documented that we silently ignore silly values. */ - if (value >= 1 && value <= 100) - cpp_opts->tabstop = value; - break; - - case OPT_fexec_charset_: - cpp_opts->narrow_charset = arg; - break; - - case OPT_fwide_exec_charset_: - cpp_opts->wide_charset = arg; - break; - - case OPT_finput_charset_: - cpp_opts->input_charset = arg; - break; - - case OPT_ftemplate_depth_: - /* Kept for backwards compatibility. */ - case OPT_ftemplate_depth_eq: - max_tinst_depth = value; - break; - - case OPT_fuse_cxa_atexit: - flag_use_cxa_atexit = value; - break; - - case OPT_fuse_cxa_get_exception_ptr: - flag_use_cxa_get_exception_ptr = value; - break; - - case OPT_fvisibility_inlines_hidden: - visibility_options.inlines_hidden = value; - break; - - case OPT_fweak: - flag_weak = value; - break; - - case OPT_fthreadsafe_statics: - flag_threadsafe_statics = value; - break; - - case OPT_fpretty_templates: - flag_pretty_templates = value; - break; - - case OPT_fzero_link: - flag_zero_link = value; - break; - - case OPT_gen_decls: - flag_gen_declaration = 1; - break; - - case OPT_femit_struct_debug_baseonly: - set_struct_debug_option ("base"); - break; - - case OPT_femit_struct_debug_reduced: - set_struct_debug_option ("dir:ord:sys,dir:gen:any,ind:base"); - break; - - case OPT_femit_struct_debug_detailed_: - set_struct_debug_option (arg); - break; - - case OPT_idirafter: - add_path (xstrdup (arg), AFTER, 0, true); - break; - - case OPT_imacros: - case OPT_include: - defer_opt (code, arg); - break; - - case OPT_imultilib: - imultilib = arg; - break; - - case OPT_iprefix: - iprefix = arg; - break; - - case OPT_iquote: - add_path (xstrdup (arg), QUOTE, 0, true); - break; - - case OPT_isysroot: - sysroot = arg; - break; - - case OPT_isystem: - add_path (xstrdup (arg), SYSTEM, 0, true); - break; - - case OPT_iwithprefix: - add_prefixed_path (arg, SYSTEM); - break; - - case OPT_iwithprefixbefore: - add_prefixed_path (arg, BRACKET); - break; - - case OPT_lang_asm: - cpp_set_lang (parse_in, CLK_ASM); - cpp_opts->dollars_in_ident = false; - break; - - case OPT_lang_objc: - cpp_opts->objc = 1; - break; - - case OPT_nostdinc: - std_inc = false; - break; - - case OPT_nostdinc__: - std_cxx_inc = false; - break; - - case OPT_o: - if (!out_fname) - out_fname = arg; - else - error ("output filename specified twice"); - break; - - /* We need to handle the -pedantic switches here, rather than in - c_common_post_options, so that a subsequent -Wno-endif-labels - is not overridden. */ - case OPT_pedantic_errors: - case OPT_pedantic: - cpp_opts->pedantic = 1; - cpp_opts->warn_endif_labels = 1; - if (warn_pointer_sign == -1) - warn_pointer_sign = 1; - if (warn_overlength_strings == -1) - warn_overlength_strings = 1; - if (warn_main == -1) - warn_main = 2; - break; - - case OPT_print_objc_runtime_info: - print_struct_values = 1; - break; - - case OPT_print_pch_checksum: - c_common_print_pch_checksum (stdout); - exit_after_options = true; - break; - - case OPT_remap: - cpp_opts->remap = 1; - break; - - case OPT_std_c__98: - case OPT_std_gnu__98: - if (!preprocessing_asm_p) - set_std_cxx98 (code == OPT_std_c__98 /* ISO */); - break; - - case OPT_std_c__0x: - case OPT_std_gnu__0x: - if (!preprocessing_asm_p) - set_std_cxx0x (code == OPT_std_c__0x /* ISO */); - break; - - case OPT_std_c89: - case OPT_std_c90: - case OPT_std_iso9899_1990: - case OPT_std_iso9899_199409: - if (!preprocessing_asm_p) - set_std_c89 (code == OPT_std_iso9899_199409 /* c94 */, true /* ISO */); - break; - - case OPT_std_gnu89: - case OPT_std_gnu90: - if (!preprocessing_asm_p) - set_std_c89 (false /* c94 */, false /* ISO */); - break; - - case OPT_std_c99: - case OPT_std_c9x: - case OPT_std_iso9899_1999: - case OPT_std_iso9899_199x: - if (!preprocessing_asm_p) - set_std_c99 (true /* ISO */); - break; - - case OPT_std_gnu99: - case OPT_std_gnu9x: - if (!preprocessing_asm_p) - set_std_c99 (false /* ISO */); - break; - - case OPT_std_c1x: - if (!preprocessing_asm_p) - set_std_c1x (true /* ISO */); - break; - - case OPT_std_gnu1x: - if (!preprocessing_asm_p) - set_std_c1x (false /* ISO */); - break; - - case OPT_trigraphs: - cpp_opts->trigraphs = 1; - break; - - case OPT_traditional_cpp: - cpp_opts->traditional = 1; - break; - - case OPT_undef: - flag_undef = 1; - break; - - case OPT_v: - verbose = true; - break; - - case OPT_Wabi: - warn_psabi = value; - break; - } - - return result; -} - -/* Post-switch processing. */ -bool -c_common_post_options (const char **pfilename) -{ - struct cpp_callbacks *cb; - - /* Canonicalize the input and output filenames. */ - if (in_fnames == NULL) - { - in_fnames = XNEWVEC (const char *, 1); - in_fnames[0] = ""; - } - else if (strcmp (in_fnames[0], "-") == 0) - in_fnames[0] = ""; - - if (out_fname == NULL || !strcmp (out_fname, "-")) - out_fname = ""; - - if (cpp_opts->deps.style == DEPS_NONE) - check_deps_environment_vars (); - - handle_deferred_opts (); - - sanitize_cpp_opts (); - - register_include_chains (parse_in, sysroot, iprefix, imultilib, - std_inc, std_cxx_inc && c_dialect_cxx (), verbose); - -#ifdef C_COMMON_OVERRIDE_OPTIONS - /* Some machines may reject certain combinations of C - language-specific options. */ - C_COMMON_OVERRIDE_OPTIONS; -#endif - - /* Excess precision other than "fast" requires front-end - support. */ - if (c_dialect_cxx ()) - { - if (flag_excess_precision_cmdline == EXCESS_PRECISION_STANDARD - && TARGET_FLT_EVAL_METHOD_NON_DEFAULT) - sorry ("-fexcess-precision=standard for C++"); - flag_excess_precision_cmdline = EXCESS_PRECISION_FAST; - } - else if (flag_excess_precision_cmdline == EXCESS_PRECISION_DEFAULT) - flag_excess_precision_cmdline = (flag_iso - ? EXCESS_PRECISION_STANDARD - : EXCESS_PRECISION_FAST); - - /* By default we use C99 inline semantics in GNU99 or C99 mode. C99 - inline semantics are not supported in GNU89 or C89 mode. */ - if (flag_gnu89_inline == -1) - flag_gnu89_inline = !flag_isoc99; - else if (!flag_gnu89_inline && !flag_isoc99) - error ("-fno-gnu89-inline is only supported in GNU99 or C99 mode"); - - /* Default to ObjC sjlj exception handling if NeXT runtime. */ - if (flag_objc_sjlj_exceptions < 0) - flag_objc_sjlj_exceptions = flag_next_runtime; - if (flag_objc_exceptions && !flag_objc_sjlj_exceptions) - flag_exceptions = 1; - - /* -Wextra implies the following flags - unless explicitly overridden. */ - if (warn_type_limits == -1) - warn_type_limits = extra_warnings; - if (warn_clobbered == -1) - warn_clobbered = extra_warnings; - if (warn_empty_body == -1) - warn_empty_body = extra_warnings; - if (warn_sign_compare == -1) - warn_sign_compare = extra_warnings; - if (warn_missing_field_initializers == -1) - warn_missing_field_initializers = extra_warnings; - if (warn_missing_parameter_type == -1) - warn_missing_parameter_type = extra_warnings; - if (warn_old_style_declaration == -1) - warn_old_style_declaration = extra_warnings; - if (warn_override_init == -1) - warn_override_init = extra_warnings; - if (warn_ignored_qualifiers == -1) - warn_ignored_qualifiers = extra_warnings; - - /* -Wpointer-sign is disabled by default, but it is enabled if any - of -Wall or -pedantic are given. */ - if (warn_pointer_sign == -1) - warn_pointer_sign = 0; - - if (warn_strict_aliasing == -1) - warn_strict_aliasing = 0; - if (warn_strict_overflow == -1) - warn_strict_overflow = 0; - if (warn_jump_misses_init == -1) - warn_jump_misses_init = 0; - - /* -Woverlength-strings is off by default, but is enabled by -pedantic. - It is never enabled in C++, as the minimum limit is not normative - in that standard. */ - if (warn_overlength_strings == -1 || c_dialect_cxx ()) - warn_overlength_strings = 0; - - /* Wmain is enabled by default in C++ but not in C. */ - /* Wmain is disabled by default for -ffreestanding (!flag_hosted), - even if -Wall was given (warn_main will be 2 if set by -Wall, 1 - if set by -Wmain). */ - if (warn_main == -1) - warn_main = (c_dialect_cxx () && flag_hosted) ? 1 : 0; - else if (warn_main == 2) - warn_main = flag_hosted ? 1 : 0; - - /* In C, -Wconversion enables -Wsign-conversion (unless disabled - through -Wno-sign-conversion). While in C++, - -Wsign-conversion needs to be requested explicitly. */ - if (warn_sign_conversion == -1) - warn_sign_conversion = (c_dialect_cxx ()) ? 0 : warn_conversion; - - /* In C, -Wall and -Wc++-compat enable -Wenum-compare, which we do - in c_common_handle_option; if it has not yet been set, it is - disabled by default. In C++, it is enabled by default. */ - if (warn_enum_compare == -1) - warn_enum_compare = c_dialect_cxx () ? 1 : 0; - - /* -Wpacked-bitfield-compat is on by default for the C languages. The - warning is issued in stor-layout.c which is not part of the front-end so - we need to selectively turn it on here. */ - if (warn_packed_bitfield_compat == -1) - warn_packed_bitfield_compat = 1; - - /* Special format checking options don't work without -Wformat; warn if - they are used. */ - if (!warn_format) - { - warning (OPT_Wformat_y2k, - "-Wformat-y2k ignored without -Wformat"); - warning (OPT_Wformat_extra_args, - "-Wformat-extra-args ignored without -Wformat"); - warning (OPT_Wformat_zero_length, - "-Wformat-zero-length ignored without -Wformat"); - warning (OPT_Wformat_nonliteral, - "-Wformat-nonliteral ignored without -Wformat"); - warning (OPT_Wformat_contains_nul, - "-Wformat-contains-nul ignored without -Wformat"); - warning (OPT_Wformat_security, - "-Wformat-security ignored without -Wformat"); - } - - if (warn_implicit == -1) - warn_implicit = 0; - - if (warn_implicit_int == -1) - warn_implicit_int = 0; - - /* -Wimplicit-function-declaration is enabled by default for C99. */ - if (warn_implicit_function_declaration == -1) - warn_implicit_function_declaration = flag_isoc99; - - /* If we're allowing C++0x constructs, don't warn about C++0x - compatibility problems. */ - if (cxx_dialect == cxx0x) - warn_cxx0x_compat = 0; - - if (flag_preprocess_only) - { - /* Open the output now. We must do so even if flag_no_output is - on, because there may be other output than from the actual - preprocessing (e.g. from -dM). */ - if (out_fname[0] == '\0') - out_stream = stdout; - else - out_stream = fopen (out_fname, "w"); - - if (out_stream == NULL) - { - fatal_error ("opening output file %s: %m", out_fname); - return false; - } - - if (num_in_fnames > 1) - error ("too many filenames given. Type %s --help for usage", - progname); - - init_pp_output (out_stream); - } - else - { - init_c_lex (); - - /* Yuk. WTF is this? I do know ObjC relies on it somewhere. */ - input_location = UNKNOWN_LOCATION; - } - - cb = cpp_get_callbacks (parse_in); - cb->file_change = cb_file_change; - cb->dir_change = cb_dir_change; - cpp_post_options (parse_in); - - input_location = UNKNOWN_LOCATION; - - *pfilename = this_input_filename - = cpp_read_main_file (parse_in, in_fnames[0]); - /* Don't do any compilation or preprocessing if there is no input file. */ - if (this_input_filename == NULL) - { - errorcount++; - return false; - } - - if (flag_working_directory - && flag_preprocess_only && !flag_no_line_commands) - pp_dir_change (parse_in, get_src_pwd ()); - - return flag_preprocess_only; -} - -/* Front end initialization common to C, ObjC and C++. */ -bool -c_common_init (void) -{ - /* Set up preprocessor arithmetic. Must be done after call to - c_common_nodes_and_builtins for type nodes to be good. */ - cpp_opts->precision = TYPE_PRECISION (intmax_type_node); - cpp_opts->char_precision = TYPE_PRECISION (char_type_node); - cpp_opts->int_precision = TYPE_PRECISION (integer_type_node); - cpp_opts->wchar_precision = TYPE_PRECISION (wchar_type_node); - cpp_opts->unsigned_wchar = TYPE_UNSIGNED (wchar_type_node); - cpp_opts->bytes_big_endian = BYTES_BIG_ENDIAN; - - /* This can't happen until after wchar_precision and bytes_big_endian - are known. */ - cpp_init_iconv (parse_in); - - if (version_flag) - c_common_print_pch_checksum (stderr); - - /* Has to wait until now so that cpplib has its hash table. */ - init_pragma (); - - if (flag_preprocess_only) - { - finish_options (); - preprocess_file (parse_in); - return false; - } - - return true; -} - -/* Initialize the integrated preprocessor after debug output has been - initialized; loop over each input file. */ -void -c_common_parse_file (int set_yydebug) -{ - unsigned int i; - - if (set_yydebug) - switch (c_language) - { - case clk_c: - warning(0, "The C parser does not support -dy, option ignored"); - break; - case clk_objc: - warning(0, - "The Objective-C parser does not support -dy, option ignored"); - break; - case clk_cxx: - warning(0, "The C++ parser does not support -dy, option ignored"); - break; - case clk_objcxx: - warning(0, - "The Objective-C++ parser does not support -dy, option ignored"); - break; - default: - gcc_unreachable (); - } - - i = 0; - for (;;) - { - finish_options (); - pch_init (); - push_file_scope (); - c_parse_file (); - finish_file (); - pop_file_scope (); - /* And end the main input file, if the debug writer wants it */ - if (debug_hooks->start_end_main_source_file) - (*debug_hooks->end_source_file) (0); - if (++i >= num_in_fnames) - break; - cpp_undef_all (parse_in); - cpp_clear_file_cache (parse_in); - this_input_filename - = cpp_read_main_file (parse_in, in_fnames[i]); - /* If an input file is missing, abandon further compilation. - cpplib has issued a diagnostic. */ - if (!this_input_filename) - break; - } -} - -/* Common finish hook for the C, ObjC and C++ front ends. */ -void -c_common_finish (void) -{ - FILE *deps_stream = NULL; - - /* Don't write the deps file if there are errors. */ - if (cpp_opts->deps.style != DEPS_NONE && !seen_error ()) - { - /* If -M or -MM was seen without -MF, default output to the - output stream. */ - if (!deps_file) - deps_stream = out_stream; - else - { - deps_stream = fopen (deps_file, deps_append ? "a": "w"); - if (!deps_stream) - fatal_error ("opening dependency file %s: %m", deps_file); - } - } - - /* For performance, avoid tearing down cpplib's internal structures - with cpp_destroy (). */ - cpp_finish (parse_in, deps_stream); - - if (deps_stream && deps_stream != out_stream - && (ferror (deps_stream) || fclose (deps_stream))) - fatal_error ("closing dependency file %s: %m", deps_file); - - if (out_stream && (ferror (out_stream) || fclose (out_stream))) - fatal_error ("when writing output to %s: %m", out_fname); -} - -/* Either of two environment variables can specify output of - dependencies. Their value is either "OUTPUT_FILE" or "OUTPUT_FILE - DEPS_TARGET", where OUTPUT_FILE is the file to write deps info to - and DEPS_TARGET is the target to mention in the deps. They also - result in dependency information being appended to the output file - rather than overwriting it, and like Sun's compiler - SUNPRO_DEPENDENCIES suppresses the dependency on the main file. */ -static void -check_deps_environment_vars (void) -{ - char *spec; - - GET_ENVIRONMENT (spec, "DEPENDENCIES_OUTPUT"); - if (spec) - cpp_opts->deps.style = DEPS_USER; - else - { - GET_ENVIRONMENT (spec, "SUNPRO_DEPENDENCIES"); - if (spec) - { - cpp_opts->deps.style = DEPS_SYSTEM; - cpp_opts->deps.ignore_main_file = true; - } - } - - if (spec) - { - /* Find the space before the DEPS_TARGET, if there is one. */ - char *s = strchr (spec, ' '); - if (s) - { - /* Let the caller perform MAKE quoting. */ - defer_opt (OPT_MT, s + 1); - *s = '\0'; - } - - /* Command line -MF overrides environment variables and default. */ - if (!deps_file) - deps_file = spec; - - deps_append = 1; - deps_seen = true; - } -} - -/* Handle deferred command line switches. */ -static void -handle_deferred_opts (void) -{ - size_t i; - struct deps *deps; - - /* Avoid allocating the deps buffer if we don't need it. - (This flag may be true without there having been -MT or -MQ - options, but we'll still need the deps buffer.) */ - if (!deps_seen) - return; - - deps = cpp_get_deps (parse_in); - - for (i = 0; i < deferred_count; i++) - { - struct deferred_opt *opt = &deferred_opts[i]; - - if (opt->code == OPT_MT || opt->code == OPT_MQ) - deps_add_target (deps, opt->arg, opt->code == OPT_MQ); - } -} - -/* These settings are appropriate for GCC, but not necessarily so for - cpplib as a library. */ -static void -sanitize_cpp_opts (void) -{ - /* If we don't know what style of dependencies to output, complain - if any other dependency switches have been given. */ - if (deps_seen && cpp_opts->deps.style == DEPS_NONE) - error ("to generate dependencies you must specify either -M or -MM"); - - /* -dM and dependencies suppress normal output; do it here so that - the last -d[MDN] switch overrides earlier ones. */ - if (flag_dump_macros == 'M') - flag_no_output = 1; - - /* By default, -fdirectives-only implies -dD. This allows subsequent phases - to perform proper macro expansion. */ - if (cpp_opts->directives_only && !cpp_opts->preprocessed && !flag_dump_macros) - flag_dump_macros = 'D'; - - /* Disable -dD, -dN and -dI if normal output is suppressed. Allow - -dM since at least glibc relies on -M -dM to work. */ - /* Also, flag_no_output implies flag_no_line_commands, always. */ - if (flag_no_output) - { - if (flag_dump_macros != 'M') - flag_dump_macros = 0; - flag_dump_includes = 0; - flag_no_line_commands = 1; - } - else if (cpp_opts->deps.missing_files) - error ("-MG may only be used with -M or -MM"); - - cpp_opts->unsigned_char = !flag_signed_char; - cpp_opts->stdc_0_in_system_headers = STDC_0_IN_SYSTEM_HEADERS; - - /* Wlong-long is disabled by default. It is enabled by: - [-pedantic | -Wtraditional] -std=[gnu|c]++98 ; or - [-pedantic | -Wtraditional] -std=non-c99 . - - Either -Wlong-long or -Wno-long-long override any other settings. */ - if (warn_long_long == -1) - warn_long_long = ((pedantic || warn_traditional) - && (c_dialect_cxx () ? cxx_dialect == cxx98 : !flag_isoc99)); - cpp_opts->warn_long_long = warn_long_long; - - /* Similarly with -Wno-variadic-macros. No check for c99 here, since - this also turns off warnings about GCCs extension. */ - cpp_opts->warn_variadic_macros - = warn_variadic_macros && (pedantic || warn_traditional); - - /* If we're generating preprocessor output, emit current directory - if explicitly requested or if debugging information is enabled. - ??? Maybe we should only do it for debugging formats that - actually output the current directory? */ - if (flag_working_directory == -1) - flag_working_directory = (debug_info_level != DINFO_LEVEL_NONE); - - if (cpp_opts->directives_only) - { - if (warn_unused_macros) - error ("-fdirectives-only is incompatible with -Wunused_macros"); - if (cpp_opts->traditional) - error ("-fdirectives-only is incompatible with -traditional"); - } -} - -/* Add include path with a prefix at the front of its name. */ -static void -add_prefixed_path (const char *suffix, size_t chain) -{ - char *path; - const char *prefix; - size_t prefix_len, suffix_len; - - suffix_len = strlen (suffix); - prefix = iprefix ? iprefix : cpp_GCC_INCLUDE_DIR; - prefix_len = iprefix ? strlen (iprefix) : cpp_GCC_INCLUDE_DIR_len; - - path = (char *) xmalloc (prefix_len + suffix_len + 1); - memcpy (path, prefix, prefix_len); - memcpy (path + prefix_len, suffix, suffix_len); - path[prefix_len + suffix_len] = '\0'; - - add_path (path, chain, 0, false); -} - -/* Handle -D, -U, -A, -imacros, and the first -include. */ -static void -finish_options (void) -{ - if (!cpp_opts->preprocessed) - { - size_t i; - - cb_file_change (parse_in, - linemap_add (line_table, LC_RENAME, 0, - _(""), 0)); - - cpp_init_builtins (parse_in, flag_hosted); - c_cpp_builtins (parse_in); - - /* We're about to send user input to cpplib, so make it warn for - things that we previously (when we sent it internal definitions) - told it to not warn. - - C99 permits implementation-defined characters in identifiers. - The documented meaning of -std= is to turn off extensions that - conflict with the specified standard, and since a strictly - conforming program cannot contain a '$', we do not condition - their acceptance on the -std= setting. */ - cpp_opts->warn_dollars = (cpp_opts->pedantic && !cpp_opts->c99); - - cb_file_change (parse_in, - linemap_add (line_table, LC_RENAME, 0, - _(""), 0)); - - for (i = 0; i < deferred_count; i++) - { - struct deferred_opt *opt = &deferred_opts[i]; - - if (opt->code == OPT_D) - cpp_define (parse_in, opt->arg); - else if (opt->code == OPT_U) - cpp_undef (parse_in, opt->arg); - else if (opt->code == OPT_A) - { - if (opt->arg[0] == '-') - cpp_unassert (parse_in, opt->arg + 1); - else - cpp_assert (parse_in, opt->arg); - } - } - - /* Start the main input file, if the debug writer wants it. */ - if (debug_hooks->start_end_main_source_file - && !flag_preprocess_only) - (*debug_hooks->start_source_file) (0, this_input_filename); - - /* Handle -imacros after -D and -U. */ - for (i = 0; i < deferred_count; i++) - { - struct deferred_opt *opt = &deferred_opts[i]; - - if (opt->code == OPT_imacros - && cpp_push_include (parse_in, opt->arg)) - { - /* Disable push_command_line_include callback for now. */ - include_cursor = deferred_count + 1; - cpp_scan_nooutput (parse_in); - } - } - } - else - { - if (cpp_opts->directives_only) - cpp_init_special_builtins (parse_in); - - /* Start the main input file, if the debug writer wants it. */ - if (debug_hooks->start_end_main_source_file - && !flag_preprocess_only) - (*debug_hooks->start_source_file) (0, this_input_filename); - } - - include_cursor = 0; - push_command_line_include (); -} - -/* Give CPP the next file given by -include, if any. */ -static void -push_command_line_include (void) -{ - while (include_cursor < deferred_count) - { - struct deferred_opt *opt = &deferred_opts[include_cursor++]; - - if (!cpp_opts->preprocessed && opt->code == OPT_include - && cpp_push_include (parse_in, opt->arg)) - return; - } - - if (include_cursor == deferred_count) - { - include_cursor++; - /* -Wunused-macros should only warn about macros defined hereafter. */ - cpp_opts->warn_unused_macros = warn_unused_macros; - /* Restore the line map from . */ - if (!cpp_opts->preprocessed) - cpp_change_file (parse_in, LC_RENAME, this_input_filename); - - /* Set this here so the client can change the option if it wishes, - and after stacking the main file so we don't trace the main file. */ - line_table->trace_includes = cpp_opts->print_include_names; - } -} - -/* File change callback. Has to handle -include files. */ -static void -cb_file_change (cpp_reader * ARG_UNUSED (pfile), - const struct line_map *new_map) -{ - if (flag_preprocess_only) - pp_file_change (new_map); - else - fe_file_change (new_map); - - if (new_map == 0 || (new_map->reason == LC_LEAVE && MAIN_FILE_P (new_map))) - push_command_line_include (); -} - -void -cb_dir_change (cpp_reader * ARG_UNUSED (pfile), const char *dir) -{ - if (!set_src_pwd (dir)) - warning (0, "too late for # directive to set debug directory"); -} - -/* Set the C 89 standard (with 1994 amendments if C94, without GNU - extensions if ISO). There is no concept of gnu94. */ -static void -set_std_c89 (int c94, int iso) -{ - cpp_set_lang (parse_in, c94 ? CLK_STDC94: iso ? CLK_STDC89: CLK_GNUC89); - flag_iso = iso; - flag_no_asm = iso; - flag_no_gnu_keywords = iso; - flag_no_nonansi_builtin = iso; - flag_isoc94 = c94; - flag_isoc99 = 0; - flag_isoc1x = 0; -} - -/* Set the C 99 standard (without GNU extensions if ISO). */ -static void -set_std_c99 (int iso) -{ - cpp_set_lang (parse_in, iso ? CLK_STDC99: CLK_GNUC99); - flag_no_asm = iso; - flag_no_nonansi_builtin = iso; - flag_iso = iso; - flag_isoc1x = 0; - flag_isoc99 = 1; - flag_isoc94 = 1; -} - -/* Set the C 1X standard draft (without GNU extensions if ISO). */ -static void -set_std_c1x (int iso) -{ - cpp_set_lang (parse_in, iso ? CLK_STDC1X: CLK_GNUC1X); - flag_no_asm = iso; - flag_no_nonansi_builtin = iso; - flag_iso = iso; - flag_isoc1x = 1; - flag_isoc99 = 1; - flag_isoc94 = 1; -} - -/* Set the C++ 98 standard (without GNU extensions if ISO). */ -static void -set_std_cxx98 (int iso) -{ - cpp_set_lang (parse_in, iso ? CLK_CXX98: CLK_GNUCXX); - flag_no_gnu_keywords = iso; - flag_no_nonansi_builtin = iso; - flag_iso = iso; - cxx_dialect = cxx98; -} - -/* Set the C++ 0x working draft "standard" (without GNU extensions if ISO). */ -static void -set_std_cxx0x (int iso) -{ - cpp_set_lang (parse_in, iso ? CLK_CXX0X: CLK_GNUCXX0X); - flag_no_gnu_keywords = iso; - flag_no_nonansi_builtin = iso; - flag_iso = iso; - cxx_dialect = cxx0x; -} - -/* Args to -d specify what to dump. Silently ignore - unrecognized options; they may be aimed at toplev.c. */ -static void -handle_OPT_d (const char *arg) -{ - char c; - - while ((c = *arg++) != '\0') - switch (c) - { - case 'M': /* Dump macros only. */ - case 'N': /* Dump names. */ - case 'D': /* Dump definitions. */ - case 'U': /* Dump used macros. */ - flag_dump_macros = c; - break; - - case 'I': - flag_dump_includes = 1; - break; - } -} diff --git a/gcc/c-parser.c b/gcc/c-parser.c index b30b0636ec0..0493524a1b2 100644 --- a/gcc/c-parser.c +++ b/gcc/c-parser.c @@ -46,13 +46,13 @@ along with GCC; see the file COPYING3. If not see #include "input.h" #include "cpplib.h" #include "timevar.h" -#include "c-pragma.h" +#include "c-family/c-pragma.h" #include "c-tree.h" #include "flags.h" #include "output.h" #include "toplev.h" #include "ggc.h" -#include "c-common.h" +#include "c-family/c-common.h" #include "vec.h" #include "target.h" #include "cgraph.h" @@ -86,7 +86,7 @@ c_parse_init (void) if (!c_dialect_objc ()) mask |= D_OBJC | D_CXX_OBJC; - ridpointers = GGC_CNEWVEC (tree, (int) RID_MAX); + ridpointers = ggc_alloc_cleared_vec_tree ((int) RID_MAX); for (i = 0; i < num_c_common_reswords; i++) { /* If a keyword is disabled, do not enter it into the table @@ -2706,7 +2706,7 @@ c_parser_parms_declarator (c_parser *parser, bool id_list_ok, tree attrs) static struct c_arg_info * c_parser_parms_list_declarator (c_parser *parser, tree attrs) { - bool good_parm = false; + bool bad_parm = false; /* ??? Following the old parser, forward parameter declarations may use abstract declarators, and if no real parameter declarations follow the forward declarations then this is not diagnosed. Also @@ -2758,11 +2758,10 @@ c_parser_parms_list_declarator (c_parser *parser, tree attrs) /* Parse a parameter. */ struct c_parm *parm = c_parser_parameter_declaration (parser, attrs); attrs = NULL_TREE; - if (parm != NULL) - { - good_parm = true; - push_parm_decl (parm); - } + if (parm == NULL) + bad_parm = true; + else + push_parm_decl (parm); if (c_parser_next_token_is (parser, CPP_SEMICOLON)) { tree new_attrs; @@ -2774,20 +2773,13 @@ c_parser_parms_list_declarator (c_parser *parser, tree attrs) if (c_parser_next_token_is (parser, CPP_CLOSE_PAREN)) { c_parser_consume_token (parser); - if (good_parm) - return get_parm_info (false); - else + if (bad_parm) { - struct c_arg_info *ret - = XOBNEW (&parser_obstack, struct c_arg_info); - ret->parms = 0; - ret->tags = 0; - ret->types = 0; - ret->others = 0; - ret->pending_sizes = 0; - ret->had_vla_unspec = 0; - return ret; + get_pending_sizes (); + return NULL; } + else + return get_parm_info (false); } if (!c_parser_require (parser, CPP_COMMA, "expected %<;%>, %<,%> or %<)%>")) @@ -2802,20 +2794,13 @@ c_parser_parms_list_declarator (c_parser *parser, tree attrs) if (c_parser_next_token_is (parser, CPP_CLOSE_PAREN)) { c_parser_consume_token (parser); - if (good_parm) - return get_parm_info (true); - else + if (bad_parm) { - struct c_arg_info *ret - = XOBNEW (&parser_obstack, struct c_arg_info); - ret->parms = 0; - ret->tags = 0; - ret->types = 0; - ret->others = 0; - ret->pending_sizes = 0; - ret->had_vla_unspec = 0; - return ret; + get_pending_sizes (); + return NULL; } + else + return get_parm_info (true); } else { @@ -2841,10 +2826,22 @@ c_parser_parameter_declaration (c_parser *parser, tree attrs) bool dummy = false; if (!c_parser_next_token_starts_declspecs (parser)) { + c_token *token = c_parser_peek_token (parser); + if (parser->error) + return NULL; + c_parser_set_source_position_from_token (token); + if (token->type == CPP_NAME + && c_parser_peek_2nd_token (parser)->type != CPP_COMMA + && c_parser_peek_2nd_token (parser)->type != CPP_CLOSE_PAREN) + { + error ("unknown type name %qE", token->value); + parser->error = true; + } /* ??? In some Objective-C cases '...' isn't applicable so there should be a different message. */ - c_parser_error (parser, - "expected declaration specifiers or %<...%>"); + else + c_parser_error (parser, + "expected declaration specifiers or %<...%>"); c_parser_skip_to_end_of_parameter (parser); return NULL; } @@ -4795,7 +4792,7 @@ static struct c_expr c_parser_conditional_expression (c_parser *parser, struct c_expr *after) { struct c_expr cond, exp1, exp2, ret; - location_t cond_loc, colon_loc; + location_t cond_loc, colon_loc, middle_loc; gcc_assert (!after || c_dialect_objc ()); @@ -4809,8 +4806,11 @@ c_parser_conditional_expression (c_parser *parser, struct c_expr *after) if (c_parser_next_token_is (parser, CPP_COLON)) { tree eptype = NULL_TREE; - pedwarn (c_parser_peek_token (parser)->location, OPT_pedantic, + + middle_loc = c_parser_peek_token (parser)->location; + pedwarn (middle_loc, OPT_pedantic, "ISO C forbids omitting the middle term of a ?: expression"); + warn_for_omitted_condop (middle_loc, cond.value); if (TREE_CODE (cond.value) == EXCESS_PRECISION_EXPR) { eptype = TREE_TYPE (cond.value); @@ -5601,6 +5601,7 @@ c_parser_postfix_expression (c_parser *parser) pedwarn (loc, OPT_pedantic, "ISO C forbids braced-groups within expressions"); expr.value = c_finish_stmt_expr (brace_loc, stmt); + mark_exp_read (expr.value); } else if (c_token_starts_typename (c_parser_peek_2nd_token (parser))) { @@ -8149,10 +8150,11 @@ c_parser_omp_for_loop (location_t loc, c_parser *parser, tree clauses, tree *par_clauses) { tree decl, cond, incr, save_break, save_cont, body, init, stmt, cl; - tree declv, condv, incrv, initv, for_block = NULL, ret = NULL; + tree declv, condv, incrv, initv, ret = NULL; bool fail = false, open_brace_parsed = false; int i, collapse = 1, nbraces = 0; location_t for_loc; + VEC(tree,gc) *for_block = make_tree_vector (); for (cl = clauses; cl; cl = OMP_CLAUSE_CHAIN (cl)) if (OMP_CLAUSE_CODE (cl) == OMP_CLAUSE_COLLAPSE) @@ -8184,8 +8186,7 @@ c_parser_omp_for_loop (location_t loc, if (c_parser_next_token_starts_declaration (parser)) { if (i > 0) - for_block - = tree_cons (NULL, c_begin_compound_stmt (true), for_block); + VEC_safe_push (tree, gc, for_block, c_begin_compound_stmt (true)); c_parser_declaration_or_fndef (parser, true, true, true, true, true); decl = check_for_loop_decls (for_loc); if (decl == NULL) @@ -8415,15 +8416,15 @@ c_parser_omp_for_loop (location_t loc, ret = stmt; } pop_scopes: - while (for_block) + while (!VEC_empty (tree, for_block)) { /* FIXME diagnostics: LOC below should be the actual location of this particular for block. We need to build a list of locations to go along with FOR_BLOCK. */ - stmt = c_end_compound_stmt (loc, TREE_VALUE (for_block), true); + stmt = c_end_compound_stmt (loc, VEC_pop (tree, for_block), true); add_stmt (stmt); - for_block = TREE_CHAIN (for_block); } + release_tree_vector (for_block); return ret; } @@ -8881,7 +8882,7 @@ c_parse_file (void) if (c_parser_peek_token (&tparser)->pragma_kind == PRAGMA_GCC_PCH_PREPROCESS) c_parser_pragma_pch_preprocess (&tparser); - the_parser = GGC_NEW (c_parser); + the_parser = ggc_alloc_c_parser (); *the_parser = tparser; /* Initialize EH, if we've been told to do so. */ diff --git a/gcc/c-pch.c b/gcc/c-pch.c deleted file mode 100644 index 951ab1fc303..00000000000 --- a/gcc/c-pch.c +++ /dev/null @@ -1,517 +0,0 @@ -/* Precompiled header implementation for the C languages. - Copyright (C) 2000, 2002, 2003, 2004, 2005, 2007, 2008, 2009, 2010 - 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 3, 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 COPYING3. If not see -. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "version.h" -#include "cpplib.h" -#include "tree.h" -#include "flags.h" -#include "c-common.h" -#include "output.h" -#include "toplev.h" -#include "debug.h" -#include "c-pragma.h" -#include "ggc.h" -#include "langhooks.h" -#include "hosthooks.h" -#include "target.h" -#include "opts.h" -#include "timevar.h" - -/* This is a list of flag variables that must match exactly, and their - names for the error message. The possible values for *flag_var must - fit in a 'signed char'. */ - -static const struct c_pch_matching -{ - int *flag_var; - const char *flag_name; -} pch_matching[] = { - { &flag_exceptions, "-fexceptions" }, -}; - -enum { - MATCH_SIZE = ARRAY_SIZE (pch_matching) -}; - -/* The value of the checksum in the dummy compiler that is actually - checksummed. That compiler should never be run. */ -static const char no_checksum[16] = { 0 }; - -/* Information about flags and suchlike that affect PCH validity. - - Before this structure is read, both an initial 8-character identification - string, and a 16-byte checksum, have been read and validated. */ - -struct c_pch_validity -{ - unsigned char debug_info_type; - signed char match[MATCH_SIZE]; - void (*pch_init) (void); - size_t target_data_length; -}; - -struct c_pch_header -{ - unsigned long asm_size; -}; - -#define IDENT_LENGTH 8 - -/* The file we'll be writing the PCH to. */ -static FILE *pch_outfile; - -/* The position in the assembler output file when pch_init was called. */ -static long asm_file_startpos; - -static const char *get_ident (void); - -/* Compute an appropriate 8-byte magic number for the PCH file, so that - utilities like file(1) can identify it, and so that GCC can quickly - ignore non-PCH files and PCH files that are of a completely different - format. */ - -static const char * -get_ident (void) -{ - static char result[IDENT_LENGTH]; - static const char templ[] = "gpch.013"; - static const char c_language_chars[] = "Co+O"; - - memcpy (result, templ, IDENT_LENGTH); - result[4] = c_language_chars[c_language]; - - return result; -} - -/* Prepare to write a PCH file, if one is being written. This is - called at the start of compilation. - - Also, print out the executable checksum if -fverbose-asm is in effect. */ - -void -pch_init (void) -{ - FILE *f; - struct c_pch_validity v; - void *target_validity; - static const char partial_pch[] = "gpcWrite"; - -#ifdef ASM_COMMENT_START - if (flag_verbose_asm) - { - fprintf (asm_out_file, "%s ", ASM_COMMENT_START); - c_common_print_pch_checksum (asm_out_file); - fputc ('\n', asm_out_file); - } -#endif - - if (!pch_file) - return; - - f = fopen (pch_file, "w+b"); - if (f == NULL) - fatal_error ("can%'t create precompiled header %s: %m", pch_file); - pch_outfile = f; - - gcc_assert (memcmp (executable_checksum, no_checksum, 16) != 0); - - memset (&v, '\0', sizeof (v)); - v.debug_info_type = write_symbols; - { - size_t i; - for (i = 0; i < MATCH_SIZE; i++) - { - v.match[i] = *pch_matching[i].flag_var; - gcc_assert (v.match[i] == *pch_matching[i].flag_var); - } - } - v.pch_init = &pch_init; - target_validity = targetm.get_pch_validity (&v.target_data_length); - - if (fwrite (partial_pch, IDENT_LENGTH, 1, f) != 1 - || fwrite (executable_checksum, 16, 1, f) != 1 - || fwrite (&v, sizeof (v), 1, f) != 1 - || fwrite (target_validity, v.target_data_length, 1, f) != 1) - fatal_error ("can%'t write to %s: %m", pch_file); - - /* We need to be able to re-read the output. */ - /* The driver always provides a valid -o option. */ - if (asm_file_name == NULL - || strcmp (asm_file_name, "-") == 0) - fatal_error ("%qs is not a valid output file", asm_file_name); - - asm_file_startpos = ftell (asm_out_file); - - /* Let the debugging format deal with the PCHness. */ - (*debug_hooks->handle_pch) (0); - - cpp_save_state (parse_in, f); -} - -/* Write the PCH file. This is called at the end of a compilation which - will produce a PCH file. */ - -void -c_common_write_pch (void) -{ - char *buf; - long asm_file_end; - long written; - struct c_pch_header h; - - timevar_push (TV_PCH_SAVE); - - (*debug_hooks->handle_pch) (1); - - cpp_write_pch_deps (parse_in, pch_outfile); - - asm_file_end = ftell (asm_out_file); - h.asm_size = asm_file_end - asm_file_startpos; - - if (fwrite (&h, sizeof (h), 1, pch_outfile) != 1) - fatal_error ("can%'t write %s: %m", pch_file); - - buf = XNEWVEC (char, 16384); - - if (fseek (asm_out_file, asm_file_startpos, SEEK_SET) != 0) - fatal_error ("can%'t seek in %s: %m", asm_file_name); - - for (written = asm_file_startpos; written < asm_file_end; ) - { - long size = asm_file_end - written; - if (size > 16384) - size = 16384; - if (fread (buf, size, 1, asm_out_file) != 1) - fatal_error ("can%'t read %s: %m", asm_file_name); - if (fwrite (buf, size, 1, pch_outfile) != 1) - fatal_error ("can%'t write %s: %m", pch_file); - written += size; - } - free (buf); - /* asm_out_file can be written afterwards, so fseek to clear - _IOREAD flag. */ - if (fseek (asm_out_file, 0, SEEK_END) != 0) - fatal_error ("can%'t seek in %s: %m", asm_file_name); - - gt_pch_save (pch_outfile); - - timevar_push (TV_PCH_CPP_SAVE); - cpp_write_pch_state (parse_in, pch_outfile); - timevar_pop (TV_PCH_CPP_SAVE); - - if (fseek (pch_outfile, 0, SEEK_SET) != 0 - || fwrite (get_ident (), IDENT_LENGTH, 1, pch_outfile) != 1) - fatal_error ("can%'t write %s: %m", pch_file); - - fclose (pch_outfile); - - timevar_pop (TV_PCH_SAVE); -} - -/* Check the PCH file called NAME, open on FD, to see if it can be - used in this compilation. Return 1 if valid, 0 if the file can't - be used now but might be if it's seen later in the compilation, and - 2 if this file could never be used in the compilation. */ - -int -c_common_valid_pch (cpp_reader *pfile, const char *name, int fd) -{ - int sizeread; - int result; - char ident[IDENT_LENGTH + 16]; - const char *pch_ident; - struct c_pch_validity v; - - /* Perform a quick test of whether this is a valid - precompiled header for the current language. */ - - gcc_assert (memcmp (executable_checksum, no_checksum, 16) != 0); - - sizeread = read (fd, ident, IDENT_LENGTH + 16); - if (sizeread == -1) - fatal_error ("can%'t read %s: %m", name); - else if (sizeread != IDENT_LENGTH + 16) - { - if (cpp_get_options (pfile)->warn_invalid_pch) - cpp_error (pfile, CPP_DL_WARNING, "%s: too short to be a PCH file", - name); - return 2; - } - - pch_ident = get_ident(); - if (memcmp (ident, pch_ident, IDENT_LENGTH) != 0) - { - if (cpp_get_options (pfile)->warn_invalid_pch) - { - if (memcmp (ident, pch_ident, 5) == 0) - /* It's a PCH, for the right language, but has the wrong version. - */ - cpp_error (pfile, CPP_DL_WARNING, - "%s: not compatible with this GCC version", name); - else if (memcmp (ident, pch_ident, 4) == 0) - /* It's a PCH for the wrong language. */ - cpp_error (pfile, CPP_DL_WARNING, "%s: not for %s", name, - lang_hooks.name); - else - /* Not any kind of PCH. */ - cpp_error (pfile, CPP_DL_WARNING, "%s: not a PCH file", name); - } - return 2; - } - if (memcmp (ident + IDENT_LENGTH, executable_checksum, 16) != 0) - { - if (cpp_get_options (pfile)->warn_invalid_pch) - cpp_error (pfile, CPP_DL_WARNING, - "%s: created by a different GCC executable", name); - return 2; - } - - /* At this point, we know it's a PCH file created by this - executable, so it ought to be long enough that we can read a - c_pch_validity structure. */ - if (read (fd, &v, sizeof (v)) != sizeof (v)) - fatal_error ("can%'t read %s: %m", name); - - /* The allowable debug info combinations are that either the PCH file - was built with the same as is being used now, or the PCH file was - built for some kind of debug info but now none is in use. */ - if (v.debug_info_type != write_symbols - && write_symbols != NO_DEBUG) - { - if (cpp_get_options (pfile)->warn_invalid_pch) - cpp_error (pfile, CPP_DL_WARNING, - "%s: created with -g%s, but used with -g%s", name, - debug_type_names[v.debug_info_type], - debug_type_names[write_symbols]); - return 2; - } - - /* Check flags that must match exactly. */ - { - size_t i; - for (i = 0; i < MATCH_SIZE; i++) - if (*pch_matching[i].flag_var != v.match[i]) - { - if (cpp_get_options (pfile)->warn_invalid_pch) - cpp_error (pfile, CPP_DL_WARNING, - "%s: settings for %s do not match", name, - pch_matching[i].flag_name); - return 2; - } - } - - /* If the text segment was not loaded at the same address as it was - when the PCH file was created, function pointers loaded from the - PCH will not be valid. We could in theory remap all the function - pointers, but no support for that exists at present. - Since we have the same executable, it should only be necessary to - check one function. */ - if (v.pch_init != &pch_init) - { - if (cpp_get_options (pfile)->warn_invalid_pch) - cpp_error (pfile, CPP_DL_WARNING, - "%s: had text segment at different address", name); - return 2; - } - - /* Check the target-specific validity data. */ - { - void *this_file_data = xmalloc (v.target_data_length); - const char *msg; - - if ((size_t) read (fd, this_file_data, v.target_data_length) - != v.target_data_length) - fatal_error ("can%'t read %s: %m", name); - msg = targetm.pch_valid_p (this_file_data, v.target_data_length); - free (this_file_data); - if (msg != NULL) - { - if (cpp_get_options (pfile)->warn_invalid_pch) - cpp_error (pfile, CPP_DL_WARNING, "%s: %s", name, msg); - return 2; - } - } - - /* Check the preprocessor macros are the same as when the PCH was - generated. */ - - result = cpp_valid_state (pfile, name, fd); - if (result == -1) - return 2; - else - return result == 0; -} - -/* If non-NULL, this function is called after a precompile header file - is loaded. */ -void (*lang_post_pch_load) (void); - -/* Load in the PCH file NAME, open on FD. It was originally searched for - by ORIG_NAME. */ - -void -c_common_read_pch (cpp_reader *pfile, const char *name, - int fd, const char *orig_name ATTRIBUTE_UNUSED) -{ - FILE *f; - struct c_pch_header h; - struct save_macro_data *smd; - expanded_location saved_loc; - bool saved_trace_includes; - - timevar_push (TV_PCH_RESTORE); - - f = fdopen (fd, "rb"); - if (f == NULL) - { - cpp_errno (pfile, CPP_DL_ERROR, "calling fdopen"); - close (fd); - goto end; - } - - cpp_get_callbacks (parse_in)->valid_pch = NULL; - - if (fread (&h, sizeof (h), 1, f) != 1) - { - cpp_errno (pfile, CPP_DL_ERROR, "reading"); - fclose (f); - goto end; - } - - if (!flag_preprocess_only) - { - unsigned long written; - char * buf = XNEWVEC (char, 16384); - - for (written = 0; written < h.asm_size; ) - { - long size = h.asm_size - written; - if (size > 16384) - size = 16384; - if (fread (buf, size, 1, f) != 1 - || fwrite (buf, size, 1, asm_out_file) != 1) - cpp_errno (pfile, CPP_DL_ERROR, "reading"); - written += size; - } - free (buf); - } - else - { - /* If we're preprocessing, don't write to a NULL - asm_out_file. */ - if (fseek (f, h.asm_size, SEEK_CUR) != 0) - cpp_errno (pfile, CPP_DL_ERROR, "seeking"); - } - - /* Save the location and then restore it after reading the PCH. */ - saved_loc = expand_location (line_table->highest_line); - saved_trace_includes = line_table->trace_includes; - - timevar_push (TV_PCH_CPP_RESTORE); - cpp_prepare_state (pfile, &smd); - timevar_pop (TV_PCH_CPP_RESTORE); - - gt_pch_restore (f); - - timevar_push (TV_PCH_CPP_RESTORE); - if (cpp_read_state (pfile, name, f, smd) != 0) - { - fclose (f); - timevar_pop (TV_PCH_CPP_RESTORE); - goto end; - } - timevar_pop (TV_PCH_CPP_RESTORE); - - - fclose (f); - - line_table->trace_includes = saved_trace_includes; - cpp_set_line_map (pfile, line_table); - linemap_add (line_table, LC_RENAME, 0, saved_loc.file, saved_loc.line); - - /* Give the front end a chance to take action after a PCH file has - been loaded. */ - if (lang_post_pch_load) - (*lang_post_pch_load) (); - -end: - timevar_pop (TV_PCH_RESTORE); -} - -/* Indicate that no more PCH files should be read. */ - -void -c_common_no_more_pch (void) -{ - if (cpp_get_callbacks (parse_in)->valid_pch) - { - cpp_get_callbacks (parse_in)->valid_pch = NULL; - host_hooks.gt_pch_use_address (NULL, 0, -1, 0); - } -} - -/* Handle #pragma GCC pch_preprocess, to load in the PCH file. */ - -#ifndef O_BINARY -# define O_BINARY 0 -#endif - -void -c_common_pch_pragma (cpp_reader *pfile, const char *name) -{ - int fd; - - if (!cpp_get_options (pfile)->preprocessed) - { - error ("pch_preprocess pragma should only be used with -fpreprocessed"); - inform (input_location, "use #include instead"); - return; - } - - fd = open (name, O_RDONLY | O_BINARY, 0666); - if (fd == -1) - fatal_error ("%s: couldn%'t open PCH file: %m", name); - - if (c_common_valid_pch (pfile, name, fd) != 1) - { - if (!cpp_get_options (pfile)->warn_invalid_pch) - inform (input_location, "use -Winvalid-pch for more information"); - fatal_error ("%s: PCH file was invalid", name); - } - - c_common_read_pch (pfile, name, fd, name); - - close (fd); -} - -/* Print out executable_checksum[]. */ - -void -c_common_print_pch_checksum (FILE *f) -{ - int i; - fputs ("Compiler executable checksum: ", f); - for (i = 0; i < 16; i++) - fprintf (f, "%02x", executable_checksum[i]); - putc ('\n', f); -} diff --git a/gcc/c-ppoutput.c b/gcc/c-ppoutput.c deleted file mode 100644 index 1700fae3ed0..00000000000 --- a/gcc/c-ppoutput.c +++ /dev/null @@ -1,625 +0,0 @@ -/* Preprocess only, using cpplib. - Copyright (C) 1995, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2007, - 2008, 2009 Free Software Foundation, Inc. - Written by Per Bothner, 1994-95. - - This program is free software; you can redistribute it and/or modify it - under the terms of the GNU General Public License as published by the - Free Software Foundation; either version 3, or (at your option) any - later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; see the file COPYING3. If not see - . */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "cpplib.h" -#include "../libcpp/internal.h" -#include "tree.h" -#include "c-common.h" /* For flags. */ -#include "c-pragma.h" /* For parse_in. */ - -/* Encapsulates state used to convert a stream of tokens into a text - file. */ -static struct -{ - FILE *outf; /* Stream to write to. */ - const cpp_token *prev; /* Previous token. */ - const cpp_token *source; /* Source token for spacing. */ - int src_line; /* Line number currently being written. */ - unsigned char printed; /* Nonzero if something output at line. */ - bool first_time; /* pp_file_change hasn't been called yet. */ -} print; - -/* Defined and undefined macros being queued for output with -dU at - the next newline. */ -typedef struct macro_queue -{ - struct macro_queue *next; /* Next macro in the list. */ - char *macro; /* The name of the macro if not - defined, the full definition if - defined. */ -} macro_queue; -static macro_queue *define_queue, *undef_queue; - -/* General output routines. */ -static void scan_translation_unit (cpp_reader *); -static void print_lines_directives_only (int, const void *, size_t); -static void scan_translation_unit_directives_only (cpp_reader *); -static void scan_translation_unit_trad (cpp_reader *); -static void account_for_newlines (const unsigned char *, size_t); -static int dump_macro (cpp_reader *, cpp_hashnode *, void *); -static void dump_queued_macros (cpp_reader *); - -static void print_line (source_location, const char *); -static void maybe_print_line (source_location); -static void do_line_change (cpp_reader *, const cpp_token *, - source_location, int); - -/* Callback routines for the parser. Most of these are active only - in specific modes. */ -static void cb_line_change (cpp_reader *, const cpp_token *, int); -static void cb_define (cpp_reader *, source_location, cpp_hashnode *); -static void cb_undef (cpp_reader *, source_location, cpp_hashnode *); -static void cb_used_define (cpp_reader *, source_location, cpp_hashnode *); -static void cb_used_undef (cpp_reader *, source_location, cpp_hashnode *); -static void cb_include (cpp_reader *, source_location, const unsigned char *, - const char *, int, const cpp_token **); -static void cb_ident (cpp_reader *, source_location, const cpp_string *); -static void cb_def_pragma (cpp_reader *, source_location); -static void cb_read_pch (cpp_reader *pfile, const char *name, - int fd, const char *orig_name); - -/* Preprocess and output. */ -void -preprocess_file (cpp_reader *pfile) -{ - /* A successful cpp_read_main_file guarantees that we can call - cpp_scan_nooutput or cpp_get_token next. */ - if (flag_no_output) - { - /* Scan -included buffers, then the main file. */ - while (pfile->buffer->prev) - cpp_scan_nooutput (pfile); - cpp_scan_nooutput (pfile); - } - else if (cpp_get_options (pfile)->traditional) - scan_translation_unit_trad (pfile); - else if (cpp_get_options (pfile)->directives_only - && !cpp_get_options (pfile)->preprocessed) - scan_translation_unit_directives_only (pfile); - else - scan_translation_unit (pfile); - - /* -dM command line option. Should this be elsewhere? */ - if (flag_dump_macros == 'M') - cpp_forall_identifiers (pfile, dump_macro, NULL); - - /* Flush any pending output. */ - if (print.printed) - putc ('\n', print.outf); -} - -/* Set up the callbacks as appropriate. */ -void -init_pp_output (FILE *out_stream) -{ - cpp_callbacks *cb = cpp_get_callbacks (parse_in); - - if (!flag_no_output) - { - cb->line_change = cb_line_change; - /* Don't emit #pragma or #ident directives if we are processing - assembly language; the assembler may choke on them. */ - if (cpp_get_options (parse_in)->lang != CLK_ASM) - { - cb->ident = cb_ident; - cb->def_pragma = cb_def_pragma; - } - } - - if (flag_dump_includes) - cb->include = cb_include; - - if (flag_pch_preprocess) - { - cb->valid_pch = c_common_valid_pch; - cb->read_pch = cb_read_pch; - } - - if (flag_dump_macros == 'N' || flag_dump_macros == 'D') - { - cb->define = cb_define; - cb->undef = cb_undef; - } - - if (flag_dump_macros == 'U') - { - cb->before_define = dump_queued_macros; - cb->used_define = cb_used_define; - cb->used_undef = cb_used_undef; - } - - /* Initialize the print structure. */ - print.src_line = 1; - print.printed = 0; - print.prev = 0; - print.outf = out_stream; - print.first_time = 1; -} - -/* Writes out the preprocessed file, handling spacing and paste - avoidance issues. */ -static void -scan_translation_unit (cpp_reader *pfile) -{ - bool avoid_paste = false; - bool do_line_adjustments - = cpp_get_options (parse_in)->lang != CLK_ASM - && !flag_no_line_commands; - bool in_pragma = false; - - print.source = NULL; - for (;;) - { - source_location loc; - const cpp_token *token = cpp_get_token_with_location (pfile, &loc); - - if (token->type == CPP_PADDING) - { - avoid_paste = true; - if (print.source == NULL - || (!(print.source->flags & PREV_WHITE) - && token->val.source == NULL)) - print.source = token->val.source; - continue; - } - - if (token->type == CPP_EOF) - break; - - /* Subtle logic to output a space if and only if necessary. */ - if (avoid_paste) - { - const struct line_map *map - = linemap_lookup (line_table, loc); - int src_line = SOURCE_LINE (map, loc); - - if (print.source == NULL) - print.source = token; - - if (src_line != print.src_line - && do_line_adjustments - && !in_pragma) - { - do_line_change (pfile, token, loc, false); - putc (' ', print.outf); - } - else if (print.source->flags & PREV_WHITE - || (print.prev - && cpp_avoid_paste (pfile, print.prev, token)) - || (print.prev == NULL && token->type == CPP_HASH)) - putc (' ', print.outf); - } - else if (token->flags & PREV_WHITE) - { - const struct line_map *map - = linemap_lookup (line_table, loc); - int src_line = SOURCE_LINE (map, loc); - - if (src_line != print.src_line - && do_line_adjustments - && !in_pragma) - do_line_change (pfile, token, loc, false); - putc (' ', print.outf); - } - - avoid_paste = false; - print.source = NULL; - print.prev = token; - if (token->type == CPP_PRAGMA) - { - const char *space; - const char *name; - - maybe_print_line (token->src_loc); - fputs ("#pragma ", print.outf); - c_pp_lookup_pragma (token->val.pragma, &space, &name); - if (space) - fprintf (print.outf, "%s %s", space, name); - else - fprintf (print.outf, "%s", name); - print.printed = 1; - in_pragma = true; - } - else if (token->type == CPP_PRAGMA_EOL) - { - maybe_print_line (token->src_loc); - in_pragma = false; - } - else - cpp_output_token (token, print.outf); - - if (token->type == CPP_COMMENT) - account_for_newlines (token->val.str.text, token->val.str.len); - } -} - -static void -print_lines_directives_only (int lines, const void *buf, size_t size) -{ - print.src_line += lines; - fwrite (buf, 1, size, print.outf); -} - -/* Writes out the preprocessed file, handling spacing and paste - avoidance issues. */ -static void -scan_translation_unit_directives_only (cpp_reader *pfile) -{ - struct _cpp_dir_only_callbacks cb; - - cb.print_lines = print_lines_directives_only; - cb.maybe_print_line = maybe_print_line; - - _cpp_preprocess_dir_only (pfile, &cb); -} - -/* Adjust print.src_line for newlines embedded in output. */ -static void -account_for_newlines (const unsigned char *str, size_t len) -{ - while (len--) - if (*str++ == '\n') - print.src_line++; -} - -/* Writes out a traditionally preprocessed file. */ -static void -scan_translation_unit_trad (cpp_reader *pfile) -{ - while (_cpp_read_logical_line_trad (pfile)) - { - size_t len = pfile->out.cur - pfile->out.base; - maybe_print_line (pfile->out.first_line); - fwrite (pfile->out.base, 1, len, print.outf); - print.printed = 1; - if (!CPP_OPTION (pfile, discard_comments)) - account_for_newlines (pfile->out.base, len); - } -} - -/* If the token read on logical line LINE needs to be output on a - different line to the current one, output the required newlines or - a line marker, and return 1. Otherwise return 0. */ -static void -maybe_print_line (source_location src_loc) -{ - const struct line_map *map = linemap_lookup (line_table, src_loc); - int src_line = SOURCE_LINE (map, src_loc); - /* End the previous line of text. */ - if (print.printed) - { - putc ('\n', print.outf); - print.src_line++; - print.printed = 0; - } - - if (src_line >= print.src_line && src_line < print.src_line + 8) - { - while (src_line > print.src_line) - { - putc ('\n', print.outf); - print.src_line++; - } - } - else - print_line (src_loc, ""); -} - -/* Output a line marker for logical line LINE. Special flags are "1" - or "2" indicating entering or leaving a file. */ -static void -print_line (source_location src_loc, const char *special_flags) -{ - /* End any previous line of text. */ - if (print.printed) - putc ('\n', print.outf); - print.printed = 0; - - if (!flag_no_line_commands) - { - const struct line_map *map = linemap_lookup (line_table, src_loc); - - size_t to_file_len = strlen (map->to_file); - unsigned char *to_file_quoted = - (unsigned char *) alloca (to_file_len * 4 + 1); - unsigned char *p; - - print.src_line = SOURCE_LINE (map, src_loc); - - /* cpp_quote_string does not nul-terminate, so we have to do it - ourselves. */ - p = cpp_quote_string (to_file_quoted, - (const unsigned char *) map->to_file, to_file_len); - *p = '\0'; - fprintf (print.outf, "# %u \"%s\"%s", - print.src_line == 0 ? 1 : print.src_line, - to_file_quoted, special_flags); - - if (map->sysp == 2) - fputs (" 3 4", print.outf); - else if (map->sysp == 1) - fputs (" 3", print.outf); - - putc ('\n', print.outf); - } -} - -/* Helper function for cb_line_change and scan_translation_unit. */ -static void -do_line_change (cpp_reader *pfile, const cpp_token *token, - source_location src_loc, int parsing_args) -{ - if (define_queue || undef_queue) - dump_queued_macros (pfile); - - if (token->type == CPP_EOF || parsing_args) - return; - - maybe_print_line (src_loc); - print.prev = 0; - print.source = 0; - - /* Supply enough spaces to put this token in its original column, - one space per column greater than 2, since scan_translation_unit - will provide a space if PREV_WHITE. Don't bother trying to - reconstruct tabs; we can't get it right in general, and nothing - ought to care. Some things do care; the fault lies with them. */ - if (!CPP_OPTION (pfile, traditional)) - { - const struct line_map *map = linemap_lookup (line_table, src_loc); - int spaces = SOURCE_COLUMN (map, src_loc) - 2; - print.printed = 1; - - while (-- spaces >= 0) - putc (' ', print.outf); - } -} - -/* Called when a line of output is started. TOKEN is the first token - of the line, and at end of file will be CPP_EOF. */ -static void -cb_line_change (cpp_reader *pfile, const cpp_token *token, - int parsing_args) -{ - do_line_change (pfile, token, token->src_loc, parsing_args); -} - -static void -cb_ident (cpp_reader *pfile ATTRIBUTE_UNUSED, source_location line, - const cpp_string *str) -{ - maybe_print_line (line); - fprintf (print.outf, "#ident %s\n", str->text); - print.src_line++; -} - -static void -cb_define (cpp_reader *pfile, source_location line, cpp_hashnode *node) -{ - maybe_print_line (line); - fputs ("#define ", print.outf); - - /* 'D' is whole definition; 'N' is name only. */ - if (flag_dump_macros == 'D') - fputs ((const char *) cpp_macro_definition (pfile, node), - print.outf); - else - fputs ((const char *) NODE_NAME (node), print.outf); - - putc ('\n', print.outf); - if (linemap_lookup (line_table, line)->to_line != 0) - print.src_line++; -} - -static void -cb_undef (cpp_reader *pfile ATTRIBUTE_UNUSED, source_location line, - cpp_hashnode *node) -{ - maybe_print_line (line); - fprintf (print.outf, "#undef %s\n", NODE_NAME (node)); - print.src_line++; -} - -static void -cb_used_define (cpp_reader *pfile, source_location line ATTRIBUTE_UNUSED, - cpp_hashnode *node) -{ - macro_queue *q; - if (node->flags & NODE_BUILTIN) - return; - q = XNEW (macro_queue); - q->macro = xstrdup ((const char *) cpp_macro_definition (pfile, node)); - q->next = define_queue; - define_queue = q; -} - -static void -cb_used_undef (cpp_reader *pfile ATTRIBUTE_UNUSED, - source_location line ATTRIBUTE_UNUSED, - cpp_hashnode *node) -{ - macro_queue *q; - q = XNEW (macro_queue); - q->macro = xstrdup ((const char *) NODE_NAME (node)); - q->next = undef_queue; - undef_queue = q; -} - -static void -dump_queued_macros (cpp_reader *pfile ATTRIBUTE_UNUSED) -{ - macro_queue *q; - - /* End the previous line of text. */ - if (print.printed) - { - putc ('\n', print.outf); - print.src_line++; - print.printed = 0; - } - - for (q = define_queue; q;) - { - macro_queue *oq; - fputs ("#define ", print.outf); - fputs (q->macro, print.outf); - putc ('\n', print.outf); - print.src_line++; - oq = q; - q = q->next; - free (oq->macro); - free (oq); - } - define_queue = NULL; - for (q = undef_queue; q;) - { - macro_queue *oq; - fprintf (print.outf, "#undef %s\n", q->macro); - print.src_line++; - oq = q; - q = q->next; - free (oq->macro); - free (oq); - } - undef_queue = NULL; -} - -static void -cb_include (cpp_reader *pfile ATTRIBUTE_UNUSED, source_location line, - const unsigned char *dir, const char *header, int angle_brackets, - const cpp_token **comments) -{ - maybe_print_line (line); - if (angle_brackets) - fprintf (print.outf, "#%s <%s>", dir, header); - else - fprintf (print.outf, "#%s \"%s\"", dir, header); - - if (comments != NULL) - { - while (*comments != NULL) - { - if ((*comments)->flags & PREV_WHITE) - putc (' ', print.outf); - cpp_output_token (*comments, print.outf); - ++comments; - } - } - - putc ('\n', print.outf); - print.src_line++; -} - -/* Callback called when -fworking-director and -E to emit working - directory in cpp output file. */ - -void -pp_dir_change (cpp_reader *pfile ATTRIBUTE_UNUSED, const char *dir) -{ - size_t to_file_len = strlen (dir); - unsigned char *to_file_quoted = - (unsigned char *) alloca (to_file_len * 4 + 1); - unsigned char *p; - - /* cpp_quote_string does not nul-terminate, so we have to do it ourselves. */ - p = cpp_quote_string (to_file_quoted, (const unsigned char *) dir, to_file_len); - *p = '\0'; - fprintf (print.outf, "# 1 \"%s//\"\n", to_file_quoted); -} - -/* The file name, line number or system header flags have changed, as - described in MAP. */ - -void -pp_file_change (const struct line_map *map) -{ - const char *flags = ""; - - if (flag_no_line_commands) - return; - - if (map != NULL) - { - input_location = map->start_location; - if (print.first_time) - { - /* Avoid printing foo.i when the main file is foo.c. */ - if (!cpp_get_options (parse_in)->preprocessed) - print_line (map->start_location, flags); - print.first_time = 0; - } - else - { - /* Bring current file to correct line when entering a new file. */ - if (map->reason == LC_ENTER) - { - const struct line_map *from = INCLUDED_FROM (line_table, map); - maybe_print_line (LAST_SOURCE_LINE_LOCATION (from)); - } - if (map->reason == LC_ENTER) - flags = " 1"; - else if (map->reason == LC_LEAVE) - flags = " 2"; - print_line (map->start_location, flags); - } - } -} - -/* Copy a #pragma directive to the preprocessed output. */ -static void -cb_def_pragma (cpp_reader *pfile, source_location line) -{ - maybe_print_line (line); - fputs ("#pragma ", print.outf); - cpp_output_line (pfile, print.outf); - print.src_line++; -} - -/* Dump out the hash table. */ -static int -dump_macro (cpp_reader *pfile, cpp_hashnode *node, void *v ATTRIBUTE_UNUSED) -{ - if (node->type == NT_MACRO && !(node->flags & NODE_BUILTIN)) - { - fputs ("#define ", print.outf); - fputs ((const char *) cpp_macro_definition (pfile, node), - print.outf); - putc ('\n', print.outf); - print.src_line++; - } - - return 1; -} - -/* Load in the PCH file NAME, open on FD. It was originally searched for - by ORIG_NAME. Also, print out a #include command so that the PCH - file can be loaded when the preprocessed output is compiled. */ - -static void -cb_read_pch (cpp_reader *pfile, const char *name, - int fd, const char *orig_name ATTRIBUTE_UNUSED) -{ - c_common_read_pch (pfile, name, fd, orig_name); - - fprintf (print.outf, "#pragma GCC pch_preprocess \"%s\"\n", name); - print.src_line++; -} diff --git a/gcc/c-pragma.c b/gcc/c-pragma.c deleted file mode 100644 index 526d5fdfe92..00000000000 --- a/gcc/c-pragma.c +++ /dev/null @@ -1,1336 +0,0 @@ -/* Handle #pragma, system V.4 style. Supports #pragma weak and #pragma pack. - Copyright (C) 1992, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007, 2008 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 3, 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 COPYING3. If not see -. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "tm.h" -#include "tree.h" -#include "function.h" /* For cfun. FIXME: Does the parser know - when it is inside a function, so that - we don't have to look at cfun? */ -#include "cpplib.h" -#include "c-pragma.h" -#include "flags.h" -#include "toplev.h" -#include "c-common.h" -#include "output.h" -#include "tm_p.h" /* For REGISTER_TARGET_PRAGMAS (why is - this not a target hook?). */ -#include "vec.h" -#include "vecprim.h" -#include "target.h" -#include "diagnostic.h" -#include "opts.h" -#include "plugin.h" - -#define GCC_BAD(gmsgid) \ - do { warning (OPT_Wpragmas, gmsgid); return; } while (0) -#define GCC_BAD2(gmsgid, arg) \ - do { warning (OPT_Wpragmas, gmsgid, arg); return; } while (0) - -typedef struct GTY(()) align_stack { - int alignment; - tree id; - struct align_stack * prev; -} align_stack; - -static GTY(()) struct align_stack * alignment_stack; - -#ifdef HANDLE_PRAGMA_PACK -static void handle_pragma_pack (cpp_reader *); - -#ifdef HANDLE_PRAGMA_PACK_PUSH_POP -/* If we have a "global" #pragma pack() in effect when the first - #pragma pack(push,) is encountered, this stores the value of - maximum_field_alignment in effect. When the final pop_alignment() - happens, we restore the value to this, not to a value of 0 for - maximum_field_alignment. Value is in bits. */ -static int default_alignment; -#define SET_GLOBAL_ALIGNMENT(ALIGN) (maximum_field_alignment = *(alignment_stack == NULL \ - ? &default_alignment \ - : &alignment_stack->alignment) = (ALIGN)) - -static void push_alignment (int, tree); -static void pop_alignment (tree); - -/* Push an alignment value onto the stack. */ -static void -push_alignment (int alignment, tree id) -{ - align_stack * entry; - - entry = GGC_NEW (align_stack); - - entry->alignment = alignment; - entry->id = id; - entry->prev = alignment_stack; - - /* The current value of maximum_field_alignment is not necessarily - 0 since there may be a #pragma pack() in effect; remember it - so that we can restore it after the final #pragma pop(). */ - if (alignment_stack == NULL) - default_alignment = maximum_field_alignment; - - alignment_stack = entry; - - maximum_field_alignment = alignment; -} - -/* Undo a push of an alignment onto the stack. */ -static void -pop_alignment (tree id) -{ - align_stack * entry; - - if (alignment_stack == NULL) - GCC_BAD ("#pragma pack (pop) encountered without matching #pragma pack (push)"); - - /* If we got an identifier, strip away everything above the target - entry so that the next step will restore the state just below it. */ - if (id) - { - for (entry = alignment_stack; entry; entry = entry->prev) - if (entry->id == id) - { - alignment_stack = entry; - break; - } - if (entry == NULL) - warning (OPT_Wpragmas, "\ -#pragma pack(pop, %E) encountered without matching #pragma pack(push, %E)" - , id, id); - } - - entry = alignment_stack->prev; - - maximum_field_alignment = entry ? entry->alignment : default_alignment; - - alignment_stack = entry; -} -#else /* not HANDLE_PRAGMA_PACK_PUSH_POP */ -#define SET_GLOBAL_ALIGNMENT(ALIGN) (maximum_field_alignment = (ALIGN)) -#define push_alignment(ID, N) \ - GCC_BAD ("#pragma pack(push[, id], ) is not supported on this target") -#define pop_alignment(ID) \ - GCC_BAD ("#pragma pack(pop[, id], ) is not supported on this target") -#endif /* HANDLE_PRAGMA_PACK_PUSH_POP */ - -/* #pragma pack () - #pragma pack (N) - - #pragma pack (push) - #pragma pack (push, N) - #pragma pack (push, ID) - #pragma pack (push, ID, N) - #pragma pack (pop) - #pragma pack (pop, ID) */ -static void -handle_pragma_pack (cpp_reader * ARG_UNUSED (dummy)) -{ - tree x, id = 0; - int align = -1; - enum cpp_ttype token; - enum { set, push, pop } action; - - if (pragma_lex (&x) != CPP_OPEN_PAREN) - GCC_BAD ("missing %<(%> after %<#pragma pack%> - ignored"); - - token = pragma_lex (&x); - if (token == CPP_CLOSE_PAREN) - { - action = set; - align = initial_max_fld_align; - } - else if (token == CPP_NUMBER) - { - if (TREE_CODE (x) != INTEGER_CST) - GCC_BAD ("invalid constant in %<#pragma pack%> - ignored"); - align = TREE_INT_CST_LOW (x); - action = set; - if (pragma_lex (&x) != CPP_CLOSE_PAREN) - GCC_BAD ("malformed %<#pragma pack%> - ignored"); - } - else if (token == CPP_NAME) - { -#define GCC_BAD_ACTION do { if (action != pop) \ - GCC_BAD ("malformed %<#pragma pack(push[, id][, ])%> - ignored"); \ - else \ - GCC_BAD ("malformed %<#pragma pack(pop[, id])%> - ignored"); \ - } while (0) - - const char *op = IDENTIFIER_POINTER (x); - if (!strcmp (op, "push")) - action = push; - else if (!strcmp (op, "pop")) - action = pop; - else - GCC_BAD2 ("unknown action %qE for %<#pragma pack%> - ignored", x); - - while ((token = pragma_lex (&x)) == CPP_COMMA) - { - token = pragma_lex (&x); - if (token == CPP_NAME && id == 0) - { - id = x; - } - else if (token == CPP_NUMBER && action == push && align == -1) - { - if (TREE_CODE (x) != INTEGER_CST) - GCC_BAD ("invalid constant in %<#pragma pack%> - ignored"); - align = TREE_INT_CST_LOW (x); - if (align == -1) - action = set; - } - else - GCC_BAD_ACTION; - } - - if (token != CPP_CLOSE_PAREN) - GCC_BAD_ACTION; -#undef GCC_BAD_ACTION - } - else - GCC_BAD ("malformed %<#pragma pack%> - ignored"); - - if (pragma_lex (&x) != CPP_EOF) - warning (OPT_Wpragmas, "junk at end of %<#pragma pack%>"); - - if (flag_pack_struct) - GCC_BAD ("#pragma pack has no effect with -fpack-struct - ignored"); - - if (action != pop) - switch (align) - { - case 0: - case 1: - case 2: - case 4: - case 8: - case 16: - align *= BITS_PER_UNIT; - break; - case -1: - if (action == push) - { - align = maximum_field_alignment; - break; - } - default: - GCC_BAD2 ("alignment must be a small power of two, not %d", align); - } - - switch (action) - { - case set: SET_GLOBAL_ALIGNMENT (align); break; - case push: push_alignment (align, id); break; - case pop: pop_alignment (id); break; - } -} -#endif /* HANDLE_PRAGMA_PACK */ - -typedef struct GTY(()) pending_weak_d -{ - tree name; - tree value; -} pending_weak; - -DEF_VEC_O(pending_weak); -DEF_VEC_ALLOC_O(pending_weak,gc); - -static GTY(()) VEC(pending_weak,gc) *pending_weaks; - -#ifdef HANDLE_PRAGMA_WEAK -static void apply_pragma_weak (tree, tree); -static void handle_pragma_weak (cpp_reader *); - -static void -apply_pragma_weak (tree decl, tree value) -{ - if (value) - { - value = build_string (IDENTIFIER_LENGTH (value), - IDENTIFIER_POINTER (value)); - decl_attributes (&decl, build_tree_list (get_identifier ("alias"), - build_tree_list (NULL, value)), - 0); - } - - if (SUPPORTS_WEAK && DECL_EXTERNAL (decl) && TREE_USED (decl) - && !DECL_WEAK (decl) /* Don't complain about a redundant #pragma. */ - && TREE_SYMBOL_REFERENCED (DECL_ASSEMBLER_NAME (decl))) - warning (OPT_Wpragmas, "applying #pragma weak %q+D after first use " - "results in unspecified behavior", decl); - - declare_weak (decl); -} - -void -maybe_apply_pragma_weak (tree decl) -{ - tree id; - int i; - pending_weak *pe; - - /* Avoid asking for DECL_ASSEMBLER_NAME when it's not needed. */ - - /* No weak symbols pending, take the short-cut. */ - if (!pending_weaks) - return; - /* If it's not visible outside this file, it doesn't matter whether - it's weak. */ - if (!DECL_EXTERNAL (decl) && !TREE_PUBLIC (decl)) - return; - /* If it's not a function or a variable, it can't be weak. - FIXME: what kinds of things are visible outside this file but - aren't functions or variables? Should this be an assert instead? */ - if (TREE_CODE (decl) != FUNCTION_DECL && TREE_CODE (decl) != VAR_DECL) - return; - - id = DECL_ASSEMBLER_NAME (decl); - - for (i = 0; VEC_iterate (pending_weak, pending_weaks, i, pe); i++) - if (id == pe->name) - { - apply_pragma_weak (decl, pe->value); - VEC_unordered_remove (pending_weak, pending_weaks, i); - break; - } -} - -/* Process all "#pragma weak A = B" directives where we have not seen - a decl for A. */ -void -maybe_apply_pending_pragma_weaks (void) -{ - tree alias_id, id, decl; - int i; - pending_weak *pe; - - for (i = 0; VEC_iterate (pending_weak, pending_weaks, i, pe); i++) - { - alias_id = pe->name; - id = pe->value; - - if (id == NULL) - continue; - - decl = build_decl (UNKNOWN_LOCATION, - FUNCTION_DECL, alias_id, default_function_type); - - DECL_ARTIFICIAL (decl) = 1; - TREE_PUBLIC (decl) = 1; - DECL_EXTERNAL (decl) = 1; - DECL_WEAK (decl) = 1; - - assemble_alias (decl, id); - } -} - -/* #pragma weak name [= value] */ -static void -handle_pragma_weak (cpp_reader * ARG_UNUSED (dummy)) -{ - tree name, value, x, decl; - enum cpp_ttype t; - - value = 0; - - if (pragma_lex (&name) != CPP_NAME) - GCC_BAD ("malformed #pragma weak, ignored"); - t = pragma_lex (&x); - if (t == CPP_EQ) - { - if (pragma_lex (&value) != CPP_NAME) - GCC_BAD ("malformed #pragma weak, ignored"); - t = pragma_lex (&x); - } - if (t != CPP_EOF) - warning (OPT_Wpragmas, "junk at end of %<#pragma weak%>"); - - decl = identifier_global_value (name); - if (decl && DECL_P (decl)) - { - apply_pragma_weak (decl, value); - if (value) - assemble_alias (decl, value); - } - else - { - pending_weak *pe; - pe = VEC_safe_push (pending_weak, gc, pending_weaks, NULL); - pe->name = name; - pe->value = value; - } -} -#else -void -maybe_apply_pragma_weak (tree ARG_UNUSED (decl)) -{ -} - -void -maybe_apply_pending_pragma_weaks (void) -{ -} -#endif /* HANDLE_PRAGMA_WEAK */ - -/* GCC supports two #pragma directives for renaming the external - symbol associated with a declaration (DECL_ASSEMBLER_NAME), for - compatibility with the Solaris and Tru64 system headers. GCC also - has its own notation for this, __asm__("name") annotations. - - Corner cases of these features and their interaction: - - 1) Both pragmas silently apply only to declarations with external - linkage (that is, TREE_PUBLIC || DECL_EXTERNAL). Asm labels - do not have this restriction. - - 2) In C++, both #pragmas silently apply only to extern "C" declarations. - Asm labels do not have this restriction. - - 3) If any of the three ways of changing DECL_ASSEMBLER_NAME is - applied to a decl whose DECL_ASSEMBLER_NAME is already set, and the - new name is different, a warning issues and the name does not change. - - 4) The "source name" for #pragma redefine_extname is the DECL_NAME, - *not* the DECL_ASSEMBLER_NAME. - - 5) If #pragma extern_prefix is in effect and a declaration occurs - with an __asm__ name, the #pragma extern_prefix is silently - ignored for that declaration. - - 6) If #pragma extern_prefix and #pragma redefine_extname apply to - the same declaration, whichever triggered first wins, and a warning - is issued. (We would like to have #pragma redefine_extname always - win, but it can appear either before or after the declaration, and - if it appears afterward, we have no way of knowing whether a modified - DECL_ASSEMBLER_NAME is due to #pragma extern_prefix.) */ - -static GTY(()) tree pending_redefine_extname; - -static void handle_pragma_redefine_extname (cpp_reader *); - -/* #pragma redefine_extname oldname newname */ -static void -handle_pragma_redefine_extname (cpp_reader * ARG_UNUSED (dummy)) -{ - tree oldname, newname, decl, x; - enum cpp_ttype t; - - if (pragma_lex (&oldname) != CPP_NAME) - GCC_BAD ("malformed #pragma redefine_extname, ignored"); - if (pragma_lex (&newname) != CPP_NAME) - GCC_BAD ("malformed #pragma redefine_extname, ignored"); - t = pragma_lex (&x); - if (t != CPP_EOF) - warning (OPT_Wpragmas, "junk at end of %<#pragma redefine_extname%>"); - - decl = identifier_global_value (oldname); - if (decl - && (TREE_PUBLIC (decl) || DECL_EXTERNAL (decl)) - && (TREE_CODE (decl) == FUNCTION_DECL - || TREE_CODE (decl) == VAR_DECL) - && has_c_linkage (decl)) - { - if (DECL_ASSEMBLER_NAME_SET_P (decl)) - { - const char *name = IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (decl)); - name = targetm.strip_name_encoding (name); - - if (strcmp (name, IDENTIFIER_POINTER (newname))) - warning (OPT_Wpragmas, "#pragma redefine_extname ignored due to " - "conflict with previous rename"); - } - else - change_decl_assembler_name (decl, newname); - } - else - /* We have to add this to the rename list even if there's already - a global value that doesn't meet the above criteria, because in - C++ "struct foo {...};" puts "foo" in the current namespace but - does *not* conflict with a subsequent declaration of a function - or variable foo. See g++.dg/other/pragma-re-2.C. */ - add_to_renaming_pragma_list (oldname, newname); -} - -/* This is called from here and from ia64.c. */ -void -add_to_renaming_pragma_list (tree oldname, tree newname) -{ - tree previous = purpose_member (oldname, pending_redefine_extname); - if (previous) - { - if (TREE_VALUE (previous) != newname) - warning (OPT_Wpragmas, "#pragma redefine_extname ignored due to " - "conflict with previous #pragma redefine_extname"); - return; - } - - pending_redefine_extname - = tree_cons (oldname, newname, pending_redefine_extname); -} - -static GTY(()) tree pragma_extern_prefix; - -/* #pragma extern_prefix "prefix" */ -static void -handle_pragma_extern_prefix (cpp_reader * ARG_UNUSED (dummy)) -{ - tree prefix, x; - enum cpp_ttype t; - - if (pragma_lex (&prefix) != CPP_STRING) - GCC_BAD ("malformed #pragma extern_prefix, ignored"); - t = pragma_lex (&x); - if (t != CPP_EOF) - warning (OPT_Wpragmas, "junk at end of %<#pragma extern_prefix%>"); - - if (targetm.handle_pragma_extern_prefix) - /* Note that the length includes the null terminator. */ - pragma_extern_prefix = (TREE_STRING_LENGTH (prefix) > 1 ? prefix : NULL); - else if (warn_unknown_pragmas > in_system_header) - warning (OPT_Wunknown_pragmas, - "#pragma extern_prefix not supported on this target"); -} - -/* Hook from the front ends to apply the results of one of the preceding - pragmas that rename variables. */ - -tree -maybe_apply_renaming_pragma (tree decl, tree asmname) -{ - tree *p, t; - - /* The renaming pragmas are only applied to declarations with - external linkage. */ - if ((TREE_CODE (decl) != FUNCTION_DECL && TREE_CODE (decl) != VAR_DECL) - || (!TREE_PUBLIC (decl) && !DECL_EXTERNAL (decl)) - || !has_c_linkage (decl)) - return asmname; - - /* If the DECL_ASSEMBLER_NAME is already set, it does not change, - but we may warn about a rename that conflicts. */ - if (DECL_ASSEMBLER_NAME_SET_P (decl)) - { - const char *oldname = IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (decl)); - oldname = targetm.strip_name_encoding (oldname); - - if (asmname && strcmp (TREE_STRING_POINTER (asmname), oldname)) - warning (OPT_Wpragmas, "asm declaration ignored due to " - "conflict with previous rename"); - - /* Take any pending redefine_extname off the list. */ - for (p = &pending_redefine_extname; (t = *p); p = &TREE_CHAIN (t)) - if (DECL_NAME (decl) == TREE_PURPOSE (t)) - { - /* Only warn if there is a conflict. */ - if (strcmp (IDENTIFIER_POINTER (TREE_VALUE (t)), oldname)) - warning (OPT_Wpragmas, "#pragma redefine_extname ignored due to " - "conflict with previous rename"); - - *p = TREE_CHAIN (t); - break; - } - return 0; - } - - /* Find out if we have a pending #pragma redefine_extname. */ - for (p = &pending_redefine_extname; (t = *p); p = &TREE_CHAIN (t)) - if (DECL_NAME (decl) == TREE_PURPOSE (t)) - { - tree newname = TREE_VALUE (t); - *p = TREE_CHAIN (t); - - /* If we already have an asmname, #pragma redefine_extname is - ignored (with a warning if it conflicts). */ - if (asmname) - { - if (strcmp (TREE_STRING_POINTER (asmname), - IDENTIFIER_POINTER (newname)) != 0) - warning (OPT_Wpragmas, "#pragma redefine_extname ignored due to " - "conflict with __asm__ declaration"); - return asmname; - } - - /* Otherwise we use what we've got; #pragma extern_prefix is - silently ignored. */ - return build_string (IDENTIFIER_LENGTH (newname), - IDENTIFIER_POINTER (newname)); - } - - /* If we've got an asmname, #pragma extern_prefix is silently ignored. */ - if (asmname) - return asmname; - - /* If #pragma extern_prefix is in effect, apply it. */ - if (pragma_extern_prefix) - { - const char *prefix = TREE_STRING_POINTER (pragma_extern_prefix); - size_t plen = TREE_STRING_LENGTH (pragma_extern_prefix) - 1; - - const char *id = IDENTIFIER_POINTER (DECL_NAME (decl)); - size_t ilen = IDENTIFIER_LENGTH (DECL_NAME (decl)); - - char *newname = (char *) alloca (plen + ilen + 1); - - memcpy (newname, prefix, plen); - memcpy (newname + plen, id, ilen + 1); - - return build_string (plen + ilen, newname); - } - - /* Nada. */ - return 0; -} - - -#ifdef HANDLE_PRAGMA_VISIBILITY -static void handle_pragma_visibility (cpp_reader *); - -static VEC (int, heap) *visstack; - -/* Push the visibility indicated by STR onto the top of the #pragma - visibility stack. KIND is 0 for #pragma GCC visibility, 1 for - C++ namespace with visibility attribute and 2 for C++ builtin - ABI namespace. push_visibility/pop_visibility calls must have - matching KIND, it is not allowed to push visibility using one - KIND and pop using a different one. */ - -void -push_visibility (const char *str, int kind) -{ - VEC_safe_push (int, heap, visstack, - ((int) default_visibility) | (kind << 8)); - if (!strcmp (str, "default")) - default_visibility = VISIBILITY_DEFAULT; - else if (!strcmp (str, "internal")) - default_visibility = VISIBILITY_INTERNAL; - else if (!strcmp (str, "hidden")) - default_visibility = VISIBILITY_HIDDEN; - else if (!strcmp (str, "protected")) - default_visibility = VISIBILITY_PROTECTED; - else - GCC_BAD ("#pragma GCC visibility push() must specify default, internal, hidden or protected"); - visibility_options.inpragma = 1; -} - -/* Pop a level of the #pragma visibility stack. Return true if - successful. */ - -bool -pop_visibility (int kind) -{ - if (!VEC_length (int, visstack)) - return false; - if ((VEC_last (int, visstack) >> 8) != kind) - return false; - default_visibility - = (enum symbol_visibility) (VEC_pop (int, visstack) & 0xff); - visibility_options.inpragma - = VEC_length (int, visstack) != 0; - return true; -} - -/* Sets the default visibility for symbols to something other than that - specified on the command line. */ - -static void -handle_pragma_visibility (cpp_reader *dummy ATTRIBUTE_UNUSED) -{ - /* Form is #pragma GCC visibility push(hidden)|pop */ - tree x; - enum cpp_ttype token; - enum { bad, push, pop } action = bad; - - token = pragma_lex (&x); - if (token == CPP_NAME) - { - const char *op = IDENTIFIER_POINTER (x); - if (!strcmp (op, "push")) - action = push; - else if (!strcmp (op, "pop")) - action = pop; - } - if (bad == action) - GCC_BAD ("#pragma GCC visibility must be followed by push or pop"); - else - { - if (pop == action) - { - if (! pop_visibility (0)) - GCC_BAD ("no matching push for %<#pragma GCC visibility pop%>"); - } - else - { - if (pragma_lex (&x) != CPP_OPEN_PAREN) - GCC_BAD ("missing %<(%> after %<#pragma GCC visibility push%> - ignored"); - token = pragma_lex (&x); - if (token != CPP_NAME) - GCC_BAD ("malformed #pragma GCC visibility push"); - else - push_visibility (IDENTIFIER_POINTER (x), 0); - if (pragma_lex (&x) != CPP_CLOSE_PAREN) - GCC_BAD ("missing %<(%> after %<#pragma GCC visibility push%> - ignored"); - } - } - if (pragma_lex (&x) != CPP_EOF) - warning (OPT_Wpragmas, "junk at end of %<#pragma GCC visibility%>"); -} - -#endif - -static void -handle_pragma_diagnostic(cpp_reader *ARG_UNUSED(dummy)) -{ - const char *kind_string, *option_string; - unsigned int option_index; - enum cpp_ttype token; - diagnostic_t kind; - tree x; - - if (cfun) - { - error ("#pragma GCC diagnostic not allowed inside functions"); - return; - } - - token = pragma_lex (&x); - if (token != CPP_NAME) - GCC_BAD ("missing [error|warning|ignored] after %<#pragma GCC diagnostic%>"); - kind_string = IDENTIFIER_POINTER (x); - if (strcmp (kind_string, "error") == 0) - kind = DK_ERROR; - else if (strcmp (kind_string, "warning") == 0) - kind = DK_WARNING; - else if (strcmp (kind_string, "ignored") == 0) - kind = DK_IGNORED; - else - GCC_BAD ("expected [error|warning|ignored] after %<#pragma GCC diagnostic%>"); - - token = pragma_lex (&x); - if (token != CPP_STRING) - GCC_BAD ("missing option after %<#pragma GCC diagnostic%> kind"); - option_string = TREE_STRING_POINTER (x); - for (option_index = 0; option_index < cl_options_count; option_index++) - if (strcmp (cl_options[option_index].opt_text, option_string) == 0) - { - /* This overrides -Werror, for example. */ - diagnostic_classify_diagnostic (global_dc, option_index, kind); - /* This makes sure the option is enabled, like -Wfoo would do. */ - if (cl_options[option_index].var_type == CLVC_BOOLEAN - && cl_options[option_index].flag_var - && kind != DK_IGNORED) - *(int *) cl_options[option_index].flag_var = 1; - return; - } - GCC_BAD ("unknown option after %<#pragma GCC diagnostic%> kind"); -} - -/* Parse #pragma GCC target (xxx) to set target specific options. */ -static void -handle_pragma_target(cpp_reader *ARG_UNUSED(dummy)) -{ - enum cpp_ttype token; - tree x; - bool close_paren_needed_p = false; - - if (cfun) - { - error ("#pragma GCC option is not allowed inside functions"); - return; - } - - token = pragma_lex (&x); - if (token == CPP_OPEN_PAREN) - { - close_paren_needed_p = true; - token = pragma_lex (&x); - } - - if (token != CPP_STRING) - { - GCC_BAD ("%<#pragma GCC option%> is not a string"); - return; - } - - /* Strings are user options. */ - else - { - tree args = NULL_TREE; - - do - { - /* Build up the strings now as a tree linked list. Skip empty - strings. */ - if (TREE_STRING_LENGTH (x) > 0) - args = tree_cons (NULL_TREE, x, args); - - token = pragma_lex (&x); - while (token == CPP_COMMA) - token = pragma_lex (&x); - } - while (token == CPP_STRING); - - if (close_paren_needed_p) - { - if (token == CPP_CLOSE_PAREN) - token = pragma_lex (&x); - else - GCC_BAD ("%<#pragma GCC target (string [,string]...)%> does " - "not have a final %<)%>."); - } - - if (token != CPP_EOF) - { - error ("#pragma GCC target string... is badly formed"); - return; - } - - /* put arguments in the order the user typed them. */ - args = nreverse (args); - - if (targetm.target_option.pragma_parse (args, NULL_TREE)) - current_target_pragma = args; - } -} - -/* Handle #pragma GCC optimize to set optimization options. */ -static void -handle_pragma_optimize (cpp_reader *ARG_UNUSED(dummy)) -{ - enum cpp_ttype token; - tree x; - bool close_paren_needed_p = false; - tree optimization_previous_node = optimization_current_node; - - if (cfun) - { - error ("#pragma GCC optimize is not allowed inside functions"); - return; - } - - token = pragma_lex (&x); - if (token == CPP_OPEN_PAREN) - { - close_paren_needed_p = true; - token = pragma_lex (&x); - } - - if (token != CPP_STRING && token != CPP_NUMBER) - { - GCC_BAD ("%<#pragma GCC optimize%> is not a string or number"); - return; - } - - /* Strings/numbers are user options. */ - else - { - tree args = NULL_TREE; - - do - { - /* Build up the numbers/strings now as a list. */ - if (token != CPP_STRING || TREE_STRING_LENGTH (x) > 0) - args = tree_cons (NULL_TREE, x, args); - - token = pragma_lex (&x); - while (token == CPP_COMMA) - token = pragma_lex (&x); - } - while (token == CPP_STRING || token == CPP_NUMBER); - - if (close_paren_needed_p) - { - if (token == CPP_CLOSE_PAREN) - token = pragma_lex (&x); - else - GCC_BAD ("%<#pragma GCC optimize (string [,string]...)%> does " - "not have a final %<)%>."); - } - - if (token != CPP_EOF) - { - error ("#pragma GCC optimize string... is badly formed"); - return; - } - - /* put arguments in the order the user typed them. */ - args = nreverse (args); - - parse_optimize_options (args, false); - current_optimize_pragma = chainon (current_optimize_pragma, args); - optimization_current_node = build_optimization_node (); - c_cpp_builtins_optimize_pragma (parse_in, - optimization_previous_node, - optimization_current_node); - } -} - -/* Stack of the #pragma GCC options created with #pragma GCC push_option. Save - both the binary representation of the options and the TREE_LIST of - strings that will be added to the function's attribute list. */ -typedef struct GTY(()) opt_stack { - struct opt_stack *prev; - tree target_binary; - tree target_strings; - tree optimize_binary; - tree optimize_strings; -} opt_stack; - -static GTY(()) struct opt_stack * options_stack; - -/* Handle #pragma GCC push_options to save the current target and optimization - options. */ - -static void -handle_pragma_push_options (cpp_reader *ARG_UNUSED(dummy)) -{ - enum cpp_ttype token; - tree x = 0; - opt_stack *p; - - token = pragma_lex (&x); - if (token != CPP_EOF) - { - warning (OPT_Wpragmas, "junk at end of %<#pragma push_options%>"); - return; - } - - p = GGC_NEW (opt_stack); - p->prev = options_stack; - options_stack = p; - - /* Save optimization and target flags in binary format. */ - p->optimize_binary = build_optimization_node (); - p->target_binary = build_target_option_node (); - - /* Save optimization and target flags in string list format. */ - p->optimize_strings = copy_list (current_optimize_pragma); - p->target_strings = copy_list (current_target_pragma); -} - -/* Handle #pragma GCC pop_options to restore the current target and - optimization options from a previous push_options. */ - -static void -handle_pragma_pop_options (cpp_reader *ARG_UNUSED(dummy)) -{ - enum cpp_ttype token; - tree x = 0; - opt_stack *p; - - token = pragma_lex (&x); - if (token != CPP_EOF) - { - warning (OPT_Wpragmas, "junk at end of %<#pragma pop_options%>"); - return; - } - - if (! options_stack) - { - warning (OPT_Wpragmas, - "%<#pragma GCC pop_options%> without a corresponding " - "%<#pragma GCC push_options%>"); - return; - } - - p = options_stack; - options_stack = p->prev; - - if (p->target_binary != target_option_current_node) - { - (void) targetm.target_option.pragma_parse (NULL_TREE, p->target_binary); - target_option_current_node = p->target_binary; - } - - if (p->optimize_binary != optimization_current_node) - { - tree old_optimize = optimization_current_node; - cl_optimization_restore (TREE_OPTIMIZATION (p->optimize_binary)); - c_cpp_builtins_optimize_pragma (parse_in, old_optimize, - p->optimize_binary); - optimization_current_node = p->optimize_binary; - } - - current_target_pragma = p->target_strings; - current_optimize_pragma = p->optimize_strings; -} - -/* Handle #pragma GCC reset_options to restore the current target and - optimization options to the original options used on the command line. */ - -static void -handle_pragma_reset_options (cpp_reader *ARG_UNUSED(dummy)) -{ - enum cpp_ttype token; - tree x = 0; - tree new_optimize = optimization_default_node; - tree new_target = target_option_default_node; - - token = pragma_lex (&x); - if (token != CPP_EOF) - { - warning (OPT_Wpragmas, "junk at end of %<#pragma reset_options%>"); - return; - } - - if (new_target != target_option_current_node) - { - (void) targetm.target_option.pragma_parse (NULL_TREE, new_target); - target_option_current_node = new_target; - } - - if (new_optimize != optimization_current_node) - { - tree old_optimize = optimization_current_node; - cl_optimization_restore (TREE_OPTIMIZATION (new_optimize)); - c_cpp_builtins_optimize_pragma (parse_in, old_optimize, new_optimize); - optimization_current_node = new_optimize; - } - - current_target_pragma = NULL_TREE; - current_optimize_pragma = NULL_TREE; -} - -/* Print a plain user-specified message. */ - -static void -handle_pragma_message (cpp_reader *ARG_UNUSED(dummy)) -{ - enum cpp_ttype token; - tree x, message = 0; - - token = pragma_lex (&x); - if (token == CPP_OPEN_PAREN) - { - token = pragma_lex (&x); - if (token == CPP_STRING) - message = x; - else - GCC_BAD ("expected a string after %<#pragma message%>"); - if (pragma_lex (&x) != CPP_CLOSE_PAREN) - GCC_BAD ("malformed %<#pragma message%>, ignored"); - } - else if (token == CPP_STRING) - message = x; - else - GCC_BAD ("expected a string after %<#pragma message%>"); - - gcc_assert (message); - - if (pragma_lex (&x) != CPP_EOF) - warning (OPT_Wpragmas, "junk at end of %<#pragma message%>"); - - if (TREE_STRING_LENGTH (message) > 1) - inform (input_location, "#pragma message: %s", TREE_STRING_POINTER (message)); -} - -/* Mark whether the current location is valid for a STDC pragma. */ - -static bool valid_location_for_stdc_pragma; - -void -mark_valid_location_for_stdc_pragma (bool flag) -{ - valid_location_for_stdc_pragma = flag; -} - -/* Return true if the current location is valid for a STDC pragma. */ - -bool -valid_location_for_stdc_pragma_p (void) -{ - return valid_location_for_stdc_pragma; -} - -enum pragma_switch_t { PRAGMA_ON, PRAGMA_OFF, PRAGMA_DEFAULT, PRAGMA_BAD }; - -/* A STDC pragma must appear outside of external declarations or - preceding all explicit declarations and statements inside a compound - statement; its behavior is undefined if used in any other context. - It takes a switch of ON, OFF, or DEFAULT. */ - -static enum pragma_switch_t -handle_stdc_pragma (const char *pname) -{ - const char *arg; - tree t; - enum pragma_switch_t ret; - - if (!valid_location_for_stdc_pragma_p ()) - { - warning (OPT_Wpragmas, "invalid location for %, ignored", - pname); - return PRAGMA_BAD; - } - - if (pragma_lex (&t) != CPP_NAME) - { - warning (OPT_Wpragmas, "malformed %<#pragma %s%>, ignored", pname); - return PRAGMA_BAD; - } - - arg = IDENTIFIER_POINTER (t); - - if (!strcmp (arg, "ON")) - ret = PRAGMA_ON; - else if (!strcmp (arg, "OFF")) - ret = PRAGMA_OFF; - else if (!strcmp (arg, "DEFAULT")) - ret = PRAGMA_DEFAULT; - else - { - warning (OPT_Wpragmas, "malformed %<#pragma %s%>, ignored", pname); - return PRAGMA_BAD; - } - - if (pragma_lex (&t) != CPP_EOF) - { - warning (OPT_Wpragmas, "junk at end of %<#pragma %s%>", pname); - return PRAGMA_BAD; - } - - return ret; -} - -/* #pragma STDC FLOAT_CONST_DECIMAL64 ON - #pragma STDC FLOAT_CONST_DECIMAL64 OFF - #pragma STDC FLOAT_CONST_DECIMAL64 DEFAULT */ - -static void -handle_pragma_float_const_decimal64 (cpp_reader *ARG_UNUSED (dummy)) -{ - if (c_dialect_cxx ()) - { - if (warn_unknown_pragmas > in_system_header) - warning (OPT_Wunknown_pragmas, - "%<#pragma STDC FLOAT_CONST_DECIMAL64%> is not supported" - " for C++"); - return; - } - - if (!targetm.decimal_float_supported_p ()) - { - if (warn_unknown_pragmas > in_system_header) - warning (OPT_Wunknown_pragmas, - "%<#pragma STDC FLOAT_CONST_DECIMAL64%> is not supported" - " on this target"); - return; - } - - pedwarn (input_location, OPT_pedantic, - "ISO C does not support %<#pragma STDC FLOAT_CONST_DECIMAL64%>"); - - switch (handle_stdc_pragma ("STDC FLOAT_CONST_DECIMAL64")) - { - case PRAGMA_ON: - set_float_const_decimal64 (); - break; - case PRAGMA_OFF: - case PRAGMA_DEFAULT: - clear_float_const_decimal64 (); - break; - case PRAGMA_BAD: - break; - } -} - -/* A vector of registered pragma callbacks. */ - -DEF_VEC_O (pragma_handler); -DEF_VEC_ALLOC_O (pragma_handler, heap); - -static VEC(pragma_handler, heap) *registered_pragmas; - -typedef struct -{ - const char *space; - const char *name; -} pragma_ns_name; - -DEF_VEC_O (pragma_ns_name); -DEF_VEC_ALLOC_O (pragma_ns_name, heap); - -static VEC(pragma_ns_name, heap) *registered_pp_pragmas; - -struct omp_pragma_def { const char *name; unsigned int id; }; -static const struct omp_pragma_def omp_pragmas[] = { - { "atomic", PRAGMA_OMP_ATOMIC }, - { "barrier", PRAGMA_OMP_BARRIER }, - { "critical", PRAGMA_OMP_CRITICAL }, - { "flush", PRAGMA_OMP_FLUSH }, - { "for", PRAGMA_OMP_FOR }, - { "master", PRAGMA_OMP_MASTER }, - { "ordered", PRAGMA_OMP_ORDERED }, - { "parallel", PRAGMA_OMP_PARALLEL }, - { "section", PRAGMA_OMP_SECTION }, - { "sections", PRAGMA_OMP_SECTIONS }, - { "single", PRAGMA_OMP_SINGLE }, - { "task", PRAGMA_OMP_TASK }, - { "taskwait", PRAGMA_OMP_TASKWAIT }, - { "threadprivate", PRAGMA_OMP_THREADPRIVATE } -}; - -void -c_pp_lookup_pragma (unsigned int id, const char **space, const char **name) -{ - const int n_omp_pragmas = sizeof (omp_pragmas) / sizeof (*omp_pragmas); - int i; - - for (i = 0; i < n_omp_pragmas; ++i) - if (omp_pragmas[i].id == id) - { - *space = "omp"; - *name = omp_pragmas[i].name; - return; - } - - if (id >= PRAGMA_FIRST_EXTERNAL - && (id < PRAGMA_FIRST_EXTERNAL - + VEC_length (pragma_ns_name, registered_pp_pragmas))) - { - *space = VEC_index (pragma_ns_name, registered_pp_pragmas, - id - PRAGMA_FIRST_EXTERNAL)->space; - *name = VEC_index (pragma_ns_name, registered_pp_pragmas, - id - PRAGMA_FIRST_EXTERNAL)->name; - return; - } - - gcc_unreachable (); -} - -/* Front-end wrappers for pragma registration to avoid dragging - cpplib.h in almost everywhere. */ - -static void -c_register_pragma_1 (const char *space, const char *name, - pragma_handler handler, bool allow_expansion) -{ - unsigned id; - - if (flag_preprocess_only) - { - pragma_ns_name ns_name; - - if (!allow_expansion) - return; - - ns_name.space = space; - ns_name.name = name; - VEC_safe_push (pragma_ns_name, heap, registered_pp_pragmas, &ns_name); - id = VEC_length (pragma_ns_name, registered_pp_pragmas); - id += PRAGMA_FIRST_EXTERNAL - 1; - } - else - { - VEC_safe_push (pragma_handler, heap, registered_pragmas, &handler); - id = VEC_length (pragma_handler, registered_pragmas); - id += PRAGMA_FIRST_EXTERNAL - 1; - - /* The C++ front end allocates 6 bits in cp_token; the C front end - allocates 7 bits in c_token. At present this is sufficient. */ - gcc_assert (id < 64); - } - - cpp_register_deferred_pragma (parse_in, space, name, id, - allow_expansion, false); -} - -void -c_register_pragma (const char *space, const char *name, pragma_handler handler) -{ - c_register_pragma_1 (space, name, handler, false); -} - -void -c_register_pragma_with_expansion (const char *space, const char *name, - pragma_handler handler) -{ - c_register_pragma_1 (space, name, handler, true); -} - -void -c_invoke_pragma_handler (unsigned int id) -{ - pragma_handler handler; - - id -= PRAGMA_FIRST_EXTERNAL; - handler = *VEC_index (pragma_handler, registered_pragmas, id); - - handler (parse_in); -} - -/* Set up front-end pragmas. */ -void -init_pragma (void) -{ - if (flag_openmp) - { - const int n_omp_pragmas = sizeof (omp_pragmas) / sizeof (*omp_pragmas); - int i; - - for (i = 0; i < n_omp_pragmas; ++i) - cpp_register_deferred_pragma (parse_in, "omp", omp_pragmas[i].name, - omp_pragmas[i].id, true, true); - } - - if (!flag_preprocess_only) - cpp_register_deferred_pragma (parse_in, "GCC", "pch_preprocess", - PRAGMA_GCC_PCH_PREPROCESS, false, false); - -#ifdef HANDLE_PRAGMA_PACK -#ifdef HANDLE_PRAGMA_PACK_WITH_EXPANSION - c_register_pragma_with_expansion (0, "pack", handle_pragma_pack); -#else - c_register_pragma (0, "pack", handle_pragma_pack); -#endif -#endif -#ifdef HANDLE_PRAGMA_WEAK - c_register_pragma (0, "weak", handle_pragma_weak); -#endif -#ifdef HANDLE_PRAGMA_VISIBILITY - c_register_pragma ("GCC", "visibility", handle_pragma_visibility); -#endif - - c_register_pragma ("GCC", "diagnostic", handle_pragma_diagnostic); - c_register_pragma ("GCC", "target", handle_pragma_target); - c_register_pragma ("GCC", "optimize", handle_pragma_optimize); - c_register_pragma ("GCC", "push_options", handle_pragma_push_options); - c_register_pragma ("GCC", "pop_options", handle_pragma_pop_options); - c_register_pragma ("GCC", "reset_options", handle_pragma_reset_options); - - c_register_pragma ("STDC", "FLOAT_CONST_DECIMAL64", - handle_pragma_float_const_decimal64); - - c_register_pragma_with_expansion (0, "redefine_extname", handle_pragma_redefine_extname); - c_register_pragma (0, "extern_prefix", handle_pragma_extern_prefix); - - c_register_pragma_with_expansion (0, "message", handle_pragma_message); - -#ifdef REGISTER_TARGET_PRAGMAS - REGISTER_TARGET_PRAGMAS (); -#endif - - /* Allow plugins to register their own pragmas. */ - invoke_plugin_callbacks (PLUGIN_PRAGMAS, NULL); -} - -#include "gt-c-pragma.h" diff --git a/gcc/c-pragma.h b/gcc/c-pragma.h deleted file mode 100644 index eab23db6cd9..00000000000 --- a/gcc/c-pragma.h +++ /dev/null @@ -1,133 +0,0 @@ -/* Pragma related interfaces. - Copyright (C) 1995, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2007, 2008 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 3, 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 COPYING3. If not see -. */ - -#ifndef GCC_C_PRAGMA_H -#define GCC_C_PRAGMA_H - -#include /* For enum cpp_ttype. */ - -/* Pragma identifiers built in to the front end parsers. Identifiers - for ancillary handlers will follow these. */ -typedef enum pragma_kind { - PRAGMA_NONE = 0, - - PRAGMA_OMP_ATOMIC, - PRAGMA_OMP_BARRIER, - PRAGMA_OMP_CRITICAL, - PRAGMA_OMP_FLUSH, - PRAGMA_OMP_FOR, - PRAGMA_OMP_MASTER, - PRAGMA_OMP_ORDERED, - PRAGMA_OMP_PARALLEL, - PRAGMA_OMP_PARALLEL_FOR, - PRAGMA_OMP_PARALLEL_SECTIONS, - PRAGMA_OMP_SECTION, - PRAGMA_OMP_SECTIONS, - PRAGMA_OMP_SINGLE, - PRAGMA_OMP_TASK, - PRAGMA_OMP_TASKWAIT, - PRAGMA_OMP_THREADPRIVATE, - - PRAGMA_GCC_PCH_PREPROCESS, - - PRAGMA_FIRST_EXTERNAL -} pragma_kind; - - -/* All clauses defined by OpenMP 2.5 and 3.0. - Used internally by both C and C++ parsers. */ -typedef enum pragma_omp_clause { - PRAGMA_OMP_CLAUSE_NONE = 0, - - PRAGMA_OMP_CLAUSE_COLLAPSE, - PRAGMA_OMP_CLAUSE_COPYIN, - PRAGMA_OMP_CLAUSE_COPYPRIVATE, - PRAGMA_OMP_CLAUSE_DEFAULT, - PRAGMA_OMP_CLAUSE_FIRSTPRIVATE, - PRAGMA_OMP_CLAUSE_IF, - PRAGMA_OMP_CLAUSE_LASTPRIVATE, - PRAGMA_OMP_CLAUSE_NOWAIT, - PRAGMA_OMP_CLAUSE_NUM_THREADS, - PRAGMA_OMP_CLAUSE_ORDERED, - PRAGMA_OMP_CLAUSE_PRIVATE, - PRAGMA_OMP_CLAUSE_REDUCTION, - PRAGMA_OMP_CLAUSE_SCHEDULE, - PRAGMA_OMP_CLAUSE_SHARED, - PRAGMA_OMP_CLAUSE_UNTIED -} pragma_omp_clause; - -extern struct cpp_reader* parse_in; - -#define HANDLE_PRAGMA_WEAK SUPPORTS_WEAK - -#ifdef HANDLE_SYSV_PRAGMA -/* We always support #pragma pack for SYSV pragmas. */ -#ifndef HANDLE_PRAGMA_PACK -#define HANDLE_PRAGMA_PACK 1 -#endif -#endif /* HANDLE_SYSV_PRAGMA */ - - -#ifdef HANDLE_PRAGMA_PACK_PUSH_POP -/* If we are supporting #pragma pack(push... then we automatically - support #pragma pack() */ -#define HANDLE_PRAGMA_PACK 1 -#endif /* HANDLE_PRAGMA_PACK_PUSH_POP */ - -/* It's safe to always leave visibility pragma enabled as if - visibility is not supported on the host OS platform the - statements are ignored. */ -#define HANDLE_PRAGMA_VISIBILITY 1 -extern void push_visibility (const char *, int); -extern bool pop_visibility (int); - -extern void init_pragma (void); - -/* Front-end wrappers for pragma registration. */ -typedef void (*pragma_handler)(struct cpp_reader *); -extern void c_register_pragma (const char *, const char *, pragma_handler); -extern void c_register_pragma_with_expansion (const char *, const char *, - pragma_handler); -extern void c_invoke_pragma_handler (unsigned int); - -extern void maybe_apply_pragma_weak (tree); -extern void maybe_apply_pending_pragma_weaks (void); -extern tree maybe_apply_renaming_pragma (tree, tree); -extern void add_to_renaming_pragma_list (tree, tree); - -extern enum cpp_ttype pragma_lex (tree *); - -/* Flags for use with c_lex_with_flags. The values here were picked - so that 0 means to translate and join strings. */ -#define C_LEX_STRING_NO_TRANSLATE 1 /* Do not lex strings into - execution character set. */ -#define C_LEX_STRING_NO_JOIN 2 /* Do not concatenate strings - nor translate them into execution - character set. */ - -/* This is not actually available to pragma parsers. It's merely a - convenient location to declare this function for c-lex, after - having enum cpp_ttype declared. */ -extern enum cpp_ttype c_lex_with_flags (tree *, location_t *, unsigned char *, - int); - -extern void c_pp_lookup_pragma (unsigned int, const char **, const char **); - -#endif /* GCC_C_PRAGMA_H */ diff --git a/gcc/c-pretty-print.c b/gcc/c-pretty-print.c deleted file mode 100644 index ca0608c79e2..00000000000 --- a/gcc/c-pretty-print.c +++ /dev/null @@ -1,2261 +0,0 @@ -/* Subroutines common to both C and C++ pretty-printers. - Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 - Free Software Foundation, Inc. - Contributed by Gabriel Dos Reis - -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 3, 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 COPYING3. If not see -. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "tm.h" -#include "tree.h" -#include "intl.h" -#include "c-pretty-print.h" -#include "tree-pretty-print.h" -#include "tree-iterator.h" -#include "diagnostic.h" - -/* Translate if being used for diagnostics, but not for dump files or - __PRETTY_FUNCTION. */ -#define M_(msgid) (pp_translate_identifiers (pp) ? _(msgid) : (msgid)) - -/* The pretty-printer code is primarily designed to closely follow - (GNU) C and C++ grammars. That is to be contrasted with spaghetti - codes we used to have in the past. Following a structured - approach (preferably the official grammars) is believed to make it - much easier to add extensions and nifty pretty-printing effects that - takes expression or declaration contexts into account. */ - - -#define pp_c_maybe_whitespace(PP) \ - do { \ - if (pp_base (PP)->padding == pp_before) \ - pp_c_whitespace (PP); \ - } while (0) - -/* literal */ -static void pp_c_char (c_pretty_printer *, int); - -/* postfix-expression */ -static void pp_c_initializer_list (c_pretty_printer *, tree); -static void pp_c_brace_enclosed_initializer_list (c_pretty_printer *, tree); - -static void pp_c_multiplicative_expression (c_pretty_printer *, tree); -static void pp_c_additive_expression (c_pretty_printer *, tree); -static void pp_c_shift_expression (c_pretty_printer *, tree); -static void pp_c_relational_expression (c_pretty_printer *, tree); -static void pp_c_equality_expression (c_pretty_printer *, tree); -static void pp_c_and_expression (c_pretty_printer *, tree); -static void pp_c_exclusive_or_expression (c_pretty_printer *, tree); -static void pp_c_inclusive_or_expression (c_pretty_printer *, tree); -static void pp_c_logical_and_expression (c_pretty_printer *, tree); -static void pp_c_conditional_expression (c_pretty_printer *, tree); -static void pp_c_assignment_expression (c_pretty_printer *, tree); - -/* declarations. */ - - -/* Helper functions. */ - -void -pp_c_whitespace (c_pretty_printer *pp) -{ - pp_space (pp); - pp_base (pp)->padding = pp_none; -} - -void -pp_c_left_paren (c_pretty_printer *pp) -{ - pp_left_paren (pp); - pp_base (pp)->padding = pp_none; -} - -void -pp_c_right_paren (c_pretty_printer *pp) -{ - pp_right_paren (pp); - pp_base (pp)->padding = pp_none; -} - -void -pp_c_left_brace (c_pretty_printer *pp) -{ - pp_left_brace (pp); - pp_base (pp)->padding = pp_none; -} - -void -pp_c_right_brace (c_pretty_printer *pp) -{ - pp_right_brace (pp); - pp_base (pp)->padding = pp_none; -} - -void -pp_c_left_bracket (c_pretty_printer *pp) -{ - pp_left_bracket (pp); - pp_base (pp)->padding = pp_none; -} - -void -pp_c_right_bracket (c_pretty_printer *pp) -{ - pp_right_bracket (pp); - pp_base (pp)->padding = pp_none; -} - -void -pp_c_dot (c_pretty_printer *pp) -{ - pp_dot (pp); - pp_base (pp)->padding = pp_none; -} - -void -pp_c_ampersand (c_pretty_printer *pp) -{ - pp_ampersand (pp); - pp_base (pp)->padding = pp_none; -} - -void -pp_c_star (c_pretty_printer *pp) -{ - pp_star (pp); - pp_base (pp)->padding = pp_none; -} - -void -pp_c_arrow (c_pretty_printer *pp) -{ - pp_arrow (pp); - pp_base (pp)->padding = pp_none; -} - -void -pp_c_semicolon (c_pretty_printer *pp) -{ - pp_semicolon (pp); - pp_base (pp)->padding = pp_none; -} - -void -pp_c_complement (c_pretty_printer *pp) -{ - pp_complement (pp); - pp_base (pp)->padding = pp_none; -} - -void -pp_c_exclamation (c_pretty_printer *pp) -{ - pp_exclamation (pp); - pp_base (pp)->padding = pp_none; -} - -/* Print out the external representation of CV-QUALIFIER. */ - -static void -pp_c_cv_qualifier (c_pretty_printer *pp, const char *cv) -{ - const char *p = pp_last_position_in_text (pp); - /* The C programming language does not have references, but it is much - simpler to handle those here rather than going through the same - logic in the C++ pretty-printer. */ - if (p != NULL && (*p == '*' || *p == '&')) - pp_c_whitespace (pp); - pp_c_ws_string (pp, cv); -} - -/* Pretty-print T using the type-cast notation '( type-name )'. */ - -static void -pp_c_type_cast (c_pretty_printer *pp, tree t) -{ - pp_c_left_paren (pp); - pp_type_id (pp, t); - pp_c_right_paren (pp); -} - -/* We're about to pretty-print a pointer type as indicated by T. - Output a whitespace, if needed, preparing for subsequent output. */ - -void -pp_c_space_for_pointer_operator (c_pretty_printer *pp, tree t) -{ - if (POINTER_TYPE_P (t)) - { - tree pointee = strip_pointer_operator (TREE_TYPE (t)); - if (TREE_CODE (pointee) != ARRAY_TYPE - && TREE_CODE (pointee) != FUNCTION_TYPE) - pp_c_whitespace (pp); - } -} - - -/* Declarations. */ - -/* C++ cv-qualifiers are called type-qualifiers in C. Print out the - cv-qualifiers of T. If T is a declaration then it is the cv-qualifier - of its type. Take care of possible extensions. - - type-qualifier-list: - type-qualifier - type-qualifier-list type-qualifier - - type-qualifier: - const - restrict -- C99 - __restrict__ -- GNU C - address-space-qualifier -- GNU C - volatile - - address-space-qualifier: - identifier -- GNU C */ - -void -pp_c_type_qualifier_list (c_pretty_printer *pp, tree t) -{ - int qualifiers; - - if (!t || t == error_mark_node) - return; - - if (!TYPE_P (t)) - t = TREE_TYPE (t); - - qualifiers = TYPE_QUALS (t); - if (qualifiers & TYPE_QUAL_CONST) - pp_c_cv_qualifier (pp, "const"); - if (qualifiers & TYPE_QUAL_VOLATILE) - pp_c_cv_qualifier (pp, "volatile"); - if (qualifiers & TYPE_QUAL_RESTRICT) - pp_c_cv_qualifier (pp, flag_isoc99 ? "restrict" : "__restrict__"); - - if (!ADDR_SPACE_GENERIC_P (TYPE_ADDR_SPACE (t))) - { - const char *as = c_addr_space_name (TYPE_ADDR_SPACE (t)); - pp_c_identifier (pp, as); - } -} - -/* pointer: - * type-qualifier-list(opt) - * type-qualifier-list(opt) pointer */ - -static void -pp_c_pointer (c_pretty_printer *pp, tree t) -{ - if (!TYPE_P (t) && TREE_CODE (t) != TYPE_DECL) - t = TREE_TYPE (t); - switch (TREE_CODE (t)) - { - case POINTER_TYPE: - /* It is easier to handle C++ reference types here. */ - case REFERENCE_TYPE: - if (TREE_CODE (TREE_TYPE (t)) == POINTER_TYPE) - pp_c_pointer (pp, TREE_TYPE (t)); - if (TREE_CODE (t) == POINTER_TYPE) - pp_c_star (pp); - else - pp_c_ampersand (pp); - pp_c_type_qualifier_list (pp, t); - break; - - /* ??? This node is now in GENERIC and so shouldn't be here. But - we'll fix that later. */ - case DECL_EXPR: - pp_declaration (pp, DECL_EXPR_DECL (t)); - pp_needs_newline (pp) = true; - break; - - default: - pp_unsupported_tree (pp, t); - } -} - -/* type-specifier: - void - char - short - int - long - float - double - signed - unsigned - _Bool -- C99 - _Complex -- C99 - _Imaginary -- C99 - struct-or-union-specifier - enum-specifier - typedef-name. - - GNU extensions. - simple-type-specifier: - __complex__ - __vector__ */ - -void -pp_c_type_specifier (c_pretty_printer *pp, tree t) -{ - const enum tree_code code = TREE_CODE (t); - switch (code) - { - case ERROR_MARK: - pp_c_ws_string (pp, M_("")); - break; - - case IDENTIFIER_NODE: - pp_c_tree_decl_identifier (pp, t); - break; - - case VOID_TYPE: - case BOOLEAN_TYPE: - case INTEGER_TYPE: - case REAL_TYPE: - case FIXED_POINT_TYPE: - if (TYPE_NAME (t)) - { - t = TYPE_NAME (t); - pp_c_type_specifier (pp, t); - } - else - { - int prec = TYPE_PRECISION (t); - if (ALL_FIXED_POINT_MODE_P (TYPE_MODE (t))) - t = c_common_type_for_mode (TYPE_MODE (t), TYPE_SATURATING (t)); - else - t = c_common_type_for_mode (TYPE_MODE (t), TYPE_UNSIGNED (t)); - if (TYPE_NAME (t)) - { - pp_c_type_specifier (pp, t); - if (TYPE_PRECISION (t) != prec) - { - pp_string (pp, ":"); - pp_decimal_int (pp, prec); - } - } - else - { - switch (code) - { - case INTEGER_TYPE: - pp_string (pp, (TYPE_UNSIGNED (t) - ? M_(""); - } - } - break; - - case TYPE_DECL: - if (DECL_NAME (t)) - pp_id_expression (pp, t); - else - pp_c_ws_string (pp, M_("")); - break; - - case UNION_TYPE: - case RECORD_TYPE: - case ENUMERAL_TYPE: - if (code == UNION_TYPE) - pp_c_ws_string (pp, "union"); - else if (code == RECORD_TYPE) - pp_c_ws_string (pp, "struct"); - else if (code == ENUMERAL_TYPE) - pp_c_ws_string (pp, "enum"); - else - pp_c_ws_string (pp, M_("")); - - if (TYPE_NAME (t)) - pp_id_expression (pp, TYPE_NAME (t)); - else - pp_c_ws_string (pp, M_("")); - break; - - default: - pp_unsupported_tree (pp, t); - break; - } -} - -/* specifier-qualifier-list: - type-specifier specifier-qualifier-list-opt - type-qualifier specifier-qualifier-list-opt - - - Implementation note: Because of the non-linearities in array or - function declarations, this routine prints not just the - specifier-qualifier-list of such entities or types of such entities, - but also the 'pointer' production part of their declarators. The - remaining part is done by pp_declarator or pp_c_abstract_declarator. */ - -void -pp_c_specifier_qualifier_list (c_pretty_printer *pp, tree t) -{ - const enum tree_code code = TREE_CODE (t); - - if (TREE_CODE (t) != POINTER_TYPE) - pp_c_type_qualifier_list (pp, t); - switch (code) - { - case REFERENCE_TYPE: - case POINTER_TYPE: - { - /* Get the types-specifier of this type. */ - tree pointee = strip_pointer_operator (TREE_TYPE (t)); - pp_c_specifier_qualifier_list (pp, pointee); - if (TREE_CODE (pointee) == ARRAY_TYPE - || TREE_CODE (pointee) == FUNCTION_TYPE) - { - pp_c_whitespace (pp); - pp_c_left_paren (pp); - } - else if (!c_dialect_cxx ()) - pp_c_whitespace (pp); - pp_ptr_operator (pp, t); - } - break; - - case FUNCTION_TYPE: - case ARRAY_TYPE: - pp_c_specifier_qualifier_list (pp, TREE_TYPE (t)); - break; - - case VECTOR_TYPE: - case COMPLEX_TYPE: - if (code == COMPLEX_TYPE) - pp_c_ws_string (pp, flag_isoc99 ? "_Complex" : "__complex__"); - else if (code == VECTOR_TYPE) - { - pp_c_ws_string (pp, "__vector"); - pp_c_left_paren (pp); - pp_wide_integer (pp, TYPE_VECTOR_SUBPARTS (t)); - pp_c_right_paren (pp); - pp_c_whitespace (pp); - } - pp_c_specifier_qualifier_list (pp, TREE_TYPE (t)); - break; - - default: - pp_simple_type_specifier (pp, t); - break; - } -} - -/* parameter-type-list: - parameter-list - parameter-list , ... - - parameter-list: - parameter-declaration - parameter-list , parameter-declaration - - parameter-declaration: - declaration-specifiers declarator - declaration-specifiers abstract-declarator(opt) */ - -void -pp_c_parameter_type_list (c_pretty_printer *pp, tree t) -{ - bool want_parm_decl = DECL_P (t) && !(pp->flags & pp_c_flag_abstract); - tree parms = want_parm_decl ? DECL_ARGUMENTS (t) : TYPE_ARG_TYPES (t); - pp_c_left_paren (pp); - if (parms == void_list_node) - pp_c_ws_string (pp, "void"); - else - { - bool first = true; - for ( ; parms && parms != void_list_node; parms = TREE_CHAIN (parms)) - { - if (!first) - pp_separate_with (pp, ','); - first = false; - pp_declaration_specifiers - (pp, want_parm_decl ? parms : TREE_VALUE (parms)); - if (want_parm_decl) - pp_declarator (pp, parms); - else - pp_abstract_declarator (pp, TREE_VALUE (parms)); - } - } - pp_c_right_paren (pp); -} - -/* abstract-declarator: - pointer - pointer(opt) direct-abstract-declarator */ - -static void -pp_c_abstract_declarator (c_pretty_printer *pp, tree t) -{ - if (TREE_CODE (t) == POINTER_TYPE) - { - if (TREE_CODE (TREE_TYPE (t)) == ARRAY_TYPE - || TREE_CODE (TREE_TYPE (t)) == FUNCTION_TYPE) - pp_c_right_paren (pp); - t = TREE_TYPE (t); - } - - pp_direct_abstract_declarator (pp, t); -} - -/* direct-abstract-declarator: - ( abstract-declarator ) - direct-abstract-declarator(opt) [ assignment-expression(opt) ] - direct-abstract-declarator(opt) [ * ] - direct-abstract-declarator(opt) ( parameter-type-list(opt) ) */ - -void -pp_c_direct_abstract_declarator (c_pretty_printer *pp, tree t) -{ - switch (TREE_CODE (t)) - { - case POINTER_TYPE: - pp_abstract_declarator (pp, t); - break; - - case FUNCTION_TYPE: - pp_c_parameter_type_list (pp, t); - pp_direct_abstract_declarator (pp, TREE_TYPE (t)); - break; - - case ARRAY_TYPE: - pp_c_left_bracket (pp); - if (TYPE_DOMAIN (t) && TYPE_MAX_VALUE (TYPE_DOMAIN (t))) - { - tree maxval = TYPE_MAX_VALUE (TYPE_DOMAIN (t)); - tree type = TREE_TYPE (maxval); - - if (host_integerp (maxval, 0)) - pp_wide_integer (pp, tree_low_cst (maxval, 0) + 1); - else - pp_expression (pp, fold_build2 (PLUS_EXPR, type, maxval, - build_int_cst (type, 1))); - } - pp_c_right_bracket (pp); - pp_direct_abstract_declarator (pp, TREE_TYPE (t)); - break; - - case IDENTIFIER_NODE: - case VOID_TYPE: - case BOOLEAN_TYPE: - case INTEGER_TYPE: - case REAL_TYPE: - case FIXED_POINT_TYPE: - case ENUMERAL_TYPE: - case RECORD_TYPE: - case UNION_TYPE: - case VECTOR_TYPE: - case COMPLEX_TYPE: - case TYPE_DECL: - break; - - default: - pp_unsupported_tree (pp, t); - break; - } -} - -/* type-name: - specifier-qualifier-list abstract-declarator(opt) */ - -void -pp_c_type_id (c_pretty_printer *pp, tree t) -{ - pp_c_specifier_qualifier_list (pp, t); - pp_abstract_declarator (pp, t); -} - -/* storage-class-specifier: - typedef - extern - static - auto - register */ - -void -pp_c_storage_class_specifier (c_pretty_printer *pp, tree t) -{ - if (TREE_CODE (t) == TYPE_DECL) - pp_c_ws_string (pp, "typedef"); - else if (DECL_P (t)) - { - if (DECL_REGISTER (t)) - pp_c_ws_string (pp, "register"); - else if (TREE_STATIC (t) && TREE_CODE (t) == VAR_DECL) - pp_c_ws_string (pp, "static"); - } -} - -/* function-specifier: - inline */ - -void -pp_c_function_specifier (c_pretty_printer *pp, tree t) -{ - if (TREE_CODE (t) == FUNCTION_DECL && DECL_DECLARED_INLINE_P (t)) - pp_c_ws_string (pp, "inline"); -} - -/* declaration-specifiers: - storage-class-specifier declaration-specifiers(opt) - type-specifier declaration-specifiers(opt) - type-qualifier declaration-specifiers(opt) - function-specifier declaration-specifiers(opt) */ - -void -pp_c_declaration_specifiers (c_pretty_printer *pp, tree t) -{ - pp_storage_class_specifier (pp, t); - pp_function_specifier (pp, t); - pp_c_specifier_qualifier_list (pp, DECL_P (t) ? TREE_TYPE (t) : t); -} - -/* direct-declarator - identifier - ( declarator ) - direct-declarator [ type-qualifier-list(opt) assignment-expression(opt) ] - direct-declarator [ static type-qualifier-list(opt) assignment-expression(opt)] - direct-declarator [ type-qualifier-list static assignment-expression ] - direct-declarator [ type-qualifier-list * ] - direct-declarator ( parameter-type-list ) - direct-declarator ( identifier-list(opt) ) */ - -void -pp_c_direct_declarator (c_pretty_printer *pp, tree t) -{ - switch (TREE_CODE (t)) - { - case VAR_DECL: - case PARM_DECL: - case TYPE_DECL: - case FIELD_DECL: - case LABEL_DECL: - pp_c_space_for_pointer_operator (pp, TREE_TYPE (t)); - pp_c_tree_decl_identifier (pp, t); - break; - - case ARRAY_TYPE: - case POINTER_TYPE: - pp_abstract_declarator (pp, TREE_TYPE (t)); - break; - - case FUNCTION_TYPE: - pp_parameter_list (pp, t); - pp_abstract_declarator (pp, TREE_TYPE (t)); - break; - - case FUNCTION_DECL: - pp_c_space_for_pointer_operator (pp, TREE_TYPE (TREE_TYPE (t))); - pp_c_tree_decl_identifier (pp, t); - if (pp_c_base (pp)->flags & pp_c_flag_abstract) - pp_abstract_declarator (pp, TREE_TYPE (t)); - else - { - pp_parameter_list (pp, t); - pp_abstract_declarator (pp, TREE_TYPE (TREE_TYPE (t))); - } - break; - - case INTEGER_TYPE: - case REAL_TYPE: - case FIXED_POINT_TYPE: - case ENUMERAL_TYPE: - case UNION_TYPE: - case RECORD_TYPE: - break; - - default: - pp_unsupported_tree (pp, t); - break; - } -} - - -/* declarator: - pointer(opt) direct-declarator */ - -void -pp_c_declarator (c_pretty_printer *pp, tree t) -{ - switch (TREE_CODE (t)) - { - case INTEGER_TYPE: - case REAL_TYPE: - case FIXED_POINT_TYPE: - case ENUMERAL_TYPE: - case UNION_TYPE: - case RECORD_TYPE: - break; - - case VAR_DECL: - case PARM_DECL: - case FIELD_DECL: - case ARRAY_TYPE: - case FUNCTION_TYPE: - case FUNCTION_DECL: - case TYPE_DECL: - pp_direct_declarator (pp, t); - break; - - - default: - pp_unsupported_tree (pp, t); - break; - } -} - -/* declaration: - declaration-specifiers init-declarator-list(opt) ; */ - -void -pp_c_declaration (c_pretty_printer *pp, tree t) -{ - pp_declaration_specifiers (pp, t); - pp_c_init_declarator (pp, t); -} - -/* Pretty-print ATTRIBUTES using GNU C extension syntax. */ - -void -pp_c_attributes (c_pretty_printer *pp, tree attributes) -{ - if (attributes == NULL_TREE) - return; - - pp_c_ws_string (pp, "__attribute__"); - pp_c_left_paren (pp); - pp_c_left_paren (pp); - for (; attributes != NULL_TREE; attributes = TREE_CHAIN (attributes)) - { - pp_tree_identifier (pp, TREE_PURPOSE (attributes)); - if (TREE_VALUE (attributes)) - pp_c_call_argument_list (pp, TREE_VALUE (attributes)); - - if (TREE_CHAIN (attributes)) - pp_separate_with (pp, ','); - } - pp_c_right_paren (pp); - pp_c_right_paren (pp); -} - -/* function-definition: - declaration-specifiers declarator compound-statement */ - -void -pp_c_function_definition (c_pretty_printer *pp, tree t) -{ - pp_declaration_specifiers (pp, t); - pp_declarator (pp, t); - pp_needs_newline (pp) = true; - pp_statement (pp, DECL_SAVED_TREE (t)); - pp_newline (pp); - pp_flush (pp); -} - - -/* Expressions. */ - -/* Print out a c-char. This is called solely for characters which are - in the *target* execution character set. We ought to convert them - back to the *host* execution character set before printing, but we - have no way to do this at present. A decent compromise is to print - all characters as if they were in the host execution character set, - and not attempt to recover any named escape characters, but render - all unprintables as octal escapes. If the host and target character - sets are the same, this produces relatively readable output. If they - are not the same, strings may appear as gibberish, but that's okay - (in fact, it may well be what the reader wants, e.g. if they are looking - to see if conversion to the target character set happened correctly). - - A special case: we need to prefix \, ", and ' with backslashes. It is - correct to do so for the *host*'s \, ", and ', because the rest of the - file appears in the host character set. */ - -static void -pp_c_char (c_pretty_printer *pp, int c) -{ - if (ISPRINT (c)) - { - switch (c) - { - case '\\': pp_string (pp, "\\\\"); break; - case '\'': pp_string (pp, "\\\'"); break; - case '\"': pp_string (pp, "\\\""); break; - default: pp_character (pp, c); - } - } - else - pp_scalar (pp, "\\%03o", (unsigned) c); -} - -/* Print out a STRING literal. */ - -void -pp_c_string_literal (c_pretty_printer *pp, tree s) -{ - const char *p = TREE_STRING_POINTER (s); - int n = TREE_STRING_LENGTH (s) - 1; - int i; - pp_doublequote (pp); - for (i = 0; i < n; ++i) - pp_c_char (pp, p[i]); - pp_doublequote (pp); -} - -/* Pretty-print an INTEGER literal. */ - -static void -pp_c_integer_constant (c_pretty_printer *pp, tree i) -{ - tree type = TREE_TYPE (i); - - if (TREE_INT_CST_HIGH (i) == 0) - pp_wide_integer (pp, TREE_INT_CST_LOW (i)); - else - { - unsigned HOST_WIDE_INT low = TREE_INT_CST_LOW (i); - HOST_WIDE_INT high = TREE_INT_CST_HIGH (i); - if (tree_int_cst_sgn (i) < 0) - { - pp_character (pp, '-'); - high = ~high + !low; - low = -low; - } - sprintf (pp_buffer (pp)->digit_buffer, HOST_WIDE_INT_PRINT_DOUBLE_HEX, - (unsigned HOST_WIDE_INT) high, (unsigned HOST_WIDE_INT) low); - pp_string (pp, pp_buffer (pp)->digit_buffer); - } - if (TYPE_UNSIGNED (type)) - pp_character (pp, 'u'); - if (type == long_integer_type_node || type == long_unsigned_type_node) - pp_character (pp, 'l'); - else if (type == long_long_integer_type_node - || type == long_long_unsigned_type_node) - pp_string (pp, "ll"); - else if (type == int128_integer_type_node - || type == int128_unsigned_type_node) - pp_string (pp, "I128"); -} - -/* Print out a CHARACTER literal. */ - -static void -pp_c_character_constant (c_pretty_printer *pp, tree c) -{ - tree type = TREE_TYPE (c); - if (type == wchar_type_node) - pp_character (pp, 'L'); - pp_quote (pp); - if (host_integerp (c, TYPE_UNSIGNED (type))) - pp_c_char (pp, tree_low_cst (c, TYPE_UNSIGNED (type))); - else - pp_scalar (pp, "\\x%x", (unsigned) TREE_INT_CST_LOW (c)); - pp_quote (pp); -} - -/* Print out a BOOLEAN literal. */ - -static void -pp_c_bool_constant (c_pretty_printer *pp, tree b) -{ - if (b == boolean_false_node) - { - if (c_dialect_cxx ()) - pp_c_ws_string (pp, "false"); - else if (flag_isoc99) - pp_c_ws_string (pp, "_False"); - else - pp_unsupported_tree (pp, b); - } - else if (b == boolean_true_node) - { - if (c_dialect_cxx ()) - pp_c_ws_string (pp, "true"); - else if (flag_isoc99) - pp_c_ws_string (pp, "_True"); - else - pp_unsupported_tree (pp, b); - } - else if (TREE_CODE (b) == INTEGER_CST) - pp_c_integer_constant (pp, b); - else - pp_unsupported_tree (pp, b); -} - -/* Attempt to print out an ENUMERATOR. Return true on success. Else return - false; that means the value was obtained by a cast, in which case - print out the type-id part of the cast-expression -- the casted value - is then printed by pp_c_integer_literal. */ - -static bool -pp_c_enumeration_constant (c_pretty_printer *pp, tree e) -{ - bool value_is_named = true; - tree type = TREE_TYPE (e); - tree value; - - /* Find the name of this constant. */ - for (value = TYPE_VALUES (type); - value != NULL_TREE && !tree_int_cst_equal (TREE_VALUE (value), e); - value = TREE_CHAIN (value)) - ; - - if (value != NULL_TREE) - pp_id_expression (pp, TREE_PURPOSE (value)); - else - { - /* Value must have been cast. */ - pp_c_type_cast (pp, type); - value_is_named = false; - } - - return value_is_named; -} - -/* Print out a REAL value as a decimal-floating-constant. */ - -static void -pp_c_floating_constant (c_pretty_printer *pp, tree r) -{ - real_to_decimal (pp_buffer (pp)->digit_buffer, &TREE_REAL_CST (r), - sizeof (pp_buffer (pp)->digit_buffer), 0, 1); - pp_string (pp, pp_buffer(pp)->digit_buffer); - if (TREE_TYPE (r) == float_type_node) - pp_character (pp, 'f'); - else if (TREE_TYPE (r) == long_double_type_node) - pp_character (pp, 'l'); - else if (TREE_TYPE (r) == dfloat128_type_node) - pp_string (pp, "dl"); - else if (TREE_TYPE (r) == dfloat64_type_node) - pp_string (pp, "dd"); - else if (TREE_TYPE (r) == dfloat32_type_node) - pp_string (pp, "df"); -} - -/* Print out a FIXED value as a decimal-floating-constant. */ - -static void -pp_c_fixed_constant (c_pretty_printer *pp, tree r) -{ - fixed_to_decimal (pp_buffer (pp)->digit_buffer, &TREE_FIXED_CST (r), - sizeof (pp_buffer (pp)->digit_buffer)); - pp_string (pp, pp_buffer(pp)->digit_buffer); -} - -/* Pretty-print a compound literal expression. GNU extensions include - vector constants. */ - -static void -pp_c_compound_literal (c_pretty_printer *pp, tree e) -{ - tree type = TREE_TYPE (e); - pp_c_type_cast (pp, type); - - switch (TREE_CODE (type)) - { - case RECORD_TYPE: - case UNION_TYPE: - case ARRAY_TYPE: - case VECTOR_TYPE: - case COMPLEX_TYPE: - pp_c_brace_enclosed_initializer_list (pp, e); - break; - - default: - pp_unsupported_tree (pp, e); - break; - } -} - -/* Pretty-print a COMPLEX_EXPR expression. */ - -static void -pp_c_complex_expr (c_pretty_printer *pp, tree e) -{ - /* Handle a few common special cases, otherwise fallback - to printing it as compound literal. */ - tree type = TREE_TYPE (e); - tree realexpr = TREE_OPERAND (e, 0); - tree imagexpr = TREE_OPERAND (e, 1); - - /* Cast of an COMPLEX_TYPE expression to a different COMPLEX_TYPE. */ - if (TREE_CODE (realexpr) == NOP_EXPR - && TREE_CODE (imagexpr) == NOP_EXPR - && TREE_TYPE (realexpr) == TREE_TYPE (type) - && TREE_TYPE (imagexpr) == TREE_TYPE (type) - && TREE_CODE (TREE_OPERAND (realexpr, 0)) == REALPART_EXPR - && TREE_CODE (TREE_OPERAND (imagexpr, 0)) == IMAGPART_EXPR - && TREE_OPERAND (TREE_OPERAND (realexpr, 0), 0) - == TREE_OPERAND (TREE_OPERAND (imagexpr, 0), 0)) - { - pp_c_type_cast (pp, type); - pp_expression (pp, TREE_OPERAND (TREE_OPERAND (realexpr, 0), 0)); - return; - } - - /* Cast of an scalar expression to COMPLEX_TYPE. */ - if ((integer_zerop (imagexpr) || real_zerop (imagexpr)) - && TREE_TYPE (realexpr) == TREE_TYPE (type)) - { - pp_c_type_cast (pp, type); - if (TREE_CODE (realexpr) == NOP_EXPR) - realexpr = TREE_OPERAND (realexpr, 0); - pp_expression (pp, realexpr); - return; - } - - pp_c_compound_literal (pp, e); -} - -/* constant: - integer-constant - floating-constant - fixed-point-constant - enumeration-constant - character-constant */ - -void -pp_c_constant (c_pretty_printer *pp, tree e) -{ - const enum tree_code code = TREE_CODE (e); - - switch (code) - { - case INTEGER_CST: - { - tree type = TREE_TYPE (e); - if (type == boolean_type_node) - pp_c_bool_constant (pp, e); - else if (type == char_type_node) - pp_c_character_constant (pp, e); - else if (TREE_CODE (type) == ENUMERAL_TYPE - && pp_c_enumeration_constant (pp, e)) - ; - else - pp_c_integer_constant (pp, e); - } - break; - - case REAL_CST: - pp_c_floating_constant (pp, e); - break; - - case FIXED_CST: - pp_c_fixed_constant (pp, e); - break; - - case STRING_CST: - pp_c_string_literal (pp, e); - break; - - case COMPLEX_CST: - /* Sometimes, we are confused and we think a complex literal - is a constant. Such thing is a compound literal which - grammatically belongs to postfix-expr production. */ - pp_c_compound_literal (pp, e); - break; - - default: - pp_unsupported_tree (pp, e); - break; - } -} - -/* Pretty-print a string such as an identifier, without changing its - encoding, preceded by whitespace is necessary. */ - -void -pp_c_ws_string (c_pretty_printer *pp, const char *str) -{ - pp_c_maybe_whitespace (pp); - pp_string (pp, str); - pp_base (pp)->padding = pp_before; -} - -/* Pretty-print an IDENTIFIER_NODE, which may contain UTF-8 sequences - that need converting to the locale encoding, preceded by whitespace - is necessary. */ - -void -pp_c_identifier (c_pretty_printer *pp, const char *id) -{ - pp_c_maybe_whitespace (pp); - pp_identifier (pp, id); - pp_base (pp)->padding = pp_before; -} - -/* Pretty-print a C primary-expression. - primary-expression: - identifier - constant - string-literal - ( expression ) */ - -void -pp_c_primary_expression (c_pretty_printer *pp, tree e) -{ - switch (TREE_CODE (e)) - { - case VAR_DECL: - case PARM_DECL: - case FIELD_DECL: - case CONST_DECL: - case FUNCTION_DECL: - case LABEL_DECL: - pp_c_tree_decl_identifier (pp, e); - break; - - case IDENTIFIER_NODE: - pp_c_tree_identifier (pp, e); - break; - - case ERROR_MARK: - pp_c_ws_string (pp, M_("")); - break; - - case RESULT_DECL: - pp_c_ws_string (pp, M_("")); - break; - - case INTEGER_CST: - case REAL_CST: - case FIXED_CST: - case STRING_CST: - pp_c_constant (pp, e); - break; - - case TARGET_EXPR: - pp_c_ws_string (pp, "__builtin_memcpy"); - pp_c_left_paren (pp); - pp_ampersand (pp); - pp_primary_expression (pp, TREE_OPERAND (e, 0)); - pp_separate_with (pp, ','); - pp_ampersand (pp); - pp_initializer (pp, TREE_OPERAND (e, 1)); - if (TREE_OPERAND (e, 2)) - { - pp_separate_with (pp, ','); - pp_c_expression (pp, TREE_OPERAND (e, 2)); - } - pp_c_right_paren (pp); - break; - - default: - /* FIXME: Make sure we won't get into an infinite loop. */ - pp_c_left_paren (pp); - pp_expression (pp, e); - pp_c_right_paren (pp); - break; - } -} - -/* Print out a C initializer -- also support C compound-literals. - initializer: - assignment-expression: - { initializer-list } - { initializer-list , } */ - -static void -pp_c_initializer (c_pretty_printer *pp, tree e) -{ - if (TREE_CODE (e) == CONSTRUCTOR) - pp_c_brace_enclosed_initializer_list (pp, e); - else - pp_expression (pp, e); -} - -/* init-declarator: - declarator: - declarator = initializer */ - -void -pp_c_init_declarator (c_pretty_printer *pp, tree t) -{ - pp_declarator (pp, t); - /* We don't want to output function definitions here. There are handled - elsewhere (and the syntactic form is bogus anyway). */ - if (TREE_CODE (t) != FUNCTION_DECL && DECL_INITIAL (t)) - { - tree init = DECL_INITIAL (t); - /* This C++ bit is handled here because it is easier to do so. - In templates, the C++ parser builds a TREE_LIST for a - direct-initialization; the TREE_PURPOSE is the variable to - initialize and the TREE_VALUE is the initializer. */ - if (TREE_CODE (init) == TREE_LIST) - { - pp_c_left_paren (pp); - pp_expression (pp, TREE_VALUE (init)); - pp_right_paren (pp); - } - else - { - pp_space (pp); - pp_equal (pp); - pp_space (pp); - pp_c_initializer (pp, init); - } - } -} - -/* initializer-list: - designation(opt) initializer - initializer-list , designation(opt) initializer - - designation: - designator-list = - - designator-list: - designator - designator-list designator - - designator: - [ constant-expression ] - identifier */ - -static void -pp_c_initializer_list (c_pretty_printer *pp, tree e) -{ - tree type = TREE_TYPE (e); - const enum tree_code code = TREE_CODE (type); - - if (TREE_CODE (e) == CONSTRUCTOR) - { - pp_c_constructor_elts (pp, CONSTRUCTOR_ELTS (e)); - return; - } - - switch (code) - { - case RECORD_TYPE: - case UNION_TYPE: - case ARRAY_TYPE: - { - tree init = TREE_OPERAND (e, 0); - for (; init != NULL_TREE; init = TREE_CHAIN (init)) - { - if (code == RECORD_TYPE || code == UNION_TYPE) - { - pp_c_dot (pp); - pp_c_primary_expression (pp, TREE_PURPOSE (init)); - } - else - { - pp_c_left_bracket (pp); - if (TREE_PURPOSE (init)) - pp_c_constant (pp, TREE_PURPOSE (init)); - pp_c_right_bracket (pp); - } - pp_c_whitespace (pp); - pp_equal (pp); - pp_c_whitespace (pp); - pp_initializer (pp, TREE_VALUE (init)); - if (TREE_CHAIN (init)) - pp_separate_with (pp, ','); - } - } - return; - - case VECTOR_TYPE: - if (TREE_CODE (e) == VECTOR_CST) - pp_c_expression_list (pp, TREE_VECTOR_CST_ELTS (e)); - else - break; - return; - - case COMPLEX_TYPE: - if (TREE_CODE (e) == COMPLEX_CST || TREE_CODE (e) == COMPLEX_EXPR) - { - const bool cst = TREE_CODE (e) == COMPLEX_CST; - pp_expression (pp, cst ? TREE_REALPART (e) : TREE_OPERAND (e, 0)); - pp_separate_with (pp, ','); - pp_expression (pp, cst ? TREE_IMAGPART (e) : TREE_OPERAND (e, 1)); - } - else - break; - return; - - default: - break; - } - - pp_unsupported_tree (pp, type); -} - -/* Pretty-print a brace-enclosed initializer-list. */ - -static void -pp_c_brace_enclosed_initializer_list (c_pretty_printer *pp, tree l) -{ - pp_c_left_brace (pp); - pp_c_initializer_list (pp, l); - pp_c_right_brace (pp); -} - - -/* This is a convenient function, used to bridge gap between C and C++ - grammars. - - id-expression: - identifier */ - -void -pp_c_id_expression (c_pretty_printer *pp, tree t) -{ - switch (TREE_CODE (t)) - { - case VAR_DECL: - case PARM_DECL: - case CONST_DECL: - case TYPE_DECL: - case FUNCTION_DECL: - case FIELD_DECL: - case LABEL_DECL: - pp_c_tree_decl_identifier (pp, t); - break; - - case IDENTIFIER_NODE: - pp_c_tree_identifier (pp, t); - break; - - default: - pp_unsupported_tree (pp, t); - break; - } -} - -/* postfix-expression: - primary-expression - postfix-expression [ expression ] - postfix-expression ( argument-expression-list(opt) ) - postfix-expression . identifier - postfix-expression -> identifier - postfix-expression ++ - postfix-expression -- - ( type-name ) { initializer-list } - ( type-name ) { initializer-list , } */ - -void -pp_c_postfix_expression (c_pretty_printer *pp, tree e) -{ - enum tree_code code = TREE_CODE (e); - switch (code) - { - case POSTINCREMENT_EXPR: - case POSTDECREMENT_EXPR: - pp_postfix_expression (pp, TREE_OPERAND (e, 0)); - pp_string (pp, code == POSTINCREMENT_EXPR ? "++" : "--"); - break; - - case ARRAY_REF: - pp_postfix_expression (pp, TREE_OPERAND (e, 0)); - pp_c_left_bracket (pp); - pp_expression (pp, TREE_OPERAND (e, 1)); - pp_c_right_bracket (pp); - break; - - case CALL_EXPR: - { - call_expr_arg_iterator iter; - tree arg; - pp_postfix_expression (pp, CALL_EXPR_FN (e)); - pp_c_left_paren (pp); - FOR_EACH_CALL_EXPR_ARG (arg, iter, e) - { - pp_expression (pp, arg); - if (more_call_expr_args_p (&iter)) - pp_separate_with (pp, ','); - } - pp_c_right_paren (pp); - break; - } - - case UNORDERED_EXPR: - pp_c_ws_string (pp, flag_isoc99 - ? "isunordered" - : "__builtin_isunordered"); - goto two_args_fun; - - case ORDERED_EXPR: - pp_c_ws_string (pp, flag_isoc99 - ? "!isunordered" - : "!__builtin_isunordered"); - goto two_args_fun; - - case UNLT_EXPR: - pp_c_ws_string (pp, flag_isoc99 - ? "!isgreaterequal" - : "!__builtin_isgreaterequal"); - goto two_args_fun; - - case UNLE_EXPR: - pp_c_ws_string (pp, flag_isoc99 - ? "!isgreater" - : "!__builtin_isgreater"); - goto two_args_fun; - - case UNGT_EXPR: - pp_c_ws_string (pp, flag_isoc99 - ? "!islessequal" - : "!__builtin_islessequal"); - goto two_args_fun; - - case UNGE_EXPR: - pp_c_ws_string (pp, flag_isoc99 - ? "!isless" - : "!__builtin_isless"); - goto two_args_fun; - - case UNEQ_EXPR: - pp_c_ws_string (pp, flag_isoc99 - ? "!islessgreater" - : "!__builtin_islessgreater"); - goto two_args_fun; - - case LTGT_EXPR: - pp_c_ws_string (pp, flag_isoc99 - ? "islessgreater" - : "__builtin_islessgreater"); - goto two_args_fun; - - two_args_fun: - pp_c_left_paren (pp); - pp_expression (pp, TREE_OPERAND (e, 0)); - pp_separate_with (pp, ','); - pp_expression (pp, TREE_OPERAND (e, 1)); - pp_c_right_paren (pp); - break; - - case ABS_EXPR: - pp_c_ws_string (pp, "__builtin_abs"); - pp_c_left_paren (pp); - pp_expression (pp, TREE_OPERAND (e, 0)); - pp_c_right_paren (pp); - break; - - case COMPONENT_REF: - { - tree object = TREE_OPERAND (e, 0); - if (TREE_CODE (object) == INDIRECT_REF) - { - pp_postfix_expression (pp, TREE_OPERAND (object, 0)); - pp_c_arrow (pp); - } - else - { - pp_postfix_expression (pp, object); - pp_c_dot (pp); - } - pp_expression (pp, TREE_OPERAND (e, 1)); - } - break; - - case BIT_FIELD_REF: - { - tree type = TREE_TYPE (e); - - type = signed_or_unsigned_type_for (TYPE_UNSIGNED (type), type); - if (type - && tree_int_cst_equal (TYPE_SIZE (type), TREE_OPERAND (e, 1))) - { - HOST_WIDE_INT bitpos = tree_low_cst (TREE_OPERAND (e, 2), 0); - HOST_WIDE_INT size = tree_low_cst (TYPE_SIZE (type), 0); - if ((bitpos % size) == 0) - { - pp_c_left_paren (pp); - pp_c_left_paren (pp); - pp_type_id (pp, type); - pp_c_star (pp); - pp_c_right_paren (pp); - pp_c_ampersand (pp); - pp_expression (pp, TREE_OPERAND (e, 0)); - pp_c_right_paren (pp); - pp_c_left_bracket (pp); - pp_wide_integer (pp, bitpos / size); - pp_c_right_bracket (pp); - break; - } - } - pp_unsupported_tree (pp, e); - } - break; - - case COMPLEX_CST: - case VECTOR_CST: - pp_c_compound_literal (pp, e); - break; - - case COMPLEX_EXPR: - pp_c_complex_expr (pp, e); - break; - - case COMPOUND_LITERAL_EXPR: - e = DECL_INITIAL (COMPOUND_LITERAL_EXPR_DECL (e)); - /* Fall through. */ - case CONSTRUCTOR: - pp_initializer (pp, e); - break; - - case VA_ARG_EXPR: - pp_c_ws_string (pp, "__builtin_va_arg"); - pp_c_left_paren (pp); - pp_assignment_expression (pp, TREE_OPERAND (e, 0)); - pp_separate_with (pp, ','); - pp_type_id (pp, TREE_TYPE (e)); - pp_c_right_paren (pp); - break; - - case ADDR_EXPR: - if (TREE_CODE (TREE_OPERAND (e, 0)) == FUNCTION_DECL) - { - pp_c_id_expression (pp, TREE_OPERAND (e, 0)); - break; - } - /* else fall through. */ - - default: - pp_primary_expression (pp, e); - break; - } -} - -/* Print out an expression-list; E is expected to be a TREE_LIST. */ - -void -pp_c_expression_list (c_pretty_printer *pp, tree e) -{ - for (; e != NULL_TREE; e = TREE_CHAIN (e)) - { - pp_expression (pp, TREE_VALUE (e)); - if (TREE_CHAIN (e)) - pp_separate_with (pp, ','); - } -} - -/* Print out V, which contains the elements of a constructor. */ - -void -pp_c_constructor_elts (c_pretty_printer *pp, VEC(constructor_elt,gc) *v) -{ - unsigned HOST_WIDE_INT ix; - tree value; - - FOR_EACH_CONSTRUCTOR_VALUE (v, ix, value) - { - pp_expression (pp, value); - if (ix != VEC_length (constructor_elt, v) - 1) - pp_separate_with (pp, ','); - } -} - -/* Print out an expression-list in parens, as if it were the argument - list to a function. */ - -void -pp_c_call_argument_list (c_pretty_printer *pp, tree t) -{ - pp_c_left_paren (pp); - if (t && TREE_CODE (t) == TREE_LIST) - pp_c_expression_list (pp, t); - pp_c_right_paren (pp); -} - -/* unary-expression: - postfix-expression - ++ cast-expression - -- cast-expression - unary-operator cast-expression - sizeof unary-expression - sizeof ( type-id ) - - unary-operator: one of - * & + - ! ~ - - GNU extensions. - unary-expression: - __alignof__ unary-expression - __alignof__ ( type-id ) - __real__ unary-expression - __imag__ unary-expression */ - -void -pp_c_unary_expression (c_pretty_printer *pp, tree e) -{ - enum tree_code code = TREE_CODE (e); - switch (code) - { - case PREINCREMENT_EXPR: - case PREDECREMENT_EXPR: - pp_string (pp, code == PREINCREMENT_EXPR ? "++" : "--"); - pp_c_unary_expression (pp, TREE_OPERAND (e, 0)); - break; - - case ADDR_EXPR: - case INDIRECT_REF: - case NEGATE_EXPR: - case BIT_NOT_EXPR: - case TRUTH_NOT_EXPR: - case CONJ_EXPR: - /* String literal are used by address. */ - if (code == ADDR_EXPR && TREE_CODE (TREE_OPERAND (e, 0)) != STRING_CST) - pp_ampersand (pp); - else if (code == INDIRECT_REF) - pp_c_star (pp); - else if (code == NEGATE_EXPR) - pp_minus (pp); - else if (code == BIT_NOT_EXPR || code == CONJ_EXPR) - pp_complement (pp); - else if (code == TRUTH_NOT_EXPR) - pp_exclamation (pp); - pp_c_cast_expression (pp, TREE_OPERAND (e, 0)); - break; - - case REALPART_EXPR: - case IMAGPART_EXPR: - pp_c_ws_string (pp, code == REALPART_EXPR ? "__real__" : "__imag__"); - pp_c_whitespace (pp); - pp_unary_expression (pp, TREE_OPERAND (e, 0)); - break; - - default: - pp_postfix_expression (pp, e); - break; - } -} - -/* cast-expression: - unary-expression - ( type-name ) cast-expression */ - -void -pp_c_cast_expression (c_pretty_printer *pp, tree e) -{ - switch (TREE_CODE (e)) - { - case FLOAT_EXPR: - case FIX_TRUNC_EXPR: - CASE_CONVERT: - case VIEW_CONVERT_EXPR: - pp_c_type_cast (pp, TREE_TYPE (e)); - pp_c_cast_expression (pp, TREE_OPERAND (e, 0)); - break; - - default: - pp_unary_expression (pp, e); - } -} - -/* multiplicative-expression: - cast-expression - multiplicative-expression * cast-expression - multiplicative-expression / cast-expression - multiplicative-expression % cast-expression */ - -static void -pp_c_multiplicative_expression (c_pretty_printer *pp, tree e) -{ - enum tree_code code = TREE_CODE (e); - switch (code) - { - case MULT_EXPR: - case TRUNC_DIV_EXPR: - case TRUNC_MOD_EXPR: - pp_multiplicative_expression (pp, TREE_OPERAND (e, 0)); - pp_c_whitespace (pp); - if (code == MULT_EXPR) - pp_c_star (pp); - else if (code == TRUNC_DIV_EXPR) - pp_slash (pp); - else - pp_modulo (pp); - pp_c_whitespace (pp); - pp_c_cast_expression (pp, TREE_OPERAND (e, 1)); - break; - - default: - pp_c_cast_expression (pp, e); - break; - } -} - -/* additive-expression: - multiplicative-expression - additive-expression + multiplicative-expression - additive-expression - multiplicative-expression */ - -static void -pp_c_additive_expression (c_pretty_printer *pp, tree e) -{ - enum tree_code code = TREE_CODE (e); - switch (code) - { - case POINTER_PLUS_EXPR: - case PLUS_EXPR: - case MINUS_EXPR: - pp_c_additive_expression (pp, TREE_OPERAND (e, 0)); - pp_c_whitespace (pp); - if (code == PLUS_EXPR || code == POINTER_PLUS_EXPR) - pp_plus (pp); - else - pp_minus (pp); - pp_c_whitespace (pp); - pp_multiplicative_expression (pp, TREE_OPERAND (e, 1)); - break; - - default: - pp_multiplicative_expression (pp, e); - break; - } -} - -/* additive-expression: - additive-expression - shift-expression << additive-expression - shift-expression >> additive-expression */ - -static void -pp_c_shift_expression (c_pretty_printer *pp, tree e) -{ - enum tree_code code = TREE_CODE (e); - switch (code) - { - case LSHIFT_EXPR: - case RSHIFT_EXPR: - pp_c_shift_expression (pp, TREE_OPERAND (e, 0)); - pp_c_whitespace (pp); - pp_string (pp, code == LSHIFT_EXPR ? "<<" : ">>"); - pp_c_whitespace (pp); - pp_c_additive_expression (pp, TREE_OPERAND (e, 1)); - break; - - default: - pp_c_additive_expression (pp, e); - } -} - -/* relational-expression: - shift-expression - relational-expression < shift-expression - relational-expression > shift-expression - relational-expression <= shift-expression - relational-expression >= shift-expression */ - -static void -pp_c_relational_expression (c_pretty_printer *pp, tree e) -{ - enum tree_code code = TREE_CODE (e); - switch (code) - { - case LT_EXPR: - case GT_EXPR: - case LE_EXPR: - case GE_EXPR: - pp_c_relational_expression (pp, TREE_OPERAND (e, 0)); - pp_c_whitespace (pp); - if (code == LT_EXPR) - pp_less (pp); - else if (code == GT_EXPR) - pp_greater (pp); - else if (code == LE_EXPR) - pp_string (pp, "<="); - else if (code == GE_EXPR) - pp_string (pp, ">="); - pp_c_whitespace (pp); - pp_c_shift_expression (pp, TREE_OPERAND (e, 1)); - break; - - default: - pp_c_shift_expression (pp, e); - break; - } -} - -/* equality-expression: - relational-expression - equality-expression == relational-expression - equality-equality != relational-expression */ - -static void -pp_c_equality_expression (c_pretty_printer *pp, tree e) -{ - enum tree_code code = TREE_CODE (e); - switch (code) - { - case EQ_EXPR: - case NE_EXPR: - pp_c_equality_expression (pp, TREE_OPERAND (e, 0)); - pp_c_whitespace (pp); - pp_string (pp, code == EQ_EXPR ? "==" : "!="); - pp_c_whitespace (pp); - pp_c_relational_expression (pp, TREE_OPERAND (e, 1)); - break; - - default: - pp_c_relational_expression (pp, e); - break; - } -} - -/* AND-expression: - equality-expression - AND-expression & equality-equality */ - -static void -pp_c_and_expression (c_pretty_printer *pp, tree e) -{ - if (TREE_CODE (e) == BIT_AND_EXPR) - { - pp_c_and_expression (pp, TREE_OPERAND (e, 0)); - pp_c_whitespace (pp); - pp_ampersand (pp); - pp_c_whitespace (pp); - pp_c_equality_expression (pp, TREE_OPERAND (e, 1)); - } - else - pp_c_equality_expression (pp, e); -} - -/* exclusive-OR-expression: - AND-expression - exclusive-OR-expression ^ AND-expression */ - -static void -pp_c_exclusive_or_expression (c_pretty_printer *pp, tree e) -{ - if (TREE_CODE (e) == BIT_XOR_EXPR - || TREE_CODE (e) == TRUTH_XOR_EXPR) - { - pp_c_exclusive_or_expression (pp, TREE_OPERAND (e, 0)); - if (TREE_CODE (e) == BIT_XOR_EXPR) - pp_c_maybe_whitespace (pp); - else - pp_c_whitespace (pp); - pp_carret (pp); - pp_c_whitespace (pp); - pp_c_and_expression (pp, TREE_OPERAND (e, 1)); - } - else - pp_c_and_expression (pp, e); -} - -/* inclusive-OR-expression: - exclusive-OR-expression - inclusive-OR-expression | exclusive-OR-expression */ - -static void -pp_c_inclusive_or_expression (c_pretty_printer *pp, tree e) -{ - if (TREE_CODE (e) == BIT_IOR_EXPR) - { - pp_c_exclusive_or_expression (pp, TREE_OPERAND (e, 0)); - pp_c_whitespace (pp); - pp_bar (pp); - pp_c_whitespace (pp); - pp_c_exclusive_or_expression (pp, TREE_OPERAND (e, 1)); - } - else - pp_c_exclusive_or_expression (pp, e); -} - -/* logical-AND-expression: - inclusive-OR-expression - logical-AND-expression && inclusive-OR-expression */ - -static void -pp_c_logical_and_expression (c_pretty_printer *pp, tree e) -{ - if (TREE_CODE (e) == TRUTH_ANDIF_EXPR - || TREE_CODE (e) == TRUTH_AND_EXPR) - { - pp_c_logical_and_expression (pp, TREE_OPERAND (e, 0)); - pp_c_whitespace (pp); - pp_string (pp, "&&"); - pp_c_whitespace (pp); - pp_c_inclusive_or_expression (pp, TREE_OPERAND (e, 1)); - } - else - pp_c_inclusive_or_expression (pp, e); -} - -/* logical-OR-expression: - logical-AND-expression - logical-OR-expression || logical-AND-expression */ - -void -pp_c_logical_or_expression (c_pretty_printer *pp, tree e) -{ - if (TREE_CODE (e) == TRUTH_ORIF_EXPR - || TREE_CODE (e) == TRUTH_OR_EXPR) - { - pp_c_logical_or_expression (pp, TREE_OPERAND (e, 0)); - pp_c_whitespace (pp); - pp_string (pp, "||"); - pp_c_whitespace (pp); - pp_c_logical_and_expression (pp, TREE_OPERAND (e, 1)); - } - else - pp_c_logical_and_expression (pp, e); -} - -/* conditional-expression: - logical-OR-expression - logical-OR-expression ? expression : conditional-expression */ - -static void -pp_c_conditional_expression (c_pretty_printer *pp, tree e) -{ - if (TREE_CODE (e) == COND_EXPR) - { - pp_c_logical_or_expression (pp, TREE_OPERAND (e, 0)); - pp_c_whitespace (pp); - pp_question (pp); - pp_c_whitespace (pp); - pp_expression (pp, TREE_OPERAND (e, 1)); - pp_c_whitespace (pp); - pp_colon (pp); - pp_c_whitespace (pp); - pp_c_conditional_expression (pp, TREE_OPERAND (e, 2)); - } - else - pp_c_logical_or_expression (pp, e); -} - - -/* assignment-expression: - conditional-expression - unary-expression assignment-operator assignment-expression - - assignment-expression: one of - = *= /= %= += -= >>= <<= &= ^= |= */ - -static void -pp_c_assignment_expression (c_pretty_printer *pp, tree e) -{ - if (TREE_CODE (e) == MODIFY_EXPR - || TREE_CODE (e) == INIT_EXPR) - { - pp_c_unary_expression (pp, TREE_OPERAND (e, 0)); - pp_c_whitespace (pp); - pp_equal (pp); - pp_space (pp); - pp_c_expression (pp, TREE_OPERAND (e, 1)); - } - else - pp_c_conditional_expression (pp, e); -} - -/* expression: - assignment-expression - expression , assignment-expression - - Implementation note: instead of going through the usual recursion - chain, I take the liberty of dispatching nodes to the appropriate - functions. This makes some redundancy, but it worths it. That also - prevents a possible infinite recursion between pp_c_primary_expression () - and pp_c_expression (). */ - -void -pp_c_expression (c_pretty_printer *pp, tree e) -{ - switch (TREE_CODE (e)) - { - case INTEGER_CST: - pp_c_integer_constant (pp, e); - break; - - case REAL_CST: - pp_c_floating_constant (pp, e); - break; - - case FIXED_CST: - pp_c_fixed_constant (pp, e); - break; - - case STRING_CST: - pp_c_string_literal (pp, e); - break; - - case IDENTIFIER_NODE: - case FUNCTION_DECL: - case VAR_DECL: - case CONST_DECL: - case PARM_DECL: - case RESULT_DECL: - case FIELD_DECL: - case LABEL_DECL: - case ERROR_MARK: - pp_primary_expression (pp, e); - break; - - case POSTINCREMENT_EXPR: - case POSTDECREMENT_EXPR: - case ARRAY_REF: - case CALL_EXPR: - case COMPONENT_REF: - case BIT_FIELD_REF: - case COMPLEX_CST: - case COMPLEX_EXPR: - case VECTOR_CST: - case ORDERED_EXPR: - case UNORDERED_EXPR: - case LTGT_EXPR: - case UNEQ_EXPR: - case UNLE_EXPR: - case UNLT_EXPR: - case UNGE_EXPR: - case UNGT_EXPR: - case ABS_EXPR: - case CONSTRUCTOR: - case COMPOUND_LITERAL_EXPR: - case VA_ARG_EXPR: - pp_postfix_expression (pp, e); - break; - - case CONJ_EXPR: - case ADDR_EXPR: - case INDIRECT_REF: - case NEGATE_EXPR: - case BIT_NOT_EXPR: - case TRUTH_NOT_EXPR: - case PREINCREMENT_EXPR: - case PREDECREMENT_EXPR: - case REALPART_EXPR: - case IMAGPART_EXPR: - pp_c_unary_expression (pp, e); - break; - - case FLOAT_EXPR: - case FIX_TRUNC_EXPR: - CASE_CONVERT: - case VIEW_CONVERT_EXPR: - pp_c_cast_expression (pp, e); - break; - - case MULT_EXPR: - case TRUNC_MOD_EXPR: - case TRUNC_DIV_EXPR: - pp_multiplicative_expression (pp, e); - break; - - case LSHIFT_EXPR: - case RSHIFT_EXPR: - pp_c_shift_expression (pp, e); - break; - - case LT_EXPR: - case GT_EXPR: - case LE_EXPR: - case GE_EXPR: - pp_c_relational_expression (pp, e); - break; - - case BIT_AND_EXPR: - pp_c_and_expression (pp, e); - break; - - case BIT_XOR_EXPR: - case TRUTH_XOR_EXPR: - pp_c_exclusive_or_expression (pp, e); - break; - - case BIT_IOR_EXPR: - pp_c_inclusive_or_expression (pp, e); - break; - - case TRUTH_ANDIF_EXPR: - case TRUTH_AND_EXPR: - pp_c_logical_and_expression (pp, e); - break; - - case TRUTH_ORIF_EXPR: - case TRUTH_OR_EXPR: - pp_c_logical_or_expression (pp, e); - break; - - case EQ_EXPR: - case NE_EXPR: - pp_c_equality_expression (pp, e); - break; - - case COND_EXPR: - pp_conditional_expression (pp, e); - break; - - case POINTER_PLUS_EXPR: - case PLUS_EXPR: - case MINUS_EXPR: - pp_c_additive_expression (pp, e); - break; - - case MODIFY_EXPR: - case INIT_EXPR: - pp_assignment_expression (pp, e); - break; - - case COMPOUND_EXPR: - pp_c_left_paren (pp); - pp_expression (pp, TREE_OPERAND (e, 0)); - pp_separate_with (pp, ','); - pp_assignment_expression (pp, TREE_OPERAND (e, 1)); - pp_c_right_paren (pp); - break; - - case NON_LVALUE_EXPR: - case SAVE_EXPR: - pp_expression (pp, TREE_OPERAND (e, 0)); - break; - - case TARGET_EXPR: - pp_postfix_expression (pp, TREE_OPERAND (e, 1)); - break; - - case BIND_EXPR: - case GOTO_EXPR: - /* We don't yet have a way of dumping statements in a - human-readable format. */ - pp_string (pp, "({...})"); - break; - - default: - pp_unsupported_tree (pp, e); - break; - } -} - - - -/* Statements. */ - -void -pp_c_statement (c_pretty_printer *pp, tree stmt) -{ - if (stmt == NULL) - return; - - if (pp_needs_newline (pp)) - pp_newline_and_indent (pp, 0); - - dump_generic_node (pp_base (pp), stmt, pp_indentation (pp), 0, true); -} - - -/* Initialize the PRETTY-PRINTER for handling C codes. */ - -void -pp_c_pretty_printer_init (c_pretty_printer *pp) -{ - pp->offset_list = 0; - - pp->declaration = pp_c_declaration; - pp->declaration_specifiers = pp_c_declaration_specifiers; - pp->declarator = pp_c_declarator; - pp->direct_declarator = pp_c_direct_declarator; - pp->type_specifier_seq = pp_c_specifier_qualifier_list; - pp->abstract_declarator = pp_c_abstract_declarator; - pp->direct_abstract_declarator = pp_c_direct_abstract_declarator; - pp->ptr_operator = pp_c_pointer; - pp->parameter_list = pp_c_parameter_type_list; - pp->type_id = pp_c_type_id; - pp->simple_type_specifier = pp_c_type_specifier; - pp->function_specifier = pp_c_function_specifier; - pp->storage_class_specifier = pp_c_storage_class_specifier; - - pp->statement = pp_c_statement; - - pp->constant = pp_c_constant; - pp->id_expression = pp_c_id_expression; - pp->primary_expression = pp_c_primary_expression; - pp->postfix_expression = pp_c_postfix_expression; - pp->unary_expression = pp_c_unary_expression; - pp->initializer = pp_c_initializer; - pp->multiplicative_expression = pp_c_multiplicative_expression; - pp->conditional_expression = pp_c_conditional_expression; - pp->assignment_expression = pp_c_assignment_expression; - pp->expression = pp_c_expression; -} - - -/* Print the tree T in full, on file FILE. */ - -void -print_c_tree (FILE *file, tree t) -{ - static c_pretty_printer pp_rec; - static bool initialized = 0; - c_pretty_printer *pp = &pp_rec; - - if (!initialized) - { - initialized = 1; - pp_construct (pp_base (pp), NULL, 0); - pp_c_pretty_printer_init (pp); - pp_needs_newline (pp) = true; - } - pp_base (pp)->buffer->stream = file; - - pp_statement (pp, t); - - pp_newline (pp); - pp_flush (pp); -} - -/* Print the tree T in full, on stderr. */ - -DEBUG_FUNCTION void -debug_c_tree (tree t) -{ - print_c_tree (stderr, t); - fputc ('\n', stderr); -} - -/* Output the DECL_NAME of T. If T has no DECL_NAME, output a string made - up of T's memory address. */ - -void -pp_c_tree_decl_identifier (c_pretty_printer *pp, tree t) -{ - const char *name; - - gcc_assert (DECL_P (t)); - - if (DECL_NAME (t)) - name = IDENTIFIER_POINTER (DECL_NAME (t)); - else - { - static char xname[8]; - sprintf (xname, "", ((unsigned)((uintptr_t)(t) & 0xffff))); - name = xname; - } - - pp_c_identifier (pp, name); -} diff --git a/gcc/c-pretty-print.h b/gcc/c-pretty-print.h deleted file mode 100644 index 8f12bb05237..00000000000 --- a/gcc/c-pretty-print.h +++ /dev/null @@ -1,212 +0,0 @@ -/* Various declarations for the C and C++ pretty-printers. - Copyright (C) 2002, 2003, 2004, 2007, 2009 Free Software Foundation, Inc. - Contributed by Gabriel Dos Reis - -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 3, 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 COPYING3. If not see -. */ - -#ifndef GCC_C_PRETTY_PRINTER -#define GCC_C_PRETTY_PRINTER - -#include "tree.h" -#include "c-common.h" -#include "pretty-print.h" - - -typedef enum - { - pp_c_flag_abstract = 1 << 1, - pp_c_flag_last_bit = 2 - } pp_c_pretty_print_flags; - - -/* The data type used to bundle information necessary for pretty-printing - a C or C++ entity. */ -typedef struct c_pretty_print_info c_pretty_printer; - -/* The type of a C pretty-printer 'member' function. */ -typedef void (*c_pretty_print_fn) (c_pretty_printer *, tree); - -/* The datatype that contains information necessary for pretty-printing - a tree that represents a C construct. Any pretty-printer for a - language using C/c++ syntax can derive from this datatype and reuse - facilities provided here. It can do so by having a subobject of type - c_pretty_printer and override the macro pp_c_base to return a pointer - to that subobject. Such a pretty-printer has the responsibility to - initialize the pp_base() part, then call pp_c_pretty_printer_init - to set up the components that are specific to the C pretty-printer. - A derived pretty-printer can override any function listed in the - vtable below. See cp/cxx-pretty-print.h and cp/cxx-pretty-print.c - for an example of derivation. */ -struct c_pretty_print_info -{ - pretty_printer base; - /* Points to the first element of an array of offset-list. - Not used yet. */ - int *offset_list; - - pp_flags flags; - - /* These must be overridden by each of the C and C++ front-end to - reflect their understanding of syntactic productions when they differ. */ - c_pretty_print_fn declaration; - c_pretty_print_fn declaration_specifiers; - c_pretty_print_fn declarator; - c_pretty_print_fn abstract_declarator; - c_pretty_print_fn direct_abstract_declarator; - c_pretty_print_fn type_specifier_seq; - c_pretty_print_fn direct_declarator; - c_pretty_print_fn ptr_operator; - c_pretty_print_fn parameter_list; - c_pretty_print_fn type_id; - c_pretty_print_fn simple_type_specifier; - c_pretty_print_fn function_specifier; - c_pretty_print_fn storage_class_specifier; - c_pretty_print_fn initializer; - - c_pretty_print_fn statement; - - c_pretty_print_fn constant; - c_pretty_print_fn id_expression; - c_pretty_print_fn primary_expression; - c_pretty_print_fn postfix_expression; - c_pretty_print_fn unary_expression; - c_pretty_print_fn multiplicative_expression; - c_pretty_print_fn conditional_expression; - c_pretty_print_fn assignment_expression; - c_pretty_print_fn expression; -}; - -/* Override the pp_base macro. Derived pretty-printers should not - touch this macro. Instead they should override pp_c_base instead. */ -#undef pp_base -#define pp_base(PP) (&pp_c_base (PP)->base) - - -#define pp_c_tree_identifier(PPI, ID) \ - pp_c_identifier (PPI, IDENTIFIER_POINTER (ID)) - -#define pp_declaration(PPI, T) \ - pp_c_base (PPI)->declaration (pp_c_base (PPI), T) -#define pp_declaration_specifiers(PPI, D) \ - pp_c_base (PPI)->declaration_specifiers (pp_c_base (PPI), D) -#define pp_abstract_declarator(PP, D) \ - pp_c_base (PP)->abstract_declarator (pp_c_base (PP), D) -#define pp_type_specifier_seq(PPI, D) \ - pp_c_base (PPI)->type_specifier_seq (pp_c_base (PPI), D) -#define pp_declarator(PPI, D) \ - pp_c_base (PPI)->declarator (pp_c_base (PPI), D) -#define pp_direct_declarator(PPI, D) \ - pp_c_base (PPI)->direct_declarator (pp_c_base (PPI), D) -#define pp_direct_abstract_declarator(PP, D) \ - pp_c_base (PP)->direct_abstract_declarator (pp_c_base (PP), D) -#define pp_ptr_operator(PP, D) \ - pp_c_base (PP)->ptr_operator (pp_c_base (PP), D) -#define pp_parameter_list(PPI, T) \ - pp_c_base (PPI)->parameter_list (pp_c_base (PPI), T) -#define pp_type_id(PPI, D) \ - pp_c_base (PPI)->type_id (pp_c_base (PPI), D) -#define pp_simple_type_specifier(PP, T) \ - pp_c_base (PP)->simple_type_specifier (pp_c_base (PP), T) -#define pp_function_specifier(PP, D) \ - pp_c_base (PP)->function_specifier (pp_c_base (PP), D) -#define pp_storage_class_specifier(PP, D) \ - pp_c_base (PP)->storage_class_specifier (pp_c_base (PP), D); - -#define pp_statement(PPI, S) \ - pp_c_base (PPI)->statement (pp_c_base (PPI), S) - -#define pp_constant(PP, E) \ - pp_c_base (PP)->constant (pp_c_base (PP), E) -#define pp_id_expression(PP, E) \ - pp_c_base (PP)->id_expression (pp_c_base (PP), E) -#define pp_primary_expression(PPI, E) \ - pp_c_base (PPI)->primary_expression (pp_c_base (PPI), E) -#define pp_postfix_expression(PPI, E) \ - pp_c_base (PPI)->postfix_expression (pp_c_base (PPI), E) -#define pp_unary_expression(PPI, E) \ - pp_c_base (PPI)->unary_expression (pp_c_base (PPI), E) -#define pp_initializer(PPI, E) \ - pp_c_base (PPI)->initializer (pp_c_base (PPI), E) -#define pp_multiplicative_expression(PPI, E) \ - pp_c_base (PPI)->multiplicative_expression (pp_c_base (PPI), E) -#define pp_conditional_expression(PPI, E) \ - pp_c_base (PPI)->conditional_expression (pp_c_base (PPI), E) -#define pp_assignment_expression(PPI, E) \ - pp_c_base (PPI)->assignment_expression (pp_c_base (PPI), E) -#define pp_expression(PP, E) \ - pp_c_base (PP)->expression (pp_c_base (PP), E) - - -/* Returns the c_pretty_printer base object of PRETTY-PRINTER. This - macro must be overridden by any subclass of c_pretty_print_info. */ -#define pp_c_base(PP) (PP) - -extern void pp_c_pretty_printer_init (c_pretty_printer *); -void pp_c_whitespace (c_pretty_printer *); -void pp_c_left_paren (c_pretty_printer *); -void pp_c_right_paren (c_pretty_printer *); -void pp_c_left_brace (c_pretty_printer *); -void pp_c_right_brace (c_pretty_printer *); -void pp_c_left_bracket (c_pretty_printer *); -void pp_c_right_bracket (c_pretty_printer *); -void pp_c_dot (c_pretty_printer *); -void pp_c_ampersand (c_pretty_printer *); -void pp_c_star (c_pretty_printer *); -void pp_c_arrow (c_pretty_printer *); -void pp_c_semicolon (c_pretty_printer *); -void pp_c_complement (c_pretty_printer *); -void pp_c_exclamation (c_pretty_printer *); -void pp_c_space_for_pointer_operator (c_pretty_printer *, tree); - -/* Declarations. */ -void pp_c_tree_decl_identifier (c_pretty_printer *, tree); -void pp_c_function_definition (c_pretty_printer *, tree); -void pp_c_attributes (c_pretty_printer *, tree); -void pp_c_type_qualifier_list (c_pretty_printer *, tree); -void pp_c_parameter_type_list (c_pretty_printer *, tree); -void pp_c_declaration (c_pretty_printer *, tree); -void pp_c_declaration_specifiers (c_pretty_printer *, tree); -void pp_c_declarator (c_pretty_printer *, tree); -void pp_c_direct_declarator (c_pretty_printer *, tree); -void pp_c_specifier_qualifier_list (c_pretty_printer *, tree); -void pp_c_function_specifier (c_pretty_printer *, tree); -void pp_c_type_id (c_pretty_printer *, tree); -void pp_c_direct_abstract_declarator (c_pretty_printer *, tree); -void pp_c_type_specifier (c_pretty_printer *, tree); -void pp_c_storage_class_specifier (c_pretty_printer *, tree); -/* Statements. */ -void pp_c_statement (c_pretty_printer *, tree); -/* Expressions. */ -void pp_c_expression (c_pretty_printer *, tree); -void pp_c_logical_or_expression (c_pretty_printer *, tree); -void pp_c_expression_list (c_pretty_printer *, tree); -void pp_c_constructor_elts (c_pretty_printer *, VEC(constructor_elt,gc) *); -void pp_c_call_argument_list (c_pretty_printer *, tree); -void pp_c_unary_expression (c_pretty_printer *, tree); -void pp_c_cast_expression (c_pretty_printer *, tree); -void pp_c_postfix_expression (c_pretty_printer *, tree); -void pp_c_primary_expression (c_pretty_printer *, tree); -void pp_c_init_declarator (c_pretty_printer *, tree); -void pp_c_constant (c_pretty_printer *, tree); -void pp_c_id_expression (c_pretty_printer *, tree); -void pp_c_ws_string (c_pretty_printer *, const char *); -void pp_c_identifier (c_pretty_printer *, const char *); -void pp_c_string_literal (c_pretty_printer *, tree); - -void print_c_tree (FILE *file, tree t); - -#endif /* GCC_C_PRETTY_PRINTER */ diff --git a/gcc/c-semantics.c b/gcc/c-semantics.c deleted file mode 100644 index 683655f77c0..00000000000 --- a/gcc/c-semantics.c +++ /dev/null @@ -1,146 +0,0 @@ -/* This file contains subroutine used by the C front-end to construct GENERIC. - Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008 - Free Software Foundation, Inc. - Written by Benjamin Chelf (chelf@codesourcery.com). - -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 3, 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 COPYING3. If not see -. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "tm.h" -#include "tree.h" -#include "function.h" -#include "splay-tree.h" -#include "c-common.h" -/* In order for the format checking to accept the C frontend - diagnostic framework extensions, you must define this token before - including toplev.h. */ -#define GCC_DIAG_STYLE __gcc_cdiag__ -#include "toplev.h" -#include "flags.h" -#include "output.h" -#include "tree-iterator.h" - -/* Create an empty statement tree rooted at T. */ - -tree -push_stmt_list (void) -{ - tree t; - t = alloc_stmt_list (); - TREE_CHAIN (t) = cur_stmt_list; - cur_stmt_list = t; - return t; -} - -/* Finish the statement tree rooted at T. */ - -tree -pop_stmt_list (tree t) -{ - tree u = cur_stmt_list, chain; - - /* Pop statement lists until we reach the target level. The extra - nestings will be due to outstanding cleanups. */ - while (1) - { - chain = TREE_CHAIN (u); - TREE_CHAIN (u) = NULL_TREE; - if (chain) - STATEMENT_LIST_HAS_LABEL (chain) |= STATEMENT_LIST_HAS_LABEL (u); - if (t == u) - break; - u = chain; - } - cur_stmt_list = chain; - - /* If the statement list is completely empty, just return it. This is - just as good small as build_empty_stmt, with the advantage that - statement lists are merged when they appended to one another. So - using the STATEMENT_LIST avoids pathological buildup of EMPTY_STMT_P - statements. */ - if (TREE_SIDE_EFFECTS (t)) - { - tree_stmt_iterator i = tsi_start (t); - - /* If the statement list contained exactly one statement, then - extract it immediately. */ - if (tsi_one_before_end_p (i)) - { - u = tsi_stmt (i); - tsi_delink (&i); - free_stmt_list (t); - t = u; - } - } - - return t; -} - -/* Build a generic statement based on the given type of node and - arguments. Similar to `build_nt', except that we set - EXPR_LOCATION to LOC. */ -/* ??? This should be obsolete with the lineno_stmt productions - in the grammar. */ - -tree -build_stmt (location_t loc, enum tree_code code, ...) -{ - tree ret; - int length, i; - va_list p; - bool side_effects; - - /* This function cannot be used to construct variably-sized nodes. */ - gcc_assert (TREE_CODE_CLASS (code) != tcc_vl_exp); - - va_start (p, code); - - ret = make_node (code); - TREE_TYPE (ret) = void_type_node; - length = TREE_CODE_LENGTH (code); - SET_EXPR_LOCATION (ret, loc); - - /* TREE_SIDE_EFFECTS will already be set for statements with - implicit side effects. Here we make sure it is set for other - expressions by checking whether the parameters have side - effects. */ - - side_effects = false; - for (i = 0; i < length; i++) - { - tree t = va_arg (p, tree); - if (t && !TYPE_P (t)) - side_effects |= TREE_SIDE_EFFECTS (t); - TREE_OPERAND (ret, i) = t; - } - - TREE_SIDE_EFFECTS (ret) |= side_effects; - - va_end (p); - return ret; -} - -/* Create a CASE_LABEL_EXPR tree node and return it. */ - -tree -build_case_label (location_t loc, - tree low_value, tree high_value, tree label_decl) -{ - return build_stmt (loc, CASE_LABEL_EXPR, low_value, high_value, label_decl); -} diff --git a/gcc/c-tree.h b/gcc/c-tree.h index 30b5274841a..a607ecdeda6 100644 --- a/gcc/c-tree.h +++ b/gcc/c-tree.h @@ -22,7 +22,7 @@ along with GCC; see the file COPYING3. If not see #ifndef GCC_C_TREE_H #define GCC_C_TREE_H -#include "c-common.h" +#include "c-family/c-common.h" #include "toplev.h" #include "diagnostic.h" @@ -490,11 +490,6 @@ extern bool c_warn_unused_global_decl (const_tree); extern void c_initialize_diagnostics (diagnostic_context *); extern bool c_vla_unspec_p (tree x, tree fn); -#define c_build_type_variant(TYPE, CONST_P, VOLATILE_P) \ - c_build_qualified_type ((TYPE), \ - ((CONST_P) ? TYPE_QUAL_CONST : 0) | \ - ((VOLATILE_P) ? TYPE_QUAL_VOLATILE : 0)) - /* in c-typeck.c */ extern bool in_late_binary_op; extern int in_alignof; diff --git a/gcc/c-typeck.c b/gcc/c-typeck.c index dade1e53391..18e4bdcebfe 100644 --- a/gcc/c-typeck.c +++ b/gcc/c-typeck.c @@ -39,7 +39,8 @@ along with GCC; see the file COPYING3. If not see #include "intl.h" #include "target.h" #include "tree-iterator.h" -#include "tree-flow.h" +#include "bitmap.h" +#include "gimple.h" /* Possible cases of implicit bad conversions. Used to select diagnostic messages in convert_for_assignment. */ @@ -1841,6 +1842,7 @@ mark_exp_read (tree exp) mark_exp_read (TREE_OPERAND (exp, 0)); break; case COMPOUND_EXPR: + case C_MAYBE_CONST_EXPR: mark_exp_read (TREE_OPERAND (exp, 1)); break; default: @@ -3744,14 +3746,24 @@ build_unary_op (location_t location, argtype = TREE_TYPE (arg); /* If the lvalue is const or volatile, merge that into the type - to which the address will point. Note that you can't get a - restricted pointer by taking the address of something, so we - only have to deal with `const' and `volatile' here. */ + to which the address will point. This should only be needed + for function types. */ if ((DECL_P (arg) || REFERENCE_CLASS_P (arg)) && (TREE_READONLY (arg) || TREE_THIS_VOLATILE (arg))) - argtype = c_build_type_variant (argtype, - TREE_READONLY (arg), - TREE_THIS_VOLATILE (arg)); + { + int orig_quals = TYPE_QUALS (strip_array_types (argtype)); + int quals = orig_quals; + + if (TREE_READONLY (arg)) + quals |= TYPE_QUAL_CONST; + if (TREE_THIS_VOLATILE (arg)) + quals |= TYPE_QUAL_VOLATILE; + + gcc_assert (quals == orig_quals + || TREE_CODE (argtype) == FUNCTION_TYPE); + + argtype = c_build_qualified_type (argtype, quals); + } if (!c_mark_addressable (arg)) return error_mark_node; @@ -4402,12 +4414,13 @@ build_compound_expr (location_t loc, tree expr1, tree expr2) /* Issue -Wcast-qual warnings when appropriate. TYPE is the type to which we are casting. OTYPE is the type of the expression being - cast. Both TYPE and OTYPE are pointer types. -Wcast-qual appeared - on the command line. Named address space qualifiers are not handled - here, because they result in different warnings. */ + cast. Both TYPE and OTYPE are pointer types. LOC is the location + of the cast. -Wcast-qual appeared on the command line. Named + address space qualifiers are not handled here, because they result + in different warnings. */ static void -handle_warn_cast_qual (tree type, tree otype) +handle_warn_cast_qual (location_t loc, tree type, tree otype) { tree in_type = type; tree in_otype = otype; @@ -4440,13 +4453,15 @@ handle_warn_cast_qual (tree type, tree otype) && TREE_CODE (in_otype) == POINTER_TYPE); if (added) - warning (OPT_Wcast_qual, "cast adds new qualifiers to function type"); + warning_at (loc, OPT_Wcast_qual, + "cast adds %q#v qualifier to function type", added); if (discarded) /* There are qualifiers present in IN_OTYPE that are not present in IN_TYPE. */ - warning (OPT_Wcast_qual, - "cast discards qualifiers from pointer target type"); + warning_at (loc, OPT_Wcast_qual, + "cast discards %q#v qualifier from pointer target type", + discarded); if (added || discarded) return; @@ -4479,9 +4494,10 @@ handle_warn_cast_qual (tree type, tree otype) if ((TYPE_QUALS (in_type) &~ TYPE_QUALS (in_otype)) != 0 && !is_const) { - warning (OPT_Wcast_qual, - ("new qualifiers in middle of multi-level non-const cast " - "are unsafe")); + warning_at (loc, OPT_Wcast_qual, + "to be safe all intermediate pointers in cast from " + "%qT to %qT must be % qualified", + otype, type); break; } if (is_const) @@ -4585,7 +4601,7 @@ build_c_cast (location_t loc, tree type, tree expr) if (warn_cast_qual && TREE_CODE (type) == POINTER_TYPE && TREE_CODE (otype) == POINTER_TYPE) - handle_warn_cast_qual (type, otype); + handle_warn_cast_qual (loc, type, otype); /* Warn about conversions between pointers to disjoint address spaces. */ @@ -4997,7 +5013,7 @@ convert_for_assignment (location_t location, tree type, tree rhs, pedwarn (LOCATION, OPT, AS); \ break; \ case ic_init: \ - pedwarn (LOCATION, OPT, IN); \ + pedwarn_init (LOCATION, OPT, IN); \ break; \ case ic_return: \ pedwarn (LOCATION, OPT, RE); \ @@ -5007,6 +5023,36 @@ convert_for_assignment (location_t location, tree type, tree rhs, } \ } while (0) + /* This macro is used to emit diagnostics to ensure that all format + strings are complete sentences, visible to gettext and checked at + compile time. It is the same as WARN_FOR_ASSIGNMENT but with an + extra parameter to enumerate qualifiers. */ + +#define WARN_FOR_QUALIFIERS(LOCATION, OPT, AR, AS, IN, RE, QUALS) \ + do { \ + switch (errtype) \ + { \ + case ic_argpass: \ + if (pedwarn (LOCATION, OPT, AR, parmnum, rname, QUALS)) \ + inform ((fundecl && !DECL_IS_BUILTIN (fundecl)) \ + ? DECL_SOURCE_LOCATION (fundecl) : LOCATION, \ + "expected %qT but argument is of type %qT", \ + type, rhstype); \ + break; \ + case ic_assign: \ + pedwarn (LOCATION, OPT, AS, QUALS); \ + break; \ + case ic_init: \ + pedwarn (LOCATION, OPT, IN, QUALS); \ + break; \ + case ic_return: \ + pedwarn (LOCATION, OPT, RE, QUALS); \ + break; \ + default: \ + gcc_unreachable (); \ + } \ + } while (0) + if (TREE_CODE (rhs) == EXCESS_PRECISION_EXPR) rhs = TREE_OPERAND (rhs, 0); @@ -5214,30 +5260,32 @@ convert_for_assignment (location_t location, tree type, tree rhs, vice-versa. */ if (TYPE_QUALS_NO_ADDR_SPACE (ttl) & ~TYPE_QUALS_NO_ADDR_SPACE (ttr)) - WARN_FOR_ASSIGNMENT (location, 0, + WARN_FOR_QUALIFIERS (location, 0, G_("passing argument %d of %qE " - "makes qualified function " + "makes %q#v qualified function " "pointer from unqualified"), - G_("assignment makes qualified " + G_("assignment makes %q#v qualified " "function pointer from " "unqualified"), - G_("initialization makes qualified " + G_("initialization makes %q#v qualified " "function pointer from " "unqualified"), - G_("return makes qualified function " - "pointer from unqualified")); + G_("return makes %q#v qualified function " + "pointer from unqualified"), + TYPE_QUALS (ttl) & ~TYPE_QUALS (ttr)); } else if (TYPE_QUALS_NO_ADDR_SPACE (ttr) & ~TYPE_QUALS_NO_ADDR_SPACE (ttl)) - WARN_FOR_ASSIGNMENT (location, 0, + WARN_FOR_QUALIFIERS (location, 0, G_("passing argument %d of %qE discards " - "qualifiers from pointer target type"), - G_("assignment discards qualifiers " + "%qv qualifier from pointer target type"), + G_("assignment discards %qv qualifier " "from pointer target type"), - G_("initialization discards qualifiers " + G_("initialization discards %qv qualifier " "from pointer target type"), - G_("return discards qualifiers from " - "pointer target type")); + G_("return discards %qv qualifier from " + "pointer target type"), + TYPE_QUALS (ttr) & ~TYPE_QUALS (ttl)); memb = marginal_memb; } @@ -5383,15 +5431,16 @@ convert_for_assignment (location_t location, tree type, tree rhs, qualifier are acceptable if the 'volatile' has been added in by the Objective-C EH machinery. */ if (!objc_type_quals_match (ttl, ttr)) - WARN_FOR_ASSIGNMENT (location, 0, + WARN_FOR_QUALIFIERS (location, 0, G_("passing argument %d of %qE discards " - "qualifiers from pointer target type"), - G_("assignment discards qualifiers " + "%qv qualifier from pointer target type"), + G_("assignment discards %qv qualifier " "from pointer target type"), - G_("initialization discards qualifiers " + G_("initialization discards %qv qualifier " "from pointer target type"), - G_("return discards qualifiers from " - "pointer target type")); + G_("return discards %qv qualifier from " + "pointer target type"), + TYPE_QUALS (ttr) & ~TYPE_QUALS (ttl)); } /* If this is not a case of ignoring a mismatch in signedness, no warning. */ @@ -5419,16 +5468,17 @@ convert_for_assignment (location_t location, tree type, tree rhs, where an ordinary one is wanted, but not vice-versa. */ if (TYPE_QUALS_NO_ADDR_SPACE (ttl) & ~TYPE_QUALS_NO_ADDR_SPACE (ttr)) - WARN_FOR_ASSIGNMENT (location, 0, + WARN_FOR_QUALIFIERS (location, 0, G_("passing argument %d of %qE makes " - "qualified function pointer " + "%q#v qualified function pointer " "from unqualified"), - G_("assignment makes qualified function " + G_("assignment makes %q#v qualified function " "pointer from unqualified"), - G_("initialization makes qualified " + G_("initialization makes %q#v qualified " "function pointer from unqualified"), - G_("return makes qualified function " - "pointer from unqualified")); + G_("return makes %q#v qualified function " + "pointer from unqualified"), + TYPE_QUALS (ttl) & ~TYPE_QUALS (ttr)); } } else @@ -5737,15 +5787,16 @@ print_spelling (char *buffer) } /* Issue an error message for a bad initializer component. - MSGID identifies the message. + GMSGID identifies the message. The component name is taken from the spelling stack. */ void -error_init (const char *msgid) +error_init (const char *gmsgid) { char *ofwhat; - error ("%s", _(msgid)); + /* The gmsgid may be a format string with %< and %>. */ + error (gmsgid); ofwhat = print_spelling ((char *) alloca (spelling_length () + 1)); if (*ofwhat) error ("(near initialization for %qs)", ofwhat); @@ -5753,15 +5804,16 @@ error_init (const char *msgid) /* Issue a pedantic warning for a bad initializer component. OPT is the option OPT_* (from options.h) controlling this warning or 0 if - it is unconditionally given. MSGID identifies the message. The + it is unconditionally given. GMSGID identifies the message. The component name is taken from the spelling stack. */ void -pedwarn_init (location_t location, int opt, const char *msgid) +pedwarn_init (location_t location, int opt, const char *gmsgid) { char *ofwhat; - - pedwarn (location, opt, "%s", _(msgid)); + + /* The gmsgid may be a format string with %< and %>. */ + pedwarn (location, opt, gmsgid); ofwhat = print_spelling ((char *) alloca (spelling_length () + 1)); if (*ofwhat) pedwarn (location, opt, "(near initialization for %qs)", ofwhat); @@ -5770,15 +5822,16 @@ pedwarn_init (location_t location, int opt, const char *msgid) /* Issue a warning for a bad initializer component. OPT is the OPT_W* value corresponding to the warning option that - controls this warning. MSGID identifies the message. The + controls this warning. GMSGID identifies the message. The component name is taken from the spelling stack. */ static void -warning_init (int opt, const char *msgid) +warning_init (int opt, const char *gmsgid) { char *ofwhat; - warning (opt, "%s", _(msgid)); + /* The gmsgid may be a format string with %< and %>. */ + warning (opt, gmsgid); ofwhat = print_spelling ((char *) alloca (spelling_length () + 1)); if (*ofwhat) warning (opt, "(near initialization for %qs)", ofwhat); diff --git a/gcc/c.opt b/gcc/c.opt deleted file mode 100644 index 01d6428ea6a..00000000000 --- a/gcc/c.opt +++ /dev/null @@ -1,1060 +0,0 @@ -; Options for the C, ObjC, C++ and ObjC++ front ends. -; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 -; 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 3, 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 COPYING3. If not see -; . - -; See the GCC internals manual for a description of this file's format. - -; Please try to keep this file in ASCII collating order. - -Language -C - -Language -ObjC - -Language -C++ - -Language -ObjC++ - --output-pch= -C ObjC C++ ObjC++ Joined Separate - -A -C ObjC C++ ObjC++ Joined Separate --A= Assert the to . Putting '-' before disables the to - -C -C ObjC C++ ObjC++ -Do not discard comments - -CC -C ObjC C++ ObjC++ -Do not discard comments in macro expansions - -D -C ObjC C++ ObjC++ Joined Separate --D[=] Define a with as its value. If just is given, is taken to be 1 - -E -C ObjC C++ ObjC++ Undocumented - -F -C ObjC C++ ObjC++ Joined Separate --F Add to the end of the main framework include path - -H -C ObjC C++ ObjC++ -Print the name of header files as they are used - -I -C ObjC C++ ObjC++ Joined Separate --I Add to the end of the main include path - -M -C ObjC C++ ObjC++ -Generate make dependencies - -MD -C ObjC C++ ObjC++ Separate -Generate make dependencies and compile - -MF -C ObjC C++ ObjC++ Joined Separate --MF Write dependency output to the given file - -MG -C ObjC C++ ObjC++ -Treat missing header files as generated files - -MM -C ObjC C++ ObjC++ -Like -M but ignore system header files - -MMD -C ObjC C++ ObjC++ Separate -Like -MD but ignore system header files - -MP -C ObjC C++ ObjC++ -Generate phony targets for all headers - -MQ -C ObjC C++ ObjC++ Joined Separate --MQ Add a MAKE-quoted target - -MT -C ObjC C++ ObjC++ Joined Separate --MT Add an unquoted target - -P -C ObjC C++ ObjC++ -Do not generate #line directives - -U -C ObjC C++ ObjC++ Joined Separate --U Undefine - -Wabi -C ObjC C++ ObjC++ LTO Var(warn_abi) Warning -Warn about things that will change when compiling with an ABI-compliant compiler - -Wpsabi -C ObjC C++ ObjC++ LTO Var(warn_psabi) Init(1) Undocumented - -Waddress -C ObjC C++ ObjC++ Var(warn_address) Warning -Warn about suspicious uses of memory addresses - -Wall -C ObjC C++ ObjC++ Warning -Enable most warning messages - -Wassign-intercept -ObjC ObjC++ Var(warn_assign_intercept) Warning -Warn whenever an Objective-C assignment is being intercepted by the garbage collector - -Wbad-function-cast -C ObjC Var(warn_bad_function_cast) Warning -Warn about casting functions to incompatible types - -Wbuiltin-macro-redefined -C ObjC C++ ObjC++ Warning -Warn when a built-in preprocessor macro is undefined or redefined - -Wc++-compat -C ObjC Var(warn_cxx_compat) Warning -Warn about C constructs that are not in the common subset of C and C++ - -Wc++0x-compat -C++ ObjC++ Var(warn_cxx0x_compat) Warning -Warn about C++ constructs whose meaning differs between ISO C++ 1998 and ISO C++ 200x - -Wcast-qual -C ObjC C++ ObjC++ Var(warn_cast_qual) Warning -Warn about casts which discard qualifiers - -Wchar-subscripts -C ObjC C++ ObjC++ Var(warn_char_subscripts) Warning -Warn about subscripts whose type is \"char\" - -Wclobbered -C ObjC C++ ObjC++ Var(warn_clobbered) Init(-1) Warning -Warn about variables that might be changed by \"longjmp\" or \"vfork\" - -Wcomment -C ObjC C++ ObjC++ Warning -Warn about possibly nested block comments, and C++ comments spanning more than one physical line - -Wcomments -C ObjC C++ ObjC++ Warning -Synonym for -Wcomment - -Wconversion -C ObjC C++ ObjC++ Var(warn_conversion) Warning -Warn for implicit type conversions that may change a value - -Wconversion-null -C++ ObjC++ Var(warn_conversion_null) Init(1) Warning -Warn for converting NULL from/to a non-pointer type - -Wsign-conversion -C ObjC C++ ObjC++ Var(warn_sign_conversion) Init(-1) -Warn for implicit type conversions between signed and unsigned integers - -Wctor-dtor-privacy -C++ ObjC++ Var(warn_ctor_dtor_privacy) Warning -Warn when all constructors and destructors are private - -Wdeclaration-after-statement -C ObjC Var(warn_declaration_after_statement) Warning -Warn when a declaration is found after a statement - -Wdeprecated -C C++ ObjC ObjC++ Var(warn_deprecated) Init(1) Warning -Warn if a deprecated compiler feature, class, method, or field is used - -Wdiv-by-zero -C ObjC C++ ObjC++ Var(warn_div_by_zero) Init(1) Warning -Warn about compile-time integer division by zero - -Weffc++ -C++ ObjC++ Var(warn_ecpp) Warning -Warn about violations of Effective C++ style rules - -Wempty-body -C ObjC C++ ObjC++ Var(warn_empty_body) Init(-1) Warning -Warn about an empty body in an if or else statement - -Wendif-labels -C ObjC C++ ObjC++ Warning -Warn about stray tokens after #elif and #endif - -Wenum-compare -C ObjC C++ ObjC++ Var(warn_enum_compare) Init(-1) Warning -Warn about comparison of different enum types - -Werror -C ObjC C++ ObjC++ -; Documented in common.opt - -Werror-implicit-function-declaration -C ObjC RejectNegative Warning -This switch is deprecated; use -Werror=implicit-function-declaration instead - -Wfloat-equal -C ObjC C++ ObjC++ Var(warn_float_equal) Warning -Warn if testing floating point numbers for equality - -Wformat -C ObjC C++ ObjC++ Warning -Warn about printf/scanf/strftime/strfmon format string anomalies - -Wformat-extra-args -C ObjC C++ ObjC++ Var(warn_format_extra_args) Warning -Warn if passing too many arguments to a function for its format string - -Wformat-nonliteral -C ObjC C++ ObjC++ Var(warn_format_nonliteral) Warning -Warn about format strings that are not literals - -Wformat-contains-nul -C ObjC C++ ObjC++ Var(warn_format_contains_nul) Warning -Warn about format strings that contain NUL bytes - -Wformat-security -C ObjC C++ ObjC++ Var(warn_format_security) Warning -Warn about possible security problems with format functions - -Wformat-y2k -C ObjC C++ ObjC++ Var(warn_format_y2k) Warning -Warn about strftime formats yielding 2-digit years - -Wformat-zero-length -C ObjC Var(warn_format_zero_length) Warning -Warn about zero-length formats - -Wformat= -C ObjC C++ ObjC++ Joined Warning - -Wignored-qualifiers -C C++ Var(warn_ignored_qualifiers) Init(-1) Warning -Warn whenever type qualifiers are ignored. - -Winit-self -C ObjC C++ ObjC++ Var(warn_init_self) Warning -Warn about variables which are initialized to themselves - -Wimplicit -C ObjC Var(warn_implicit) Init(-1) Warning -Warn about implicit declarations - -Wimplicit-function-declaration -C ObjC Var(warn_implicit_function_declaration) Init(-1) Warning -Warn about implicit function declarations - -Wimplicit-int -C ObjC Var(warn_implicit_int) Init(-1) Warning -Warn when a declaration does not specify a type - -Wimport -C ObjC C++ ObjC++ Undocumented - -Wint-to-pointer-cast -C ObjC C++ ObjC++ Var(warn_int_to_pointer_cast) Init(1) Warning -Warn when there is a cast to a pointer from an integer of a different size - -Winvalid-offsetof -C++ ObjC++ Var(warn_invalid_offsetof) Init(1) Warning -Warn about invalid uses of the \"offsetof\" macro - -Winvalid-pch -C ObjC C++ ObjC++ Warning -Warn about PCH files that are found but not used - -Wjump-misses-init -C ObjC Var(warn_jump_misses_init) Init(-1) Warning -Warn when a jump misses a variable initialization - -Wlogical-op -C ObjC C++ ObjC++ Var(warn_logical_op) Init(0) Warning -Warn when a logical operator is suspiciously always evaluating to true or false - -Wlong-long -C ObjC C++ ObjC++ Var(warn_long_long) Init(-1) Warning -Do not warn about using \"long long\" when -pedantic - -Wmain -C ObjC C++ ObjC++ Var(warn_main) Init(-1) Warning -Warn about suspicious declarations of \"main\" - -Wmissing-braces -C ObjC C++ ObjC++ Var(warn_missing_braces) Warning -Warn about possibly missing braces around initializers - -Wmissing-declarations -C ObjC C++ ObjC++ Var(warn_missing_declarations) Warning -Warn about global functions without previous declarations - -Wmissing-field-initializers -C ObjC C++ ObjC++ Var(warn_missing_field_initializers) Init(-1) Warning -Warn about missing fields in struct initializers - -Wmissing-format-attribute -C ObjC C++ ObjC++ Var(warn_missing_format_attribute) Warning -Warn about functions which might be candidates for format attributes - -Wmissing-include-dirs -C ObjC C++ ObjC++ Warning -Warn about user-specified include directories that do not exist - -Wmissing-parameter-type -C ObjC Var(warn_missing_parameter_type) Init(-1) Warning -Warn about function parameters declared without a type specifier in K&R-style functions - -Wmissing-prototypes -C ObjC Var(warn_missing_prototypes) Warning -Warn about global functions without prototypes - -Wmultichar -C ObjC C++ ObjC++ Warning -Warn about use of multi-character character constants - -Wnested-externs -C ObjC Var(warn_nested_externs) Warning -Warn about \"extern\" declarations not at file scope - -Wnon-template-friend -C++ ObjC++ Var(warn_nontemplate_friend) Init(1) Warning -Warn when non-templatized friend functions are declared within a template - -Wnon-virtual-dtor -C++ ObjC++ Var(warn_nonvdtor) Warning -Warn about non-virtual destructors - -Wnonnull -C ObjC Var(warn_nonnull) Warning -Warn about NULL being passed to argument slots marked as requiring non-NULL - -Wnormalized= -C ObjC C++ ObjC++ Joined Warning --Wnormalized= Warn about non-normalised Unicode strings - -Wold-style-cast -C++ ObjC++ Var(warn_old_style_cast) Warning -Warn if a C-style cast is used in a program - -Wold-style-declaration -C ObjC Var(warn_old_style_declaration) Init(-1) Warning -Warn for obsolescent usage in a declaration - -Wold-style-definition -C ObjC Var(warn_old_style_definition) Warning -Warn if an old-style parameter definition is used - -Woverlength-strings -C ObjC C++ ObjC++ Var(warn_overlength_strings) Init(-1) Warning -Warn if a string is longer than the maximum portable length specified by the standard - -Woverloaded-virtual -C++ ObjC++ Var(warn_overloaded_virtual) Warning -Warn about overloaded virtual function names - -Woverride-init -C ObjC Var(warn_override_init) Init(-1) Warning -Warn about overriding initializers without side effects - -Wpacked-bitfield-compat -C ObjC C++ ObjC++ Var(warn_packed_bitfield_compat) Init(-1) Warning -Warn about packed bit-fields whose offset changed in GCC 4.4 - -Wparentheses -C ObjC C++ ObjC++ Var(warn_parentheses) Warning -Warn about possibly missing parentheses - -Wpmf-conversions -C++ ObjC++ Var(warn_pmf2ptr) Init(1) Warning -Warn when converting the type of pointers to member functions - -Wpointer-arith -C ObjC C++ ObjC++ Var(warn_pointer_arith) Warning -Warn about function pointer arithmetic - -Wpointer-to-int-cast -C ObjC Var(warn_pointer_to_int_cast) Init(1) Warning -Warn when a pointer is cast to an integer of a different size - -Wpragmas -C ObjC C++ ObjC++ Var(warn_pragmas) Init(1) Warning -Warn about misuses of pragmas - -Wprotocol -ObjC ObjC++ Var(warn_protocol) Init(1) Warning -Warn if inherited methods are unimplemented - -Wredundant-decls -C ObjC C++ ObjC++ Var(warn_redundant_decls) Warning -Warn about multiple declarations of the same object - -Wreorder -C++ ObjC++ Var(warn_reorder) Warning -Warn when the compiler reorders code - -Wreturn-type -C ObjC C++ ObjC++ Var(warn_return_type) Warning -Warn whenever a function's return type defaults to \"int\" (C), or about inconsistent return types (C++) - -Wselector -ObjC ObjC++ Var(warn_selector) Warning -Warn if a selector has multiple methods - -Wsequence-point -C ObjC C++ ObjC++ Var(warn_sequence_point) Warning -Warn about possible violations of sequence point rules - -Wsign-compare -C ObjC C++ ObjC++ Var(warn_sign_compare) Init(-1) Warning -Warn about signed-unsigned comparisons - -Wsign-promo -C++ ObjC++ Var(warn_sign_promo) Warning -Warn when overload promotes from unsigned to signed - -Wstrict-null-sentinel -C++ ObjC++ Warning -Warn about uncasted NULL used as sentinel - -Wstrict-prototypes -C ObjC Var(warn_strict_prototypes) Warning -Warn about unprototyped function declarations - -Wstrict-selector-match -ObjC ObjC++ Var(warn_strict_selector_match) Warning -Warn if type signatures of candidate methods do not match exactly - -Wsync-nand -C C++ Var(warn_sync_nand) Init(1) Warning -Warn when __sync_fetch_and_nand and __sync_nand_and_fetch built-in functions are used - -Wsynth -C++ ObjC++ Var(warn_synth) Warning -Deprecated. This switch has no effect - -Wsystem-headers -C ObjC C++ ObjC++ Warning -; Documented in common.opt - -Wtraditional -C ObjC Var(warn_traditional) Warning -Warn about features not present in traditional C - -Wtraditional-conversion -C ObjC Var(warn_traditional_conversion) Warning -Warn of prototypes causing type conversions different from what would happen in the absence of prototype - -Wtrigraphs -C ObjC C++ ObjC++ Warning -Warn if trigraphs are encountered that might affect the meaning of the program - -Wundeclared-selector -ObjC ObjC++ Var(warn_undeclared_selector) Warning -Warn about @selector()s without previously declared methods - -Wundef -C ObjC C++ ObjC++ Warning -Warn if an undefined macro is used in an #if directive - -Wunknown-pragmas -C ObjC C++ ObjC++ Warning -Warn about unrecognized pragmas - -Wunsuffixed-float-constants -C ObjC Var(warn_unsuffixed_float_constants) Warning -Warn about unsuffixed float constants - -Wunused-macros -C ObjC C++ ObjC++ Warning -Warn about macros defined in the main file that are not used - -Wunused-result -C ObjC C++ ObjC++ Var(warn_unused_result) Init(1) Warning -Warn if a caller of a function, marked with attribute warn_unused_result, does not use its return value - -Wvariadic-macros -C ObjC C++ ObjC++ Warning -Do not warn about using variadic macros when -pedantic - -Wvla -C ObjC C++ ObjC++ Var(warn_vla) Init(-1) Warning -Warn if a variable length array is used - -Wvolatile-register-var -C ObjC C++ ObjC++ Var(warn_volatile_register_var) Warning -Warn when a register variable is declared volatile - -Wwrite-strings -C ObjC C++ ObjC++ Var(warn_write_strings) Warning -In C++, nonzero means warn about deprecated conversion from string literals to `char *'. In C, similar warning, except that the conversion is of course not deprecated by the ISO C standard. - -Wpointer-sign -C ObjC Var(warn_pointer_sign) Init(-1) Warning -Warn when a pointer differs in signedness in an assignment - -ansi -C ObjC C++ ObjC++ -A synonym for -std=c89 (for C) or -std=c++98 (for C++) - -d -C ObjC C++ ObjC++ Joined -; Documented in common.opt. FIXME - what about -dI, -dD, -dN and -dD? - -faccess-control -C++ ObjC++ -Enforce class member access control semantics - -fall-virtual -C++ ObjC++ - -falt-external-templates -C++ ObjC++ -Change when template instances are emitted - -fasm -C ObjC C++ ObjC++ -Recognize the \"asm\" keyword - -fbuiltin -C ObjC C++ ObjC++ -Recognize built-in functions - -fbuiltin- -C ObjC C++ ObjC++ Joined - -fcheck-new -C++ ObjC++ -Check the return value of new - -fcond-mismatch -C ObjC C++ ObjC++ -Allow the arguments of the '?' operator to have different types - -fconserve-space -C++ ObjC++ -Reduce the size of object files - -fconstant-string-class= -ObjC ObjC++ Joined --fconst-string-class= Use class for constant strings - -fdeduce-init-list -C++ ObjC++ Var(flag_deduce_init_list) Init(1) --fno-deduce-init-list disable deduction of std::initializer_list for a template type parameter from a brace-enclosed initializer-list - -fdefault-inline -C++ ObjC++ -Inline member functions by default - -fdirectives-only -C ObjC C++ ObjC++ -Preprocess directives only. - -fdollars-in-identifiers -C ObjC C++ ObjC++ -Permit '$' as an identifier character - -felide-constructors -C++ ObjC++ - -fenforce-eh-specs -C++ ObjC++ -Generate code to check exception specifications - -fenum-int-equiv -C++ ObjC++ - -fexec-charset= -C ObjC C++ ObjC++ Joined RejectNegative --fexec-charset= Convert all strings and character constants to character set - -fextended-identifiers -C ObjC C++ ObjC++ -Permit universal character names (\\u and \\U) in identifiers - -finput-charset= -C ObjC C++ ObjC++ Joined RejectNegative --finput-charset= Specify the default character set for source files - - -fexternal-templates -C++ ObjC++ - -ffor-scope -C++ ObjC++ -Scope of for-init-statement variables is local to the loop - -ffreestanding -C ObjC C++ ObjC++ -Do not assume that standard C libraries and \"main\" exist - -fgnu-keywords -C++ ObjC++ -Recognize GNU-defined keywords - -fgnu-runtime -ObjC ObjC++ -Generate code for GNU runtime environment - -fgnu89-inline -C ObjC Var(flag_gnu89_inline) Init(-1) -Use traditional GNU semantics for inline functions - -fguiding-decls -C++ ObjC++ - -fhandle-exceptions -C++ ObjC++ Optimization - -fhonor-std -C++ ObjC++ - -fhosted -C ObjC -Assume normal C execution environment - -fhuge-objects -C++ ObjC++ -Enable support for huge objects - -fimplement-inlines -C++ ObjC++ -Export functions even if they can be inlined - -fimplicit-inline-templates -C++ ObjC++ -Emit implicit instantiations of inline templates - -fimplicit-templates -C++ ObjC++ -Emit implicit instantiations of templates - -ffriend-injection -C++ ObjC++ Var(flag_friend_injection) -Inject friend functions into enclosing namespace - -flabels-ok -C++ ObjC++ - -flax-vector-conversions -C ObjC C++ ObjC++ -Allow implicit conversions between vectors with differing numbers of subparts and/or differing element types. - -fms-extensions -C ObjC C++ ObjC++ -Don't warn about uses of Microsoft extensions - -fname-mangling-version- -C++ ObjC++ Joined - -fnew-abi -C++ ObjC++ - -fnext-runtime -ObjC ObjC++ -Generate code for NeXT (Apple Mac OS X) runtime environment - -fnil-receivers -ObjC ObjC++ -Assume that receivers of Objective-C messages may be nil - -fnonansi-builtins -C++ ObjC++ - -fnonnull-objects -C++ ObjC++ - -fnothrow-opt -C++ ObjC++ Optimization Var(flag_nothrow_opt) -Treat a throw() exception specification as noexcept to improve code size - -; Generate special '- .cxx_construct' and '- .cxx_destruct' methods -; to initialize any non-POD ivars in Objective-C++ classes. -fobjc-call-cxx-cdtors -ObjC++ Var(flag_objc_call_cxx_cdtors) -Generate special Objective-C methods to initialize/destroy non-POD C++ ivars, if needed - -fobjc-direct-dispatch -ObjC ObjC++ Var(flag_objc_direct_dispatch) -Allow fast jumps to the message dispatcher - -; Nonzero means that we will allow new ObjC exception syntax (@throw, -; @try, etc.) in source code. -fobjc-exceptions -ObjC ObjC++ Var(flag_objc_exceptions) -Enable Objective-C exception and synchronization syntax - -fobjc-gc -ObjC ObjC++ Var(flag_objc_gc) -Enable garbage collection (GC) in Objective-C/Objective-C++ programs - -; Nonzero means that we generate NeXT setjmp based exceptions. -fobjc-sjlj-exceptions -ObjC ObjC++ Var(flag_objc_sjlj_exceptions) Init(-1) -Enable Objective-C setjmp exception handling runtime - -fopenmp -C ObjC C++ ObjC++ Var(flag_openmp) -Enable OpenMP (implies -frecursive in Fortran) - -foperator-names -C++ ObjC++ -Recognize C++ keywords like \"compl\" and \"xor\" - -foptional-diags -C++ ObjC++ -Enable optional diagnostics - -fpch-deps -C ObjC C++ ObjC++ - -fpch-preprocess -C ObjC C++ ObjC++ -Look for and use PCH files even when preprocessing - -fpermissive -C++ ObjC++ -Downgrade conformance errors to warnings - -fpreprocessed -C ObjC C++ ObjC++ -Treat the input file as already preprocessed - -fpretty-templates -C++ ObjC++ --fno-pretty-templates Do not pretty-print template specializations as the template signature followed by the arguments - -freplace-objc-classes -ObjC ObjC++ -Used in Fix-and-Continue mode to indicate that object files may be swapped in at runtime - -frepo -C++ ObjC++ -Enable automatic template instantiation - -frtti -C++ ObjC++ Optimization -Generate run time type descriptor information - -fshort-double -C ObjC C++ ObjC++ Optimization -Use the same size for double as for float - -fshort-enums -C ObjC C++ ObjC++ Optimization -Use the narrowest integer type possible for enumeration types - -fshort-wchar -C ObjC C++ ObjC++ Optimization -Force the underlying type for \"wchar_t\" to be \"unsigned short\" - -fsigned-bitfields -C ObjC C++ ObjC++ -When \"signed\" or \"unsigned\" is not given make the bitfield signed - -fsigned-char -C ObjC C++ ObjC++ LTO -Make \"char\" signed by default - -fsquangle -C++ ObjC++ - -fstats -C++ ObjC++ -Display statistics accumulated during compilation - -fstrict-enums -C++ ObjC++ Optimization Var(flag_strict_enums) -Assume that values of enumeration type are always within the minimum range of that type - -fstrict-prototype -C++ ObjC++ - -ftabstop= -C ObjC C++ ObjC++ Joined RejectNegative UInteger --ftabstop= Distance between tab stops for column reporting - -ftemplate-depth- -C++ ObjC++ Joined RejectNegative UInteger Undocumented - -ftemplate-depth= -C++ ObjC++ Joined RejectNegative UInteger --ftemplate-depth= Specify maximum template instantiation depth - -fthis-is-variable -C++ ObjC++ - -fthreadsafe-statics -C++ ObjC++ Optimization --fno-threadsafe-statics Do not generate thread-safe code for initializing local statics - -funsigned-bitfields -C ObjC C++ ObjC++ -When \"signed\" or \"unsigned\" is not given make the bitfield unsigned - -funsigned-char -C ObjC C++ ObjC++ LTO -Make \"char\" unsigned by default - -fuse-cxa-atexit -C++ ObjC++ -Use __cxa_atexit to register destructors - -fuse-cxa-get-exception-ptr -C++ ObjC++ -Use __cxa_get_exception_ptr in exception handling - -fvisibility-inlines-hidden -C++ ObjC++ -Marks all inlined methods as having hidden visibility - -fvisibility-ms-compat -C++ ObjC++ Var(flag_visibility_ms_compat) -Changes visibility to match Microsoft Visual Studio by default - -fvtable-gc -C++ ObjC++ -Discard unused virtual functions - -fvtable-thunks -C++ ObjC++ -Implement vtables using thunks - -fweak -C++ ObjC++ -Emit common-like symbols as weak symbols - -fwide-exec-charset= -C ObjC C++ ObjC++ Joined RejectNegative --fwide-exec-charset= Convert all wide strings and character constants to character set - -fworking-directory -C ObjC C++ ObjC++ -Generate a #line directive pointing at the current working directory - -fxref -C++ ObjC++ -Emit cross referencing information - -fzero-link -ObjC ObjC++ -Generate lazy class lookup (via objc_getClass()) for use in Zero-Link mode - -gen-decls -ObjC ObjC++ -Dump declarations to a .decl file - -femit-struct-debug-baseonly -C ObjC C++ ObjC++ --femit-struct-debug-baseonly Aggressive reduced debug info for structs - -femit-struct-debug-reduced -C ObjC C++ ObjC++ --femit-struct-debug-reduced Conservative reduced debug info for structs - -femit-struct-debug-detailed= -C ObjC C++ ObjC++ Joined --femit-struct-debug-detailed= Detailed reduced debug info for structs - -idirafter -C ObjC C++ ObjC++ Joined Separate --idirafter Add to the end of the system include path - -imacros -C ObjC C++ ObjC++ Joined Separate --imacros Accept definition of macros in - -imultilib -C ObjC C++ ObjC++ Joined Separate --imultilib Set to be the multilib include subdirectory - -include -C ObjC C++ ObjC++ Joined Separate --include Include the contents of before other files - -iprefix -C ObjC C++ ObjC++ Joined Separate --iprefix Specify as a prefix for next two options - -isysroot -C ObjC C++ ObjC++ Joined Separate --isysroot Set to be the system root directory - -isystem -C ObjC C++ ObjC++ Joined Separate --isystem Add to the start of the system include path - -iquote -C ObjC C++ ObjC++ Joined Separate --iquote Add to the end of the quote include path - -iwithprefix -C ObjC C++ ObjC++ Joined Separate --iwithprefix Add to the end of the system include path - -iwithprefixbefore -C ObjC C++ ObjC++ Joined Separate --iwithprefixbefore Add to the end of the main include path - -lang-asm -C Undocumented - -lang-objc -C ObjC C++ ObjC++ Undocumented - -nostdinc -C ObjC C++ ObjC++ -Do not search standard system include directories (those specified with -isystem will still be used) - -nostdinc++ -C++ ObjC++ -Do not search standard system include directories for C++ - -o -C ObjC C++ ObjC++ Joined Separate -; Documented in common.opt - -pedantic -C ObjC C++ ObjC++ -; Documented in common.opt - -pedantic-errors -C ObjC C++ ObjC++ -; Documented in common.opt - -print-objc-runtime-info -ObjC ObjC++ -Generate C header of platform-specific features - -print-pch-checksum -C ObjC C++ ObjC++ -Print a checksum of the executable for PCH validity checking, and stop - -remap -C ObjC C++ ObjC++ -Remap file names when including files - -std=c++98 -C++ ObjC++ -Conform to the ISO 1998 C++ standard - -std=c++0x -C++ ObjC++ -Conform to the ISO 1998 C++ standard, with extensions that are likely to -become a part of the upcoming ISO C++ standard, dubbed C++0x. Note that the -extensions enabled by this mode are experimental and may be removed in -future releases of GCC. - -std=c1x -C ObjC -Conform to the ISO 201X C standard draft (experimental and incomplete support) - -std=c89 -C ObjC -Conform to the ISO 1990 C standard - -std=c90 -C ObjC -Conform to the ISO 1990 C standard - -std=c99 -C ObjC -Conform to the ISO 1999 C standard - -std=c9x -C ObjC -Deprecated in favor of -std=c99 - -std=gnu++98 -C++ ObjC++ -Conform to the ISO 1998 C++ standard with GNU extensions - -std=gnu++0x -C++ ObjC++ -Conform to the ISO 1998 C++ standard, with GNU extensions and -extensions that are likely to become a part of the upcoming ISO C++ -standard, dubbed C++0x. Note that the extensions enabled by this mode -are experimental and may be removed in future releases of GCC. - -std=gnu1x -C ObjC -Conform to the ISO 201X C standard draft with GNU extensions (experimental and incomplete support) - -std=gnu89 -C ObjC -Conform to the ISO 1990 C standard with GNU extensions - -std=gnu90 -C ObjC -Conform to the ISO 1990 C standard with GNU extensions - -std=gnu99 -C ObjC -Conform to the ISO 1999 C standard with GNU extensions - -std=gnu9x -C ObjC -Deprecated in favor of -std=gnu99 - -std=iso9899:1990 -C ObjC -Conform to the ISO 1990 C standard - -std=iso9899:199409 -C ObjC -Conform to the ISO 1990 C standard as amended in 1994 - -std=iso9899:1999 -C ObjC -Conform to the ISO 1999 C standard - -std=iso9899:199x -C ObjC -Deprecated in favor of -std=iso9899:1999 - -traditional-cpp -C ObjC C++ ObjC++ -Enable traditional preprocessing - -trigraphs -C ObjC C++ ObjC++ --trigraphs Support ISO C trigraphs - -undef -C ObjC C++ ObjC++ -Do not predefine system-specific and GCC-specific macros - -v -Common C ObjC C++ ObjC++ -Enable verbose output - -w -C ObjC C++ ObjC++ -; Documented in common.opt - -; This comment is to ensure we retain the blank line above. diff --git a/gcc/caller-save.c b/gcc/caller-save.c index 6bcfd4bf4c7..78b508cc535 100644 --- a/gcc/caller-save.c +++ b/gcc/caller-save.c @@ -1212,7 +1212,7 @@ insert_restore (struct insn_chain *chain, int before_p, int regno, /* Check that insn to restore REGNO in save_mode[regno] is correct. */ && reg_save_code (regno, save_mode[regno]) >= 0) - mem = adjust_address (mem, save_mode[regno], 0); + mem = adjust_address_nv (mem, save_mode[regno], 0); else mem = copy_rtx (mem); @@ -1293,7 +1293,7 @@ insert_save (struct insn_chain *chain, int before_p, int regno, /* Check that insn to save REGNO in save_mode[regno] is correct. */ && reg_save_code (regno, save_mode[regno]) >= 0) - mem = adjust_address (mem, save_mode[regno], 0); + mem = adjust_address_nv (mem, save_mode[regno], 0); else mem = copy_rtx (mem); diff --git a/gcc/calls.c b/gcc/calls.c index 9c51f1a5a74..3b06ad397de 100644 --- a/gcc/calls.c +++ b/gcc/calls.c @@ -208,13 +208,15 @@ prepare_call_address (tree fndecl, rtx funexp, rtx static_chain_value, The CALL_INSN is the first insn generated. FNDECL is the declaration node of the function. This is given to the - macro RETURN_POPS_ARGS to determine whether this function pops its own args. + hook TARGET_RETURN_POPS_ARGS to determine whether this function pops + its own args. - FUNTYPE is the data type of the function. This is given to the macro - RETURN_POPS_ARGS to determine whether this function pops its own args. - We used to allow an identifier for library functions, but that doesn't - work when the return type is an aggregate type and the calling convention - says that the pointer to this aggregate is to be popped by the callee. + FUNTYPE is the data type of the function. This is given to the hook + TARGET_RETURN_POPS_ARGS to determine whether this function pops its + own args. We used to allow an identifier for library functions, but + that doesn't work when the return type is an aggregate type and the + calling convention says that the pointer to this aggregate is to be + popped by the callee. STACK_SIZE is the number of bytes of arguments on the stack, ROUNDED_STACK_SIZE is that number rounded up to @@ -226,7 +228,7 @@ prepare_call_address (tree fndecl, rtx funexp, rtx static_chain_value, It is zero if this call doesn't want a structure value. NEXT_ARG_REG is the rtx that results from executing - FUNCTION_ARG (args_so_far, VOIDmode, void_type_node, 1) + targetm.calls.function_arg (&args_so_far, VOIDmode, void_type_node, true) just after all the args have had their registers assigned. This could be whatever you like, but normally it is the first arg-register beyond those used for args in this call, @@ -256,7 +258,8 @@ emit_call_1 (rtx funexp, tree fntree ATTRIBUTE_UNUSED, tree fndecl ATTRIBUTE_UNU rtx rounded_stack_size_rtx = GEN_INT (rounded_stack_size); rtx call_insn; int already_popped = 0; - HOST_WIDE_INT n_popped = RETURN_POPS_ARGS (fndecl, funtype, stack_size); + HOST_WIDE_INT n_popped + = targetm.calls.return_pops_args (fndecl, funtype, stack_size); #ifdef CALL_POPS_ARGS n_popped += CALL_POPS_ARGS (* args_so_far); @@ -1124,17 +1127,18 @@ initialize_argument_information (int num_actuals ATTRIBUTE_UNUSED, args[i].unsignedp = unsignedp; args[i].mode = mode; - args[i].reg = FUNCTION_ARG (*args_so_far, mode, type, - argpos < n_named_args); -#ifdef FUNCTION_INCOMING_ARG + args[i].reg = targetm.calls.function_arg (args_so_far, mode, type, + argpos < n_named_args); + /* If this is a sibling call and the machine has register windows, the register window has to be unwinded before calling the routine, so arguments have to go into the incoming registers. */ - args[i].tail_call_reg = FUNCTION_INCOMING_ARG (*args_so_far, mode, type, - argpos < n_named_args); -#else - args[i].tail_call_reg = args[i].reg; -#endif + if (targetm.calls.function_incoming_arg != targetm.calls.function_arg) + args[i].tail_call_reg + = targetm.calls.function_incoming_arg (args_so_far, mode, type, + argpos < n_named_args); + else + args[i].tail_call_reg = args[i].reg; if (args[i].reg) args[i].partial @@ -1189,8 +1193,8 @@ initialize_argument_information (int num_actuals ATTRIBUTE_UNUSED, /* Increment ARGS_SO_FAR, which has info about which arg-registers have been used, etc. */ - FUNCTION_ARG_ADVANCE (*args_so_far, TYPE_MODE (type), type, - argpos < n_named_args); + targetm.calls.function_arg_advance (args_so_far, TYPE_MODE (type), + type, argpos < n_named_args); } } @@ -2323,10 +2327,10 @@ expand_call (tree exp, rtx target, int ignore) - crtl->args.pretend_args_size) /* If the callee pops its own arguments, then it must pop exactly the same number of arguments as the current function. */ - || (RETURN_POPS_ARGS (fndecl, funtype, args_size.constant) - != RETURN_POPS_ARGS (current_function_decl, - TREE_TYPE (current_function_decl), - crtl->args.size)) + || (targetm.calls.return_pops_args (fndecl, funtype, args_size.constant) + != targetm.calls.return_pops_args (current_function_decl, + TREE_TYPE (current_function_decl), + crtl->args.size)) || !lang_hooks.decls.ok_for_sibcall (fndecl)) try_tail_call = 0; @@ -2825,14 +2829,15 @@ expand_call (tree exp, rtx target, int ignore) /* Set up next argument register. For sibling calls on machines with register windows this should be the incoming register. */ -#ifdef FUNCTION_INCOMING_ARG if (pass == 0) - next_arg_reg = FUNCTION_INCOMING_ARG (args_so_far, VOIDmode, - void_type_node, 1); + next_arg_reg = targetm.calls.function_incoming_arg (&args_so_far, + VOIDmode, + void_type_node, + true); else -#endif - next_arg_reg = FUNCTION_ARG (args_so_far, VOIDmode, - void_type_node, 1); + next_arg_reg = targetm.calls.function_arg (&args_so_far, + VOIDmode, void_type_node, + true); /* All arguments and registers used for the call must be set up by now! */ @@ -3419,7 +3424,8 @@ emit_library_call_value_1 (int retval, rtx orgfun, rtx value, argvec[count].mode = Pmode; argvec[count].partial = 0; - argvec[count].reg = FUNCTION_ARG (args_so_far, Pmode, NULL_TREE, 1); + argvec[count].reg = targetm.calls.function_arg (&args_so_far, + Pmode, NULL_TREE, true); gcc_assert (targetm.calls.arg_partial_bytes (&args_so_far, Pmode, NULL_TREE, 1) == 0); @@ -3435,7 +3441,7 @@ emit_library_call_value_1 (int retval, rtx orgfun, rtx value, || reg_parm_stack_space > 0) args_size.constant += argvec[count].locate.size.constant; - FUNCTION_ARG_ADVANCE (args_so_far, Pmode, (tree) 0, 1); + targetm.calls.function_arg_advance (&args_so_far, Pmode, (tree) 0, true); count++; } @@ -3494,7 +3500,8 @@ emit_library_call_value_1 (int retval, rtx orgfun, rtx value, argvec[count].value = val; argvec[count].mode = mode; - argvec[count].reg = FUNCTION_ARG (args_so_far, mode, NULL_TREE, 1); + argvec[count].reg = targetm.calls.function_arg (&args_so_far, mode, + NULL_TREE, true); argvec[count].partial = targetm.calls.arg_partial_bytes (&args_so_far, mode, NULL_TREE, 1); @@ -3514,7 +3521,7 @@ emit_library_call_value_1 (int retval, rtx orgfun, rtx value, || reg_parm_stack_space > 0) args_size.constant += argvec[count].locate.size.constant; - FUNCTION_ARG_ADVANCE (args_so_far, mode, (tree) 0, 1); + targetm.calls.function_arg_advance (&args_so_far, mode, (tree) 0, true); } /* If this machine requires an external definition for library @@ -3823,7 +3830,8 @@ emit_library_call_value_1 (int retval, rtx orgfun, rtx value, build_function_type (tfom, NULL_TREE), original_args_size.constant, args_size.constant, struct_value_size, - FUNCTION_ARG (args_so_far, VOIDmode, void_type_node, 1), + targetm.calls.function_arg (&args_so_far, + VOIDmode, void_type_node, true), valreg, old_inhibit_defer_pop + 1, call_fusage, flags, & args_so_far); diff --git a/gcc/cfg.c b/gcc/cfg.c index ee6af697468..563582ff296 100644 --- a/gcc/cfg.c +++ b/gcc/cfg.c @@ -84,13 +84,13 @@ void init_flow (struct function *the_fun) { if (!the_fun->cfg) - the_fun->cfg = GGC_CNEW (struct control_flow_graph); + the_fun->cfg = ggc_alloc_cleared_control_flow_graph (); n_edges_for_function (the_fun) = 0; ENTRY_BLOCK_PTR_FOR_FUNCTION (the_fun) - = GGC_CNEW (struct basic_block_def); + = ggc_alloc_cleared_basic_block_def (); ENTRY_BLOCK_PTR_FOR_FUNCTION (the_fun)->index = ENTRY_BLOCK; EXIT_BLOCK_PTR_FOR_FUNCTION (the_fun) - = GGC_CNEW (struct basic_block_def); + = ggc_alloc_cleared_basic_block_def (); EXIT_BLOCK_PTR_FOR_FUNCTION (the_fun)->index = EXIT_BLOCK; ENTRY_BLOCK_PTR_FOR_FUNCTION (the_fun)->next_bb = EXIT_BLOCK_PTR_FOR_FUNCTION (the_fun); @@ -139,7 +139,7 @@ basic_block alloc_block (void) { basic_block bb; - bb = GGC_CNEW (struct basic_block_def); + bb = ggc_alloc_cleared_basic_block_def (); return bb; } @@ -277,7 +277,7 @@ edge unchecked_make_edge (basic_block src, basic_block dst, int flags) { edge e; - e = GGC_CNEW (struct edge_def); + e = ggc_alloc_cleared_edge_def (); n_edges++; e->src = src; diff --git a/gcc/cfganal.c b/gcc/cfganal.c index 5bb23b77adb..65fe337ab01 100644 --- a/gcc/cfganal.c +++ b/gcc/cfganal.c @@ -1256,7 +1256,7 @@ dfs_enumerate_from (basic_block bb, int reverse, static void -compute_dominance_frontiers_1 (bitmap *frontiers) +compute_dominance_frontiers_1 (bitmap_head *frontiers) { edge p; edge_iterator ei; @@ -1275,10 +1275,9 @@ compute_dominance_frontiers_1 (bitmap *frontiers) domsb = get_immediate_dominator (CDI_DOMINATORS, b); while (runner != domsb) { - if (bitmap_bit_p (frontiers[runner->index], b->index)) + if (!bitmap_set_bit (&frontiers[runner->index], + b->index)) break; - bitmap_set_bit (frontiers[runner->index], - b->index); runner = get_immediate_dominator (CDI_DOMINATORS, runner); } @@ -1289,7 +1288,7 @@ compute_dominance_frontiers_1 (bitmap *frontiers) void -compute_dominance_frontiers (bitmap *frontiers) +compute_dominance_frontiers (bitmap_head *frontiers) { timevar_push (TV_DOM_FRONTIERS); @@ -1308,7 +1307,7 @@ compute_dominance_frontiers (bitmap *frontiers) allocated for the return value. */ bitmap -compute_idf (bitmap def_blocks, bitmap *dfs) +compute_idf (bitmap def_blocks, bitmap_head *dfs) { bitmap_iterator bi; unsigned bb_index, i; @@ -1341,7 +1340,7 @@ compute_idf (bitmap def_blocks, bitmap *dfs) we may pull a non-existing block from the work stack. */ gcc_assert (bb_index < (unsigned) last_basic_block); - EXECUTE_IF_AND_COMPL_IN_BITMAP (dfs[bb_index], phi_insertion_points, + EXECUTE_IF_AND_COMPL_IN_BITMAP (&dfs[bb_index], phi_insertion_points, 0, i, bi) { /* Use a safe push because if there is a definition of VAR diff --git a/gcc/cfgexpand.c b/gcc/cfgexpand.c index cc8ff336a42..a76aeb23b3b 100644 --- a/gcc/cfgexpand.c +++ b/gcc/cfgexpand.c @@ -47,6 +47,7 @@ along with GCC; see the file COPYING3. If not see #include "ssaexpand.h" #include "bitmap.h" #include "sbitmap.h" +#include "insn-attr.h" /* For INSN_SCHEDULING. */ /* This variable holds information helping the rewriting of SSA trees into RTL. */ @@ -67,7 +68,13 @@ gimple_assign_rhs_to_tree (gimple stmt) grhs_class = get_gimple_rhs_class (gimple_expr_code (stmt)); - if (grhs_class == GIMPLE_BINARY_RHS) + if (grhs_class == GIMPLE_TERNARY_RHS) + t = build3 (gimple_assign_rhs_code (stmt), + TREE_TYPE (gimple_assign_lhs (stmt)), + gimple_assign_rhs1 (stmt), + gimple_assign_rhs2 (stmt), + gimple_assign_rhs3 (stmt)); + else if (grhs_class == GIMPLE_BINARY_RHS) t = build2 (gimple_assign_rhs_code (stmt), TREE_TYPE (gimple_assign_lhs (stmt)), gimple_assign_rhs1 (stmt), @@ -1888,6 +1895,9 @@ expand_gimple_stmt_1 (gimple stmt) ops.type = TREE_TYPE (lhs); switch (get_gimple_rhs_class (gimple_expr_code (stmt))) { + case GIMPLE_TERNARY_RHS: + ops.op2 = gimple_assign_rhs3 (stmt); + /* Fallthru */ case GIMPLE_BINARY_RHS: ops.op1 = gimple_assign_rhs2 (stmt); /* Fallthru */ @@ -2238,6 +2248,8 @@ expand_debug_expr (tree exp) { case COND_EXPR: case DOT_PROD_EXPR: + case WIDEN_MULT_PLUS_EXPR: + case WIDEN_MULT_MINUS_EXPR: goto ternary; case TRUTH_ANDIF_EXPR: @@ -2426,6 +2438,11 @@ expand_debug_expr (tree exp) return op0; } + case MEM_REF: + /* ??? FIXME. */ + if (!integer_zerop (TREE_OPERAND (exp, 1))) + return NULL; + /* Fallthru. */ case INDIRECT_REF: case ALIGN_INDIRECT_REF: case MISALIGNED_INDIRECT_REF: @@ -3024,6 +3041,8 @@ expand_debug_expr (tree exp) return NULL; case WIDEN_MULT_EXPR: + case WIDEN_MULT_PLUS_EXPR: + case WIDEN_MULT_MINUS_EXPR: if (SCALAR_INT_MODE_P (GET_MODE (op0)) && SCALAR_INT_MODE_P (mode)) { @@ -3036,7 +3055,13 @@ expand_debug_expr (tree exp) op1 = simplify_gen_unary (ZERO_EXTEND, mode, op1, inner_mode); else op1 = simplify_gen_unary (SIGN_EXTEND, mode, op1, inner_mode); - return gen_rtx_MULT (mode, op0, op1); + op0 = gen_rtx_MULT (mode, op0, op1); + if (TREE_CODE (exp) == WIDEN_MULT_EXPR) + return op0; + else if (TREE_CODE (exp) == WIDEN_MULT_PLUS_EXPR) + return gen_rtx_PLUS (mode, op0, op2); + else + return gen_rtx_MINUS (mode, op2, op0); } return NULL; @@ -3761,6 +3786,10 @@ gimple_expand_cfg (void) set_curr_insn_block (DECL_INITIAL (current_function_decl)); prologue_locator = curr_insn_locator (); +#ifdef INSN_SCHEDULING + init_sched_attrs (); +#endif + /* Make sure first insn is a note even if we don't want linenums. This makes sure the first insn will never be deleted. Also, final expects a note to appear there. */ diff --git a/gcc/cfgloop.c b/gcc/cfgloop.c index 858e75b3f52..c0d9a4cacc2 100644 --- a/gcc/cfgloop.c +++ b/gcc/cfgloop.c @@ -334,9 +334,9 @@ flow_loop_tree_node_remove (struct loop *loop) struct loop * alloc_loop (void) { - struct loop *loop = GGC_CNEW (struct loop); + struct loop *loop = ggc_alloc_cleared_loop (); - loop->exits = GGC_CNEW (struct loop_exit); + loop->exits = ggc_alloc_cleared_loop_exit (); loop->exits->next = loop->exits->prev = loop->exits; loop->can_be_parallel = false; loop->single_iv = NULL_TREE; @@ -1026,7 +1026,7 @@ rescan_loop_exit (edge e, bool new_edge, bool removed) aloop != cloop; aloop = loop_outer (aloop)) { - exit = GGC_NEW (struct loop_exit); + exit = ggc_alloc_loop_exit (); exit->e = e; exit->next = aloop->exits->next; @@ -1076,11 +1076,9 @@ record_loop_exits (void) loops_state_set (LOOPS_HAVE_RECORDED_EXITS); gcc_assert (current_loops->exits == NULL); - current_loops->exits = htab_create_alloc (2 * number_of_loops (), - loop_exit_hash, - loop_exit_eq, - loop_exit_free, - ggc_calloc, ggc_free); + current_loops->exits = htab_create_ggc (2 * number_of_loops (), + loop_exit_hash, loop_exit_eq, + loop_exit_free); FOR_EACH_BB (bb) { diff --git a/gcc/cfgrtl.c b/gcc/cfgrtl.c index abdbf9d8598..3138281b589 100644 --- a/gcc/cfgrtl.c +++ b/gcc/cfgrtl.c @@ -42,7 +42,6 @@ along with GCC; see the file COPYING3. If not see #include "coretypes.h" #include "tm.h" #include "tree.h" -#include "rtl.h" #include "hard-reg-set.h" #include "basic-block.h" #include "regs.h" @@ -50,7 +49,7 @@ along with GCC; see the file COPYING3. If not see #include "output.h" #include "function.h" #include "except.h" -#include "toplev.h" +#include "rtl-error.h" #include "tm_p.h" #include "obstack.h" #include "insn-attr.h" @@ -3080,7 +3079,7 @@ void init_rtl_bb_info (basic_block bb) { gcc_assert (!bb->il.rtl); - bb->il.rtl = GGC_CNEW (struct rtl_bb_info); + bb->il.rtl = ggc_alloc_cleared_rtl_bb_info (); } diff --git a/gcc/cgraph.c b/gcc/cgraph.c index 0c2441fcf6f..aaa50b607d2 100644 --- a/gcc/cgraph.c +++ b/gcc/cgraph.c @@ -442,7 +442,7 @@ cgraph_allocate_node (void) } else { - node = GGC_CNEW (struct cgraph_node); + node = ggc_alloc_cleared_cgraph_node (); node->uid = cgraph_max_uid++; } @@ -970,7 +970,7 @@ cgraph_create_edge_1 (struct cgraph_node *caller, struct cgraph_node *callee, } else { - edge = GGC_NEW (struct cgraph_edge); + edge = ggc_alloc_cgraph_edge (); edge->uid = cgraph_edge_max_uid++; } @@ -1045,7 +1045,7 @@ cgraph_create_indirect_edge (struct cgraph_node *caller, gimple call_stmt, edge->indirect_unknown_callee = 1; initialize_inline_failed (edge); - edge->indirect_info = GGC_CNEW (struct cgraph_indirect_call_info); + edge->indirect_info = ggc_alloc_cleared_cgraph_indirect_call_info (); edge->indirect_info->param_index = -1; edge->indirect_info->ecf_flags = ecf_flags; @@ -1825,6 +1825,8 @@ dump_cgraph_node (FILE *f, struct cgraph_node *node) fprintf (f, " local"); if (node->local.externally_visible) fprintf (f, " externally_visible"); + if (node->local.used_from_object_file) + fprintf (f, " used_from_object_file"); if (node->local.finalized) fprintf (f, " finalized"); if (node->local.disregard_inline_limits) @@ -1973,7 +1975,7 @@ cgraph_add_asm_node (tree asm_str) { struct cgraph_asm_node *node; - node = GGC_CNEW (struct cgraph_asm_node); + node = ggc_alloc_cleared_cgraph_asm_node (); node->asm_str = asm_str; node->order = cgraph_order++; node->next = NULL; @@ -2075,6 +2077,7 @@ cgraph_clone_node (struct cgraph_node *n, tree decl, gcov_type count, int freq, new_node->analyzed = n->analyzed; new_node->local = n->local; new_node->local.externally_visible = false; + new_node->local.used_from_object_file = false; new_node->local.local = true; new_node->local.vtable_method = false; new_node->global = n->global; @@ -2214,6 +2217,8 @@ cgraph_create_virtual_clone (struct cgraph_node *old_node, ??? We cannot use COMDAT linkage because there is no ABI support for this. */ DECL_EXTERNAL (new_node->decl) = 0; + if (DECL_ONE_ONLY (old_decl)) + DECL_SECTION_NAME (new_node->decl) = NULL; DECL_COMDAT_GROUP (new_node->decl) = 0; TREE_PUBLIC (new_node->decl) = 0; DECL_COMDAT (new_node->decl) = 0; @@ -2266,6 +2271,7 @@ cgraph_create_virtual_clone (struct cgraph_node *old_node, else new_node->clone.combined_args_to_skip = args_to_skip; new_node->local.externally_visible = 0; + new_node->local.used_from_object_file = 0; new_node->local.local = 1; new_node->lowered = true; new_node->reachable = true; @@ -2606,6 +2612,8 @@ cgraph_node_cannot_return (struct cgraph_node *node) bool cgraph_edge_cannot_lead_to_return (struct cgraph_edge *e) { + if (cgraph_node_cannot_return (e->caller)) + return true; if (e->indirect_unknown_callee) { int flags = e->indirect_info->ecf_flags; diff --git a/gcc/cgraph.h b/gcc/cgraph.h index c82fc181ebe..ef556b9cd7f 100644 --- a/gcc/cgraph.h +++ b/gcc/cgraph.h @@ -102,6 +102,9 @@ struct GTY(()) cgraph_local_info { /* Set when function is visible by other units. */ unsigned externally_visible : 1; + /* Set when resolver determines that function is visible by other units. */ + unsigned used_from_object_file : 1; + /* Set once it has been finalized so we consider it to be output. */ unsigned finalized : 1; @@ -466,6 +469,8 @@ struct GTY((chain_next ("%h.next"), chain_prev ("%h.prev"))) varpool_node { /* Circular list of nodes in the same comdat group if non-NULL. */ struct varpool_node *same_comdat_group; struct ipa_ref_list ref_list; + /* File stream where this node is being written to. */ + struct lto_file_decl_data * lto_file_data; PTR GTY ((skip)) aux; /* Ordering of all cgraph nodes. */ int order; @@ -485,6 +490,8 @@ struct GTY((chain_next ("%h.next"), chain_prev ("%h.prev"))) varpool_node { unsigned output : 1; /* Set when function is visible by other units. */ unsigned externally_visible : 1; + /* Set when resolver determines that variable is visible by other units. */ + unsigned used_from_object_file : 1; /* Set for aliases once they got through assemble_alias. Also set for extra name aliases in varpool_extra_name_alias. */ unsigned alias : 1; @@ -722,7 +729,7 @@ varpool_first_static_initializer (void) struct varpool_node *node; for (node = varpool_nodes_queue; node; node = node->next_needed) { - gcc_assert (TREE_CODE (node->decl) == VAR_DECL); + gcc_checking_assert (TREE_CODE (node->decl) == VAR_DECL); if (DECL_INITIAL (node->decl)) return node; } @@ -735,7 +742,7 @@ varpool_next_static_initializer (struct varpool_node *node) { for (node = node->next_needed; node; node = node->next_needed) { - gcc_assert (TREE_CODE (node->decl) == VAR_DECL); + gcc_checking_assert (TREE_CODE (node->decl) == VAR_DECL); if (DECL_INITIAL (node->decl)) return node; } diff --git a/gcc/cgraphbuild.c b/gcc/cgraphbuild.c index c63b5afc81c..9dcb8623167 100644 --- a/gcc/cgraphbuild.c +++ b/gcc/cgraphbuild.c @@ -275,7 +275,7 @@ mark_load (gimple stmt ATTRIBUTE_UNUSED, tree t, void *data ATTRIBUTE_UNUSED) { t = get_base_address (t); - if (TREE_CODE (t) == VAR_DECL + if (t && TREE_CODE (t) == VAR_DECL && (TREE_STATIC (t) || DECL_EXTERNAL (t))) { struct varpool_node *vnode = varpool_node (t); @@ -300,7 +300,7 @@ mark_store (gimple stmt ATTRIBUTE_UNUSED, tree t, void *data ATTRIBUTE_UNUSED) { t = get_base_address (t); - if (TREE_CODE (t) == VAR_DECL + if (t && TREE_CODE (t) == VAR_DECL && (TREE_STATIC (t) || DECL_EXTERNAL (t))) { struct varpool_node *vnode = varpool_node (t); diff --git a/gcc/cgraphunit.c b/gcc/cgraphunit.c index 54752ed54c1..5a69afa5286 100644 --- a/gcc/cgraphunit.c +++ b/gcc/cgraphunit.c @@ -1364,8 +1364,7 @@ thunk_adjust (gimple_stmt_iterator * bsi, vtabletmp2 = create_tmp_var (TREE_TYPE (TREE_TYPE (vtabletmp)), "vtableaddr"); stmt = gimple_build_assign (vtabletmp2, - build1 (INDIRECT_REF, - TREE_TYPE (vtabletmp2), vtabletmp)); + build_simple_mem_ref (vtabletmp)); gsi_insert_after (bsi, stmt, GSI_NEW_STMT); mark_symbols_for_renaming (stmt); find_referenced_vars_in (stmt); @@ -1384,9 +1383,7 @@ thunk_adjust (gimple_stmt_iterator * bsi, vtabletmp3 = create_tmp_var (TREE_TYPE (TREE_TYPE (vtabletmp2)), "vcalloffset"); stmt = gimple_build_assign (vtabletmp3, - build1 (INDIRECT_REF, - TREE_TYPE (vtabletmp3), - vtabletmp2)); + build_simple_mem_ref (vtabletmp2)); gsi_insert_after (bsi, stmt, GSI_NEW_STMT); mark_symbols_for_renaming (stmt); find_referenced_vars_in (stmt); @@ -2128,7 +2125,7 @@ cgraph_copy_node_for_versioning (struct cgraph_node *old_version, new_version->local.local = true; new_version->local.vtable_method = false; new_version->global = old_version->global; - new_version->rtl = new_version->rtl; + new_version->rtl = old_version->rtl; new_version->reachable = true; new_version->count = old_version->count; @@ -2196,7 +2193,6 @@ cgraph_function_versioning (struct cgraph_node *old_version_node, else new_decl = build_function_decl_skip_args (old_decl, args_to_skip); - cgraph_make_decl_local (new_decl); /* Generate a new name for the new version. */ DECL_NAME (new_decl) = clone_function_name (old_decl, clone_name); SET_DECL_ASSEMBLER_NAME (new_decl, DECL_NAME (new_decl)); @@ -2345,7 +2341,6 @@ cgraph_redirect_edge_call_stmt_to_callee (struct cgraph_edge *e) { tree decl = gimple_call_fndecl (e->call_stmt); gimple new_stmt; - gimple_stmt_iterator gsi; #ifdef ENABLE_CHECKING struct cgraph_node *node; #endif @@ -2367,29 +2362,34 @@ cgraph_redirect_edge_call_stmt_to_callee (struct cgraph_edge *e) cgraph_node_name (e->callee), e->callee->uid); print_gimple_stmt (cgraph_dump_file, e->call_stmt, 0, dump_flags); if (e->callee->clone.combined_args_to_skip) - { - fprintf (cgraph_dump_file, " combined args to skip: "); - dump_bitmap (cgraph_dump_file, e->callee->clone.combined_args_to_skip); + { + fprintf (cgraph_dump_file, " combined args to skip: "); + dump_bitmap (cgraph_dump_file, + e->callee->clone.combined_args_to_skip); } } if (e->callee->clone.combined_args_to_skip) - new_stmt = gimple_call_copy_skip_args (e->call_stmt, - e->callee->clone.combined_args_to_skip); + { + gimple_stmt_iterator gsi; + + new_stmt + = gimple_call_copy_skip_args (e->call_stmt, + e->callee->clone.combined_args_to_skip); + + if (gimple_vdef (new_stmt) + && TREE_CODE (gimple_vdef (new_stmt)) == SSA_NAME) + SSA_NAME_DEF_STMT (gimple_vdef (new_stmt)) = new_stmt; + + gsi = gsi_for_stmt (e->call_stmt); + gsi_replace (&gsi, new_stmt, true); + } else new_stmt = e->call_stmt; - if (gimple_vdef (new_stmt) - && TREE_CODE (gimple_vdef (new_stmt)) == SSA_NAME) - SSA_NAME_DEF_STMT (gimple_vdef (new_stmt)) = new_stmt; - gimple_call_set_fndecl (new_stmt, e->callee->decl); - gsi = gsi_for_stmt (e->call_stmt); - gsi_replace (&gsi, new_stmt, true); + gimple_call_set_fndecl (new_stmt, e->callee->decl); update_stmt (new_stmt); - /* Update EH information too, just in case. */ - maybe_clean_or_replace_eh_stmt (e->call_stmt, new_stmt); - cgraph_set_call_stmt_including_clones (e->caller, e->call_stmt, new_stmt); if (cgraph_dump_file) diff --git a/gcc/collect2.c b/gcc/collect2.c index 42db3cbf0ff..b26aaf31485 100644 --- a/gcc/collect2.c +++ b/gcc/collect2.c @@ -1535,12 +1535,7 @@ main (int argc, char **argv) case 'o': if (arg[2] == '\0') output_file = *ld1++ = *ld2++ = *++argv; - else if (1 -#ifdef SWITCHES_NEED_SPACES - && ! strchr (SWITCHES_NEED_SPACES, arg[1]) -#endif - ) - + else output_file = &arg[2]; break; @@ -1593,9 +1588,9 @@ main (int argc, char **argv) } else if (strncmp (arg, "--sysroot=", 10) == 0) target_system_root = arg + 10; - else if (strncmp (arg, "--version", 9) == 0) + else if (strcmp (arg, "--version") == 0) vflag = true; - else if (strncmp (arg, "--help", 9) == 0) + else if (strcmp (arg, "--help") == 0) helpflag = true; break; } diff --git a/gcc/combine-stack-adj.c b/gcc/combine-stack-adj.c index 8849697bfce..96bfb3a633e 100644 --- a/gcc/combine-stack-adj.c +++ b/gcc/combine-stack-adj.c @@ -555,7 +555,7 @@ rest_of_handle_stack_adjustments (void) cleanup_cfg (flag_crossjumping ? CLEANUP_CROSSJUMP : 0); /* This is kind of a heuristic. We need to run combine_stack_adjustments - even for machines with possibly nonzero RETURN_POPS_ARGS + even for machines with possibly nonzero TARGET_RETURN_POPS_ARGS and ACCUMULATE_OUTGOING_ARGS. We expect that only ports having push instructions will have popping returns. */ #ifndef PUSH_ROUNDING diff --git a/gcc/combine.c b/gcc/combine.c index 1bee2c7f422..d3305cb4abe 100644 --- a/gcc/combine.c +++ b/gcc/combine.c @@ -7277,22 +7277,21 @@ make_compound_operation (rtx x, enum rtx_code in_code) /* Call ourselves recursively on the inner expression. If we are narrowing the object and it has a different RTL code from what it originally did, do this SUBREG as a force_to_mode. */ - - tem = make_compound_operation (SUBREG_REG (x), in_code); - { - rtx simplified = simplify_subreg (mode, tem, GET_MODE (SUBREG_REG (x)), - SUBREG_BYTE (x)); + rtx inner = SUBREG_REG (x), simplified; + + tem = make_compound_operation (inner, in_code); + simplified + = simplify_subreg (mode, tem, GET_MODE (inner), SUBREG_BYTE (x)); if (simplified) tem = simplified; - if (GET_CODE (tem) != GET_CODE (SUBREG_REG (x)) - && GET_MODE_SIZE (mode) < GET_MODE_SIZE (GET_MODE (SUBREG_REG (x))) + if (GET_CODE (tem) != GET_CODE (inner) + && GET_MODE_SIZE (mode) < GET_MODE_SIZE (GET_MODE (inner)) && subreg_lowpart_p (x)) { - rtx newer = force_to_mode (tem, mode, ~(HOST_WIDE_INT) 0, - 0); + rtx newer = force_to_mode (tem, mode, ~(HOST_WIDE_INT) 0, 0); /* If we have something other than a SUBREG, we might have done an expansion, so rerun ourselves. */ @@ -7300,9 +7299,16 @@ make_compound_operation (rtx x, enum rtx_code in_code) newer = make_compound_operation (newer, in_code); /* force_to_mode can expand compounds. If it just re-expanded the - compound use gen_lowpart instead to convert to the desired - mode. */ - if (rtx_equal_p (newer, x)) + compound, use gen_lowpart to convert to the desired mode. */ + if (rtx_equal_p (newer, x) + /* Likewise if it re-expanded the compound only partially. + This happens for SUBREG of ZERO_EXTRACT if they extract + the same number of bits. */ + || (GET_CODE (newer) == SUBREG + && (GET_CODE (SUBREG_REG (newer)) == LSHIFTRT + || GET_CODE (SUBREG_REG (newer)) == ASHIFTRT) + && GET_CODE (inner) == AND + && rtx_equal_p (SUBREG_REG (newer), XEXP (inner, 0)))) return gen_lowpart (GET_MODE (x), tem); return newer; diff --git a/gcc/common.opt b/gcc/common.opt index 49044815509..6ca787a4b5f 100644 --- a/gcc/common.opt +++ b/gcc/common.opt @@ -173,7 +173,7 @@ Common Warning Warn about code which might break strict aliasing rules Wstrict-aliasing= -Common Joined UInteger Var(warn_strict_aliasing) Init(-1) Warning +Common Joined RejectNegative UInteger Var(warn_strict_aliasing) Init(-1) Warning Warn about code which might break strict aliasing rules Wstrict-overflow @@ -181,7 +181,7 @@ Common Warning Warn about optimizations that assume that signed overflow is undefined Wstrict-overflow= -Common Joined UInteger Var(warn_strict_overflow) Init(-1) Warning +Common Joined RejectNegative UInteger Var(warn_strict_overflow) Init(-1) Warning Warn about optimizations that assume that signed overflow is undefined Wsuggest-attribute=const @@ -192,6 +192,10 @@ Wsuggest-attribute=pure Common Var(warn_suggest_attribute_pure) Warning Warn about functions which might be candidates for __attribute__((pure)) +Wsuggest-attribute=noreturn +Common Var(warn_suggest_attribute_noreturn) Warning +Warn about functions which might be candidates for __attribute__((noreturn)) + Wswitch Common Var(warn_switch) Warning Warn about enumerated switches, with no default, missing a case @@ -301,7 +305,7 @@ Common Separate ; Additional positive integers will be assigned as new versions of ; the ABI become the default version of the ABI. fabi-version= -Common Joined UInteger Var(flag_abi_version) Init(2) +Common Joined RejectNegative UInteger Var(flag_abi_version) Init(2) falign-functions Common Report Var(align_functions,0) Optimization UInteger @@ -625,6 +629,10 @@ floop-block Common Report Var(flag_loop_block) Optimization Enable Loop Blocking transformation +fstrict-volatile-bitfields +Common Report Var(flag_strict_volatile_bitfields) Init(-1) +Force bitfield accesses to match their type width + fguess-branch-probability Common Report Var(flag_guess_branch_prob) Optimization Enable guessing of branch probabilities @@ -757,7 +765,7 @@ Common Report Var(flag_ira_share_spill_slots) Init(1) Share stack slots for spilled pseudo-registers. fira-verbose= -Common RejectNegative Joined UInteger +Common RejectNegative Joined UInteger Var(flag_ira_verbose) Init(5) -fira-verbose= Control IRA's level of diagnostic messages. fivopts @@ -790,7 +798,7 @@ Enable link-time optimization. ; The initial value of -1 comes from Z_DEFAULT_COMPRESSION in zlib.h. flto-compression-level= -Common Joined UInteger Var(flag_lto_compression_level) Init(-1) +Common Joined RejectNegative UInteger Var(flag_lto_compression_level) Init(-1) -flto-compression-level= Use zlib compression level for IL flto-report @@ -876,6 +884,10 @@ foptimize-sibling-calls Common Report Var(flag_optimize_sibling_calls) Optimization Optimize sibling and tail recursive calls +fpartial-inlining +Common Report Var(flag_partial_inlining) +Perform partial inlining + fpre-ipa-mem-report Common Report Var(pre_ipa_mem_report) Report on memory allocation before interprocedural optimization @@ -893,7 +905,7 @@ Common RejectNegative Joined UInteger Optimization -fpack-struct= Set initial maximum structure member alignment fpcc-struct-return -Common Report Var(flag_pcc_struct_return,1) VarExists +Common Report Var(flag_pcc_struct_return,1) Init(DEFAULT_PCC_STRUCT_RETURN) Return small aggregates in memory, not registers fpeel-loops @@ -937,7 +949,7 @@ Common Report Var(flag_predictive_commoning) Optimization Run predictive commoning optimization. fprefetch-loop-arrays -Common Report Var(flag_prefetch_loop_arrays) Optimization +Common Report Var(flag_prefetch_loop_arrays) Init(-1) Optimization Generate prefetch instructions, if available, for arrays in loops fprofile @@ -1152,7 +1164,7 @@ Common Report Var(flag_zee) Init(0) Eliminate redundant zero extensions on targets that support implicit extensions. fshow-column -Common C ObjC C++ ObjC++ Report Var(flag_show_column) Init(1) +Common Report Var(flag_show_column) Init(1) Show column numbers in diagnostics, when available. Default on fsignaling-nans @@ -1334,7 +1346,7 @@ Common Report Var(flag_tree_loop_optimize) Init(1) Optimization Enable loop optimizations on tree level ftree-parallelize-loops= -Common Report Joined UInteger Var(flag_tree_parallelize_loops) Init(1) +Common Report Joined RejectNegative UInteger Var(flag_tree_parallelize_loops) Init(1) Enable automatic parallelization of loops ftree-phiprop diff --git a/gcc/config.gcc b/gcc/config.gcc index 3b74b689a52..6dc074d8a88 100644 --- a/gcc/config.gcc +++ b/gcc/config.gcc @@ -1750,6 +1750,7 @@ mips64*-*-linux* | mipsisa64*-*-linux*) tm_defines="${tm_defines} MIPS_ISA_DEFAULT=65" ;; esac + extra_parts="$extra_parts crtfastmath.o" gnu_ld=yes gas=yes test x$with_llsc != x || with_llsc=yes @@ -1764,6 +1765,7 @@ mips*-*-linux*) # Linux MIPS, either endian. mipsisa32*) tm_defines="${tm_defines} MIPS_ISA_DEFAULT=32" esac + extra_parts="$extra_parts crtfastmath.o" test x$with_llsc != x || with_llsc=yes ;; mips*-*-openbsd*) @@ -3284,7 +3286,7 @@ case "${target}" in | 401 | 403 | 405 | 405fp | 440 | 440fp | 464 | 464fp \ | 476 | 476fp | 505 | 601 | 602 | 603 | 603e | ec603e \ | 604 | 604e | 620 | 630 | 740 | 750 | 7400 | 7450 \ - | a2 | e300c[23] | 854[08] | e500mc | e500mc64 \ + | a2 | e300c[23] | 854[08] | e500mc | e500mc64 | titan\ | 801 | 821 | 823 | 860 | 970 | G3 | G4 | G5 | cell) # OK ;; diff --git a/gcc/config.in b/gcc/config.in index b7884a386d1..35d406d1872 100644 --- a/gcc/config.in +++ b/gcc/config.in @@ -1168,6 +1168,12 @@ #endif +/* Define if your PowerPC64 linker supports a large TOC. */ +#ifndef USED_FOR_TARGET +#undef HAVE_LD_LARGE_TOC +#endif + + /* Define if your PowerPC64 linker only needs function descriptor syms. */ #ifndef USED_FOR_TARGET #undef HAVE_LD_NO_DOT_SYMS diff --git a/gcc/config/alpha/alpha.c b/gcc/config/alpha/alpha.c index 4daf3df4d65..a67097a3c2c 100644 --- a/gcc/config/alpha/alpha.c +++ b/gcc/config/alpha/alpha.c @@ -1569,10 +1569,12 @@ alpha_preferred_reload_class(rtx x, enum reg_class rclass) RCLASS requires an extra scratch or immediate register. Return the class needed for the immediate register. */ -static enum reg_class -alpha_secondary_reload (bool in_p, rtx x, enum reg_class rclass, +static reg_class_t +alpha_secondary_reload (bool in_p, rtx x, reg_class_t rclass_i, enum machine_mode mode, secondary_reload_info *sri) { + enum reg_class rclass = (enum reg_class) rclass_i; + /* Loading and storing HImode or QImode values to and from memory usually requires a scratch register. */ if (!TARGET_BWX && (mode == QImode || mode == HImode || mode == CQImode)) @@ -4806,8 +4808,7 @@ struct GTY(()) machine_function static struct machine_function * alpha_init_machine_status (void) { - return ((struct machine_function *) - ggc_alloc_cleared (sizeof (struct machine_function))); + return ggc_alloc_cleared_machine_function (); } /* Support for frame based VMS condition handlers. */ @@ -6024,7 +6025,7 @@ alpha_stdarg_optimize_hook (struct stdarg_info *si, const_gimple stmt) rhs = gimple_assign_rhs1 (stmt); while (handled_component_p (rhs)) rhs = TREE_OPERAND (rhs, 0); - if (TREE_CODE (rhs) != INDIRECT_REF + if (TREE_CODE (rhs) != MEM_REF || TREE_CODE (TREE_OPERAND (rhs, 0)) != SSA_NAME) return false; @@ -9743,7 +9744,7 @@ alpha_file_start (void) /* If emitting dwarf2 debug information, we cannot generate a .file directive to start the file, as it will conflict with dwarf2out file numbers. So it's only useful when emitting mdebug output. */ - targetm.file_start_file_directive = (write_symbols == DBX_DEBUG); + targetm.asm_file_start_file_directive = (write_symbols == DBX_DEBUG); #endif default_file_start (); @@ -9901,10 +9902,13 @@ alpha_need_linkage (const char *name, int is_local) struct alpha_funcs *cfaf; if (!alpha_funcs_tree) - alpha_funcs_tree = splay_tree_new_ggc ((splay_tree_compare_fn) - splay_tree_compare_pointers); + alpha_funcs_tree = splay_tree_new_ggc + (splay_tree_compare_pointers, + ggc_alloc_splay_tree_tree_node_tree_node_splay_tree_s, + ggc_alloc_splay_tree_tree_node_tree_node_splay_tree_node_s); + - cfaf = (struct alpha_funcs *) ggc_alloc (sizeof (struct alpha_funcs)); + cfaf = ggc_alloc_alpha_funcs (); cfaf->links = 0; cfaf->num = ++alpha_funcs_num; @@ -9938,9 +9942,12 @@ alpha_need_linkage (const char *name, int is_local) } } else - alpha_links_tree = splay_tree_new_ggc ((splay_tree_compare_fn) strcmp); + alpha_links_tree = splay_tree_new_ggc + ((splay_tree_compare_fn) strcmp, + ggc_alloc_splay_tree_str_alpha_links_splay_tree_s, + ggc_alloc_splay_tree_str_alpha_links_splay_tree_node_s); - al = (struct alpha_links *) ggc_alloc (sizeof (struct alpha_links)); + al = ggc_alloc_alpha_links (); name = ggc_strdup (name); /* Assume external if no definition. */ @@ -9996,7 +10003,10 @@ alpha_use_linkage (rtx func, tree cfundecl, int lflag, int rflag) al = (struct alpha_links *) lnode->value; } else - cfaf->links = splay_tree_new_ggc ((splay_tree_compare_fn) strcmp); + cfaf->links = splay_tree_new_ggc + ((splay_tree_compare_fn) strcmp, + ggc_alloc_splay_tree_str_alpha_links_splay_tree_s, + ggc_alloc_splay_tree_str_alpha_links_splay_tree_node_s); if (!al) { @@ -10012,7 +10022,7 @@ alpha_use_linkage (rtx func, tree cfundecl, int lflag, int rflag) name_len = strlen (name); linksym = (char *) alloca (name_len + 50); - al = (struct alpha_links *) ggc_alloc (sizeof (struct alpha_links)); + al = ggc_alloc_alpha_links (); al->num = cfaf->num; node = splay_tree_lookup (alpha_links_tree, (splay_tree_key) name); diff --git a/gcc/config/alpha/alpha.h b/gcc/config/alpha/alpha.h index 6235d9ff90a..c8590b9c782 100644 --- a/gcc/config/alpha/alpha.h +++ b/gcc/config/alpha/alpha.h @@ -703,15 +703,6 @@ extern int alpha_memory_latency; in a register. */ /* #define REG_PARM_STACK_SPACE */ -/* Value is the number of bytes of arguments automatically - popped when returning from a subroutine call. - FUNDECL is the declaration node of the function (as a tree), - FUNTYPE is the data type of the function (as a tree), - or for a library call it is an identifier node for the subroutine name. - SIZE is the number of bytes of arguments passed on the stack. */ - -#define RETURN_POPS_ARGS(FUNDECL,FUNTYPE,SIZE) 0 - /* Define how to find the value returned by a function. VALTYPE is the data type of the value (as a tree). If the precise function being called is known, FUNC is its FUNCTION_DECL; diff --git a/gcc/config/arc/arc.h b/gcc/config/arc/arc.h index 5127a123e31..9a4e360504b 100644 --- a/gcc/config/arc/arc.h +++ b/gcc/config/arc/arc.h @@ -530,14 +530,6 @@ extern enum reg_class arc_regno_reg_class[FIRST_PSEUDO_REGISTER]; increase the stack frame size by this amount. */ #define ACCUMULATE_OUTGOING_ARGS 1 -/* Value is the number of bytes of arguments automatically - popped when returning from a subroutine call. - FUNDECL is the declaration node of the function (as a tree), - FUNTYPE is the data type of the function (as a tree), - or for a library call it is an identifier node for the subroutine name. - SIZE is the number of bytes of arguments passed on the stack. */ -#define RETURN_POPS_ARGS(DECL, FUNTYPE, SIZE) 0 - /* Define a data type for recording info about an argument list during the scan of that argument list. This data type should hold all necessary information about the function itself diff --git a/gcc/config/arm/arm-c.c b/gcc/config/arm/arm-c.c index 4e2a9cbe51a..786a7a3587f 100644 --- a/gcc/config/arm/arm-c.c +++ b/gcc/config/arm/arm-c.c @@ -23,7 +23,7 @@ along with GCC; see the file COPYING3. If not see #include "tm_p.h" #include "tree.h" #include "output.h" -#include "c-common.h" +#include "c-family/c-common.h" /* Output C specific EABI object attributes. These can not be done in diff --git a/gcc/config/arm/arm-cores.def b/gcc/config/arm/arm-cores.def index a1a6960f5fd..9e949a2c334 100644 --- a/gcc/config/arm/arm-cores.def +++ b/gcc/config/arm/arm-cores.def @@ -123,6 +123,7 @@ ARM_CORE("cortex-a8", cortexa8, 7A, FL_LDSCHED, 9e) ARM_CORE("cortex-a9", cortexa9, 7A, FL_LDSCHED, 9e) ARM_CORE("cortex-r4", cortexr4, 7R, FL_LDSCHED, 9e) ARM_CORE("cortex-r4f", cortexr4f, 7R, FL_LDSCHED, 9e) +ARM_CORE("cortex-m4", cortexm4, 7EM, FL_LDSCHED, 9e) ARM_CORE("cortex-m3", cortexm3, 7M, FL_LDSCHED, 9e) ARM_CORE("cortex-m1", cortexm1, 6M, FL_LDSCHED, 9e) ARM_CORE("cortex-m0", cortexm0, 6M, FL_LDSCHED, 9e) diff --git a/gcc/config/arm/arm-protos.h b/gcc/config/arm/arm-protos.h index 2933201a1eb..61dcf07d8ef 100644 --- a/gcc/config/arm/arm-protos.h +++ b/gcc/config/arm/arm-protos.h @@ -136,8 +136,6 @@ extern const char *arithmetic_instr (rtx, int); extern void output_ascii_pseudo_op (FILE *, const unsigned char *, int); extern const char *output_return_instruction (rtx, int, int); extern void arm_poke_function_name (FILE *, const char *); -extern void arm_print_operand (FILE *, rtx, int); -extern void arm_print_operand_address (FILE *, rtx); extern void arm_final_prescan_insn (rtx); extern int arm_debugger_arg_offset (int, rtx); extern bool arm_is_long_call_p (tree); diff --git a/gcc/config/arm/arm-tune.md b/gcc/config/arm/arm-tune.md index 7aef5f5fb78..4123043058b 100644 --- a/gcc/config/arm/arm-tune.md +++ b/gcc/config/arm/arm-tune.md @@ -1,5 +1,5 @@ ;; -*- buffer-read-only: t -*- ;; Generated automatically by gentune.sh from arm-cores.def (define_attr "tune" - "arm2,arm250,arm3,arm6,arm60,arm600,arm610,arm620,arm7,arm7d,arm7di,arm70,arm700,arm700i,arm710,arm720,arm710c,arm7100,arm7500,arm7500fe,arm7m,arm7dm,arm7dmi,arm8,arm810,strongarm,strongarm110,strongarm1100,strongarm1110,arm7tdmi,arm7tdmis,arm710t,arm720t,arm740t,arm9,arm9tdmi,arm920,arm920t,arm922t,arm940t,ep9312,arm10tdmi,arm1020t,arm9e,arm946es,arm966es,arm968es,arm10e,arm1020e,arm1022e,xscale,iwmmxt,iwmmxt2,arm926ejs,arm1026ejs,arm1136js,arm1136jfs,arm1176jzs,arm1176jzfs,mpcorenovfp,mpcore,arm1156t2s,arm1156t2fs,cortexa5,cortexa8,cortexa9,cortexr4,cortexr4f,cortexm3,cortexm1,cortexm0" + "arm2,arm250,arm3,arm6,arm60,arm600,arm610,arm620,arm7,arm7d,arm7di,arm70,arm700,arm700i,arm710,arm720,arm710c,arm7100,arm7500,arm7500fe,arm7m,arm7dm,arm7dmi,arm8,arm810,strongarm,strongarm110,strongarm1100,strongarm1110,arm7tdmi,arm7tdmis,arm710t,arm720t,arm740t,arm9,arm9tdmi,arm920,arm920t,arm922t,arm940t,ep9312,arm10tdmi,arm1020t,arm9e,arm946es,arm966es,arm968es,arm10e,arm1020e,arm1022e,xscale,iwmmxt,iwmmxt2,arm926ejs,arm1026ejs,arm1136js,arm1136jfs,arm1176jzs,arm1176jzfs,mpcorenovfp,mpcore,arm1156t2s,arm1156t2fs,cortexa5,cortexa8,cortexa9,cortexr4,cortexr4f,cortexm4,cortexm3,cortexm1,cortexm0" (const (symbol_ref "((enum attr_tune) arm_tune)"))) diff --git a/gcc/config/arm/arm.c b/gcc/config/arm/arm.c index 6c886dccaef..9cb272c323e 100644 --- a/gcc/config/arm/arm.c +++ b/gcc/config/arm/arm.c @@ -45,7 +45,7 @@ #include "cgraph.h" #include "ggc.h" #include "except.h" -#include "c-pragma.h" +#include "c-family/c-pragma.h" /* ??? */ #include "integrate.h" #include "tm_p.h" #include "target.h" @@ -83,6 +83,9 @@ static int const_ok_for_op (HOST_WIDE_INT, enum rtx_code); static rtx emit_sfm (int, int); static unsigned arm_size_return_regs (void); static bool arm_assemble_integer (rtx, unsigned int, int); +static void arm_print_operand (FILE *, rtx, int); +static void arm_print_operand_address (FILE *, rtx); +static bool arm_print_operand_punct_valid_p (unsigned char code); static const char *fp_const_from_val (REAL_VALUE_TYPE *); static arm_cc get_arm_condition_code (rtx); static HOST_WIDE_INT int_log2 (HOST_WIDE_INT); @@ -285,6 +288,13 @@ static const struct attribute_spec arm_attribute_table[] = #undef TARGET_ASM_INTEGER #define TARGET_ASM_INTEGER arm_assemble_integer +#undef TARGET_PRINT_OPERAND +#define TARGET_PRINT_OPERAND arm_print_operand +#undef TARGET_PRINT_OPERAND_ADDRESS +#define TARGET_PRINT_OPERAND_ADDRESS arm_print_operand_address +#undef TARGET_PRINT_OPERAND_PUNCT_VALID_P +#define TARGET_PRINT_OPERAND_PUNCT_VALID_P arm_print_operand_punct_valid_p + #undef TARGET_ASM_FUNCTION_PROLOGUE #define TARGET_ASM_FUNCTION_PROLOGUE arm_output_function_prologue @@ -424,8 +434,8 @@ static const struct attribute_spec arm_attribute_table[] = #define TARGET_MUST_PASS_IN_STACK arm_must_pass_in_stack #ifdef TARGET_UNWIND_INFO -#undef TARGET_UNWIND_EMIT -#define TARGET_UNWIND_EMIT arm_unwind_emit +#undef TARGET_ASM_UNWIND_EMIT +#define TARGET_ASM_UNWIND_EMIT arm_unwind_emit /* EABI unwinding tables use a different format for the typeinfo tables. */ #undef TARGET_ASM_TTYPE @@ -527,9 +537,6 @@ enum processor_type arm_tune = arm_none; /* The current tuning set. */ const struct tune_params *current_tune; -/* The default processor used if not overridden by commandline. */ -static enum processor_type arm_default_cpu = arm_none; - /* Which floating point hardware to schedule for. */ int arm_fpu_attr; @@ -585,6 +592,10 @@ static int thumb_call_reg_needed; #define FL_IWMMXT (1 << 29) /* XScale v2 or "Intel Wireless MMX technology". */ +/* Flags that only effect tuning, not available instructions. */ +#define FL_TUNE (FL_WBUF | FL_VFPV2 | FL_STRONG | FL_LDSCHED \ + | FL_CO_PROC) + #define FL_FOR_ARCH2 FL_NOTM #define FL_FOR_ARCH3 (FL_FOR_ARCH2 | FL_MODE32) #define FL_FOR_ARCH3M (FL_FOR_ARCH3 | FL_ARCH3M) @@ -687,9 +698,9 @@ int arm_arch_thumb2; /* Nonzero if chip supports integer division instruction. */ int arm_arch_hwdiv; -/* In case of a PRE_INC, POST_INC, PRE_DEC, POST_DEC memory reference, we - must report the mode of the memory reference from PRINT_OPERAND to - PRINT_OPERAND_ADDRESS. */ +/* In case of a PRE_INC, POST_INC, PRE_DEC, POST_DEC memory reference, + we must report the mode of the memory reference from + TARGET_PRINT_OPERAND to TARGET_PRINT_OPERAND_ADDRESS. */ enum machine_mode output_memory_reference_mode; /* The register number to be used for the PIC offset register. */ @@ -770,7 +781,7 @@ static const struct processors all_cores[] = { /* ARM Cores */ #define ARM_CORE(NAME, IDENT, ARCH, FLAGS, COSTS) \ - {NAME, arm_none, #ARCH, FLAGS | FL_FOR_ARCH##ARCH, &arm_##COSTS##_tune}, + {NAME, IDENT, #ARCH, FLAGS | FL_FOR_ARCH##ARCH, &arm_##COSTS##_tune}, #include "arm-cores.def" #undef ARM_CORE {NULL, arm_none, NULL, 0, NULL} @@ -805,36 +816,19 @@ static const struct processors all_architectures[] = {"armv7-a", cortexa8, "7A", FL_CO_PROC | FL_FOR_ARCH7A, NULL}, {"armv7-r", cortexr4, "7R", FL_CO_PROC | FL_FOR_ARCH7R, NULL}, {"armv7-m", cortexm3, "7M", FL_CO_PROC | FL_FOR_ARCH7M, NULL}, - {"armv7e-m", cortexm3, "7EM", FL_CO_PROC | FL_FOR_ARCH7EM, NULL}, + {"armv7e-m", cortexm4, "7EM", FL_CO_PROC | FL_FOR_ARCH7EM, NULL}, {"ep9312", ep9312, "4T", FL_LDSCHED | FL_CIRRUS | FL_FOR_ARCH4, NULL}, {"iwmmxt", iwmmxt, "5TE", FL_LDSCHED | FL_STRONG | FL_FOR_ARCH5TE | FL_XSCALE | FL_IWMMXT , NULL}, {"iwmmxt2", iwmmxt2, "5TE", FL_LDSCHED | FL_STRONG | FL_FOR_ARCH5TE | FL_XSCALE | FL_IWMMXT , NULL}, {NULL, arm_none, NULL, 0 , NULL} }; -struct arm_cpu_select -{ - const char * string; - const char * name; - const struct processors * processors; -}; - -/* This is a magic structure. The 'string' field is magically filled in - with a pointer to the value specified by the user on the command line - assuming that the user has specified such a value. */ - -static struct arm_cpu_select arm_select[] = -{ - /* string name processors */ - { NULL, "-mcpu=", all_cores }, - { NULL, "-march=", all_architectures }, - { NULL, "-mtune=", all_cores } -}; -/* Defines representing the indexes into the above table. */ -#define ARM_OPT_SET_CPU 0 -#define ARM_OPT_SET_ARCH 1 -#define ARM_OPT_SET_TUNE 2 +/* These are populated as commandline arguments are processed, or NULL + if not specified. */ +static const struct processors *arm_selected_arch; +static const struct processors *arm_selected_cpu; +static const struct processors *arm_selected_tune; /* The name of the preprocessor macro to define for this architecture. */ @@ -1196,6 +1190,24 @@ arm_gimplify_va_arg_expr (tree valist, tree type, gimple_seq *pre_p, return std_gimplify_va_arg_expr (valist, type, pre_p, post_p); } +/* Lookup NAME in SEL. */ + +static const struct processors * +arm_find_cpu (const char *name, const struct processors *sel, const char *desc) +{ + if (!(name && *name)) + return NULL; + + for (; sel->name != NULL; sel++) + { + if (streq (name, sel->name)) + return sel; + } + + error ("bad value (%s) for %s switch", name, desc); + return NULL; +} + /* Implement TARGET_HANDLE_OPTION. */ static bool @@ -1204,11 +1216,11 @@ arm_handle_option (size_t code, const char *arg, int value ATTRIBUTE_UNUSED) switch (code) { case OPT_march_: - arm_select[1].string = arg; + arm_selected_arch = arm_find_cpu(arg, all_architectures, "-march"); return true; case OPT_mcpu_: - arm_select[0].string = arg; + arm_selected_cpu = arm_find_cpu(arg, all_cores, "-mcpu"); return true; case OPT_mhard_float: @@ -1220,7 +1232,7 @@ arm_handle_option (size_t code, const char *arg, int value ATTRIBUTE_UNUSED) return true; case OPT_mtune_: - arm_select[2].string = arg; + arm_selected_tune = arm_find_cpu(arg, all_cores, "-mtune"); return true; default: @@ -1320,88 +1332,52 @@ void arm_override_options (void) { unsigned i; - enum processor_type target_arch_cpu = arm_none; - enum processor_type selected_cpu = arm_none; - /* Set up the flags based on the cpu/architecture selected by the user. */ - for (i = ARRAY_SIZE (arm_select); i--;) + if (arm_selected_arch) { - struct arm_cpu_select * ptr = arm_select + i; - - if (ptr->string != NULL && ptr->string[0] != '\0') - { - const struct processors * sel; - - for (sel = ptr->processors; sel->name != NULL; sel++) - if (streq (ptr->string, sel->name)) - { - /* Set the architecture define. */ - if (i != ARM_OPT_SET_TUNE) - sprintf (arm_arch_name, "__ARM_ARCH_%s__", sel->arch); - - /* Determine the processor core for which we should - tune code-generation. */ - if (/* -mcpu= is a sensible default. */ - i == ARM_OPT_SET_CPU - /* -mtune= overrides -mcpu= and -march=. */ - || i == ARM_OPT_SET_TUNE) - arm_tune = (enum processor_type) (sel - ptr->processors); - - /* Remember the CPU associated with this architecture. - If no other option is used to set the CPU type, - we'll use this to guess the most suitable tuning - options. */ - if (i == ARM_OPT_SET_ARCH) - target_arch_cpu = sel->core; - - if (i == ARM_OPT_SET_CPU) - selected_cpu = (enum processor_type) (sel - ptr->processors); - - if (i != ARM_OPT_SET_TUNE) - { - /* If we have been given an architecture and a processor - make sure that they are compatible. We only generate - a warning though, and we prefer the CPU over the - architecture. */ - if (insn_flags != 0 && (insn_flags ^ sel->flags)) - warning (0, "switch -mcpu=%s conflicts with -march= switch", - ptr->string); - - insn_flags = sel->flags; - } - - break; - } - - if (sel->name == NULL) - error ("bad value (%s) for %s switch", ptr->string, ptr->name); - } + if (arm_selected_cpu) + { + /* Check for conflict between mcpu and march. */ + if ((arm_selected_cpu->flags ^ arm_selected_arch->flags) & ~FL_TUNE) + { + warning (0, "switch -mcpu=%s conflicts with -march=%s switch", + arm_selected_cpu->name, arm_selected_arch->name); + /* -march wins for code generation. + -mcpu wins for default tuning. */ + if (!arm_selected_tune) + arm_selected_tune = arm_selected_cpu; + + arm_selected_cpu = arm_selected_arch; + } + else + /* -mcpu wins. */ + arm_selected_arch = NULL; + } + else + /* Pick a CPU based on the architecture. */ + arm_selected_cpu = arm_selected_arch; } - /* Guess the tuning options from the architecture if necessary. */ - if (arm_tune == arm_none) - arm_tune = target_arch_cpu; - /* If the user did not specify a processor, choose one for them. */ - if (insn_flags == 0) + if (!arm_selected_cpu) { const struct processors * sel; unsigned int sought; - selected_cpu = (enum processor_type) TARGET_CPU_DEFAULT; - if (selected_cpu == arm_none) + arm_selected_cpu = &all_cores[TARGET_CPU_DEFAULT]; + if (!arm_selected_cpu->name) { #ifdef SUBTARGET_CPU_DEFAULT /* Use the subtarget default CPU if none was specified by configure. */ - selected_cpu = (enum processor_type) SUBTARGET_CPU_DEFAULT; + arm_selected_cpu = &all_cores[SUBTARGET_CPU_DEFAULT]; #endif /* Default to ARM6. */ - if (selected_cpu == arm_none) - selected_cpu = arm6; + if (arm_selected_cpu->name) + arm_selected_cpu = &all_cores[arm6]; } - sel = &all_cores[selected_cpu]; + sel = arm_selected_cpu; insn_flags = sel->flags; /* Now check to see if the user has specified some command line @@ -1462,20 +1438,21 @@ arm_override_options (void) sel = best_fit; } - insn_flags = sel->flags; + arm_selected_cpu = sel; } - sprintf (arm_arch_name, "__ARM_ARCH_%s__", sel->arch); - arm_default_cpu = (enum processor_type) (sel - all_cores); - if (arm_tune == arm_none) - arm_tune = arm_default_cpu; } - /* The processor for which we should tune should now have been - chosen. */ - gcc_assert (arm_tune != arm_none); + gcc_assert (arm_selected_cpu); + /* The selected cpu may be an architecture, so lookup tuning by core ID. */ + if (!arm_selected_tune) + arm_selected_tune = &all_cores[arm_selected_cpu->core]; - tune_flags = all_cores[(int)arm_tune].flags; - current_tune = all_cores[(int)arm_tune].tune; + sprintf (arm_arch_name, "__ARM_ARCH_%s__", arm_selected_cpu->arch); + insn_flags = arm_selected_cpu->flags; + + arm_tune = arm_selected_tune->core; + tune_flags = arm_selected_tune->flags; + current_tune = arm_selected_tune->tune; if (target_fp16_format_name) { @@ -1858,7 +1835,7 @@ arm_override_options (void) /* Enable -mfix-cortex-m3-ldrd by default for Cortex-M3 cores. */ if (fix_cm3_ldrd == 2) { - if (selected_cpu == cortexm3) + if (arm_selected_cpu->core == cortexm3) fix_cm3_ldrd = 1; else fix_cm3_ldrd = 0; @@ -3854,7 +3831,18 @@ static bool use_vfp_abi (enum arm_pcs pcs_variant, bool is_double) { if (pcs_variant == ARM_PCS_AAPCS_VFP) - return true; + { + static bool seen_thumb1_vfp = false; + + if (TARGET_THUMB1 && !seen_thumb1_vfp) + { + sorry ("Thumb-1 hard-float VFP ABI"); + /* sorry() is not immediately fatal, so only display this once. */ + seen_thumb1_vfp = true; + } + + return true; + } if (pcs_variant != ARM_PCS_AAPCS_LOCAL) return false; @@ -6410,23 +6398,6 @@ arm_rtx_costs_1 (rtx x, enum rtx_code outer, int* total, bool speed) return true; case MINUS: - if (TARGET_THUMB2) - { - if (GET_MODE_CLASS (mode) == MODE_FLOAT) - { - if (TARGET_HARD_FLOAT && (mode == SFmode || mode == DFmode)) - *total = COSTS_N_INSNS (1); - else - *total = COSTS_N_INSNS (20); - } - else - *total = COSTS_N_INSNS (ARM_NUM_REGS (mode)); - /* Thumb2 does not have RSB, so all arguments must be - registers (subtracting a constant is canonicalized as - addition of the negated constant). */ - return false; - } - if (mode == DImode) { *total = COSTS_N_INSNS (ARM_NUM_REGS (mode)); @@ -11471,6 +11442,60 @@ note_invalid_constants (rtx insn, HOST_WIDE_INT address, int do_pushes) return result; } +/* Convert instructions to their cc-clobbering variant if possible, since + that allows us to use smaller encodings. */ + +static void +thumb2_reorg (void) +{ + basic_block bb; + regset_head live; + + INIT_REG_SET (&live); + + /* We are freeing block_for_insn in the toplev to keep compatibility + with old MDEP_REORGS that are not CFG based. Recompute it now. */ + compute_bb_for_insn (); + df_analyze (); + + FOR_EACH_BB (bb) + { + rtx insn; + COPY_REG_SET (&live, DF_LR_OUT (bb)); + df_simulate_initialize_backwards (bb, &live); + FOR_BB_INSNS_REVERSE (bb, insn) + { + if (NONJUMP_INSN_P (insn) + && !REGNO_REG_SET_P (&live, CC_REGNUM)) + { + rtx pat = PATTERN (insn); + if (GET_CODE (pat) == SET + && low_register_operand (XEXP (pat, 0), SImode) + && thumb_16bit_operator (XEXP (pat, 1), SImode) + && low_register_operand (XEXP (XEXP (pat, 1), 0), SImode) + && low_register_operand (XEXP (XEXP (pat, 1), 1), SImode)) + { + rtx dst = XEXP (pat, 0); + rtx src = XEXP (pat, 1); + rtx op0 = XEXP (src, 0); + if (rtx_equal_p (dst, op0) + || GET_CODE (src) == PLUS || GET_CODE (src) == MINUS) + { + rtx ccreg = gen_rtx_REG (CCmode, CC_REGNUM); + rtx clobber = gen_rtx_CLOBBER (VOIDmode, ccreg); + rtvec vec = gen_rtvec (2, pat, clobber); + PATTERN (insn) = gen_rtx_PARALLEL (VOIDmode, vec); + INSN_CODE (insn) = -1; + } + } + } + if (NONDEBUG_INSN_P (insn)) + df_simulate_one_insn_backwards (bb, insn, &live); + } + } + CLEAR_REG_SET (&live); +} + /* Gcc puts the pool in the wrong place for ARM, since we can only load addresses a limited distance around the pc. We do some special munging to move the constant pool values to the correct @@ -11482,6 +11507,9 @@ arm_reorg (void) HOST_WIDE_INT address = 0; Mfix * fix; + if (TARGET_THUMB2) + thumb2_reorg (); + minipool_fix_head = minipool_fix_tail = NULL; /* The first insn must always be a note, or the code below won't @@ -15064,7 +15092,7 @@ arm_print_condition (FILE *stream) before output. If CODE is 'B' then output a bitwise inverted value of X (a const int). If X is a REG and CODE is `M', output a ldm/stm style multi-reg. */ -void +static void arm_print_operand (FILE *stream, rtx x, int code) { switch (code) @@ -15683,6 +15711,140 @@ arm_print_operand (FILE *stream, rtx x, int code) } } +/* Target hook for printing a memory address. */ +static void +arm_print_operand_address (FILE *stream, rtx x) +{ + if (TARGET_32BIT) + { + int is_minus = GET_CODE (x) == MINUS; + + if (GET_CODE (x) == REG) + asm_fprintf (stream, "[%r, #0]", REGNO (x)); + else if (GET_CODE (x) == PLUS || is_minus) + { + rtx base = XEXP (x, 0); + rtx index = XEXP (x, 1); + HOST_WIDE_INT offset = 0; + if (GET_CODE (base) != REG + || (GET_CODE (index) == REG && REGNO (index) == SP_REGNUM)) + { + /* Ensure that BASE is a register. */ + /* (one of them must be). */ + /* Also ensure the SP is not used as in index register. */ + rtx temp = base; + base = index; + index = temp; + } + switch (GET_CODE (index)) + { + case CONST_INT: + offset = INTVAL (index); + if (is_minus) + offset = -offset; + asm_fprintf (stream, "[%r, #%wd]", + REGNO (base), offset); + break; + + case REG: + asm_fprintf (stream, "[%r, %s%r]", + REGNO (base), is_minus ? "-" : "", + REGNO (index)); + break; + + case MULT: + case ASHIFTRT: + case LSHIFTRT: + case ASHIFT: + case ROTATERT: + { + asm_fprintf (stream, "[%r, %s%r", + REGNO (base), is_minus ? "-" : "", + REGNO (XEXP (index, 0))); + arm_print_operand (stream, index, 'S'); + fputs ("]", stream); + break; + } + + default: + gcc_unreachable (); + } + } + else if (GET_CODE (x) == PRE_INC || GET_CODE (x) == POST_INC + || GET_CODE (x) == PRE_DEC || GET_CODE (x) == POST_DEC) + { + extern enum machine_mode output_memory_reference_mode; + + gcc_assert (GET_CODE (XEXP (x, 0)) == REG); + + if (GET_CODE (x) == PRE_DEC || GET_CODE (x) == PRE_INC) + asm_fprintf (stream, "[%r, #%s%d]!", + REGNO (XEXP (x, 0)), + GET_CODE (x) == PRE_DEC ? "-" : "", + GET_MODE_SIZE (output_memory_reference_mode)); + else + asm_fprintf (stream, "[%r], #%s%d", + REGNO (XEXP (x, 0)), + GET_CODE (x) == POST_DEC ? "-" : "", + GET_MODE_SIZE (output_memory_reference_mode)); + } + else if (GET_CODE (x) == PRE_MODIFY) + { + asm_fprintf (stream, "[%r, ", REGNO (XEXP (x, 0))); + if (GET_CODE (XEXP (XEXP (x, 1), 1)) == CONST_INT) + asm_fprintf (stream, "#%wd]!", + INTVAL (XEXP (XEXP (x, 1), 1))); + else + asm_fprintf (stream, "%r]!", + REGNO (XEXP (XEXP (x, 1), 1))); + } + else if (GET_CODE (x) == POST_MODIFY) + { + asm_fprintf (stream, "[%r], ", REGNO (XEXP (x, 0))); + if (GET_CODE (XEXP (XEXP (x, 1), 1)) == CONST_INT) + asm_fprintf (stream, "#%wd", + INTVAL (XEXP (XEXP (x, 1), 1))); + else + asm_fprintf (stream, "%r", + REGNO (XEXP (XEXP (x, 1), 1))); + } + else output_addr_const (stream, x); + } + else + { + if (GET_CODE (x) == REG) + asm_fprintf (stream, "[%r]", REGNO (x)); + else if (GET_CODE (x) == POST_INC) + asm_fprintf (stream, "%r!", REGNO (XEXP (x, 0))); + else if (GET_CODE (x) == PLUS) + { + gcc_assert (GET_CODE (XEXP (x, 0)) == REG); + if (GET_CODE (XEXP (x, 1)) == CONST_INT) + asm_fprintf (stream, "[%r, #%wd]", + REGNO (XEXP (x, 0)), + INTVAL (XEXP (x, 1))); + else + asm_fprintf (stream, "[%r, %r]", + REGNO (XEXP (x, 0)), + REGNO (XEXP (x, 1))); + } + else + output_addr_const (stream, x); + } +} + +/* Target hook for indicating whether a punctuation character for + TARGET_PRINT_OPERAND is valid. */ +static bool +arm_print_operand_punct_valid_p (unsigned char code) +{ + return (code == '@' || code == '|' || code == '.' + || code == '(' || code == ')' || code == '#' + || (TARGET_32BIT && (code == '?')) + || (TARGET_THUMB2 && (code == '!')) + || (TARGET_THUMB && (code == '_'))); +} + /* Target hook for assembling integer objects. The ARM version needs to handle word-sized values specially. */ static bool @@ -19313,7 +19475,7 @@ static struct machine_function * arm_init_machine_status (void) { struct machine_function *machine; - machine = (machine_function *) ggc_alloc_cleared (sizeof (machine_function)); + machine = ggc_alloc_cleared_machine_function (); #if ARM_FT_UNKNOWN != 0 machine->func_type = ARM_FT_UNKNOWN; @@ -20167,13 +20329,10 @@ arm_file_start (void) if (TARGET_BPABI) { const char *fpu_name; - if (arm_select[0].string) - asm_fprintf (asm_out_file, "\t.cpu %s\n", arm_select[0].string); - else if (arm_select[1].string) - asm_fprintf (asm_out_file, "\t.arch %s\n", arm_select[1].string); + if (arm_selected_arch) + asm_fprintf (asm_out_file, "\t.arch %s\n", arm_selected_arch->name); else - asm_fprintf (asm_out_file, "\t.cpu %s\n", - all_cores[arm_default_cpu].name); + asm_fprintf (asm_out_file, "\t.cpu %s\n", arm_selected_cpu->name); if (TARGET_SOFT_FLOAT) { diff --git a/gcc/config/arm/arm.h b/gcc/config/arm/arm.h index cf7089b7bc4..8a2d394725f 100644 --- a/gcc/config/arm/arm.h +++ b/gcc/config/arm/arm.h @@ -1498,17 +1498,6 @@ do { \ /* Offset of first parameter from the argument pointer register value. */ #define FIRST_PARM_OFFSET(FNDECL) (TARGET_ARM ? 4 : 0) -/* Value is the number of byte of arguments automatically - popped when returning from a subroutine call. - FUNDECL is the declaration node of the function (as a tree), - FUNTYPE is the data type of the function (as a tree), - or for a library call it is an identifier node for the subroutine name. - SIZE is the number of bytes of arguments passed on the stack. - - On the ARM, the caller does not pop any of its arguments that were passed - on the stack. */ -#define RETURN_POPS_ARGS(FUNDECL, FUNTYPE, SIZE) 0 - /* Define how to find the value returned by a library function assuming the value has mode MODE. */ #define LIBCALL_VALUE(MODE) \ @@ -2414,17 +2403,6 @@ extern int making_const_table; else if (TARGET_THUMB1) \ thumb1_final_prescan_insn (INSN) -#define PRINT_OPERAND_PUNCT_VALID_P(CODE) \ - (CODE == '@' || CODE == '|' || CODE == '.' \ - || CODE == '(' || CODE == ')' || CODE == '#' \ - || (TARGET_32BIT && (CODE == '?')) \ - || (TARGET_THUMB2 && (CODE == '!')) \ - || (TARGET_THUMB && (CODE == '_'))) - -/* Output an operand of an instruction. */ -#define PRINT_OPERAND(STREAM, X, CODE) \ - arm_print_operand (STREAM, X, CODE) - #define ARM_SIGN_EXTEND(x) ((HOST_WIDE_INT) \ (HOST_BITS_PER_WIDE_INT <= 32 ? (unsigned HOST_WIDE_INT) (x) \ : ((((unsigned HOST_WIDE_INT)(x)) & (unsigned HOST_WIDE_INT) 0xffffffff) |\ @@ -2433,131 +2411,6 @@ extern int making_const_table; & ~ (unsigned HOST_WIDE_INT) 0xffffffff) \ : 0)))) -/* Output the address of an operand. */ -#define ARM_PRINT_OPERAND_ADDRESS(STREAM, X) \ -{ \ - int is_minus = GET_CODE (X) == MINUS; \ - \ - if (GET_CODE (X) == REG) \ - asm_fprintf (STREAM, "[%r, #0]", REGNO (X)); \ - else if (GET_CODE (X) == PLUS || is_minus) \ - { \ - rtx base = XEXP (X, 0); \ - rtx index = XEXP (X, 1); \ - HOST_WIDE_INT offset = 0; \ - if (GET_CODE (base) != REG \ - || (GET_CODE (index) == REG && REGNO (index) == SP_REGNUM)) \ - { \ - /* Ensure that BASE is a register. */ \ - /* (one of them must be). */ \ - /* Also ensure the SP is not used as in index register. */ \ - rtx temp = base; \ - base = index; \ - index = temp; \ - } \ - switch (GET_CODE (index)) \ - { \ - case CONST_INT: \ - offset = INTVAL (index); \ - if (is_minus) \ - offset = -offset; \ - asm_fprintf (STREAM, "[%r, #%wd]", \ - REGNO (base), offset); \ - break; \ - \ - case REG: \ - asm_fprintf (STREAM, "[%r, %s%r]", \ - REGNO (base), is_minus ? "-" : "", \ - REGNO (index)); \ - break; \ - \ - case MULT: \ - case ASHIFTRT: \ - case LSHIFTRT: \ - case ASHIFT: \ - case ROTATERT: \ - { \ - asm_fprintf (STREAM, "[%r, %s%r", \ - REGNO (base), is_minus ? "-" : "", \ - REGNO (XEXP (index, 0))); \ - arm_print_operand (STREAM, index, 'S'); \ - fputs ("]", STREAM); \ - break; \ - } \ - \ - default: \ - gcc_unreachable (); \ - } \ - } \ - else if (GET_CODE (X) == PRE_INC || GET_CODE (X) == POST_INC \ - || GET_CODE (X) == PRE_DEC || GET_CODE (X) == POST_DEC) \ - { \ - extern enum machine_mode output_memory_reference_mode; \ - \ - gcc_assert (GET_CODE (XEXP (X, 0)) == REG); \ - \ - if (GET_CODE (X) == PRE_DEC || GET_CODE (X) == PRE_INC) \ - asm_fprintf (STREAM, "[%r, #%s%d]!", \ - REGNO (XEXP (X, 0)), \ - GET_CODE (X) == PRE_DEC ? "-" : "", \ - GET_MODE_SIZE (output_memory_reference_mode)); \ - else \ - asm_fprintf (STREAM, "[%r], #%s%d", \ - REGNO (XEXP (X, 0)), \ - GET_CODE (X) == POST_DEC ? "-" : "", \ - GET_MODE_SIZE (output_memory_reference_mode)); \ - } \ - else if (GET_CODE (X) == PRE_MODIFY) \ - { \ - asm_fprintf (STREAM, "[%r, ", REGNO (XEXP (X, 0))); \ - if (GET_CODE (XEXP (XEXP (X, 1), 1)) == CONST_INT) \ - asm_fprintf (STREAM, "#%wd]!", \ - INTVAL (XEXP (XEXP (X, 1), 1))); \ - else \ - asm_fprintf (STREAM, "%r]!", \ - REGNO (XEXP (XEXP (X, 1), 1))); \ - } \ - else if (GET_CODE (X) == POST_MODIFY) \ - { \ - asm_fprintf (STREAM, "[%r], ", REGNO (XEXP (X, 0))); \ - if (GET_CODE (XEXP (XEXP (X, 1), 1)) == CONST_INT) \ - asm_fprintf (STREAM, "#%wd", \ - INTVAL (XEXP (XEXP (X, 1), 1))); \ - else \ - asm_fprintf (STREAM, "%r", \ - REGNO (XEXP (XEXP (X, 1), 1))); \ - } \ - else output_addr_const (STREAM, X); \ -} - -#define THUMB_PRINT_OPERAND_ADDRESS(STREAM, X) \ -{ \ - if (GET_CODE (X) == REG) \ - asm_fprintf (STREAM, "[%r]", REGNO (X)); \ - else if (GET_CODE (X) == POST_INC) \ - asm_fprintf (STREAM, "%r!", REGNO (XEXP (X, 0))); \ - else if (GET_CODE (X) == PLUS) \ - { \ - gcc_assert (GET_CODE (XEXP (X, 0)) == REG); \ - if (GET_CODE (XEXP (X, 1)) == CONST_INT) \ - asm_fprintf (STREAM, "[%r, #%wd]", \ - REGNO (XEXP (X, 0)), \ - INTVAL (XEXP (X, 1))); \ - else \ - asm_fprintf (STREAM, "[%r, %r]", \ - REGNO (XEXP (X, 0)), \ - REGNO (XEXP (X, 1))); \ - } \ - else \ - output_addr_const (STREAM, X); \ -} - -#define PRINT_OPERAND_ADDRESS(STREAM, X) \ - if (TARGET_32BIT) \ - ARM_PRINT_OPERAND_ADDRESS (STREAM, X) \ - else \ - THUMB_PRINT_OPERAND_ADDRESS (STREAM, X) - #define OUTPUT_ADDR_CONST_EXTRA(file, x, fail) \ if (arm_output_addr_const_extra (file, x) == FALSE) \ goto fail diff --git a/gcc/config/arm/arm.md b/gcc/config/arm/arm.md index 628bd62ae62..725d505ab5c 100644 --- a/gcc/config/arm/arm.md +++ b/gcc/config/arm/arm.md @@ -737,14 +737,14 @@ [(set (reg:CC CC_REGNUM) (compare:CC (match_operand:SI 1 "s_register_operand" "r,r") - (match_operand:SI 2 "arm_addimm_operand" "I,L"))) + (match_operand:SI 2 "arm_addimm_operand" "L,I"))) (set (match_operand:SI 0 "s_register_operand" "=r,r") (plus:SI (match_dup 1) - (match_operand:SI 3 "arm_addimm_operand" "L,I")))] + (match_operand:SI 3 "arm_addimm_operand" "I,L")))] "TARGET_32BIT && INTVAL (operands[2]) == -INTVAL (operands[3])" "@ - sub%.\\t%0, %1, %2 - add%.\\t%0, %1, #%n2" + add%.\\t%0, %1, %3 + sub%.\\t%0, %1, #%n3" [(set_attr "conds" "set")] ) @@ -1422,7 +1422,15 @@ (set_attr "predicable" "yes")] ) -;; Unnamed template to match long long multiply-accumulate (smlal) +(define_expand "maddsidi4" + [(set (match_operand:DI 0 "s_register_operand" "") + (plus:DI + (mult:DI + (sign_extend:DI (match_operand:SI 1 "s_register_operand" "")) + (sign_extend:DI (match_operand:SI 2 "s_register_operand" ""))) + (match_operand:DI 3 "s_register_operand" "")))] + "TARGET_32BIT && arm_arch3m" + "") (define_insn "*mulsidi3adddi" [(set (match_operand:DI 0 "s_register_operand" "=&r") @@ -1518,7 +1526,15 @@ (set_attr "predicable" "yes")] ) -;; Unnamed template to match long long unsigned multiply-accumulate (umlal) +(define_expand "umaddsidi4" + [(set (match_operand:DI 0 "s_register_operand" "") + (plus:DI + (mult:DI + (zero_extend:DI (match_operand:SI 1 "s_register_operand" "")) + (zero_extend:DI (match_operand:SI 2 "s_register_operand" ""))) + (match_operand:DI 3 "s_register_operand" "")))] + "TARGET_32BIT && arm_arch3m" + "") (define_insn "*umulsidi3adddi" [(set (match_operand:DI 0 "s_register_operand" "=&r") @@ -1686,29 +1702,29 @@ (set_attr "predicable" "yes")] ) -(define_insn "*mulhisi3addsi" +(define_insn "maddhisi4" [(set (match_operand:SI 0 "s_register_operand" "=r") - (plus:SI (match_operand:SI 1 "s_register_operand" "r") + (plus:SI (match_operand:SI 3 "s_register_operand" "r") (mult:SI (sign_extend:SI - (match_operand:HI 2 "s_register_operand" "%r")) + (match_operand:HI 1 "s_register_operand" "%r")) (sign_extend:SI - (match_operand:HI 3 "s_register_operand" "r")))))] + (match_operand:HI 2 "s_register_operand" "r")))))] "TARGET_DSP_MULTIPLY" - "smlabb%?\\t%0, %2, %3, %1" + "smlabb%?\\t%0, %1, %2, %3" [(set_attr "insn" "smlaxy") (set_attr "predicable" "yes")] ) -(define_insn "*mulhidi3adddi" +(define_insn "*maddhidi4" [(set (match_operand:DI 0 "s_register_operand" "=r") (plus:DI - (match_operand:DI 1 "s_register_operand" "0") + (match_operand:DI 3 "s_register_operand" "0") (mult:DI (sign_extend:DI - (match_operand:HI 2 "s_register_operand" "%r")) + (match_operand:HI 1 "s_register_operand" "%r")) (sign_extend:DI - (match_operand:HI 3 "s_register_operand" "r")))))] + (match_operand:HI 2 "s_register_operand" "r")))))] "TARGET_DSP_MULTIPLY" - "smlalbb%?\\t%Q0, %R0, %2, %3" + "smlalbb%?\\t%Q0, %R0, %1, %2" [(set_attr "insn" "smlalxy") (set_attr "predicable" "yes")]) diff --git a/gcc/config/arm/constraints.md b/gcc/config/arm/constraints.md index 575d0ac4e9a..6d6c77d4b66 100644 --- a/gcc/config/arm/constraints.md +++ b/gcc/config/arm/constraints.md @@ -31,7 +31,7 @@ ;; The following multi-letter normal constraints have been used: ;; in ARM/Thumb-2 state: Da, Db, Dc, Dn, Dl, DL, Dv, Dy ;; in Thumb-1 state: Pa, Pb -;; in Thumb-2 state: Ps, Pt, Pu, Pv +;; in Thumb-2 state: Ps, Pt, Pu, Pv, Pw, Px ;; The following memory constraints have been used: ;; in ARM/Thumb-2 state: Q, Ut, Uv, Uy, Un, Um, Us @@ -168,6 +168,16 @@ (and (match_code "const_int") (match_test "TARGET_THUMB2 && ival >= -255 && ival <= 0"))) +(define_constraint "Pw" + "@internal In Thumb-2 state a constant in the range -255 to -1" + (and (match_code "const_int") + (match_test "TARGET_THUMB2 && ival >= -255 && ival <= -1"))) + +(define_constraint "Px" + "@internal In Thumb-2 state a constant in the range -7 to -1" + (and (match_code "const_int") + (match_test "TARGET_THUMB2 && ival >= -7 && ival <= -1"))) + (define_constraint "G" "In ARM/Thumb-2 state a valid FPA immediate constant." (and (match_code "const_double") diff --git a/gcc/config/arm/thumb2.md b/gcc/config/arm/thumb2.md index fa325b171e3..398518329e2 100644 --- a/gcc/config/arm/thumb2.md +++ b/gcc/config/arm/thumb2.md @@ -319,8 +319,8 @@ " [(set_attr "length" "8,12,16,8,8") (set_attr "type" "*,*,*,load2,store2") - (set_attr "pool_range" "1020") - (set_attr "neg_pool_range" "0")] + (set_attr "pool_range" "*,*,*,1020,*") + (set_attr "neg_pool_range" "*,*,*,0,*")] ) (define_insn "*thumb2_cmpsi_shiftsi" @@ -1082,29 +1082,6 @@ }" ) -;; Peepholes and insns for 16-bit flag clobbering instructions. -;; The conditional forms of these instructions do not clobber CC. -;; However by the time peepholes are run it is probably too late to do -;; anything useful with this information. -(define_peephole2 - [(set (match_operand:SI 0 "low_register_operand" "") - (match_operator:SI 3 "thumb_16bit_operator" - [(match_operand:SI 1 "low_register_operand" "") - (match_operand:SI 2 "low_register_operand" "")]))] - "TARGET_THUMB2 - && (rtx_equal_p(operands[0], operands[1]) - || GET_CODE(operands[3]) == PLUS - || GET_CODE(operands[3]) == MINUS) - && peep2_regno_dead_p(0, CC_REGNUM)" - [(parallel - [(set (match_dup 0) - (match_op_dup 3 - [(match_dup 1) - (match_dup 2)])) - (clobber (reg:CC CC_REGNUM))])] - "" -) - (define_insn "*thumb2_alusi3_short" [(set (match_operand:SI 0 "s_register_operand" "=l") (match_operator:SI 3 "thumb_16bit_operator" @@ -1254,6 +1231,32 @@ (set_attr "length" "2")] ) +(define_peephole2 + [(set (match_operand:CC 0 "cc_register" "") + (compare:CC (match_operand:SI 1 "low_register_operand" "") + (match_operand:SI 2 "const_int_operand" "")))] + "TARGET_THUMB2 + && peep2_reg_dead_p (1, operands[1]) + && satisfies_constraint_Pw (operands[2])" + [(parallel + [(set (match_dup 0) (compare:CC (match_dup 1) (match_dup 2))) + (set (match_dup 1) (plus:SI (match_dup 1) (match_dup 3)))])] + "operands[3] = GEN_INT (- INTVAL (operands[2]));" +) + +(define_peephole2 + [(match_scratch:SI 3 "l") + (set (match_operand:CC 0 "cc_register" "") + (compare:CC (match_operand:SI 1 "low_register_operand" "") + (match_operand:SI 2 "const_int_operand" "")))] + "TARGET_THUMB2 + && satisfies_constraint_Px (operands[2])" + [(parallel + [(set (match_dup 0) (compare:CC (match_dup 1) (match_dup 2))) + (set (match_dup 3) (plus:SI (match_dup 1) (match_dup 4)))])] + "operands[4] = GEN_INT (- INTVAL (operands[2]));" +) + (define_insn "*thumb2_addsi3_compare0" [(set (reg:CC_NOOV CC_REGNUM) (compare:CC_NOOV @@ -1506,88 +1509,31 @@ (set_attr "predicable" "yes")] ) -(define_insn "*thumb2_tlobits_cbranch" - [(set (pc) - (if_then_else - (match_operator 0 "equality_operator" - [(zero_extract:SI (match_operand:SI 1 "s_register_operand" "l,h,h") - (match_operand:SI 2 "const_int_operand" "i,Pu,i") - (const_int 0)) - (const_int 0)]) - (label_ref (match_operand 3 "" "")) - (pc))) - (clobber (match_scratch:SI 4 "=l,X,r")) - (clobber (reg:CC CC_REGNUM))] - "TARGET_THUMB2" - "* - { - if (which_alternative == 0) - { - rtx op[3]; - op[0] = operands[4]; - op[1] = operands[1]; - op[2] = GEN_INT (32 - INTVAL (operands[2])); - - output_asm_insn (\"lsls\\t%0, %1, %2\", op); - switch (get_attr_length (insn)) - { - case 4: return \"b%d0\\t%l3\"; - case 6: return \"b%D0\\t.LCB%=\;b\\t%l3\\t%@long jump\\n.LCB%=:\"; - default: return \"b%D0\\t.LCB%=\;bl\\t%l3\\t%@far jump\\n.LCB%=:\"; - } - } - else - { - rtx op[3]; - - if (which_alternative == 1) - { - op[0] = operands[1]; - op[1] = GEN_INT ((1 << INTVAL (operands[2])) - 1); - output_asm_insn (\"tst\\t%0, %1\", op); - } - else - { - op[0] = operands[4]; - op[1] = operands[1]; - op[2] = GEN_INT (32 - INTVAL (operands[2])); - output_asm_insn (\"lsls\\t%0, %1, %2\", op); - } +(define_peephole2 + [(set (match_operand:CC_NOOV 0 "cc_register" "") + (compare:CC_NOOV (zero_extract:SI + (match_operand:SI 1 "low_register_operand" "") + (const_int 1) + (match_operand:SI 2 "const_int_operand" "")) + (const_int 0))) + (match_scratch:SI 3 "l") + (set (pc) + (if_then_else (match_operator:CC_NOOV 4 "equality_operator" + [(match_dup 0) (const_int 0)]) + (match_operand 5 "" "") + (match_operand 6 "" "")))] + "TARGET_THUMB2 + && (INTVAL (operands[2]) >= 0 && INTVAL (operands[2]) < 32)" + [(parallel [(set (match_dup 0) + (compare:CC_NOOV (ashift:SI (match_dup 1) (match_dup 2)) + (const_int 0))) + (clobber (match_dup 3))]) + (set (pc) + (if_then_else (match_op_dup 4 [(match_dup 0) (const_int 0)]) + (match_dup 5) (match_dup 6)))] + " + operands[2] = GEN_INT (31 - INTVAL (operands[2])); + operands[4] = gen_rtx_fmt_ee (GET_CODE (operands[4]) == NE ? LT : GE, + VOIDmode, operands[0], const0_rtx); + ") - switch (get_attr_length (insn)) - { - case 6: return \"b%d0\\t%l3\"; - case 8: return \"b%D0\\t.LCB%=\;b\\t%l3\\t%@long jump\\n.LCB%=:\"; - default: return \"b%D0\\t.LCB%=\;bl\\t%l3\\t%@far jump\\n.LCB%=:\"; - } - } - }" - [(set (attr "far_jump") - (if_then_else - (and (ge (minus (match_dup 3) (pc)) (const_int -2040)) - (le (minus (match_dup 3) (pc)) (const_int 2048))) - (const_string "no") - (const_string "yes"))) - (set (attr "length") - (if_then_else - (eq (symbol_ref ("which_alternative")) - (const_int 0)) - (if_then_else - (and (ge (minus (match_dup 3) (pc)) (const_int -250)) - (le (minus (match_dup 3) (pc)) (const_int 256))) - (const_int 4) - (if_then_else - (and (ge (minus (match_dup 3) (pc)) (const_int -2040)) - (le (minus (match_dup 3) (pc)) (const_int 2048))) - (const_int 6) - (const_int 8))) - (if_then_else - (and (ge (minus (match_dup 3) (pc)) (const_int -250)) - (le (minus (match_dup 3) (pc)) (const_int 256))) - (const_int 6) - (if_then_else - (and (ge (minus (match_dup 3) (pc)) (const_int -2040)) - (le (minus (match_dup 3) (pc)) (const_int 2048))) - (const_int 8) - (const_int 10)))))] -) diff --git a/gcc/config/avr/avr-c.c b/gcc/config/avr/avr-c.c index c2c1dd5d4c3..22724c1de63 100644 --- a/gcc/config/avr/avr-c.c +++ b/gcc/config/avr/avr-c.c @@ -26,7 +26,7 @@ #include "tm_p.h" #include "cpplib.h" #include "tree.h" -#include "c-common.h" +#include "c-family/c-common.h" /* Not included in avr.c since this requires C front end. */ diff --git a/gcc/config/avr/avr.c b/gcc/config/avr/avr.c index d8942c5c081..531a4128bf3 100644 --- a/gcc/config/avr/avr.c +++ b/gcc/config/avr/avr.c @@ -243,8 +243,7 @@ static const enum reg_class reg_class_tab[]={ static struct machine_function * avr_init_machine_status (void) { - return ((struct machine_function *) - ggc_alloc_cleared (sizeof (struct machine_function))); + return ggc_alloc_cleared_machine_function (); } /* Return register class for register R. */ diff --git a/gcc/config/avr/avr.h b/gcc/config/avr/avr.h index 398b412dd91..32ff27eedf4 100644 --- a/gcc/config/avr/avr.h +++ b/gcc/config/avr/avr.h @@ -376,8 +376,6 @@ enum reg_class { for POST_DEC targets (PR27386). */ /*#define PUSH_ROUNDING(NPUSHED) (NPUSHED)*/ -#define RETURN_POPS_ARGS(FUNDECL, FUNTYPE, STACK_SIZE) 0 - #define FUNCTION_ARG(CUM, MODE, TYPE, NAMED) (function_arg (&(CUM), MODE, TYPE, NAMED)) typedef struct avr_args { diff --git a/gcc/config/bfin/bfin.c b/gcc/config/bfin/bfin.c index 152e910ee67..1232ecc7378 100644 --- a/gcc/config/bfin/bfin.c +++ b/gcc/config/bfin/bfin.c @@ -2458,8 +2458,8 @@ bfin_memory_move_cost (enum machine_mode mode ATTRIBUTE_UNUSED, RCLASS requires an extra scratch register. Return the class needed for the scratch register. */ -static enum reg_class -bfin_secondary_reload (bool in_p, rtx x, enum reg_class rclass, +static reg_class_t +bfin_secondary_reload (bool in_p, rtx x, reg_class_t rclass_i, enum machine_mode mode, secondary_reload_info *sri) { /* If we have HImode or QImode, we can only use DREGS as secondary registers; @@ -2467,6 +2467,7 @@ bfin_secondary_reload (bool in_p, rtx x, enum reg_class rclass, enum reg_class default_class = GET_MODE_SIZE (mode) >= 4 ? DPREGS : DREGS; enum reg_class x_class = NO_REGS; enum rtx_code code = GET_CODE (x); + enum reg_class rclass = (enum reg_class) rclass_i; if (code == SUBREG) x = SUBREG_REG (x), code = GET_CODE (x); @@ -2634,11 +2635,7 @@ bfin_handle_option (size_t code, const char *arg, int value) static struct machine_function * bfin_init_machine_status (void) { - struct machine_function *f; - - f = GGC_CNEW (struct machine_function); - - return f; + return ggc_alloc_cleared_machine_function (); } /* Implement the macro OVERRIDE_OPTIONS. */ diff --git a/gcc/config/bfin/bfin.h b/gcc/config/bfin/bfin.h index a1bd556003e..367cd96dbc8 100644 --- a/gcc/config/bfin/bfin.h +++ b/gcc/config/bfin/bfin.h @@ -871,8 +871,6 @@ typedef struct { #define FUNCTION_ARG_ADVANCE(CUM, MODE, TYPE, NAMED) \ (function_arg_advance (&CUM, MODE, TYPE, NAMED)) -#define RETURN_POPS_ARGS(FDECL, FUNTYPE, STKSIZE) 0 - /* Define how to find the value returned by a function. VALTYPE is the data type of the value (as a tree). If the precise function being called is known, FUNC is its FUNCTION_DECL; diff --git a/gcc/config/cris/cris-protos.h b/gcc/config/cris/cris-protos.h index 721c90ff887..c819c790d19 100644 --- a/gcc/config/cris/cris-protos.h +++ b/gcc/config/cris/cris-protos.h @@ -33,8 +33,6 @@ extern void cris_notice_update_cc (rtx, rtx); extern bool cris_reload_address_legitimized (rtx, enum machine_mode, int, int, int); extern int cris_register_move_cost (enum machine_mode, enum reg_class, enum reg_class); -extern void cris_print_operand (FILE *, rtx, int); -extern void cris_print_operand_address (FILE *, rtx); extern int cris_side_effect_mode_ok (enum rtx_code, rtx *, int, int, int, int, int); extern bool cris_cc0_user_requires_cmp (rtx); diff --git a/gcc/config/cris/cris.c b/gcc/config/cris/cris.c index 62ee7d0c330..05736c76165 100644 --- a/gcc/config/cris/cris.c +++ b/gcc/config/cris/cris.c @@ -108,6 +108,12 @@ static void cris_operand_lossage (const char *, rtx); static int cris_reg_saved_in_regsave_area (unsigned int, bool); +static void cris_print_operand (FILE *, rtx, int); + +static void cris_print_operand_address (FILE *, rtx); + +static bool cris_print_operand_punct_valid_p (unsigned char code); + static void cris_asm_output_mi_thunk (FILE *, tree, HOST_WIDE_INT, HOST_WIDE_INT, tree); @@ -158,6 +164,13 @@ int cris_cpu_version = CRIS_DEFAULT_CPU_VERSION; #undef TARGET_ASM_UNALIGNED_DI_OP #define TARGET_ASM_UNALIGNED_DI_OP TARGET_ASM_ALIGNED_DI_OP +#undef TARGET_PRINT_OPERAND +#define TARGET_PRINT_OPERAND cris_print_operand +#undef TARGET_PRINT_OPERAND_ADDRESS +#define TARGET_PRINT_OPERAND_ADDRESS cris_print_operand_address +#undef TARGET_PRINT_OPERAND_PUNCT_VALID_P +#define TARGET_PRINT_OPERAND_PUNCT_VALID_P cris_print_operand_punct_valid_p + #undef TARGET_ASM_OUTPUT_MI_THUNK #define TARGET_ASM_OUTPUT_MI_THUNK cris_asm_output_mi_thunk #undef TARGET_ASM_CAN_OUTPUT_MI_THUNK @@ -687,7 +700,7 @@ saved_regs_mentioned (rtx x) /* The PRINT_OPERAND worker. */ -void +static void cris_print_operand (FILE *file, rtx x, int code) { rtx operand = x; @@ -1114,9 +1127,15 @@ cris_print_operand (FILE *file, rtx x, int code) } } +static bool +cris_print_operand_punct_valid_p (unsigned char code) +{ + return (code == '#' || code == '!' || code == ':'); +} + /* The PRINT_OPERAND_ADDRESS worker. */ -void +static void cris_print_operand_address (FILE *file, rtx x) { /* All these were inside MEM:s so output indirection characters. */ @@ -2552,8 +2571,8 @@ cris_file_start (void) { /* These expressions can vary at run time, so we cannot put them into TARGET_INITIALIZER. */ - targetm.file_start_app_off = !(TARGET_PDEBUG || flag_print_asm_name); - targetm.file_start_file_directive = TARGET_ELF; + targetm.asm_file_start_app_off = !(TARGET_PDEBUG || flag_print_asm_name); + targetm.asm_file_start_file_directive = TARGET_ELF; default_file_start (); } @@ -2583,7 +2602,7 @@ cris_init_expanders (void) static struct machine_function * cris_init_machine_status (void) { - return GGC_CNEW (struct machine_function); + return ggc_alloc_cleared_machine_function (); } /* Split a 2 word move (DI or presumably DF) into component parts. diff --git a/gcc/config/cris/cris.h b/gcc/config/cris/cris.h index 3c426b74ae5..4c685489a8c 100644 --- a/gcc/config/cris/cris.h +++ b/gcc/config/cris/cris.h @@ -859,8 +859,6 @@ enum reg_class #define ACCUMULATE_OUTGOING_ARGS 1 -#define RETURN_POPS_ARGS(FUNDECL, FUNTYPE, STACKSIZE) 0 - /* Node: Register Arguments */ @@ -1253,16 +1251,6 @@ enum cris_pic_symbol_type #define ADDITIONAL_REGISTER_NAMES \ {{"r14", 14}, {"r15", 15}, {"pc", 15}} -#define PRINT_OPERAND(FILE, X, CODE) \ - cris_print_operand (FILE, X, CODE) - -/* For delay-slot handling. */ -#define PRINT_OPERAND_PUNCT_VALID_P(CODE) \ - ((CODE) == '#' || (CODE) == '!' || (CODE) == ':') - -#define PRINT_OPERAND_ADDRESS(FILE, ADDR) \ - cris_print_operand_address (FILE, ADDR) - /* Output an empty line to illustrate the presence of the delay slot. */ #define DBR_OUTPUT_SEQEND(FILE) \ fprintf (FILE, "\n") diff --git a/gcc/config/crx/crx.h b/gcc/config/crx/crx.h index 1d5cb87af3e..a6260f48aa2 100644 --- a/gcc/config/crx/crx.h +++ b/gcc/config/crx/crx.h @@ -313,8 +313,6 @@ enum reg_class #define PUSH_ROUNDING(BYTES) (((BYTES) + 3) & ~3) -#define RETURN_POPS_ARGS(FNDECL, FUNTYPE, SIZE) 0 - #define FUNCTION_ARG(CUM, MODE, TYPE, NAMED) \ ((rtx) crx_function_arg(&(CUM), (MODE), (TYPE), (NAMED))) diff --git a/gcc/config/darwin-c.c b/gcc/config/darwin-c.c index 0e2f8067b4b..6221ab3be1b 100644 --- a/gcc/config/darwin-c.c +++ b/gcc/config/darwin-c.c @@ -25,9 +25,9 @@ along with GCC; see the file COPYING3. If not see #include "tm.h" #include "cpplib.h" #include "tree.h" -#include "c-pragma.h" #include "incpath.h" -#include "c-common.h" +#include "c-family/c-common.h" +#include "c-family/c-pragma.h" #include "toplev.h" #include "flags.h" #include "tm_p.h" diff --git a/gcc/config/darwin-driver.c b/gcc/config/darwin-driver.c index 0997e0a9f03..f66e5a0c21d 100644 --- a/gcc/config/darwin-driver.c +++ b/gcc/config/darwin-driver.c @@ -107,8 +107,7 @@ darwin_default_min_version (int * argc_p, char *** argv_p) if (sysctl (osversion_name, ARRAY_SIZE (osversion_name), osversion, &osversion_len, NULL, 0) == -1) { - warning (0, "sysctl for kern.osversion failed: %s", - xstrerror (errno)); + warning (0, "sysctl for kern.osversion failed: %m"); return; } @@ -151,7 +150,7 @@ darwin_default_min_version (int * argc_p, char *** argv_p) return; parse_failed: - warning (0, "couldn't understand kern.osversion `%.*s'", + warning (0, "couldn't understand kern.osversion %q.*s", (int) osversion_len, osversion); return; } diff --git a/gcc/config/darwin-protos.h b/gcc/config/darwin-protos.h index 5886f0158a6..115349a64cb 100644 --- a/gcc/config/darwin-protos.h +++ b/gcc/config/darwin-protos.h @@ -87,6 +87,8 @@ extern void darwin_asm_output_dwarf_delta (FILE *, int, const char *, const char *); extern void darwin_asm_output_dwarf_offset (FILE *, int, const char *, section *); +extern void darwin_asm_declare_constant_name (FILE *, const char *, + const_tree, HOST_WIDE_INT); extern bool darwin_binds_local_p (const_tree); extern void darwin_cpp_builtins (struct cpp_reader *); extern void darwin_asm_output_anchor (rtx symbol); diff --git a/gcc/config/darwin.c b/gcc/config/darwin.c index 9a9dde160c5..5801e431dfd 100644 --- a/gcc/config/darwin.c +++ b/gcc/config/darwin.c @@ -429,7 +429,7 @@ machopic_indirection_name (rtx sym_ref, bool stub_p) } else { - p = (machopic_indirection *) ggc_alloc (sizeof (machopic_indirection)); + p = ggc_alloc_machopic_indirection (); p->symbol = sym_ref; p->ptr_name = xstrdup (buffer); p->stub_p = stub_p; @@ -966,7 +966,7 @@ machopic_output_indirection (void **slot, void *data) { switch_to_section (data_section); assemble_align (GET_MODE_ALIGNMENT (Pmode)); - assemble_label (ptr_name); + assemble_label (asm_out_file, ptr_name); assemble_integer (gen_rtx_SYMBOL_REF (Pmode, sym_name), GET_MODE_SIZE (Pmode), GET_MODE_ALIGNMENT (Pmode), 1); @@ -1617,6 +1617,20 @@ darwin_non_lazy_pcrel (FILE *file, rtx addr) fputs ("-.", file); } +/* The implementation of ASM_DECLARE_CONSTANT_NAME. */ + +void +darwin_asm_declare_constant_name (FILE *file, const char *name, + const_tree exp ATTRIBUTE_UNUSED, + HOST_WIDE_INT size) +{ + assemble_label (file, name); + + /* Darwin doesn't support zero-size objects, so give them a byte. */ + if ((size) == 0) + assemble_zeros (1); +} + /* Emit an assembler directive to set visibility for a symbol. The only supported visibilities are VISIBILITY_DEFAULT and VISIBILITY_HIDDEN; the latter corresponds to Darwin's "private @@ -1850,7 +1864,7 @@ darwin_override_options (void) /* Disable -freorder-blocks-and-partition for darwin_emit_unwind_label. */ if (flag_reorder_blocks_and_partition - && (targetm.asm_out.unwind_label == darwin_emit_unwind_label)) + && (targetm.asm_out.emit_unwind_label == darwin_emit_unwind_label)) { inform (input_location, "-freorder-blocks-and-partition does not work with exceptions " diff --git a/gcc/config/darwin.h b/gcc/config/darwin.h index 149ef4a6972..a1e805c6d5b 100644 --- a/gcc/config/darwin.h +++ b/gcc/config/darwin.h @@ -652,14 +652,8 @@ extern GTY(()) int darwin_ms_struct; ASM_OUTPUT_LABEL (FILE, xname); \ } while (0) -#define ASM_DECLARE_CONSTANT_NAME(FILE, NAME, EXP, SIZE) \ - do { \ - ASM_OUTPUT_LABEL (FILE, NAME); \ - /* Darwin doesn't support zero-size objects, so give them a \ - byte. */ \ - if ((SIZE) == 0) \ - assemble_zeros (1); \ - } while (0) +#undef TARGET_ASM_DECLARE_CONSTANT_NAME +#define TARGET_ASM_DECLARE_CONSTANT_NAME darwin_asm_declare_constant_name /* Wrap new method names in quotes so the assembler doesn't gag. Make Objective-C internal symbols local and in doing this, we need diff --git a/gcc/config/fr30/fr30.h b/gcc/config/fr30/fr30.h index 5e6237895b5..ed675b16e6a 100644 --- a/gcc/config/fr30/fr30.h +++ b/gcc/config/fr30/fr30.h @@ -568,41 +568,6 @@ enum reg_class proper. */ #define ACCUMULATE_OUTGOING_ARGS 1 -/* A C expression that should indicate the number of bytes of its own arguments - that a function pops on returning, or 0 if the function pops no arguments - and the caller must therefore pop them all after the function returns. - - FUNDECL is a C variable whose value is a tree node that describes the - function in question. Normally it is a node of type `FUNCTION_DECL' that - describes the declaration of the function. From this it is possible to - obtain the DECL_ATTRIBUTES of the function. - - FUNTYPE is a C variable whose value is a tree node that describes the - function in question. Normally it is a node of type `FUNCTION_TYPE' that - describes the data type of the function. From this it is possible to obtain - the data types of the value and arguments (if known). - - When a call to a library function is being considered, FUNTYPE will contain - an identifier node for the library function. Thus, if you need to - distinguish among various library functions, you can do so by their names. - Note that "library function" in this context means a function used to - perform arithmetic, whose name is known specially in the compiler and was - not mentioned in the C code being compiled. - - STACK-SIZE is the number of bytes of arguments passed on the stack. If a - variable number of bytes is passed, it is zero, and argument popping will - always be the responsibility of the calling function. - - On the VAX, all functions always pop their arguments, so the definition of - this macro is STACK-SIZE. On the 68000, using the standard calling - convention, no functions pop their arguments, so the value of the macro is - always 0 in this case. But an alternative calling convention is available - in which functions that take a fixed number of arguments pop them but other - functions (such as `printf') pop nothing (the caller pops all). When this - convention is in use, FUNTYPE is examined to determine whether a function - takes a fixed number of arguments. */ -#define RETURN_POPS_ARGS(FUNDECL, FUNTYPE, STACK_SIZE) 0 - /*}}}*/ /*{{{ Function Arguments in Registers. */ diff --git a/gcc/config/frv/frv-protos.h b/gcc/config/frv/frv-protos.h index 3c9950d740b..11612e49825 100644 --- a/gcc/config/frv/frv-protos.h +++ b/gcc/config/frv/frv-protos.h @@ -73,8 +73,6 @@ extern rtx frv_index_memory (rtx, enum machine_mode, int); extern const char *frv_asm_output_opcode (FILE *, const char *); extern void frv_final_prescan_insn (rtx, rtx *, int); -extern void frv_print_operand (FILE *, rtx, int); -extern void frv_print_operand_address (FILE *, rtx); extern void frv_emit_move (enum machine_mode, rtx, rtx); extern int frv_emit_movsi (rtx, rtx); extern const char *output_move_single (rtx *, rtx); diff --git a/gcc/config/frv/frv.c b/gcc/config/frv/frv.c index d4009693cd8..9454bd25e7b 100644 --- a/gcc/config/frv/frv.c +++ b/gcc/config/frv/frv.c @@ -1,5 +1,5 @@ /* Copyright (C) 1997, 1998, 1999, 2000, 2001, 2003, 2004, 2005, 2006, 2007, - 2008, 2009 Free Software Foundation, Inc. + 2008, 2009, 2010 Free Software Foundation, Inc. Contributed by Red Hat, Inc. This file is part of GCC. @@ -267,6 +267,9 @@ static bool frv_legitimate_address_p (enum machine_mode, rtx, bool); static int frv_default_flags_for_cpu (void); static int frv_string_begins_with (const_tree, const char *); static FRV_INLINE bool frv_small_data_reloc_p (rtx, int); +static void frv_print_operand (FILE *, rtx, int); +static void frv_print_operand_address (FILE *, rtx); +static bool frv_print_operand_punct_valid_p (unsigned char code); static void frv_print_operand_memory_reference_reg (FILE *, rtx); static void frv_print_operand_memory_reference (FILE *, rtx, int); @@ -381,7 +384,7 @@ static int frv_arg_partial_bytes (CUMULATIVE_ARGS *, enum machine_mode, tree, bool); static void frv_output_dwarf_dtprel (FILE *, int, rtx) ATTRIBUTE_UNUSED; -static bool frv_secondary_reload (bool, rtx, enum reg_class, +static reg_class_t frv_secondary_reload (bool, rtx, reg_class_t, enum machine_mode, secondary_reload_info *); static bool frv_frame_pointer_required (void); @@ -396,6 +399,12 @@ static void frv_trampoline_init (rtx, tree, rtx); #endif /* Initialize the GCC target structure. */ +#undef TARGET_PRINT_OPERAND +#define TARGET_PRINT_OPERAND frv_print_operand +#undef TARGET_PRINT_OPERAND_ADDRESS +#define TARGET_PRINT_OPERAND_ADDRESS frv_print_operand_address +#undef TARGET_PRINT_OPERAND_PUNCT_VALID_P +#define TARGET_PRINT_OPERAND_PUNCT_VALID_P frv_print_operand_punct_valid_p #undef TARGET_ASM_FUNCTION_PROLOGUE #define TARGET_ASM_FUNCTION_PROLOGUE frv_function_prologue #undef TARGET_ASM_FUNCTION_EPILOGUE @@ -2562,7 +2571,7 @@ frv_index_memory (rtx memref, enum machine_mode mode, int index) /* Print a memory address as an operand to reference that memory location. */ -void +static void frv_print_operand_address (FILE * stream, rtx x) { if (GET_CODE (x) == MEM) @@ -2795,9 +2804,9 @@ comparison_string (enum rtx_code code, rtx op0) /* Print an operand to an assembler instruction. `%' followed by a letter and a digit says to output an operand in an - alternate fashion. Four letters have standard, built-in meanings described - below. The machine description macro `PRINT_OPERAND' can define additional - letters with nonstandard meanings. + alternate fashion. Four letters have standard, built-in meanings + described below. The hook `TARGET_PRINT_OPERAND' can define + additional letters with nonstandard meanings. `%cDIGIT' can be used to substitute an operand that is a constant value without the syntax that normally indicates an immediate operand. @@ -2818,13 +2827,14 @@ comparison_string (enum rtx_code code, rtx op0) than once in a single template that generates multiple assembler instructions. - `%' followed by a punctuation character specifies a substitution that does - not use an operand. Only one case is standard: `%%' outputs a `%' into the - assembler code. Other nonstandard cases can be defined in the - `PRINT_OPERAND' macro. You must also define which punctuation characters - are valid with the `PRINT_OPERAND_PUNCT_VALID_P' macro. */ + `%' followed by a punctuation character specifies a substitution that + does not use an operand. Only one case is standard: `%%' outputs a + `%' into the assembler code. Other nonstandard cases can be defined + in the `TARGET_PRINT_OPERAND' hook. You must also define which + punctuation characters are valid with the + `TARGET_PRINT_OPERAND_PUNCT_VALID_P' hook. */ -void +static void frv_print_operand (FILE * file, rtx x, int code) { struct frv_unspec unspec; @@ -3115,6 +3125,13 @@ frv_print_operand (FILE * file, rtx x, int code) return; } +static bool +frv_print_operand_punct_valid_p (unsigned char code) +{ + return (code == '.' || code == '#' || code == '@' || code == '~' + || code == '*' || code == '&'); +} + /* A C statement (sans semicolon) for initializing the variable CUM for the state at the beginning of the argument list. The variable has type @@ -3374,11 +3391,11 @@ frv_regno_ok_for_base_p (int regno, int strict_p) legitimate addresses. Normally you would simply recognize any `const' as legitimate. - Usually `PRINT_OPERAND_ADDRESS' is not prepared to handle constant sums that - are not marked with `const'. It assumes that a naked `plus' indicates - indexing. If so, then you *must* reject such naked constant sums as - illegitimate addresses, so that none of them will be given to - `PRINT_OPERAND_ADDRESS'. */ + Usually `TARGET_PRINT_OPERAND_ADDRESS' is not prepared to handle + constant sums that are not marked with `const'. It assumes that a + naked `plus' indicates indexing. If so, then you *must* reject such + naked constant sums as illegitimate addresses, so that none of them + will be given to `TARGET_PRINT_OPERAND_ADDRESS'. */ int frv_legitimate_address_p_1 (enum machine_mode mode, @@ -6475,12 +6492,13 @@ frv_secondary_reload_class (enum reg_class rclass, called from init_reg_autoinc() in regclass.c - before the reload optabs have been initialised. */ -static bool -frv_secondary_reload (bool in_p, rtx x, enum reg_class reload_class, +static reg_class_t +frv_secondary_reload (bool in_p, rtx x, reg_class_t reload_class_i, enum machine_mode reload_mode, secondary_reload_info * sri) { enum reg_class rclass = NO_REGS; + enum reg_class reload_class = (enum reg_class) reload_class_i; if (sri->prev_sri && sri->prev_sri->t_icode != CODE_FOR_nothing) { @@ -7054,7 +7072,7 @@ frv_assemble_integer (rtx value, unsigned int size, int aligned_p) static struct machine_function * frv_init_machine_status (void) { - return GGC_CNEW (struct machine_function); + return ggc_alloc_cleared_machine_function (); } /* Implement TARGET_SCHED_ISSUE_RATE. */ diff --git a/gcc/config/frv/frv.h b/gcc/config/frv/frv.h index d5a7a4a6670..56db4e4a21e 100644 --- a/gcc/config/frv/frv.h +++ b/gcc/config/frv/frv.h @@ -1614,41 +1614,6 @@ typedef struct frv_stack { proper. */ #define ACCUMULATE_OUTGOING_ARGS 1 -/* A C expression that should indicate the number of bytes of its own arguments - that a function pops on returning, or 0 if the function pops no arguments - and the caller must therefore pop them all after the function returns. - - FUNDECL is a C variable whose value is a tree node that describes the - function in question. Normally it is a node of type `FUNCTION_DECL' that - describes the declaration of the function. From this it is possible to - obtain the DECL_ATTRIBUTES of the function. - - FUNTYPE is a C variable whose value is a tree node that describes the - function in question. Normally it is a node of type `FUNCTION_TYPE' that - describes the data type of the function. From this it is possible to obtain - the data types of the value and arguments (if known). - - When a call to a library function is being considered, FUNTYPE will contain - an identifier node for the library function. Thus, if you need to - distinguish among various library functions, you can do so by their names. - Note that "library function" in this context means a function used to - perform arithmetic, whose name is known specially in the compiler and was - not mentioned in the C code being compiled. - - STACK-SIZE is the number of bytes of arguments passed on the stack. If a - variable number of bytes is passed, it is zero, and argument popping will - always be the responsibility of the calling function. - - On the VAX, all functions always pop their arguments, so the definition of - this macro is STACK-SIZE. On the 68000, using the standard calling - convention, no functions pop their arguments, so the value of the macro is - always 0 in this case. But an alternative calling convention is available - in which functions that take a fixed number of arguments pop them but other - functions (such as `printf') pop nothing (the caller pops all). When this - convention is in use, FUNTYPE is examined to determine whether a function - takes a fixed number of arguments. */ -#define RETURN_POPS_ARGS(FUNDECL, FUNTYPE, STACK_SIZE) 0 - /* The number of register assigned to holding function arguments. */ @@ -2325,52 +2290,6 @@ do { \ #define FINAL_PRESCAN_INSN(INSN, OPVEC, NOPERANDS)\ frv_final_prescan_insn (INSN, OPVEC, NOPERANDS) - -/* A C compound statement to output to stdio stream STREAM the assembler syntax - for an instruction operand X. X is an RTL expression. - - CODE is a value that can be used to specify one of several ways of printing - the operand. It is used when identical operands must be printed differently - depending on the context. CODE comes from the `%' specification that was - used to request printing of the operand. If the specification was just - `%DIGIT' then CODE is 0; if the specification was `%LTR DIGIT' then CODE is - the ASCII code for LTR. - - If X is a register, this macro should print the register's name. The names - can be found in an array `reg_names' whose type is `char *[]'. `reg_names' - is initialized from `REGISTER_NAMES'. - - When the machine description has a specification `%PUNCT' (a `%' followed by - a punctuation character), this macro is called with a null pointer for X and - the punctuation character for CODE. */ -#define PRINT_OPERAND(STREAM, X, CODE) frv_print_operand (STREAM, X, CODE) - -/* A C expression which evaluates to true if CODE is a valid punctuation - character for use in the `PRINT_OPERAND' macro. If - `PRINT_OPERAND_PUNCT_VALID_P' is not defined, it means that no punctuation - characters (except for the standard one, `%') are used in this way. */ -/* . == gr0 - # == hint operand -- always zero for now - @ == small data base register (gr16) - ~ == pic register (gr17) - * == temporary integer CCR register (cr3) - & == temporary integer ICC register (icc3) */ -#define PRINT_OPERAND_PUNCT_VALID_P(CODE) \ -((CODE) == '.' || (CODE) == '#' || (CODE) == '@' || (CODE) == '~' \ - || (CODE) == '*' || (CODE) == '&') - -/* A C compound statement to output to stdio stream STREAM the assembler syntax - for an instruction operand that is a memory reference whose address is X. X - is an RTL expression. - - On some machines, the syntax for a symbolic address depends on the section - that the address refers to. On these machines, define the macro - `ENCODE_SECTION_INFO' to store the information into the `symbol_ref', and - then check for it here. - - This declaration must be present. */ -#define PRINT_OPERAND_ADDRESS(STREAM, X) frv_print_operand_address (STREAM, X) - /* If defined, C string expressions to be used for the `%R', `%L', `%U', and `%I' options of `asm_fprintf' (see `final.c'). These are useful when a single `md' file must support multiple assembler formats. In that case, the diff --git a/gcc/config/h8300/h8300.c b/gcc/config/h8300/h8300.c index 4136eb01688..5773fb15b51 100644 --- a/gcc/config/h8300/h8300.c +++ b/gcc/config/h8300/h8300.c @@ -39,7 +39,7 @@ along with GCC; see the file COPYING3. If not see #include "function.h" #include "optabs.h" #include "toplev.h" -#include "c-pragma.h" +#include "c-family/c-pragma.h" /* ??? */ #include "tm_p.h" #include "ggc.h" #include "target.h" diff --git a/gcc/config/h8300/h8300.h b/gcc/config/h8300/h8300.h index 1ce1585544e..4e0a3b6728e 100644 --- a/gcc/config/h8300/h8300.h +++ b/gcc/config/h8300/h8300.h @@ -536,17 +536,6 @@ enum reg_class { #define FIRST_PARM_OFFSET(FNDECL) 0 -/* Value is the number of bytes of arguments automatically - popped when returning from a subroutine call. - FUNDECL is the declaration node of the function (as a tree), - FUNTYPE is the data type of the function (as a tree), - or for a library call it is an identifier node for the subroutine name. - SIZE is the number of bytes of arguments passed on the stack. - - On the H8 the return does not pop anything. */ - -#define RETURN_POPS_ARGS(FUNDECL, FUNTYPE, SIZE) 0 - /* Definitions for register eliminations. This is an array of structures. Each structure initializes one pair diff --git a/gcc/config/i386/atom.md b/gcc/config/i386/atom.md index a9c4c5d0576..1664269bac0 100644 --- a/gcc/config/i386/atom.md +++ b/gcc/config/i386/atom.md @@ -501,9 +501,10 @@ ;; if palignr or psrldq (define_insn_reservation "atom_sseishft_2" 1 (and (eq_attr "cpu" "atom") - (and (eq_attr "type" "sseishft") - (and (eq_attr "atom_unit" "sishuf") - (match_operand 2 "immediate_operand")))) + (ior (eq_attr "type" "sseishft1") + (and (eq_attr "type" "sseishft") + (and (eq_attr "atom_unit" "sishuf") + (match_operand 2 "immediate_operand"))))) "atom-simple-0") ;; if reg/mem op diff --git a/gcc/config/i386/cygming.h b/gcc/config/i386/cygming.h index 7c35e2ee57f..f2b70afa447 100644 --- a/gcc/config/i386/cygming.h +++ b/gcc/config/i386/cygming.h @@ -48,7 +48,7 @@ along with GCC; see the file COPYING3. If not see #undef ASM_GENERATE_INTERNAL_LABEL #define ASM_GENERATE_INTERNAL_LABEL(BUF,PREFIX,NUMBER) \ - sprintf ((BUF), "%s%s%ld", LOCAL_LABEL_PREFIX, \ + sprintf ((BUF), "*%s%s%ld", LOCAL_LABEL_PREFIX, \ (PREFIX), (long)(NUMBER)) #undef LPREFIX diff --git a/gcc/config/i386/i386-c.c b/gcc/config/i386/i386-c.c index b33fc86ea98..1b89a0b428f 100644 --- a/gcc/config/i386/i386-c.c +++ b/gcc/config/i386/i386-c.c @@ -25,12 +25,12 @@ along with GCC; see the file COPYING3. If not see #include "tree.h" #include "tm_p.h" #include "flags.h" -#include "c-common.h" +#include "c-family/c-common.h" #include "ggc.h" #include "target.h" #include "target-def.h" #include "cpplib.h" -#include "c-pragma.h" +#include "c-family/c-pragma.h" static bool ix86_pragma_target_parse (tree, tree); static void ix86_target_macros_internal diff --git a/gcc/config/i386/i386-protos.h b/gcc/config/i386/i386-protos.h index eaff7ab5058..4a0e3062212 100644 --- a/gcc/config/i386/i386-protos.h +++ b/gcc/config/i386/i386-protos.h @@ -60,8 +60,7 @@ extern bool legitimate_pic_operand_p (rtx); extern int legitimate_pic_address_disp_p (rtx); extern void print_reg (rtx, int, FILE*); -extern void print_operand (FILE*, rtx, int); -extern void print_operand_address (FILE*, rtx); +extern void ix86_print_operand (FILE *, rtx, int); extern bool output_addr_const_extra (FILE*, rtx); extern void split_di (rtx[], int, rtx[], rtx[]); @@ -150,15 +149,12 @@ extern void ix86_split_fp_branch (enum rtx_code code, rtx, rtx, rtx, rtx, rtx, rtx); extern bool ix86_hard_regno_mode_ok (int, enum machine_mode); extern bool ix86_modes_tieable_p (enum machine_mode, enum machine_mode); -extern int ix86_register_move_cost (enum machine_mode, enum reg_class, - enum reg_class); extern int ix86_secondary_memory_needed (enum reg_class, enum reg_class, enum machine_mode, int); extern bool ix86_cannot_change_mode_class (enum machine_mode, enum machine_mode, enum reg_class); extern enum reg_class ix86_preferred_reload_class (rtx, enum reg_class); extern enum reg_class ix86_preferred_output_reload_class (rtx, enum reg_class); -extern int ix86_memory_move_cost (enum machine_mode, enum reg_class, int); extern int ix86_mode_needed (int, rtx); extern void emit_i387_cw_initialization (int); extern void x86_order_regs_for_local_alloc (void); @@ -184,16 +180,11 @@ extern void ix86_expand_truncdf_32 (rtx, rtx); #ifdef TREE_CODE extern void init_cumulative_args (CUMULATIVE_ARGS *, tree, rtx, tree); -extern rtx function_arg (CUMULATIVE_ARGS *, enum machine_mode, tree, int); -extern void function_arg_advance (CUMULATIVE_ARGS *, enum machine_mode, - tree, int); #endif /* TREE_CODE */ #endif /* RTX_CODE */ #ifdef TREE_CODE -extern int ix86_return_pops_args (tree, tree, int); - extern int ix86_data_alignment (tree, int); extern unsigned int ix86_local_alignment (tree, enum machine_mode, unsigned int); diff --git a/gcc/config/i386/i386.c b/gcc/config/i386/i386.c index 034c6c52b98..f28e794647c 100644 --- a/gcc/config/i386/i386.c +++ b/gcc/config/i386/i386.c @@ -2691,6 +2691,26 @@ ix86_target_string (int isa, int flags, const char *arch, const char *tune, return ret; } +/* Return TRUE if software prefetching is beneficial for the + given CPU. */ + +static bool +software_prefetching_beneficial_p (void) +{ + switch (ix86_tune) + { + case PROCESSOR_GEODE: + case PROCESSOR_K6: + case PROCESSOR_ATHLON: + case PROCESSOR_K8: + case PROCESSOR_AMDFAM10: + return true; + + default: + return false; + } +} + /* Function that is callable from the debugger to print the current options. */ void @@ -2725,7 +2745,7 @@ override_options (bool main_args_p) { int i; unsigned int ix86_arch_mask, ix86_tune_mask; - const bool ix86_tune_specified = (ix86_tune_string != NULL); + const bool ix86_tune_specified = (ix86_tune_string != NULL); const char *prefix; const char *suffix; const char *sw; @@ -2850,7 +2870,7 @@ override_options (bool main_args_p) {"bdver1", PROCESSOR_BDVER1, CPU_BDVER1, PTA_64BIT | PTA_MMX | PTA_3DNOW | PTA_3DNOW_A | PTA_SSE | PTA_SSE2 | PTA_SSE3 | PTA_SSE4A | PTA_CX16 | PTA_ABM - | PTA_SSSE3 | PTA_SSE4_1 | PTA_SSE4_2 | PTA_AES + | PTA_SSSE3 | PTA_SSE4_1 | PTA_SSE4_2 | PTA_AES | PTA_PCLMUL | PTA_AVX | PTA_FMA4 | PTA_XOP | PTA_LWP}, {"generic32", PROCESSOR_GENERIC32, CPU_PENTIUMPRO, 0 /* flags are only used for -march switch. */ }, @@ -2891,6 +2911,8 @@ override_options (bool main_args_p) in case they weren't overwritten by command line options. */ if (TARGET_64BIT) { + if (flag_zee == 2) + flag_zee = 1; /* Mach-O doesn't support omitting the frame pointer for now. */ if (flag_omit_frame_pointer == 2) flag_omit_frame_pointer = (TARGET_MACHO ? 0 : 1); @@ -2901,6 +2923,8 @@ override_options (bool main_args_p) } else { + if (flag_zee == 2) + flag_zee = 0; if (flag_omit_frame_pointer == 2) flag_omit_frame_pointer = 0; if (flag_asynchronous_unwind_tables == 2) @@ -3531,6 +3555,13 @@ override_options (bool main_args_p) if (!PARAM_SET_P (PARAM_L2_CACHE_SIZE)) set_param_value ("l2-cache-size", ix86_cost->l2_cache_size); + /* Enable sw prefetching at -O3 for CPUS that prefetching is helpful. */ + if (flag_prefetch_loop_arrays < 0 + && HAVE_prefetch + && optimize >= 3 + && software_prefetching_beneficial_p ()) + flag_prefetch_loop_arrays = 1; + /* If using typedef char *va_list, signal that __builtin_va_start (&ap, 0) can be optimized to ap = __builtin_next_arg (0). */ if (!TARGET_64BIT) @@ -4320,13 +4351,13 @@ x86_64_elf_unique_section (tree decl, int reloc) name = IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (decl)); name = targetm.strip_name_encoding (name); - + /* If we're using one_only, then there needs to be a .gnu.linkonce prefix to the section name. */ linkonce = one_only ? ".gnu.linkonce" : ""; - + string = ACONCAT ((linkonce, prefix, ".", name, NULL)); - + DECL_SECTION_NAME (decl) = build_string (strlen (string), string); return; } @@ -4390,10 +4421,6 @@ optimization_options (int level, int size ATTRIBUTE_UNUSED) flag_schedule_insns = 0; #endif - /* For -O2 and beyond, turn on -fzee for x86_64 target. */ - if (level > 1 && TARGET_64BIT) - flag_zee = 1; - if (TARGET_MACHO) /* The Darwin libraries never set errno, so we might as well avoid calling them when that's the only reason we would. */ @@ -4405,6 +4432,11 @@ optimization_options (int level, int size ATTRIBUTE_UNUSED) specifying them, we will set the defaults in override_options. */ if (optimize >= 1) flag_omit_frame_pointer = 2; + + /* For -O2 and beyond, turn on -fzee for x86_64 target. */ + if (level > 1) + flag_zee = 2; + flag_pcc_struct_return = 2; flag_asynchronous_unwind_tables = 2; flag_vect_cost_model = 1; @@ -4833,7 +4865,7 @@ ix86_eax_live_at_start_p (void) The attribute stdcall is equivalent to RTD on a per module basis. */ -int +static int ix86_return_pops_args (tree fundecl, tree funtype, int size) { int rtd; @@ -5148,7 +5180,7 @@ init_cumulative_args (CUMULATIVE_ARGS *cum, /* Argument info to initialize */ NULL. */ static enum machine_mode -type_natural_mode (const_tree type, CUMULATIVE_ARGS *cum) +type_natural_mode (const_tree type, const CUMULATIVE_ARGS *cum) { enum machine_mode mode = TYPE_MODE (type); @@ -5176,7 +5208,7 @@ type_natural_mode (const_tree type, CUMULATIVE_ARGS *cum) static bool warnedavx; if (cum - && !warnedavx + && !warnedavx && cum->warn_avx) { warnedavx = true; @@ -5357,7 +5389,7 @@ classify_argument (enum machine_mode mode, const_tree type, == NULL_TREE)) { static bool warned; - + if (!warned && warn_psabi) { warned = true; @@ -5779,7 +5811,7 @@ construct_container (enum machine_mode mode, enum machine_mode orig_mode, case X86_64_SSESF_CLASS: case X86_64_SSEDF_CLASS: if (mode != BLKmode) - return gen_reg_or_parallel (mode, orig_mode, + return gen_reg_or_parallel (mode, orig_mode, SSE_REGNO (sse_regno)); break; case X86_64_X87_CLASS: @@ -5905,7 +5937,8 @@ construct_container (enum machine_mode mode, enum machine_mode orig_mode, static void function_arg_advance_32 (CUMULATIVE_ARGS *cum, enum machine_mode mode, - tree type, HOST_WIDE_INT bytes, HOST_WIDE_INT words) + const_tree type, HOST_WIDE_INT bytes, + HOST_WIDE_INT words) { switch (mode) { @@ -5993,7 +6026,7 @@ function_arg_advance_32 (CUMULATIVE_ARGS *cum, enum machine_mode mode, static void function_arg_advance_64 (CUMULATIVE_ARGS *cum, enum machine_mode mode, - tree type, HOST_WIDE_INT words, int named) + const_tree type, HOST_WIDE_INT words, bool named) { int int_nregs, sse_nregs; @@ -6029,9 +6062,13 @@ function_arg_advance_ms_64 (CUMULATIVE_ARGS *cum, HOST_WIDE_INT bytes, } } -void -function_arg_advance (CUMULATIVE_ARGS *cum, enum machine_mode mode, - tree type, int named) +/* Update the data in CUM to advance over an argument of mode MODE and + data type TYPE. (TYPE is null for libcalls where that information + may not be available.) */ + +static void +ix86_function_arg_advance (CUMULATIVE_ARGS *cum, enum machine_mode mode, + const_tree type, bool named) { HOST_WIDE_INT bytes, words; @@ -6066,8 +6103,8 @@ function_arg_advance (CUMULATIVE_ARGS *cum, enum machine_mode mode, (otherwise it is an extra parameter matching an ellipsis). */ static rtx -function_arg_32 (CUMULATIVE_ARGS *cum, enum machine_mode mode, - enum machine_mode orig_mode, tree type, +function_arg_32 (const CUMULATIVE_ARGS *cum, enum machine_mode mode, + enum machine_mode orig_mode, const_tree type, HOST_WIDE_INT bytes, HOST_WIDE_INT words) { static bool warnedsse, warnedmmx; @@ -6183,8 +6220,8 @@ function_arg_32 (CUMULATIVE_ARGS *cum, enum machine_mode mode, } static rtx -function_arg_64 (CUMULATIVE_ARGS *cum, enum machine_mode mode, - enum machine_mode orig_mode, tree type, int named) +function_arg_64 (const CUMULATIVE_ARGS *cum, enum machine_mode mode, + enum machine_mode orig_mode, const_tree type, bool named) { /* Handle a hidden AL argument containing number of registers for varargs x86-64 functions. */ @@ -6219,8 +6256,8 @@ function_arg_64 (CUMULATIVE_ARGS *cum, enum machine_mode mode, } static rtx -function_arg_ms_64 (CUMULATIVE_ARGS *cum, enum machine_mode mode, - enum machine_mode orig_mode, int named, +function_arg_ms_64 (const CUMULATIVE_ARGS *cum, enum machine_mode mode, + enum machine_mode orig_mode, bool named, HOST_WIDE_INT bytes) { unsigned int regno; @@ -6266,9 +6303,19 @@ function_arg_ms_64 (CUMULATIVE_ARGS *cum, enum machine_mode mode, return gen_reg_or_parallel (mode, orig_mode, regno); } -rtx -function_arg (CUMULATIVE_ARGS *cum, enum machine_mode omode, - tree type, int named) +/* Return where to put the arguments to a function. + Return zero to push the argument on the stack, or a hard register in which to store the argument. + + MODE is the argument's machine mode. TYPE is the data type of the + argument. It is null for libcalls where that information may not be + available. CUM gives information about the preceding args and about + the function being called. NAMED is nonzero if this argument is a + named parameter (otherwise it is an extra parameter matching an + ellipsis). */ + +static rtx +ix86_function_arg (const CUMULATIVE_ARGS *cum, enum machine_mode omode, + const_tree type, bool named) { enum machine_mode mode = omode; HOST_WIDE_INT bytes, words; @@ -6393,10 +6440,9 @@ ix86_function_arg_boundary (enum machine_mode mode, tree type) int align; if (type) { - /* Since canonical type is used for call, we convert it to - canonical type if needed. */ - if (!TYPE_STRUCTURAL_EQUALITY_P (type)) - type = TYPE_CANONICAL (type); + /* Since the main variant type is used for call, we convert it to + the main variant type. */ + type = TYPE_MAIN_VARIANT (type); align = TYPE_ALIGN (type); } else @@ -6690,7 +6736,7 @@ ix86_return_in_memory (const_tree type, const_tree fntype ATTRIBUTE_UNUSED) return SUBTARGET_RETURN_IN_MEMORY (type, fntype); #else const enum machine_mode mode = type_natural_mode (type, NULL); - + if (TARGET_64BIT) { if (ix86_function_type_abi (fntype) == MS_ABI) @@ -7002,7 +7048,7 @@ ix86_setup_incoming_varargs (CUMULATIVE_ARGS *cum, enum machine_mode mode, For stdargs, we do want to skip the last named argument. */ next_cum = *cum; if (stdarg_p (fntype)) - function_arg_advance (&next_cum, mode, type, 1); + ix86_function_arg_advance (&next_cum, mode, type, true); if (cum->call_abi == MS_ABI) setup_incoming_varargs_ms_64 (&next_cum); @@ -7047,11 +7093,17 @@ ix86_va_start (tree valist, rtx nextarg) f_ovf = TREE_CHAIN (f_fpr); f_sav = TREE_CHAIN (f_ovf); - valist = build1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (valist)), valist); - gpr = build3 (COMPONENT_REF, TREE_TYPE (f_gpr), valist, f_gpr, NULL_TREE); - fpr = build3 (COMPONENT_REF, TREE_TYPE (f_fpr), valist, f_fpr, NULL_TREE); - ovf = build3 (COMPONENT_REF, TREE_TYPE (f_ovf), valist, f_ovf, NULL_TREE); - sav = build3 (COMPONENT_REF, TREE_TYPE (f_sav), valist, f_sav, NULL_TREE); + valist = build_simple_mem_ref (valist); + TREE_TYPE (valist) = TREE_TYPE (sysv_va_list_type_node); + /* The following should be folded into the MEM_REF offset. */ + gpr = build3 (COMPONENT_REF, TREE_TYPE (f_gpr), unshare_expr (valist), + f_gpr, NULL_TREE); + fpr = build3 (COMPONENT_REF, TREE_TYPE (f_fpr), unshare_expr (valist), + f_fpr, NULL_TREE); + ovf = build3 (COMPONENT_REF, TREE_TYPE (f_ovf), unshare_expr (valist), + f_ovf, NULL_TREE); + sav = build3 (COMPONENT_REF, TREE_TYPE (f_sav), unshare_expr (valist), + f_sav, NULL_TREE); /* Count number of gp and fp argument registers used. */ words = crtl->args.info.words; @@ -7263,7 +7315,7 @@ ix86_gimplify_va_arg (tree valist, tree type, gimple_seq *pre_p, } if (need_temp) { - int i; + int i, prev_size = 0; tree temp = create_tmp_var (type, "va_arg_tmp"); /* addr = &temp; */ @@ -7275,13 +7327,29 @@ ix86_gimplify_va_arg (tree valist, tree type, gimple_seq *pre_p, rtx slot = XVECEXP (container, 0, i); rtx reg = XEXP (slot, 0); enum machine_mode mode = GET_MODE (reg); - tree piece_type = lang_hooks.types.type_for_mode (mode, 1); - tree addr_type = build_pointer_type (piece_type); - tree daddr_type = build_pointer_type_for_mode (piece_type, - ptr_mode, true); + tree piece_type; + tree addr_type; + tree daddr_type; tree src_addr, src; int src_offset; tree dest_addr, dest; + int cur_size = GET_MODE_SIZE (mode); + + if (prev_size + cur_size > size) + { + cur_size = size - prev_size; + mode = mode_for_size (cur_size * BITS_PER_UNIT, MODE_INT, 1); + if (mode == BLKmode) + mode = QImode; + } + piece_type = lang_hooks.types.type_for_mode (mode, 1); + if (mode == GET_MODE (reg)) + addr_type = build_pointer_type (piece_type); + else + addr_type = build_pointer_type_for_mode (piece_type, ptr_mode, + true); + daddr_type = build_pointer_type_for_mode (piece_type, ptr_mode, + true); if (SSE_REGNO_P (REGNO (reg))) { @@ -7296,14 +7364,26 @@ ix86_gimplify_va_arg (tree valist, tree type, gimple_seq *pre_p, src_addr = fold_convert (addr_type, src_addr); src_addr = fold_build2 (POINTER_PLUS_EXPR, addr_type, src_addr, size_int (src_offset)); - src = build_va_arg_indirect_ref (src_addr); dest_addr = fold_convert (daddr_type, addr); dest_addr = fold_build2 (POINTER_PLUS_EXPR, daddr_type, dest_addr, size_int (INTVAL (XEXP (slot, 1)))); - dest = build_va_arg_indirect_ref (dest_addr); + if (cur_size == GET_MODE_SIZE (mode)) + { + src = build_va_arg_indirect_ref (src_addr); + dest = build_va_arg_indirect_ref (dest_addr); - gimplify_assign (dest, src, pre_p); + gimplify_assign (dest, src, pre_p); + } + else + { + tree copy + = build_call_expr (implicit_built_in_decls[BUILT_IN_MEMCPY], + 3, dest_addr, src_addr, + size_int (cur_size)); + gimplify_and_add (copy, pre_p); + } + prev_size += cur_size; } } @@ -7563,7 +7643,7 @@ standard_sse_constant_opcode (rtx insn, rtx x) if (TARGET_SSE_PACKED_SINGLE_INSN_OPTIMAL) return TARGET_AVX ? "vxorps\t%0, %0, %0" : "xorps\t%0, %0"; else - return TARGET_AVX ? "vxorpd\t%0, %0, %0" : "xorpd\t%0, %0"; + return TARGET_AVX ? "vxorpd\t%0, %0, %0" : "xorpd\t%0, %0"; case MODE_TI: if (TARGET_SSE_PACKED_SINGLE_INSN_OPTIMAL) return TARGET_AVX ? "vxorps\t%0, %0, %0" : "xorps\t%0, %0"; @@ -8097,8 +8177,10 @@ ix86_compute_frame_layout (struct ix86_frame *frame) preferred_alignment = crtl->preferred_stack_boundary / BITS_PER_UNIT; /* MS ABI seem to require stack alignment to be always 16 except for function - prologues. */ - if (ix86_cfun_abi () == MS_ABI && preferred_alignment < 16) + prologues and leaf. */ + if ((ix86_cfun_abi () == MS_ABI && preferred_alignment < 16) + && (!current_function_is_leaf || cfun->calls_alloca != 0 + || ix86_current_function_calls_tls_descriptor)) { preferred_alignment = 16; stack_alignment_needed = 16; @@ -8173,7 +8255,7 @@ ix86_compute_frame_layout (struct ix86_frame *frame) frame->padding0 = ((offset + 16 - 1) & -16) - offset; else frame->padding0 = 0; - + /* SSE register save area. */ offset += frame->padding0 + frame->nsseregs * 16; @@ -8391,7 +8473,7 @@ pro_epilogue_adjust_stack (rtx dest, rtx src, rtx offset, gcc_assert (ix86_cfa_state->reg == src); ix86_cfa_state->offset += INTVAL (offset); ix86_cfa_state->reg = dest; - + r = gen_rtx_PLUS (Pmode, src, offset); r = gen_rtx_SET (VOIDmode, dest, r); add_reg_note (insn, REG_CFA_ADJUST_CFA, r); @@ -8412,7 +8494,7 @@ pro_epilogue_adjust_stack (rtx dest, rtx src, rtx offset, Return: the regno of chosen register. */ -static unsigned int +static unsigned int find_drap_reg (void) { tree decl = cfun->decl; @@ -8436,7 +8518,7 @@ find_drap_reg (void) register in such case. */ if (DECL_STATIC_CHAIN (decl) || crtl->tail_call_emit) return DI_REG; - + /* Reuse static chain register if it isn't used for parameter passing. */ if (ix86_function_regparm (TREE_TYPE (decl), decl) <= 2 @@ -8461,7 +8543,7 @@ ix86_minimum_incoming_stack_boundary (bool sibcall) if (ix86_user_incoming_stack_boundary) incoming_stack_boundary = ix86_user_incoming_stack_boundary; /* In 32bit, use MIN_STACK_BOUNDARY for incoming stack boundary - if -mstackrealign is used, it isn't used for sibcall check and + if -mstackrealign is used, it isn't used for sibcall check and estimated stack alignment is 128bit. */ else if (!sibcall && !TARGET_64BIT @@ -8535,7 +8617,7 @@ ix86_get_drap_rtx (void) drap_vreg = copy_to_reg (arg_ptr); seq = get_insns (); end_sequence (); - + insn = emit_insn_before (seq, NEXT_INSN (entry_of_function ())); if (!optimize) { @@ -8558,10 +8640,10 @@ ix86_internal_arg_pointer (void) /* Finalize stack_realign_needed flag, which will guide prologue/epilogue to be generated in correct form. */ -static void +static void ix86_finalize_stack_realign_flags (void) { - /* Check if stack realign is really needed after reload, and + /* Check if stack realign is really needed after reload, and stores result in cfun */ unsigned int incoming_stack_boundary = (crtl->parm_stack_boundary > ix86_incoming_stack_boundary @@ -8694,7 +8776,7 @@ ix86_expand_prologue (void) } insn = emit_insn (gen_rtx_SET (VOIDmode, y, x)); - RTX_FRAME_RELATED_P (insn) = 1; + RTX_FRAME_RELATED_P (insn) = 1; ix86_cfa_state->reg = crtl->drap_reg; /* Align the stack. */ @@ -8756,7 +8838,7 @@ ix86_expand_prologue (void) if (!TARGET_64BIT_MS_ABI && TARGET_RED_ZONE && frame.save_regs_using_mov && (! TARGET_STACK_PROBE || allocate < CHECK_STACK_LIMIT)) ix86_emit_save_regs_using_mov ((frame_pointer_needed - && !crtl->stack_realign_needed) + && !crtl->stack_realign_needed) ? hard_frame_pointer_rtx : stack_pointer_rtx, -frame.nregs * UNITS_PER_WORD); @@ -8988,7 +9070,7 @@ ix86_emit_leave (HOST_WIDE_INT red_offset) ix86_cfa_state->reg = stack_pointer_rtx; ix86_cfa_state->offset -= UNITS_PER_WORD; - add_reg_note (insn, REG_CFA_ADJUST_CFA, + add_reg_note (insn, REG_CFA_ADJUST_CFA, copy_rtx (XVECEXP (PATTERN (insn), 0, 0))); RTX_FRAME_RELATED_P (insn) = 1; ix86_add_cfa_restore_note (insn, hard_frame_pointer_rtx, red_offset); @@ -9107,7 +9189,7 @@ ix86_expand_epilogue (int style) /* See the comment about red zone and frame pointer usage in ix86_expand_prologue. */ if (frame_pointer_needed && frame.red_zone_size) - emit_insn (gen_memory_blockage ()); + emit_insn (gen_memory_blockage ()); using_drap = crtl->drap_reg && crtl->stack_realign_needed; gcc_assert (!using_drap || ix86_cfa_state->reg == crtl->drap_reg); @@ -9163,13 +9245,13 @@ ix86_expand_epilogue (int style) locations. If both are available, default to ebp, since offsets are known to be small. Only exception is esp pointing directly to the end of block of saved registers, where we may simplify - addressing mode. + addressing mode. If we are realigning stack with bp and sp, regs restore can't be addressed by bp. sp must be used instead. */ if (!frame_pointer_needed - || (sp_valid && !(frame.to_allocate + frame.padding0)) + || (sp_valid && !(frame.to_allocate + frame.padding0)) || stack_realign_fp) { ix86_emit_restore_sse_regs_using_mov (stack_pointer_rtx, @@ -9285,7 +9367,7 @@ ix86_expand_epilogue (int style) If we realign stack with frame pointer, then stack pointer won't be able to recover via lea $offset(%bp), %sp, because - there is a padding area between bp and sp for realign. + there is a padding area between bp and sp for realign. "add $to_allocate, %sp" must be used instead. */ if (!sp_valid) { @@ -9326,8 +9408,8 @@ ix86_expand_epilogue (int style) ix86_emit_leave (red_offset); else { - /* For stack realigned really happens, recover stack - pointer to hard frame pointer is a must, if not using + /* For stack realigned really happens, recover stack + pointer to hard frame pointer is a must, if not using leave. */ if (stack_realign_fp) pro_epilogue_adjust_stack (stack_pointer_rtx, @@ -9351,10 +9433,11 @@ ix86_expand_epilogue (int style) if (!call_used_regs[REGNO (crtl->drap_reg)]) param_ptr_offset += UNITS_PER_WORD; - insn = emit_insn ((*ix86_gen_add3) (stack_pointer_rtx, - crtl->drap_reg, - GEN_INT (-param_ptr_offset))); - + insn = emit_insn (gen_rtx_SET + (VOIDmode, stack_pointer_rtx, + gen_rtx_PLUS (Pmode, + crtl->drap_reg, + GEN_INT (-param_ptr_offset)))); ix86_cfa_state->reg = stack_pointer_rtx; ix86_cfa_state->offset = param_ptr_offset; @@ -9375,7 +9458,7 @@ ix86_expand_epilogue (int style) gcc_assert (ix86_cfa_state->reg == stack_pointer_rtx); ix86_cfa_state->offset += UNITS_PER_WORD; - + r = gen_rtx_REG (Pmode, CX_REG); insn = emit_insn (ix86_gen_pop1 (r)); @@ -10635,7 +10718,7 @@ get_dllimport_decl (tree decl) if (h) return h->to; - *loc = h = GGC_NEW (struct tree_map); + *loc = h = ggc_alloc_tree_map (); h->hash = in.hash; h->base.from = decl; h->to = to = build_decl (DECL_SOURCE_LOCATION (decl), @@ -10962,7 +11045,7 @@ output_pic_addr_const (FILE *file, rtx x, int code) } else /* We can't handle floating point constants; - PRINT_OPERAND must handle them. */ + TARGET_PRINT_OPERAND must handle them. */ output_operand_lossage ("floating constant misused"); break; @@ -11580,7 +11663,7 @@ get_some_local_dynamic_name (void) */ void -print_operand (FILE *file, rtx x, int code) +ix86_print_operand (FILE *file, rtx x, int code) { if (code) { @@ -11615,7 +11698,7 @@ print_operand (FILE *file, rtx x, int code) if (!REG_P (x)) { putc ('[', file); - PRINT_OPERAND (file, x, 0); + ix86_print_operand (file, x, 0); putc (']', file); return; } @@ -11625,7 +11708,7 @@ print_operand (FILE *file, rtx x, int code) gcc_unreachable (); } - PRINT_OPERAND (file, x, 0); + ix86_print_operand (file, x, 0); return; @@ -11763,7 +11846,7 @@ print_operand (FILE *file, rtx x, int code) output_operand_lossage ("invalid operand size for operand code '%c'", code); return; - + case 'd': case 'b': case 'w': @@ -11780,7 +11863,7 @@ print_operand (FILE *file, rtx x, int code) case 's': if (CONST_INT_P (x) || ! SHIFT_DOUBLE_OMITS_COUNT) { - PRINT_OPERAND (file, x, 0); + ix86_print_operand (file, x, 0); fputs (", ", file); } return; @@ -12177,11 +12260,17 @@ print_operand (FILE *file, rtx x, int code) output_addr_const (file, x); } } + +static bool +ix86_print_operand_punct_valid_p (unsigned char code) +{ + return (code == '*' || code == '+' || code == '&' || code == ';'); +} /* Print a memory operand whose address is ADDR. */ -void -print_operand_address (FILE *file, rtx addr) +static void +ix86_print_operand_address (FILE *file, rtx addr) { struct ix86_address parts; rtx base, index, disp; @@ -13364,7 +13453,7 @@ ix86_expand_vector_move_misalign (enum machine_mode mode, rtx operands[]) op1 = gen_lowpart (mode, op1); switch (mode) - { + { case V4SFmode: emit_insn (gen_avx_movups (op0, op1)); break; @@ -13399,7 +13488,7 @@ ix86_expand_vector_move_misalign (enum machine_mode mode, rtx operands[]) if (MEM_P (op1)) { /* If we're optimizing for size, movups is the smallest. */ - if (optimize_insn_for_size_p () + if (optimize_insn_for_size_p () || TARGET_SSE_PACKED_SINGLE_INSN_OPTIMAL) { op0 = gen_lowpart (V4SFmode, op0); @@ -13508,7 +13597,7 @@ ix86_expand_vector_move_misalign (enum machine_mode mode, rtx operands[]) { op0 = gen_lowpart (V2DFmode, op0); op1 = gen_lowpart (V2DFmode, op1); - emit_insn (gen_sse2_movupd (op0, op1)); + emit_insn (gen_sse2_movupd (op0, op1)); } else { @@ -13526,7 +13615,7 @@ ix86_expand_vector_move_misalign (enum machine_mode mode, rtx operands[]) if (TARGET_SSE_UNALIGNED_STORE_OPTIMAL) { op0 = gen_lowpart (V4SFmode, op0); - emit_insn (gen_sse_movups (op0, op1)); + emit_insn (gen_sse_movups (op0, op1)); } else { @@ -13795,7 +13884,7 @@ ix86_expand_unary_operator (enum rtx_code code, enum machine_mode mode, #define LEA_SEARCH_THRESHOLD 12 /* Search backward for non-agu definition of register number REGNO1 - or register number REGNO2 in INSN's basic block until + or register number REGNO2 in INSN's basic block until 1. Pass LEA_SEARCH_THRESHOLD instructions, or 2. Reach BB boundary, or 3. Reach agu definition. @@ -13835,20 +13924,20 @@ distance_non_agu_define (unsigned int regno1, unsigned int regno2, prev = PREV_INSN (prev); } } - + if (distance < LEA_SEARCH_THRESHOLD) { edge e; edge_iterator ei; bool simple_loop = false; - + FOR_EACH_EDGE (e, ei, bb->preds) if (e->src == bb) { simple_loop = true; break; } - + if (simple_loop) { rtx prev = BB_END (bb); @@ -13885,7 +13974,7 @@ done: return distance; } -/* Return the distance between INSN and the next insn that uses +/* Return the distance between INSN and the next insn that uses register number REGNO0 in memory address. Return -1 if no such a use is found within LEA_SEARCH_THRESHOLD or REGNO0 is set. */ @@ -13936,14 +14025,14 @@ distance_agu_use (unsigned int regno0, rtx insn) edge e; edge_iterator ei; bool simple_loop = false; - + FOR_EACH_EDGE (e, ei, bb->succs) if (e->dest == bb) { simple_loop = true; break; } - + if (simple_loop) { rtx next = BB_HEAD (bb); @@ -13978,7 +14067,7 @@ distance_agu_use (unsigned int regno0, rtx insn) next = NEXT_INSN (next); } } - } + } return -1; } @@ -14012,7 +14101,7 @@ ix86_lea_for_add_ok (enum rtx_code code ATTRIBUTE_UNUSED, /* If a = b + c, (a!=b && a!=c), must use lea form. */ if (regno0 != regno1 && regno0 != regno2) return true; - else + else { int dist_define, dist_use; dist_define = distance_non_agu_define (regno1, regno2, insn); @@ -14074,7 +14163,7 @@ ix86_dep_by_shift_count_body (const_rtx set_body, const_rtx use_body) break; } - if (shift_rtx + if (shift_rtx && (GET_CODE (shift_rtx) == ASHIFT || GET_CODE (shift_rtx) == LSHIFTRT || GET_CODE (shift_rtx) == ASHIFTRT @@ -14933,7 +15022,7 @@ ix86_cc_modes_compatible (enum machine_mode m1, enum machine_mode m2) } -/* Return a comparison we can do and that it is equivalent to +/* Return a comparison we can do and that it is equivalent to swap_condition (code) apart possibly from orderedness. But, never change orderedness if TARGET_IEEE_FP, returning UNKNOWN in that case if necessary. */ @@ -18278,7 +18367,7 @@ decide_alg (HOST_WIDE_INT count, HOST_WIDE_INT expected_size, bool memset, && alg != rep_prefix_4_byte \ && alg != rep_prefix_8_byte)) const struct processor_costs *cost; - + /* Even if the string operation call is cold, we still might spend a lot of time processing large blocks. */ if (optimize_function_for_size_p (cfun) @@ -18825,7 +18914,7 @@ promote_duplicated_reg (enum machine_mode mode, rtx val) if (mode == SImode) emit_insn (gen_movsi_insv_1 (reg, reg)); else - emit_insn (gen_movdi_insv_1_rex64 (reg, reg)); + emit_insn (gen_movdi_insv_1 (reg, reg)); else { tmp = expand_simple_binop (mode, ASHIFT, reg, GEN_INT (8), @@ -19452,7 +19541,7 @@ ix86_expand_call (rtx retval, rtx fnaddr, rtx callarg1, } if (ix86_cmodel == CM_LARGE_PIC - && MEM_P (fnaddr) + && MEM_P (fnaddr) && GET_CODE (XEXP (fnaddr, 0)) == SYMBOL_REF && !local_symbolic_operand (XEXP (fnaddr, 0), VOIDmode)) fnaddr = gen_rtx_MEM (QImode, construct_plt_address (XEXP (fnaddr, 0))); @@ -19520,7 +19609,7 @@ ix86_init_machine_status (void) { struct machine_function *f; - f = GGC_CNEW (struct machine_function); + f = ggc_alloc_cleared_machine_function (); f->use_fast_prologue_epilogue_nregs = -1; f->tls_descriptor_call_expanded_p = 0; f->call_abi = ix86_abi; @@ -19548,8 +19637,7 @@ assign_386_stack_local (enum machine_mode mode, enum ix86_stack_slot n) if (s->mode == mode && s->n == n) return copy_rtx (s->rtl); - s = (struct stack_local_entry *) - ggc_alloc (sizeof (struct stack_local_entry)); + s = ggc_alloc_stack_local_entry (); s->n = n; s->mode = mode; s->rtl = assign_stack_local (mode, GET_MODE_SIZE (mode), 0); @@ -20426,7 +20514,7 @@ ix86_static_chain (const_tree fndecl, bool incoming_p) } /* Emit RTL insns to initialize the variable parts of a trampoline. - FNDECL is the decl of the target address; M_TRAMP is a MEM for + FNDECL is the decl of the target address; M_TRAMP is a MEM for the trampoline, and CHAIN_VALUE is an RTX for the static chain to be passed to the target function. */ @@ -22447,9 +22535,9 @@ static const struct builtin_description bdesc_args[] = { OPTION_MASK_ISA_AVX, CODE_FOR_avx_si256_si, "__builtin_ia32_si256_si", IX86_BUILTIN_SI256_SI, UNKNOWN, (int) V8SI_FTYPE_V4SI }, { OPTION_MASK_ISA_AVX, CODE_FOR_avx_ps256_ps, "__builtin_ia32_ps256_ps", IX86_BUILTIN_PS256_PS, UNKNOWN, (int) V8SF_FTYPE_V4SF }, { OPTION_MASK_ISA_AVX, CODE_FOR_avx_pd256_pd, "__builtin_ia32_pd256_pd", IX86_BUILTIN_PD256_PD, UNKNOWN, (int) V4DF_FTYPE_V2DF }, - { OPTION_MASK_ISA_AVX, CODE_FOR_avx_si_si256, "__builtin_ia32_si_si256", IX86_BUILTIN_SI_SI256, UNKNOWN, (int) V4SI_FTYPE_V8SI }, - { OPTION_MASK_ISA_AVX, CODE_FOR_avx_ps_ps256, "__builtin_ia32_ps_ps256", IX86_BUILTIN_PS_PS256, UNKNOWN, (int) V4SF_FTYPE_V8SF }, - { OPTION_MASK_ISA_AVX, CODE_FOR_avx_pd_pd256, "__builtin_ia32_pd_pd256", IX86_BUILTIN_PD_PD256, UNKNOWN, (int) V2DF_FTYPE_V4DF }, + { OPTION_MASK_ISA_AVX, CODE_FOR_vec_extract_lo_v8si, "__builtin_ia32_si_si256", IX86_BUILTIN_SI_SI256, UNKNOWN, (int) V4SI_FTYPE_V8SI }, + { OPTION_MASK_ISA_AVX, CODE_FOR_vec_extract_lo_v8sf, "__builtin_ia32_ps_ps256", IX86_BUILTIN_PS_PS256, UNKNOWN, (int) V4SF_FTYPE_V8SF }, + { OPTION_MASK_ISA_AVX, CODE_FOR_vec_extract_lo_v4df, "__builtin_ia32_pd_pd256", IX86_BUILTIN_PD_PD256, UNKNOWN, (int) V2DF_FTYPE_V4DF }, { OPTION_MASK_ISA_AVX, CODE_FOR_avx_vtestpd, "__builtin_ia32_vtestzpd", IX86_BUILTIN_VTESTZPD, EQ, (int) INT_FTYPE_V2DF_V2DF_PTEST }, { OPTION_MASK_ISA_AVX, CODE_FOR_avx_vtestpd, "__builtin_ia32_vtestcpd", IX86_BUILTIN_VTESTCPD, LTU, (int) INT_FTYPE_V2DF_V2DF_PTEST }, @@ -22540,7 +22628,7 @@ static const struct builtin_description bdesc_multi_arg[] = { OPTION_MASK_ISA_FMA4, CODE_FOR_fma4i_vmfmsubv2df4, "__builtin_ia32_vfmsubsd", IX86_BUILTIN_VFMSUBSD, UNKNOWN, (int)MULTI_ARG_3_DF }, { OPTION_MASK_ISA_FMA4, CODE_FOR_fma4i_fmsubv4sf4, "__builtin_ia32_vfmsubps", IX86_BUILTIN_VFMSUBPS, UNKNOWN, (int)MULTI_ARG_3_SF }, { OPTION_MASK_ISA_FMA4, CODE_FOR_fma4i_fmsubv2df4, "__builtin_ia32_vfmsubpd", IX86_BUILTIN_VFMSUBPD, UNKNOWN, (int)MULTI_ARG_3_DF }, - + { OPTION_MASK_ISA_FMA4, CODE_FOR_fma4i_vmfnmaddv4sf4, "__builtin_ia32_vfnmaddss", IX86_BUILTIN_VFNMADDSS, UNKNOWN, (int)MULTI_ARG_3_SF }, { OPTION_MASK_ISA_FMA4, CODE_FOR_fma4i_vmfnmaddv2df4, "__builtin_ia32_vfnmaddsd", IX86_BUILTIN_VFNMADDSD, UNKNOWN, (int)MULTI_ARG_3_DF }, { OPTION_MASK_ISA_FMA4, CODE_FOR_fma4i_fnmaddv4sf4, "__builtin_ia32_vfnmaddps", IX86_BUILTIN_VFNMADDPS, UNKNOWN, (int)MULTI_ARG_3_SF }, @@ -22559,7 +22647,7 @@ static const struct builtin_description bdesc_multi_arg[] = { OPTION_MASK_ISA_FMA4, CODE_FOR_fma4i_fmaddv4df4256, "__builtin_ia32_vfmaddpd256", IX86_BUILTIN_VFMADDPD256, UNKNOWN, (int)MULTI_ARG_3_DF2 }, { OPTION_MASK_ISA_FMA4, CODE_FOR_fma4i_fmsubv8sf4256, "__builtin_ia32_vfmsubps256", IX86_BUILTIN_VFMSUBPS256, UNKNOWN, (int)MULTI_ARG_3_SF2 }, { OPTION_MASK_ISA_FMA4, CODE_FOR_fma4i_fmsubv4df4256, "__builtin_ia32_vfmsubpd256", IX86_BUILTIN_VFMSUBPD256, UNKNOWN, (int)MULTI_ARG_3_DF2 }, - + { OPTION_MASK_ISA_FMA4, CODE_FOR_fma4i_fnmaddv8sf4256, "__builtin_ia32_vfnmaddps256", IX86_BUILTIN_VFNMADDPS256, UNKNOWN, (int)MULTI_ARG_3_SF2 }, { OPTION_MASK_ISA_FMA4, CODE_FOR_fma4i_fnmaddv4df4256, "__builtin_ia32_vfnmaddpd256", IX86_BUILTIN_VFNMADDPD256, UNKNOWN, (int)MULTI_ARG_3_DF2 }, { OPTION_MASK_ISA_FMA4, CODE_FOR_fma4i_fnmsubv8sf4256, "__builtin_ia32_vfnmsubps256", IX86_BUILTIN_VFNMSUBPS256, UNKNOWN, (int)MULTI_ARG_3_SF2 }, @@ -23676,7 +23764,7 @@ ix86_expand_args_builtin (const struct builtin_description *d, } args[4]; bool last_arg_count = false; enum insn_code icode = d->icode; - const struct insn_data *insn_p = &insn_data[icode]; + const struct insn_data_d *insn_p = &insn_data[icode]; enum machine_mode tmode = insn_p->operand[0].mode; enum machine_mode rmode = VOIDmode; bool swap = false; @@ -23856,8 +23944,8 @@ ix86_expand_args_builtin (const struct builtin_description *d, case V8HI_FTYPE_V8HI_V8HI_INT: case V8SI_FTYPE_V8SI_V8SI_INT: case V8SI_FTYPE_V8SI_V4SI_INT: - case V8SF_FTYPE_V8SF_V8SF_INT: - case V8SF_FTYPE_V8SF_V4SF_INT: + case V8SF_FTYPE_V8SF_V8SF_INT: + case V8SF_FTYPE_V8SF_V4SF_INT: case V4SI_FTYPE_V4SI_V4SI_INT: case V4DF_FTYPE_V4DF_V4DF_INT: case V4DF_FTYPE_V4DF_V2DF_INT: @@ -24070,7 +24158,7 @@ ix86_expand_special_args_builtin (const struct builtin_description *d, } args[3]; enum insn_code icode = d->icode; bool last_arg_constant = false; - const struct insn_data *insn_p = &insn_data[icode]; + const struct insn_data_d *insn_p = &insn_data[icode]; enum machine_mode tmode = insn_p->operand[0].mode; enum { load, store } klass; @@ -25261,13 +25349,13 @@ ix86_free_from_memory (enum machine_mode mode) /* Implement TARGET_IRA_COVER_CLASSES. If -mfpmath=sse, we prefer SSE_REGS to FLOAT_REGS if their costs for a pseudo are the same. */ -static const enum reg_class * +static const reg_class_t * i386_ira_cover_classes (void) { - static const enum reg_class sse_fpmath_classes[] = { + static const reg_class_t sse_fpmath_classes[] = { GENERAL_REGS, SSE_REGS, MMX_REGS, FLOAT_REGS, LIM_REG_CLASSES }; - static const enum reg_class no_sse_fpmath_classes[] = { + static const reg_class_t no_sse_fpmath_classes[] = { GENERAL_REGS, FLOAT_REGS, MMX_REGS, SSE_REGS, LIM_REG_CLASSES }; @@ -25377,8 +25465,8 @@ ix86_preferred_output_reload_class (rtx x, enum reg_class regclass) return regclass; } -static enum reg_class -ix86_secondary_reload (bool in_p, rtx x, enum reg_class rclass, +static reg_class_t +ix86_secondary_reload (bool in_p, rtx x, reg_class_t rclass, enum machine_mode mode, secondary_reload_info *sri ATTRIBUTE_UNUSED) { @@ -25630,10 +25718,11 @@ inline_memory_move_cost (enum machine_mode mode, enum reg_class regclass, } } -int -ix86_memory_move_cost (enum machine_mode mode, enum reg_class regclass, int in) +static int +ix86_memory_move_cost (enum machine_mode mode, reg_class_t regclass, + bool in) { - return inline_memory_move_cost (mode, regclass, in); + return inline_memory_move_cost (mode, (enum reg_class) regclass, in ? 1 : 0); } @@ -25644,10 +25733,13 @@ ix86_memory_move_cost (enum machine_mode mode, enum reg_class regclass, int in) on some machines it is expensive to move between registers if they are not general registers. */ -int -ix86_register_move_cost (enum machine_mode mode, enum reg_class class1, - enum reg_class class2) +static int +ix86_register_move_cost (enum machine_mode mode, reg_class_t class1_i, + reg_class_t class2_i) { + enum reg_class class1 = (enum reg_class) class1_i; + enum reg_class class2 = (enum reg_class) class2_i; + /* In case we require secondary memory, compute cost of the store followed by load. In order to avoid bad register allocation choices, we need for this to be *at least* as high as the symmetric MEMORY_MOVE_COST. */ @@ -27292,7 +27384,7 @@ ix86_expand_vector_init_one_nonzero (bool mmx_ok, enum machine_mode mode, emit_insn (gen_rtx_SET (VOIDmode, target, CONST0_RTX (mode))); var = force_reg (GET_MODE_INNER (mode), var); ix86_expand_vector_set (mmx_ok, target, var, one_var); - return true; + return true; } switch (mode) @@ -27626,7 +27718,7 @@ ix86_expand_vector_init_interleave (enum machine_mode mode, rtx (*gen_load_even) (rtx, rtx, rtx); rtx (*gen_interleave_first_low) (rtx, rtx, rtx); rtx (*gen_interleave_second_low) (rtx, rtx, rtx); - + switch (mode) { case V8HImode: @@ -27650,7 +27742,7 @@ ix86_expand_vector_init_interleave (enum machine_mode mode, default: gcc_unreachable (); } - + for (i = 0; i < n; i++) { /* Extend the odd elment to SImode using a paradoxical SUBREG. */ @@ -27669,7 +27761,7 @@ ix86_expand_vector_init_interleave (enum machine_mode mode, /* Cast the V4SImode vector back to a vector in orignal mode. */ op0 = gen_reg_rtx (mode); emit_move_insn (op0, gen_lowpart (mode, op1)); - + /* Load even elements into the second positon. */ emit_insn ((*gen_load_even) (op0, force_reg (inner_mode, @@ -27792,7 +27884,7 @@ half: break; /* Don't use ix86_expand_vector_init_interleave if we can't - move from GPR to SSE register directly. */ + move from GPR to SSE register directly. */ if (!TARGET_INTER_UNIT_MOVES) break; @@ -29355,28 +29447,52 @@ static const struct attribute_spec ix86_attribute_table[] = /* Implement targetm.vectorize.builtin_vectorization_cost. */ static int -ix86_builtin_vectorization_cost (bool runtime_test) +ix86_builtin_vectorization_cost (enum vect_cost_for_stmt type_of_cost) { - /* If the branch of the runtime test is taken - i.e. - the vectorized - version is skipped - this incurs a misprediction cost (because the - vectorized version is expected to be the fall-through). So we subtract - the latency of a mispredicted branch from the costs that are incured - when the vectorized version is executed. + switch (type_of_cost) + { + case scalar_stmt: + return ix86_cost->scalar_stmt_cost; - TODO: The values in individual target tables have to be tuned or new - fields may be needed. For eg. on K8, the default branch path is the - not-taken path. If the taken path is predicted correctly, the minimum - penalty of going down the taken-path is 1 cycle. If the taken-path is - not predicted correctly, then the minimum penalty is 10 cycles. */ + case scalar_load: + return ix86_cost->scalar_load_cost; - if (runtime_test) - { - return (-(ix86_cost->cond_taken_branch_cost)); + case scalar_store: + return ix86_cost->scalar_store_cost; + + case vector_stmt: + return ix86_cost->vec_stmt_cost; + + case vector_load: + return ix86_cost->vec_align_load_cost; + + case vector_store: + return ix86_cost->vec_store_cost; + + case vec_to_scalar: + return ix86_cost->vec_to_scalar_cost; + + case scalar_to_vec: + return ix86_cost->scalar_to_vec_cost; + + case unaligned_load: + return ix86_cost->vec_unalign_load_cost; + + case cond_branch_taken: + return ix86_cost->cond_taken_branch_cost; + + case cond_branch_not_taken: + return ix86_cost->cond_not_taken_branch_cost; + + case vec_perm: + return 1; + + default: + gcc_unreachable (); } - else - return 0; } + /* Implement targetm.vectorize.builtin_vec_perm. */ static tree @@ -30042,7 +30158,7 @@ expand_vec_perm_pshufb2 (struct expand_vec_perm_d *d) nelt = d->nelt; eltsz = GET_MODE_SIZE (GET_MODE_INNER (d->vmode)); - + /* Generate two permutation masks. If the required element is within the given vector it is shuffled into the proper lane. If the required element is in the other vector, force a zero into the lane by setting @@ -30440,7 +30556,7 @@ ix86_expand_vec_perm_builtin (tree exp) d.op1 = d.op0; break; } - + d.target = gen_reg_rtx (d.vmode); if (ix86_expand_vec_perm_builtin_1 (&d)) return d.target; @@ -30512,7 +30628,7 @@ ix86_vectorize_builtin_vec_perm_ok (tree vec_type, tree mask) an error generated from the extract. */ gcc_assert (vec_mask > 0 && vec_mask <= 3); one_vec = (vec_mask != 3); - + /* Implementable with shufps or pshufd. */ if (one_vec && (d.vmode == V4SFmode || d.vmode == V4SImode)) return true; @@ -30580,10 +30696,12 @@ ix86_canonical_va_list_type (tree type) tree wtype, htype; /* Resolve references and pointers to va_list type. */ - if (INDIRECT_REF_P (type)) + if (TREE_CODE (type) == MEM_REF) type = TREE_TYPE (type); else if (POINTER_TYPE_P (type) && POINTER_TYPE_P (TREE_TYPE(type))) type = TREE_TYPE (type); + else if (POINTER_TYPE_P (type) && TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE) + type = TREE_TYPE (type); if (TARGET_64BIT) { @@ -30747,6 +30865,13 @@ ix86_enum_va_list (int idx, const char **pname, tree *ptree) #undef TARGET_ASM_UNALIGNED_DI_OP #define TARGET_ASM_UNALIGNED_DI_OP TARGET_ASM_ALIGNED_DI_OP +#undef TARGET_PRINT_OPERAND +#define TARGET_PRINT_OPERAND ix86_print_operand +#undef TARGET_PRINT_OPERAND_ADDRESS +#define TARGET_PRINT_OPERAND_ADDRESS ix86_print_operand_address +#undef TARGET_PRINT_OPERAND_PUNCT_VALID_P +#define TARGET_PRINT_OPERAND_PUNCT_VALID_P ix86_print_operand_punct_valid_p + #undef TARGET_SCHED_ADJUST_COST #define TARGET_SCHED_ADJUST_COST ix86_adjust_cost #undef TARGET_SCHED_ISSUE_RATE @@ -30800,6 +30925,10 @@ ix86_enum_va_list (int idx, const char **pname, tree *ptree) #undef TARGET_HANDLE_OPTION #define TARGET_HANDLE_OPTION ix86_handle_option +#undef TARGET_REGISTER_MOVE_COST +#define TARGET_REGISTER_MOVE_COST ix86_register_move_cost +#undef TARGET_MEMORY_MOVE_COST +#define TARGET_MEMORY_MOVE_COST ix86_memory_move_cost #undef TARGET_RTX_COSTS #define TARGET_RTX_COSTS ix86_rtx_costs #undef TARGET_ADDRESS_COST @@ -30842,6 +30971,10 @@ ix86_enum_va_list (int idx, const char **pname, tree *ptree) #define TARGET_SETUP_INCOMING_VARARGS ix86_setup_incoming_varargs #undef TARGET_MUST_PASS_IN_STACK #define TARGET_MUST_PASS_IN_STACK ix86_must_pass_in_stack +#undef TARGET_FUNCTION_ARG_ADVANCE +#define TARGET_FUNCTION_ARG_ADVANCE ix86_function_arg_advance +#undef TARGET_FUNCTION_ARG +#define TARGET_FUNCTION_ARG ix86_function_arg #undef TARGET_PASS_BY_REFERENCE #define TARGET_PASS_BY_REFERENCE ix86_pass_by_reference #undef TARGET_INTERNAL_ARG_POINTER @@ -30856,6 +30989,8 @@ ix86_enum_va_list (int idx, const char **pname, tree *ptree) #define TARGET_STATIC_CHAIN ix86_static_chain #undef TARGET_TRAMPOLINE_INIT #define TARGET_TRAMPOLINE_INIT ix86_trampoline_init +#undef TARGET_RETURN_POPS_ARGS +#define TARGET_RETURN_POPS_ARGS ix86_return_pops_args #undef TARGET_GIMPLIFY_VA_ARG_EXPR #define TARGET_GIMPLIFY_VA_ARG_EXPR ix86_gimplify_va_arg diff --git a/gcc/config/i386/i386.h b/gcc/config/i386/i386.h index b18aadefaca..7bf4334cb7d 100644 --- a/gcc/config/i386/i386.h +++ b/gcc/config/i386/i386.h @@ -1543,26 +1543,6 @@ enum reg_class #define OUTGOING_REG_PARM_STACK_SPACE(FNTYPE) \ (ix86_function_type_abi (FNTYPE) == MS_ABI) -/* Value is the number of bytes of arguments automatically - popped when returning from a subroutine call. - FUNDECL is the declaration node of the function (as a tree), - FUNTYPE is the data type of the function (as a tree), - or for a library call it is an identifier node for the subroutine name. - SIZE is the number of bytes of arguments passed on the stack. - - On the 80386, the RTD insn may be used to pop them if the number - of args is fixed, but if the number is variable then the caller - must pop them all. RTD can't be used for library calls now - because the library is compiled with the Unix compiler. - Use of RTD is a selectable option, since it is incompatible with - standard Unix calling sequences. If the option is not selected, - the caller must always pop the args. - - The attribute stdcall is equivalent to RTD on a per module basis. */ - -#define RETURN_POPS_ARGS(FUNDECL, FUNTYPE, SIZE) \ - ix86_return_pops_args ((FUNDECL), (FUNTYPE), (SIZE)) - /* Define how to find the value returned by a library function assuming the value has mode MODE. */ @@ -1612,29 +1592,6 @@ typedef struct ix86_args { #define INIT_CUMULATIVE_ARGS(CUM, FNTYPE, LIBNAME, FNDECL, N_NAMED_ARGS) \ init_cumulative_args (&(CUM), (FNTYPE), (LIBNAME), (FNDECL)) -/* Update the data in CUM to advance over an argument - of mode MODE and data type TYPE. - (TYPE is null for libcalls where that information may not be available.) */ - -#define FUNCTION_ARG_ADVANCE(CUM, MODE, TYPE, NAMED) \ - function_arg_advance (&(CUM), (MODE), (TYPE), (NAMED)) - -/* Define where to put the arguments to a function. - Value is zero to push the argument on the stack, - or a hard register in which to store the argument. - - MODE is the argument's machine mode. - TYPE is the data type of the argument (as a tree). - This is null for libcalls where that information may - not be available. - CUM is a variable of type CUMULATIVE_ARGS which gives info about - the preceding args and about the function being called. - NAMED is nonzero if this argument is a named parameter - (otherwise it is an extra parameter matching an ellipsis). */ - -#define FUNCTION_ARG(CUM, MODE, TYPE, NAMED) \ - function_arg (&(CUM), (MODE), (TYPE), (NAMED)) - /* Output assembler code to FILE to increment profiler label # LABELNO for profiling a function entry. */ @@ -1892,28 +1849,6 @@ do { \ so give the MEM rtx a byte's mode. */ #define FUNCTION_MODE QImode -/* A C expression for the cost of moving data from a register in class FROM to - one in class TO. The classes are expressed using the enumeration values - such as `GENERAL_REGS'. A value of 2 is the default; other values are - interpreted relative to that. - - It is not required that the cost always equal 2 when FROM is the same as TO; - on some machines it is expensive to move between registers if they are not - general registers. */ - -#define REGISTER_MOVE_COST(MODE, CLASS1, CLASS2) \ - ix86_register_move_cost ((MODE), (CLASS1), (CLASS2)) - -/* A C expression for the cost of moving data of mode M between a - register and memory. A value of 2 is the default; this cost is - relative to those in `REGISTER_MOVE_COST'. - - If moving between registers and memory is more expensive than - between two registers, you should define this macro to express the - relative cost. */ - -#define MEMORY_MOVE_COST(MODE, CLASS, IN) \ - ix86_memory_move_cost ((MODE), (CLASS), (IN)) /* A C expression for the cost of a branch instruction. A value of 1 is the default; other values are interpreted relative to that. */ @@ -1993,7 +1928,8 @@ do { \ For non floating point regs, the following are the HImode names. For float regs, the stack top is sometimes referred to as "%st(0)" - instead of just "%st". PRINT_OPERAND handles this with the "y" code. */ + instead of just "%st". TARGET_PRINT_OPERAND handles this with the + "y" code. */ #define HI_REGISTER_NAMES \ {"ax","dx","cx","bx","si","di","bp","sp", \ @@ -2163,20 +2099,6 @@ do { \ "call " CRT_MKSTR(__USER_LABEL_PREFIX__) #FUNC "\n" \ TEXT_SECTION_ASM_OP); -/* Print operand X (an rtx) in assembler syntax to file FILE. - CODE is a letter or dot (`z' in `%z0') or 0 if no letter was specified. - Effect of various CODE letters is described in i386.c near - print_operand function. */ - -#define PRINT_OPERAND_PUNCT_VALID_P(CODE) \ - ((CODE) == '*' || (CODE) == '+' || (CODE) == '&' || (CODE) == ';') - -#define PRINT_OPERAND(FILE, X, CODE) \ - print_operand ((FILE), (X), (CODE)) - -#define PRINT_OPERAND_ADDRESS(FILE, ADDR) \ - print_operand_address ((FILE), (ADDR)) - #define OUTPUT_ADDR_CONST_EXTRA(FILE, X, FAIL) \ do { \ if (! output_addr_const_extra (FILE, (X))) \ @@ -2445,57 +2367,6 @@ struct GTY(()) machine_function { #define SYMBOL_REF_DLLEXPORT_P(X) \ ((SYMBOL_REF_FLAGS (X) & SYMBOL_FLAG_DLLEXPORT) != 0) -/* Model costs for vectorizer. */ - -/* Cost of conditional branch. */ -#undef TARG_COND_BRANCH_COST -#define TARG_COND_BRANCH_COST ix86_cost->branch_cost - -/* Cost of any scalar operation, excluding load and store. */ -#undef TARG_SCALAR_STMT_COST -#define TARG_SCALAR_STMT_COST ix86_cost->scalar_stmt_cost - -/* Cost of scalar load. */ -#undef TARG_SCALAR_LOAD_COST -#define TARG_SCALAR_LOAD_COST ix86_cost->scalar_load_cost - -/* Cost of scalar store. */ -#undef TARG_SCALAR_STORE_COST -#define TARG_SCALAR_STORE_COST ix86_cost->scalar_store_cost - -/* Cost of any vector operation, excluding load, store or vector to scalar - operation. */ -#undef TARG_VEC_STMT_COST -#define TARG_VEC_STMT_COST ix86_cost->vec_stmt_cost - -/* Cost of vector to scalar operation. */ -#undef TARG_VEC_TO_SCALAR_COST -#define TARG_VEC_TO_SCALAR_COST ix86_cost->vec_to_scalar_cost - -/* Cost of scalar to vector operation. */ -#undef TARG_SCALAR_TO_VEC_COST -#define TARG_SCALAR_TO_VEC_COST ix86_cost->scalar_to_vec_cost - -/* Cost of aligned vector load. */ -#undef TARG_VEC_LOAD_COST -#define TARG_VEC_LOAD_COST ix86_cost->vec_align_load_cost - -/* Cost of misaligned vector load. */ -#undef TARG_VEC_UNALIGNED_LOAD_COST -#define TARG_VEC_UNALIGNED_LOAD_COST ix86_cost->vec_unalign_load_cost - -/* Cost of vector store. */ -#undef TARG_VEC_STORE_COST -#define TARG_VEC_STORE_COST ix86_cost->vec_store_cost - -/* Cost of conditional taken branch for vectorizer cost model. */ -#undef TARG_COND_TAKEN_BRANCH_COST -#define TARG_COND_TAKEN_BRANCH_COST ix86_cost->cond_taken_branch_cost - -/* Cost of conditional not taken branch for vectorizer cost model. */ -#undef TARG_COND_NOT_TAKEN_BRANCH_COST -#define TARG_COND_NOT_TAKEN_BRANCH_COST ix86_cost->cond_not_taken_branch_cost - /* Local variables: version-control: t diff --git a/gcc/config/i386/i386.md b/gcc/config/i386/i386.md index f1c87ac16d8..3d7d74dde6f 100644 --- a/gcc/config/i386/i386.md +++ b/gcc/config/i386/i386.md @@ -62,198 +62,199 @@ ;; UNSPEC usage: -(define_constants - [; Relocation specifiers - (UNSPEC_GOT 0) - (UNSPEC_GOTOFF 1) - (UNSPEC_GOTPCREL 2) - (UNSPEC_GOTTPOFF 3) - (UNSPEC_TPOFF 4) - (UNSPEC_NTPOFF 5) - (UNSPEC_DTPOFF 6) - (UNSPEC_GOTNTPOFF 7) - (UNSPEC_INDNTPOFF 8) - (UNSPEC_PLTOFF 9) - (UNSPEC_MACHOPIC_OFFSET 10) - - ; Prologue support - (UNSPEC_STACK_ALLOC 11) - (UNSPEC_SET_GOT 12) - (UNSPEC_SSE_PROLOGUE_SAVE 13) - (UNSPEC_REG_SAVE 14) - (UNSPEC_DEF_CFA 15) - (UNSPEC_SET_RIP 16) - (UNSPEC_SET_GOT_OFFSET 17) - (UNSPEC_MEMORY_BLOCKAGE 18) - (UNSPEC_SSE_PROLOGUE_SAVE_LOW 19) - - ; TLS support - (UNSPEC_TP 20) - (UNSPEC_TLS_GD 21) - (UNSPEC_TLS_LD_BASE 22) - (UNSPEC_TLSDESC 23) - - ; Other random patterns - (UNSPEC_SCAS 30) - (UNSPEC_FNSTSW 31) - (UNSPEC_SAHF 32) - (UNSPEC_FSTCW 33) - (UNSPEC_ADD_CARRY 34) - (UNSPEC_FLDCW 35) - (UNSPEC_REP 36) - (UNSPEC_LD_MPIC 38) ; load_macho_picbase - (UNSPEC_TRUNC_NOOP 39) - - ; For SSE/MMX support: - (UNSPEC_FIX_NOTRUNC 40) - (UNSPEC_MASKMOV 41) - (UNSPEC_MOVMSK 42) - (UNSPEC_MOVNT 43) - (UNSPEC_MOVU 44) - (UNSPEC_RCP 45) - (UNSPEC_RSQRT 46) - (UNSPEC_SFENCE 47) - (UNSPEC_PFRCP 49) - (UNSPEC_PFRCPIT1 40) - (UNSPEC_PFRCPIT2 41) - (UNSPEC_PFRSQRT 42) - (UNSPEC_PFRSQIT1 43) - (UNSPEC_MFENCE 44) - (UNSPEC_LFENCE 45) - (UNSPEC_PSADBW 46) - (UNSPEC_LDDQU 47) - (UNSPEC_MS_TO_SYSV_CALL 48) - - ; Generic math support - (UNSPEC_COPYSIGN 50) - (UNSPEC_IEEE_MIN 51) ; not commutative - (UNSPEC_IEEE_MAX 52) ; not commutative - - ; x87 Floating point - (UNSPEC_SIN 60) - (UNSPEC_COS 61) - (UNSPEC_FPATAN 62) - (UNSPEC_FYL2X 63) - (UNSPEC_FYL2XP1 64) - (UNSPEC_FRNDINT 65) - (UNSPEC_FIST 66) - (UNSPEC_F2XM1 67) - (UNSPEC_TAN 68) - (UNSPEC_FXAM 69) - - ; x87 Rounding - (UNSPEC_FRNDINT_FLOOR 70) - (UNSPEC_FRNDINT_CEIL 71) - (UNSPEC_FRNDINT_TRUNC 72) - (UNSPEC_FRNDINT_MASK_PM 73) - (UNSPEC_FIST_FLOOR 74) - (UNSPEC_FIST_CEIL 75) - - ; x87 Double output FP - (UNSPEC_SINCOS_COS 80) - (UNSPEC_SINCOS_SIN 81) - (UNSPEC_XTRACT_FRACT 84) - (UNSPEC_XTRACT_EXP 85) - (UNSPEC_FSCALE_FRACT 86) - (UNSPEC_FSCALE_EXP 87) - (UNSPEC_FPREM_F 88) - (UNSPEC_FPREM_U 89) - (UNSPEC_FPREM1_F 90) - (UNSPEC_FPREM1_U 91) - - (UNSPEC_C2_FLAG 95) - (UNSPEC_FXAM_MEM 96) - - ; SSP patterns - (UNSPEC_SP_SET 100) - (UNSPEC_SP_TEST 101) - (UNSPEC_SP_TLS_SET 102) - (UNSPEC_SP_TLS_TEST 103) - - ; SSSE3 - (UNSPEC_PSHUFB 120) - (UNSPEC_PSIGN 121) - (UNSPEC_PALIGNR 122) - - ; For SSE4A support - (UNSPEC_EXTRQI 130) - (UNSPEC_EXTRQ 131) - (UNSPEC_INSERTQI 132) - (UNSPEC_INSERTQ 133) - - ; For SSE4.1 support - (UNSPEC_BLENDV 134) - (UNSPEC_INSERTPS 135) - (UNSPEC_DP 136) - (UNSPEC_MOVNTDQA 137) - (UNSPEC_MPSADBW 138) - (UNSPEC_PHMINPOSUW 139) - (UNSPEC_PTEST 140) - (UNSPEC_ROUND 141) - - ; For SSE4.2 support - (UNSPEC_CRC32 143) - (UNSPEC_PCMPESTR 144) - (UNSPEC_PCMPISTR 145) - - ; For FMA4 support - (UNSPEC_FMA4_INTRINSIC 150) - (UNSPEC_FMA4_FMADDSUB 151) - (UNSPEC_FMA4_FMSUBADD 152) - (UNSPEC_XOP_UNSIGNED_CMP 151) - (UNSPEC_XOP_TRUEFALSE 152) - (UNSPEC_XOP_PERMUTE 153) - (UNSPEC_FRCZ 154) - - ; For AES support - (UNSPEC_AESENC 159) - (UNSPEC_AESENCLAST 160) - (UNSPEC_AESDEC 161) - (UNSPEC_AESDECLAST 162) - (UNSPEC_AESIMC 163) - (UNSPEC_AESKEYGENASSIST 164) - - ; For PCLMUL support - (UNSPEC_PCLMUL 165) - - ; For AVX support - (UNSPEC_PCMP 166) - (UNSPEC_VPERMIL 167) - (UNSPEC_VPERMIL2 168) - (UNSPEC_VPERMIL2F128 169) - (UNSPEC_MASKLOAD 170) - (UNSPEC_MASKSTORE 171) - (UNSPEC_CAST 172) - (UNSPEC_VTESTP 173) - ]) - -(define_constants - [(UNSPECV_BLOCKAGE 0) - (UNSPECV_STACK_PROBE 1) - (UNSPECV_EMMS 2) - (UNSPECV_LDMXCSR 3) - (UNSPECV_STMXCSR 4) - (UNSPECV_FEMMS 5) - (UNSPECV_CLFLUSH 6) - (UNSPECV_ALIGN 7) - (UNSPECV_MONITOR 8) - (UNSPECV_MWAIT 9) - (UNSPECV_CMPXCHG 10) - (UNSPECV_XCHG 12) - (UNSPECV_LOCK 13) - (UNSPECV_PROLOGUE_USE 14) - (UNSPECV_CLD 15) - (UNSPECV_VZEROALL 16) - (UNSPECV_VZEROUPPER 17) - (UNSPECV_RDTSC 18) - (UNSPECV_RDTSCP 19) - (UNSPECV_RDPMC 20) - (UNSPECV_VSWAPMOV 21) - (UNSPECV_LLWP_INTRINSIC 22) - (UNSPECV_SLWP_INTRINSIC 23) - (UNSPECV_LWPVAL_INTRINSIC 24) - (UNSPECV_LWPINS_INTRINSIC 25) - ]) +(define_c_enum "unspec" [ + ;; Relocation specifiers + UNSPEC_GOT + UNSPEC_GOTOFF + UNSPEC_GOTPCREL + UNSPEC_GOTTPOFF + UNSPEC_TPOFF + UNSPEC_NTPOFF + UNSPEC_DTPOFF + UNSPEC_GOTNTPOFF + UNSPEC_INDNTPOFF + UNSPEC_PLTOFF + UNSPEC_MACHOPIC_OFFSET + + ;; Prologue support + UNSPEC_STACK_ALLOC + UNSPEC_SET_GOT + UNSPEC_SSE_PROLOGUE_SAVE + UNSPEC_REG_SAVE + UNSPEC_DEF_CFA + UNSPEC_SET_RIP + UNSPEC_SET_GOT_OFFSET + UNSPEC_MEMORY_BLOCKAGE + UNSPEC_SSE_PROLOGUE_SAVE_LOW + + ;; TLS support + UNSPEC_TP + UNSPEC_TLS_GD + UNSPEC_TLS_LD_BASE + UNSPEC_TLSDESC + + ;; Other random patterns + UNSPEC_SCAS + UNSPEC_FNSTSW + UNSPEC_SAHF + UNSPEC_PARITY + UNSPEC_FSTCW + UNSPEC_ADD_CARRY + UNSPEC_FLDCW + UNSPEC_REP + UNSPEC_LD_MPIC ; load_macho_picbase + UNSPEC_TRUNC_NOOP + + ;; For SSE/MMX support: + UNSPEC_FIX_NOTRUNC + UNSPEC_MASKMOV + UNSPEC_MOVMSK + UNSPEC_MOVNT + UNSPEC_MOVU + UNSPEC_RCP + UNSPEC_RSQRT + UNSPEC_SFENCE + UNSPEC_PFRCP + UNSPEC_PFRCPIT1 + UNSPEC_PFRCPIT2 + UNSPEC_PFRSQRT + UNSPEC_PFRSQIT1 + UNSPEC_MFENCE + UNSPEC_LFENCE + UNSPEC_PSADBW + UNSPEC_LDDQU + UNSPEC_MS_TO_SYSV_CALL + + ;; Generic math support + UNSPEC_COPYSIGN + UNSPEC_IEEE_MIN ; not commutative + UNSPEC_IEEE_MAX ; not commutative + + ;; x87 Floating point + UNSPEC_SIN + UNSPEC_COS + UNSPEC_FPATAN + UNSPEC_FYL2X + UNSPEC_FYL2XP1 + UNSPEC_FRNDINT + UNSPEC_FIST + UNSPEC_F2XM1 + UNSPEC_TAN + UNSPEC_FXAM + + ;; x87 Rounding + UNSPEC_FRNDINT_FLOOR + UNSPEC_FRNDINT_CEIL + UNSPEC_FRNDINT_TRUNC + UNSPEC_FRNDINT_MASK_PM + UNSPEC_FIST_FLOOR + UNSPEC_FIST_CEIL + + ;; x87 Double output FP + UNSPEC_SINCOS_COS + UNSPEC_SINCOS_SIN + UNSPEC_XTRACT_FRACT + UNSPEC_XTRACT_EXP + UNSPEC_FSCALE_FRACT + UNSPEC_FSCALE_EXP + UNSPEC_FPREM_F + UNSPEC_FPREM_U + UNSPEC_FPREM1_F + UNSPEC_FPREM1_U + + UNSPEC_C2_FLAG + UNSPEC_FXAM_MEM + + ;; SSP patterns + UNSPEC_SP_SET + UNSPEC_SP_TEST + UNSPEC_SP_TLS_SET + UNSPEC_SP_TLS_TEST + + ;; SSSE3 + UNSPEC_PSHUFB + UNSPEC_PSIGN + UNSPEC_PALIGNR + + ;; For SSE4A support + UNSPEC_EXTRQI + UNSPEC_EXTRQ + UNSPEC_INSERTQI + UNSPEC_INSERTQ + + ;; For SSE4.1 support + UNSPEC_BLENDV + UNSPEC_INSERTPS + UNSPEC_DP + UNSPEC_MOVNTDQA + UNSPEC_MPSADBW + UNSPEC_PHMINPOSUW + UNSPEC_PTEST + UNSPEC_ROUND + + ;; For SSE4.2 support + UNSPEC_CRC32 + UNSPEC_PCMPESTR + UNSPEC_PCMPISTR + + ;; For FMA4 support + UNSPEC_FMA4_INTRINSIC + UNSPEC_FMA4_FMADDSUB + UNSPEC_FMA4_FMSUBADD + UNSPEC_XOP_UNSIGNED_CMP + UNSPEC_XOP_TRUEFALSE + UNSPEC_XOP_PERMUTE + UNSPEC_FRCZ + + ;; For AES support + UNSPEC_AESENC + UNSPEC_AESENCLAST + UNSPEC_AESDEC + UNSPEC_AESDECLAST + UNSPEC_AESIMC + UNSPEC_AESKEYGENASSIST + + ;; For PCLMUL support + UNSPEC_PCLMUL + + ;; For AVX support + UNSPEC_PCMP + UNSPEC_VPERMIL + UNSPEC_VPERMIL2 + UNSPEC_VPERMIL2F128 + UNSPEC_MASKLOAD + UNSPEC_MASKSTORE + UNSPEC_CAST + UNSPEC_VTESTP +]) + +(define_c_enum "unspecv" [ + UNSPECV_BLOCKAGE + UNSPECV_STACK_PROBE + UNSPECV_EMMS + UNSPECV_LDMXCSR + UNSPECV_STMXCSR + UNSPECV_FEMMS + UNSPECV_CLFLUSH + UNSPECV_ALIGN + UNSPECV_MONITOR + UNSPECV_MWAIT + UNSPECV_CMPXCHG + UNSPECV_XCHG + UNSPECV_LOCK + UNSPECV_PROLOGUE_USE + UNSPECV_CLD + UNSPECV_VZEROALL + UNSPECV_VZEROUPPER + UNSPECV_RDTSC + UNSPECV_RDTSCP + UNSPECV_RDPMC + UNSPECV_VSWAPMOV + UNSPECV_LLWP_INTRINSIC + UNSPECV_SLWP_INTRINSIC + UNSPECV_LWPVAL_INTRINSIC + UNSPECV_LWPINS_INTRINSIC +]) ;; Constants to represent pcomtrue/pcomfalse variants (define_constants @@ -356,7 +357,7 @@ push,pop,call,callv,leave, str,bitmanip, fmov,fop,fsgn,fmul,fdiv,fpspc,fcmov,fcmp,fxch,fistp,fisttp,frndint, - sselog,sselog1,sseiadd,sseiadd1,sseishft,sseimul, + sselog,sselog1,sseiadd,sseiadd1,sseishft,sseishft1,sseimul, sse,ssemov,sseadd,ssemul,ssecmp,ssecomi,ssecvt,ssecvt1,sseicvt,ssediv,sseins, ssemuladd,sse4arg,lwp, mmx,mmxmov,mmxadd,mmxmul,mmxcmp,mmxcvt,mmxshft" @@ -371,7 +372,7 @@ (define_attr "unit" "integer,i387,sse,mmx,unknown" (cond [(eq_attr "type" "fmov,fop,fsgn,fmul,fdiv,fpspc,fcmov,fcmp,fxch,fistp,fisttp,frndint") (const_string "i387") - (eq_attr "type" "sselog,sselog1,sseiadd,sseiadd1,sseishft,sseimul, + (eq_attr "type" "sselog,sselog1,sseiadd,sseiadd1,sseishft,sseishft1,sseimul, sse,ssemov,sseadd,ssemul,ssecmp,ssecomi,ssecvt, ssecvt1,sseicvt,ssediv,sseins,ssemuladd,sse4arg") (const_string "sse") @@ -759,17 +760,31 @@ ;; Used in signed and unsigned divisions. (define_code_iterator any_div [div udiv]) +(define_code_attr extract_code + [(div "SIGN_EXTRACT") (udiv "ZERO_EXTRACT")]) ;; Instruction prefix for signed and unsigned operations. (define_code_attr sgnprefix [(sign_extend "i") (zero_extend "") (div "i") (udiv "")]) -;; All single word integer modes. +;; 64bit single word integer modes. +(define_mode_iterator SWI1248x [QI HI SI DI]) + +;; 64bit single word integer modes without QImode and HImode. +(define_mode_iterator SWI48x [SI DI]) + +;; Single word integer modes. (define_mode_iterator SWI [QI HI SI (DI "TARGET_64BIT")]) +;; Single word integer modes without SImode and DImode. +(define_mode_iterator SWI12 [QI HI]) + ;; Single word integer modes without DImode. (define_mode_iterator SWI124 [QI HI SI]) +;; Single word integer modes without QImode and DImode. +(define_mode_iterator SWI24 [HI SI]) + ;; Single word integer modes without QImode. (define_mode_iterator SWI248 [HI SI (DI "TARGET_64BIT")]) @@ -1584,13 +1599,47 @@ ;; Move instructions. -;; General case of fullword move. +(define_expand "movoi" + [(set (match_operand:OI 0 "nonimmediate_operand" "") + (match_operand:OI 1 "general_operand" ""))] + "TARGET_AVX" + "ix86_expand_move (OImode, operands); DONE;") -(define_expand "movsi" - [(set (match_operand:SI 0 "nonimmediate_operand" "") - (match_operand:SI 1 "general_operand" ""))] +(define_expand "movti" + [(set (match_operand:TI 0 "nonimmediate_operand" "") + (match_operand:TI 1 "nonimmediate_operand" ""))] + "TARGET_64BIT || TARGET_SSE" +{ + if (TARGET_64BIT) + ix86_expand_move (TImode, operands); + else if (push_operand (operands[0], TImode)) + ix86_expand_push (TImode, operands[1]); + else + ix86_expand_vector_move (TImode, operands); + DONE; +}) + +;; This expands to what emit_move_complex would generate if we didn't +;; have a movti pattern. Having this avoids problems with reload on +;; 32-bit targets when SSE is present, but doesn't seem to be harmful +;; to have around all the time. +(define_expand "movcdi" + [(set (match_operand:CDI 0 "nonimmediate_operand" "") + (match_operand:CDI 1 "general_operand" ""))] + "" +{ + if (push_operand (operands[0], CDImode)) + emit_move_complex_push (CDImode, operands[0], operands[1]); + else + emit_move_complex_parts (operands[0], operands[1]); + DONE; +}) + +(define_expand "mov" + [(set (match_operand:SWI1248x 0 "nonimmediate_operand" "") + (match_operand:SWI1248x 1 "general_operand" ""))] "" - "ix86_expand_move (SImode, operands); DONE;") + "ix86_expand_move (mode, operands); DONE;") ;; Push/pop instructions. They are separate since autoinc/dec is not a ;; general_operand. @@ -1601,6 +1650,79 @@ ;; targets without our curiosities, and it is just as easy to represent ;; this differently. +(define_insn "*pushdi2_rex64" + [(set (match_operand:DI 0 "push_operand" "=<,!<") + (match_operand:DI 1 "general_no_elim_operand" "re*m,n"))] + "TARGET_64BIT" + "@ + push{q}\t%1 + #" + [(set_attr "type" "push,multi") + (set_attr "mode" "DI")]) + +;; Convert impossible pushes of immediate to existing instructions. +;; First try to get scratch register and go through it. In case this +;; fails, push sign extended lower part first and then overwrite +;; upper part by 32bit move. +(define_peephole2 + [(match_scratch:DI 2 "r") + (set (match_operand:DI 0 "push_operand" "") + (match_operand:DI 1 "immediate_operand" ""))] + "TARGET_64BIT && !symbolic_operand (operands[1], DImode) + && !x86_64_immediate_operand (operands[1], DImode)" + [(set (match_dup 2) (match_dup 1)) + (set (match_dup 0) (match_dup 2))] + "") + +;; We need to define this as both peepholer and splitter for case +;; peephole2 pass is not run. +;; "&& 1" is needed to keep it from matching the previous pattern. +(define_peephole2 + [(set (match_operand:DI 0 "push_operand" "") + (match_operand:DI 1 "immediate_operand" ""))] + "TARGET_64BIT && !symbolic_operand (operands[1], DImode) + && !x86_64_immediate_operand (operands[1], DImode) && 1" + [(set (match_dup 0) (match_dup 1)) + (set (match_dup 2) (match_dup 3))] +{ + split_di (&operands[1], 1, &operands[2], &operands[3]); + + operands[1] = gen_lowpart (DImode, operands[2]); + operands[2] = gen_rtx_MEM (SImode, gen_rtx_PLUS (DImode, stack_pointer_rtx, + GEN_INT (4))); +}) + +(define_split + [(set (match_operand:DI 0 "push_operand" "") + (match_operand:DI 1 "immediate_operand" ""))] + "TARGET_64BIT && ((optimize > 0 && flag_peephole2) + ? epilogue_completed : reload_completed) + && !symbolic_operand (operands[1], DImode) + && !x86_64_immediate_operand (operands[1], DImode)" + [(set (match_dup 0) (match_dup 1)) + (set (match_dup 2) (match_dup 3))] +{ + split_di (&operands[1], 1, &operands[2], &operands[3]); + + operands[1] = gen_lowpart (DImode, operands[2]); + operands[2] = gen_rtx_MEM (SImode, gen_rtx_PLUS (DImode, stack_pointer_rtx, + GEN_INT (4))); +}) + +(define_insn "*pushdi2" + [(set (match_operand:DI 0 "push_operand" "=<") + (match_operand:DI 1 "general_no_elim_operand" "riF*m"))] + "!TARGET_64BIT" + "#") + +(define_split + [(set (match_operand:DI 0 "push_operand" "") + (match_operand:DI 1 "general_operand" ""))] + "!TARGET_64BIT && reload_completed + && !(MMX_REG_P (operands[1]) || SSE_REG_P (operands[1]))" + [(const_int 0)] + "ix86_split_long_move (operands); DONE;") + (define_insn "*pushsi2" [(set (match_operand:SI 0 "push_operand" "=<") (match_operand:SI 1 "general_no_elim_operand" "ri*m"))] @@ -1609,761 +1731,335 @@ [(set_attr "type" "push") (set_attr "mode" "SI")]) +;; emit_push_insn when it calls move_by_pieces requires an insn to +;; "push a byte/word". But actually we use pushl, which has the effect +;; of rounding the amount pushed up to a word. + ;; For 64BIT abi we always round up to 8 bytes. -(define_insn "*pushsi2_rex64" - [(set (match_operand:SI 0 "push_operand" "=X") - (match_operand:SI 1 "nonmemory_no_elim_operand" "ri"))] +(define_insn "*push2_rex64" + [(set (match_operand:SWI124 0 "push_operand" "=X") + (match_operand:SWI124 1 "nonmemory_no_elim_operand" "r"))] "TARGET_64BIT" "push{q}\t%q1" [(set_attr "type" "push") - (set_attr "mode" "SI")]) + (set_attr "mode" "DI")]) -(define_insn "*pushsi2_prologue" - [(set (match_operand:SI 0 "push_operand" "=<") - (match_operand:SI 1 "general_no_elim_operand" "ri*m")) - (clobber (mem:BLK (scratch)))] +(define_insn "*push2" + [(set (match_operand:SWI12 0 "push_operand" "=X") + (match_operand:SWI12 1 "nonmemory_no_elim_operand" "rn"))] "!TARGET_64BIT" - "push{l}\t%1" + "push{l}\t%k1" [(set_attr "type" "push") (set_attr "mode" "SI")]) -(define_insn "*popsi1_epilogue" +(define_insn "*push2_prologue" + [(set (match_operand:P 0 "push_operand" "=<") + (match_operand:P 1 "general_no_elim_operand" "r*m")) + (clobber (mem:BLK (scratch)))] + "" + "push{}\t%1" + [(set_attr "type" "push") + (set_attr "mode" "")]) + +(define_insn "popdi1" + [(set (match_operand:DI 0 "nonimmediate_operand" "=r*m") + (mem:DI (reg:DI SP_REG))) + (set (reg:DI SP_REG) + (plus:DI (reg:DI SP_REG) (const_int 8)))] + "TARGET_64BIT" + "pop{q}\t%0" + [(set_attr "type" "pop") + (set_attr "mode" "DI")]) + +(define_insn "popsi1" [(set (match_operand:SI 0 "nonimmediate_operand" "=r*m") (mem:SI (reg:SI SP_REG))) (set (reg:SI SP_REG) - (plus:SI (reg:SI SP_REG) (const_int 4))) - (clobber (mem:BLK (scratch)))] + (plus:SI (reg:SI SP_REG) (const_int 4)))] "!TARGET_64BIT" "pop{l}\t%0" [(set_attr "type" "pop") (set_attr "mode" "SI")]) -(define_insn "popsi1" +(define_insn "*popdi1_epilogue" + [(set (match_operand:DI 0 "nonimmediate_operand" "=r*m") + (mem:DI (reg:DI SP_REG))) + (set (reg:DI SP_REG) + (plus:DI (reg:DI SP_REG) (const_int 8))) + (clobber (mem:BLK (scratch)))] + "TARGET_64BIT" + "pop{q}\t%0" + [(set_attr "type" "pop") + (set_attr "mode" "DI")]) + +(define_insn "*popsi1_epilogue" [(set (match_operand:SI 0 "nonimmediate_operand" "=r*m") (mem:SI (reg:SI SP_REG))) (set (reg:SI SP_REG) - (plus:SI (reg:SI SP_REG) (const_int 4)))] + (plus:SI (reg:SI SP_REG) (const_int 4))) + (clobber (mem:BLK (scratch)))] "!TARGET_64BIT" "pop{l}\t%0" [(set_attr "type" "pop") (set_attr "mode" "SI")]) -(define_insn "*movsi_xor" - [(set (match_operand:SI 0 "register_operand" "=r") - (match_operand:SI 1 "const0_operand" "")) +(define_insn "*mov_xor" + [(set (match_operand:SWI48 0 "register_operand" "=r") + (match_operand:SWI48 1 "const0_operand" "")) (clobber (reg:CC FLAGS_REG))] "reload_completed" - "xor{l}\t%0, %0" + "xor{l}\t%k0, %k0" [(set_attr "type" "alu1") (set_attr "mode" "SI") (set_attr "length_immediate" "0")]) -(define_insn "*movsi_or" - [(set (match_operand:SI 0 "register_operand" "=r") - (match_operand:SI 1 "immediate_operand" "i")) +(define_insn "*mov_or" + [(set (match_operand:SWI48 0 "register_operand" "=r") + (match_operand:SWI48 1 "const_int_operand" "")) (clobber (reg:CC FLAGS_REG))] "reload_completed && operands[1] == constm1_rtx" -{ - operands[1] = constm1_rtx; - return "or{l}\t{%1, %0|%0, %1}"; -} + "or{}\t{%1, %0|%0, %1}" [(set_attr "type" "alu1") - (set_attr "mode" "SI") + (set_attr "mode" "") (set_attr "length_immediate" "1")]) -(define_insn "*movsi_1" - [(set (match_operand:SI 0 "nonimmediate_operand" - "=r,m ,*y,*y,?rm,?*y,*x,*x,?r ,m ,?*Yi,*x") - (match_operand:SI 1 "general_operand" - "g ,ri,C ,*y,*y ,rm ,C ,*x,*Yi,*x,r ,m "))] - "!(MEM_P (operands[0]) && MEM_P (operands[1]))" +(define_insn "*movoi_internal_avx" + [(set (match_operand:OI 0 "nonimmediate_operand" "=x,x,m") + (match_operand:OI 1 "vector_move_operand" "C,xm,x"))] + "TARGET_AVX && !(MEM_P (operands[0]) && MEM_P (operands[1]))" { - switch (get_attr_type (insn)) + switch (which_alternative) { - case TYPE_SSELOG1: - if (get_attr_mode (insn) == MODE_TI) - return "%vpxor\t%0, %d0"; - return "%vxorps\t%0, %d0"; + case 0: + return "vxorps\t%0, %0, %0"; + case 1: + case 2: + if (misaligned_operand (operands[0], OImode) + || misaligned_operand (operands[1], OImode)) + return "vmovdqu\t{%1, %0|%0, %1}"; + else + return "vmovdqa\t{%1, %0|%0, %1}"; + default: + gcc_unreachable (); + } +} + [(set_attr "type" "sselog1,ssemov,ssemov") + (set_attr "prefix" "vex") + (set_attr "mode" "OI")]) - case TYPE_SSEMOV: - switch (get_attr_mode (insn)) +(define_insn "*movti_internal_rex64" + [(set (match_operand:TI 0 "nonimmediate_operand" "=!r,o,x,x,xm") + (match_operand:TI 1 "general_operand" "riFo,riF,C,xm,x"))] + "TARGET_64BIT && !(MEM_P (operands[0]) && MEM_P (operands[1]))" +{ + switch (which_alternative) + { + case 0: + case 1: + return "#"; + case 2: + if (get_attr_mode (insn) == MODE_V4SF) + return "%vxorps\t%0, %d0"; + else + return "%vpxor\t%0, %d0"; + case 3: + case 4: + /* TDmode values are passed as TImode on the stack. Moving them + to stack may result in unaligned memory access. */ + if (misaligned_operand (operands[0], TImode) + || misaligned_operand (operands[1], TImode)) { - case MODE_TI: - return "%vmovdqa\t{%1, %0|%0, %1}"; - case MODE_V4SF: - return "%vmovaps\t{%1, %0|%0, %1}"; - case MODE_SI: - return "%vmovd\t{%1, %0|%0, %1}"; - case MODE_SF: - return "%vmovss\t{%1, %0|%0, %1}"; - default: - gcc_unreachable (); + if (get_attr_mode (insn) == MODE_V4SF) + return "%vmovups\t{%1, %0|%0, %1}"; + else + return "%vmovdqu\t{%1, %0|%0, %1}"; + } + else + { + if (get_attr_mode (insn) == MODE_V4SF) + return "%vmovaps\t{%1, %0|%0, %1}"; + else + return "%vmovdqa\t{%1, %0|%0, %1}"; } - - case TYPE_MMX: - return "pxor\t%0, %0"; - - case TYPE_MMXMOV: - if (get_attr_mode (insn) == MODE_DI) - return "movq\t{%1, %0|%0, %1}"; - return "movd\t{%1, %0|%0, %1}"; - - case TYPE_LEA: - return "lea{l}\t{%1, %0|%0, %1}"; - default: - gcc_assert (!flag_pic || LEGITIMATE_PIC_OPERAND_P (operands[1])); - return "mov{l}\t{%1, %0|%0, %1}"; + gcc_unreachable (); } } - [(set (attr "type") - (cond [(eq_attr "alternative" "2") - (const_string "mmx") - (eq_attr "alternative" "3,4,5") - (const_string "mmxmov") - (eq_attr "alternative" "6") - (const_string "sselog1") - (eq_attr "alternative" "7,8,9,10,11") - (const_string "ssemov") - (match_operand:DI 1 "pic_32bit_operand" "") - (const_string "lea") - ] - (const_string "imov"))) - (set (attr "prefix") - (if_then_else (eq_attr "alternative" "0,1,2,3,4,5") - (const_string "orig") - (const_string "maybe_vex"))) - (set (attr "prefix_data16") - (if_then_else (and (eq_attr "type" "ssemov") (eq_attr "mode" "SI")) - (const_string "1") - (const_string "*"))) - (set (attr "mode") - (cond [(eq_attr "alternative" "2,3") - (const_string "DI") - (eq_attr "alternative" "6,7") - (if_then_else - (eq (symbol_ref "TARGET_SSE2") (const_int 0)) - (const_string "V4SF") - (const_string "TI")) - (and (eq_attr "alternative" "8,9,10,11") - (eq (symbol_ref "TARGET_SSE2") (const_int 0))) - (const_string "SF") - ] - (const_string "SI")))]) - -;; Stores and loads of ax to arbitrary constant address. -;; We fake an second form of instruction to force reload to load address -;; into register when rax is not available -(define_insn "*movabssi_1_rex64" - [(set (mem:SI (match_operand:DI 0 "x86_64_movabs_operand" "i,r")) - (match_operand:SI 1 "nonmemory_operand" "a,er"))] - "TARGET_64BIT && ix86_check_movabs (insn, 0)" - "@ - movabs{l}\t{%1, %P0|%P0, %1} - mov{l}\t{%1, %a0|%a0, %1}" - [(set_attr "type" "imov") - (set_attr "modrm" "0,*") - (set_attr "length_address" "8,0") - (set_attr "length_immediate" "0,*") - (set_attr "memory" "store") - (set_attr "mode" "SI")]) - -(define_insn "*movabssi_2_rex64" - [(set (match_operand:SI 0 "register_operand" "=a,r") - (mem:SI (match_operand:DI 1 "x86_64_movabs_operand" "i,r")))] - "TARGET_64BIT && ix86_check_movabs (insn, 1)" - "@ - movabs{l}\t{%P1, %0|%0, %P1} - mov{l}\t{%a1, %0|%0, %a1}" - [(set_attr "type" "imov") - (set_attr "modrm" "0,*") - (set_attr "length_address" "8,0") - (set_attr "length_immediate" "0") - (set_attr "memory" "load") - (set_attr "mode" "SI")]) - -(define_insn "*swapsi" - [(set (match_operand:SI 0 "register_operand" "+r") - (match_operand:SI 1 "register_operand" "+r")) - (set (match_dup 1) - (match_dup 0))] - "" - "xchg{l}\t%1, %0" - [(set_attr "type" "imov") - (set_attr "mode" "SI") - (set_attr "pent_pair" "np") - (set_attr "athlon_decode" "vector") - (set_attr "amdfam10_decode" "double")]) - -(define_expand "movhi" - [(set (match_operand:HI 0 "nonimmediate_operand" "") - (match_operand:HI 1 "general_operand" ""))] - "" - "ix86_expand_move (HImode, operands); DONE;") - -(define_insn "*pushhi2" - [(set (match_operand:HI 0 "push_operand" "=X") - (match_operand:HI 1 "nonmemory_no_elim_operand" "rn"))] - "!TARGET_64BIT" - "push{l}\t%k1" - [(set_attr "type" "push") - (set_attr "mode" "SI")]) - -;; For 64BIT abi we always round up to 8 bytes. -(define_insn "*pushhi2_rex64" - [(set (match_operand:HI 0 "push_operand" "=X") - (match_operand:HI 1 "nonmemory_no_elim_operand" "rn"))] - "TARGET_64BIT" - "push{q}\t%q1" - [(set_attr "type" "push") - (set_attr "mode" "DI")]) - -(define_insn "*movhi_1" - [(set (match_operand:HI 0 "nonimmediate_operand" "=r,r,r,m") - (match_operand:HI 1 "general_operand" "r,rn,rm,rn"))] - "!(MEM_P (operands[0]) && MEM_P (operands[1]))" -{ - switch (get_attr_type (insn)) - { - case TYPE_IMOVX: - /* movzwl is faster than movw on p2 due to partial word stalls, - though not as fast as an aligned movl. */ - return "movz{wl|x}\t{%1, %k0|%k0, %1}"; - default: - if (get_attr_mode (insn) == MODE_SI) - return "mov{l}\t{%k1, %k0|%k0, %k1}"; - else - return "mov{w}\t{%1, %0|%0, %1}"; - } -} - [(set (attr "type") - (cond [(ne (symbol_ref "optimize_function_for_size_p (cfun)") (const_int 0)) - (const_string "imov") - (and (eq_attr "alternative" "0") - (ior (eq (symbol_ref "TARGET_PARTIAL_REG_STALL") - (const_int 0)) - (eq (symbol_ref "TARGET_HIMODE_MATH") - (const_int 0)))) - (const_string "imov") - (and (eq_attr "alternative" "1,2") - (match_operand:HI 1 "aligned_operand" "")) - (const_string "imov") - (and (ne (symbol_ref "TARGET_MOVX") - (const_int 0)) - (eq_attr "alternative" "0,2")) - (const_string "imovx") - ] - (const_string "imov"))) - (set (attr "mode") - (cond [(eq_attr "type" "imovx") - (const_string "SI") - (and (eq_attr "alternative" "1,2") - (match_operand:HI 1 "aligned_operand" "")) - (const_string "SI") - (and (eq_attr "alternative" "0") - (ior (eq (symbol_ref "TARGET_PARTIAL_REG_STALL") - (const_int 0)) - (eq (symbol_ref "TARGET_HIMODE_MATH") - (const_int 0)))) - (const_string "SI") - ] - (const_string "HI")))]) - -;; Stores and loads of ax to arbitrary constant address. -;; We fake an second form of instruction to force reload to load address -;; into register when rax is not available -(define_insn "*movabshi_1_rex64" - [(set (mem:HI (match_operand:DI 0 "x86_64_movabs_operand" "i,r")) - (match_operand:HI 1 "nonmemory_operand" "a,er"))] - "TARGET_64BIT && ix86_check_movabs (insn, 0)" - "@ - movabs{w}\t{%1, %P0|%P0, %1} - mov{w}\t{%1, %a0|%a0, %1}" - [(set_attr "type" "imov") - (set_attr "modrm" "0,*") - (set_attr "length_address" "8,0") - (set_attr "length_immediate" "0,*") - (set_attr "memory" "store") - (set_attr "mode" "HI")]) - -(define_insn "*movabshi_2_rex64" - [(set (match_operand:HI 0 "register_operand" "=a,r") - (mem:HI (match_operand:DI 1 "x86_64_movabs_operand" "i,r")))] - "TARGET_64BIT && ix86_check_movabs (insn, 1)" - "@ - movabs{w}\t{%P1, %0|%0, %P1} - mov{w}\t{%a1, %0|%0, %a1}" - [(set_attr "type" "imov") - (set_attr "modrm" "0,*") - (set_attr "length_address" "8,0") - (set_attr "length_immediate" "0") - (set_attr "memory" "load") - (set_attr "mode" "HI")]) - -(define_insn "*swaphi_1" - [(set (match_operand:HI 0 "register_operand" "+r") - (match_operand:HI 1 "register_operand" "+r")) - (set (match_dup 1) - (match_dup 0))] - "!TARGET_PARTIAL_REG_STALL || optimize_function_for_size_p (cfun)" - "xchg{l}\t%k1, %k0" - [(set_attr "type" "imov") - (set_attr "mode" "SI") - (set_attr "pent_pair" "np") - (set_attr "athlon_decode" "vector") - (set_attr "amdfam10_decode" "double")]) - -;; Not added amdfam10_decode since TARGET_PARTIAL_REG_STALL is disabled for AMDFAM10 -(define_insn "*swaphi_2" - [(set (match_operand:HI 0 "register_operand" "+r") - (match_operand:HI 1 "register_operand" "+r")) - (set (match_dup 1) - (match_dup 0))] - "TARGET_PARTIAL_REG_STALL" - "xchg{w}\t%1, %0" - [(set_attr "type" "imov") - (set_attr "mode" "HI") - (set_attr "pent_pair" "np") - (set_attr "athlon_decode" "vector")]) - -(define_expand "movstricthi" - [(set (strict_low_part (match_operand:HI 0 "nonimmediate_operand" "")) - (match_operand:HI 1 "general_operand" ""))] - "" -{ - if (TARGET_PARTIAL_REG_STALL && optimize_function_for_speed_p (cfun)) - FAIL; - /* Don't generate memory->memory moves, go through a register */ - if (MEM_P (operands[0]) && MEM_P (operands[1])) - operands[1] = force_reg (HImode, operands[1]); -}) - -(define_insn "*movstricthi_1" - [(set (strict_low_part (match_operand:HI 0 "nonimmediate_operand" "+rm,r")) - (match_operand:HI 1 "general_operand" "rn,m"))] - "(! TARGET_PARTIAL_REG_STALL || optimize_function_for_size_p (cfun)) - && !(MEM_P (operands[0]) && MEM_P (operands[1]))" - "mov{w}\t{%1, %0|%0, %1}" - [(set_attr "type" "imov") - (set_attr "mode" "HI")]) - -(define_insn "*movstricthi_xor" - [(set (strict_low_part (match_operand:HI 0 "register_operand" "+r")) - (match_operand:HI 1 "const0_operand" "")) - (clobber (reg:CC FLAGS_REG))] - "reload_completed" - "xor{w}\t%0, %0" - [(set_attr "type" "alu1") - (set_attr "mode" "HI") - (set_attr "length_immediate" "0")]) - -(define_expand "movqi" - [(set (match_operand:QI 0 "nonimmediate_operand" "") - (match_operand:QI 1 "general_operand" ""))] - "" - "ix86_expand_move (QImode, operands); DONE;") - -;; emit_push_insn when it calls move_by_pieces requires an insn to -;; "push a byte". But actually we use pushl, which has the effect -;; of rounding the amount pushed up to a word. - -(define_insn "*pushqi2" - [(set (match_operand:QI 0 "push_operand" "=X") - (match_operand:QI 1 "nonmemory_no_elim_operand" "rn"))] - "!TARGET_64BIT" - "push{l}\t%k1" - [(set_attr "type" "push") - (set_attr "mode" "SI")]) - -;; For 64BIT abi we always round up to 8 bytes. -(define_insn "*pushqi2_rex64" - [(set (match_operand:QI 0 "push_operand" "=X") - (match_operand:QI 1 "nonmemory_no_elim_operand" "qn"))] - "TARGET_64BIT" - "push{q}\t%q1" - [(set_attr "type" "push") - (set_attr "mode" "DI")]) - -;; Situation is quite tricky about when to choose full sized (SImode) move -;; over QImode moves. For Q_REG -> Q_REG move we use full size only for -;; partial register dependency machines (such as AMD Athlon), where QImode -;; moves issue extra dependency and for partial register stalls machines -;; that don't use QImode patterns (and QImode move cause stall on the next -;; instruction). -;; -;; For loads of Q_REG to NONQ_REG we use full sized moves except for partial -;; register stall machines with, where we use QImode instructions, since -;; partial register stall can be caused there. Then we use movzx. -(define_insn "*movqi_1" - [(set (match_operand:QI 0 "nonimmediate_operand" "=q,q ,q ,r,r ,?r,m") - (match_operand:QI 1 "general_operand" " q,qn,qm,q,rn,qm,qn"))] - "!(MEM_P (operands[0]) && MEM_P (operands[1]))" -{ - switch (get_attr_type (insn)) - { - case TYPE_IMOVX: - gcc_assert (ANY_QI_REG_P (operands[1]) || MEM_P (operands[1])); - return "movz{bl|x}\t{%1, %k0|%k0, %1}"; - default: - if (get_attr_mode (insn) == MODE_SI) - return "mov{l}\t{%k1, %k0|%k0, %k1}"; - else - return "mov{b}\t{%1, %0|%0, %1}"; - } -} - [(set (attr "type") - (cond [(and (eq_attr "alternative" "5") - (not (match_operand:QI 1 "aligned_operand" ""))) - (const_string "imovx") - (ne (symbol_ref "optimize_function_for_size_p (cfun)") (const_int 0)) - (const_string "imov") - (and (eq_attr "alternative" "3") - (ior (eq (symbol_ref "TARGET_PARTIAL_REG_STALL") - (const_int 0)) - (eq (symbol_ref "TARGET_QIMODE_MATH") - (const_int 0)))) - (const_string "imov") - (eq_attr "alternative" "3,5") - (const_string "imovx") - (and (ne (symbol_ref "TARGET_MOVX") - (const_int 0)) - (eq_attr "alternative" "2")) - (const_string "imovx") - ] - (const_string "imov"))) - (set (attr "mode") - (cond [(eq_attr "alternative" "3,4,5") - (const_string "SI") - (eq_attr "alternative" "6") - (const_string "QI") - (eq_attr "type" "imovx") - (const_string "SI") - (and (eq_attr "type" "imov") - (and (eq_attr "alternative" "0,1") - (and (ne (symbol_ref "TARGET_PARTIAL_REG_DEPENDENCY") - (const_int 0)) - (and (eq (symbol_ref "optimize_function_for_size_p (cfun)") - (const_int 0)) - (eq (symbol_ref "TARGET_PARTIAL_REG_STALL") - (const_int 0)))))) - (const_string "SI") - ;; Avoid partial register stalls when not using QImode arithmetic - (and (eq_attr "type" "imov") - (and (eq_attr "alternative" "0,1") - (and (ne (symbol_ref "TARGET_PARTIAL_REG_STALL") - (const_int 0)) - (eq (symbol_ref "TARGET_QIMODE_MATH") - (const_int 0))))) - (const_string "SI") - ] - (const_string "QI")))]) - -(define_insn "*swapqi_1" - [(set (match_operand:QI 0 "register_operand" "+r") - (match_operand:QI 1 "register_operand" "+r")) - (set (match_dup 1) - (match_dup 0))] - "!TARGET_PARTIAL_REG_STALL || optimize_function_for_size_p (cfun)" - "xchg{l}\t%k1, %k0" - [(set_attr "type" "imov") - (set_attr "mode" "SI") - (set_attr "pent_pair" "np") - (set_attr "athlon_decode" "vector") - (set_attr "amdfam10_decode" "vector")]) - -;; Not added amdfam10_decode since TARGET_PARTIAL_REG_STALL is disabled for AMDFAM10 -(define_insn "*swapqi_2" - [(set (match_operand:QI 0 "register_operand" "+q") - (match_operand:QI 1 "register_operand" "+q")) - (set (match_dup 1) - (match_dup 0))] - "TARGET_PARTIAL_REG_STALL" - "xchg{b}\t%1, %0" - [(set_attr "type" "imov") - (set_attr "mode" "QI") - (set_attr "pent_pair" "np") - (set_attr "athlon_decode" "vector")]) - -(define_expand "movstrictqi" - [(set (strict_low_part (match_operand:QI 0 "nonimmediate_operand" "")) - (match_operand:QI 1 "general_operand" ""))] - "" -{ - if (TARGET_PARTIAL_REG_STALL && optimize_function_for_speed_p (cfun)) - FAIL; - /* Don't generate memory->memory moves, go through a register. */ - if (MEM_P (operands[0]) && MEM_P (operands[1])) - operands[1] = force_reg (QImode, operands[1]); -}) - -(define_insn "*movstrictqi_1" - [(set (strict_low_part (match_operand:QI 0 "nonimmediate_operand" "+qm,q")) - (match_operand:QI 1 "general_operand" "*qn,m"))] - "(! TARGET_PARTIAL_REG_STALL || optimize_function_for_size_p (cfun)) - && !(MEM_P (operands[0]) && MEM_P (operands[1]))" - "mov{b}\t{%1, %0|%0, %1}" - [(set_attr "type" "imov") - (set_attr "mode" "QI")]) - -(define_insn "*movstrictqi_xor" - [(set (strict_low_part (match_operand:QI 0 "q_regs_operand" "+q")) - (match_operand:QI 1 "const0_operand" "")) - (clobber (reg:CC FLAGS_REG))] - "reload_completed" - "xor{b}\t%0, %0" - [(set_attr "type" "alu1") - (set_attr "mode" "QI") - (set_attr "length_immediate" "0")]) - -(define_insn "*movsi_extv_1" - [(set (match_operand:SI 0 "register_operand" "=R") - (sign_extract:SI (match_operand 1 "ext_register_operand" "Q") - (const_int 8) - (const_int 8)))] - "" - "movs{bl|x}\t{%h1, %0|%0, %h1}" - [(set_attr "type" "imovx") - (set_attr "mode" "SI")]) - -(define_insn "*movhi_extv_1" - [(set (match_operand:HI 0 "register_operand" "=R") - (sign_extract:HI (match_operand 1 "ext_register_operand" "Q") - (const_int 8) - (const_int 8)))] - "" - "movs{bl|x}\t{%h1, %k0|%k0, %h1}" - [(set_attr "type" "imovx") - (set_attr "mode" "SI")]) - -(define_insn "*movqi_extv_1" - [(set (match_operand:QI 0 "nonimmediate_operand" "=Qm,?r") - (sign_extract:QI (match_operand 1 "ext_register_operand" "Q,Q") - (const_int 8) - (const_int 8)))] - "!TARGET_64BIT" -{ - switch (get_attr_type (insn)) - { - case TYPE_IMOVX: - return "movs{bl|x}\t{%h1, %k0|%k0, %h1}"; - default: - return "mov{b}\t{%h1, %0|%0, %h1}"; - } -} - [(set (attr "type") - (if_then_else (and (match_operand:QI 0 "register_operand" "") - (ior (not (match_operand:QI 0 "q_regs_operand" "")) - (ne (symbol_ref "TARGET_MOVX") - (const_int 0)))) - (const_string "imovx") - (const_string "imov"))) - (set (attr "mode") - (if_then_else (eq_attr "type" "imovx") - (const_string "SI") - (const_string "QI")))]) - -(define_insn "*movqi_extv_1_rex64" - [(set (match_operand:QI 0 "register_operand" "=Q,?R") - (sign_extract:QI (match_operand 1 "ext_register_operand" "Q,Q") - (const_int 8) - (const_int 8)))] - "TARGET_64BIT" -{ - switch (get_attr_type (insn)) - { - case TYPE_IMOVX: - return "movs{bl|x}\t{%h1, %k0|%k0, %h1}"; - default: - return "mov{b}\t{%h1, %0|%0, %h1}"; - } -} - [(set (attr "type") - (if_then_else (and (match_operand:QI 0 "register_operand" "") - (ior (not (match_operand:QI 0 "q_regs_operand" "")) - (ne (symbol_ref "TARGET_MOVX") - (const_int 0)))) - (const_string "imovx") - (const_string "imov"))) + [(set_attr "type" "*,*,sselog1,ssemov,ssemov") + (set_attr "prefix" "*,*,maybe_vex,maybe_vex,maybe_vex") (set (attr "mode") - (if_then_else (eq_attr "type" "imovx") - (const_string "SI") - (const_string "QI")))]) - -;; Stores and loads of ax to arbitrary constant address. -;; We fake an second form of instruction to force reload to load address -;; into register when rax is not available -(define_insn "*movabsqi_1_rex64" - [(set (mem:QI (match_operand:DI 0 "x86_64_movabs_operand" "i,r")) - (match_operand:QI 1 "nonmemory_operand" "a,er"))] - "TARGET_64BIT && ix86_check_movabs (insn, 0)" - "@ - movabs{b}\t{%1, %P0|%P0, %1} - mov{b}\t{%1, %a0|%a0, %1}" - [(set_attr "type" "imov") - (set_attr "modrm" "0,*") - (set_attr "length_address" "8,0") - (set_attr "length_immediate" "0,*") - (set_attr "memory" "store") - (set_attr "mode" "QI")]) - -(define_insn "*movabsqi_2_rex64" - [(set (match_operand:QI 0 "register_operand" "=a,r") - (mem:QI (match_operand:DI 1 "x86_64_movabs_operand" "i,r")))] - "TARGET_64BIT && ix86_check_movabs (insn, 1)" - "@ - movabs{b}\t{%P1, %0|%0, %P1} - mov{b}\t{%a1, %0|%0, %a1}" - [(set_attr "type" "imov") - (set_attr "modrm" "0,*") - (set_attr "length_address" "8,0") - (set_attr "length_immediate" "0") - (set_attr "memory" "load") - (set_attr "mode" "QI")]) - -(define_insn "*movdi_extzv_1" - [(set (match_operand:DI 0 "register_operand" "=R") - (zero_extract:DI (match_operand 1 "ext_register_operand" "Q") - (const_int 8) - (const_int 8)))] - "TARGET_64BIT" - "movz{bl|x}\t{%h1, %k0|%k0, %h1}" - [(set_attr "type" "imovx") - (set_attr "mode" "SI")]) + (cond [(eq_attr "alternative" "2,3") + (if_then_else + (ne (symbol_ref "optimize_function_for_size_p (cfun)") + (const_int 0)) + (const_string "V4SF") + (const_string "TI")) + (eq_attr "alternative" "4") + (if_then_else + (ior (ne (symbol_ref "TARGET_SSE_TYPELESS_STORES") + (const_int 0)) + (ne (symbol_ref "optimize_function_for_size_p (cfun)") + (const_int 0))) + (const_string "V4SF") + (const_string "TI"))] + (const_string "DI")))]) -(define_insn "*movsi_extzv_1" - [(set (match_operand:SI 0 "register_operand" "=R") - (zero_extract:SI (match_operand 1 "ext_register_operand" "Q") - (const_int 8) - (const_int 8)))] - "" - "movz{bl|x}\t{%h1, %0|%0, %h1}" - [(set_attr "type" "imovx") - (set_attr "mode" "SI")]) +(define_split + [(set (match_operand:TI 0 "nonimmediate_operand" "") + (match_operand:TI 1 "general_operand" ""))] + "reload_completed + && !SSE_REG_P (operands[0]) && !SSE_REG_P (operands[1])" + [(const_int 0)] + "ix86_split_long_move (operands); DONE;") -(define_insn "*movqi_extzv_2" - [(set (match_operand:QI 0 "nonimmediate_operand" "=Qm,?R") - (subreg:QI (zero_extract:SI (match_operand 1 "ext_register_operand" "Q,Q") - (const_int 8) - (const_int 8)) 0))] - "!TARGET_64BIT" +(define_insn "*movti_internal_sse" + [(set (match_operand:TI 0 "nonimmediate_operand" "=x,x,m") + (match_operand:TI 1 "vector_move_operand" "C,xm,x"))] + "TARGET_SSE && !TARGET_64BIT + && !(MEM_P (operands[0]) && MEM_P (operands[1]))" { - switch (get_attr_type (insn)) + switch (which_alternative) { - case TYPE_IMOVX: - return "movz{bl|x}\t{%h1, %k0|%k0, %h1}"; + case 0: + if (get_attr_mode (insn) == MODE_V4SF) + return "%vxorps\t%0, %d0"; + else + return "%vpxor\t%0, %d0"; + case 1: + case 2: + /* TDmode values are passed as TImode on the stack. Moving them + to stack may result in unaligned memory access. */ + if (misaligned_operand (operands[0], TImode) + || misaligned_operand (operands[1], TImode)) + { + if (get_attr_mode (insn) == MODE_V4SF) + return "%vmovups\t{%1, %0|%0, %1}"; + else + return "%vmovdqu\t{%1, %0|%0, %1}"; + } + else + { + if (get_attr_mode (insn) == MODE_V4SF) + return "%vmovaps\t{%1, %0|%0, %1}"; + else + return "%vmovdqa\t{%1, %0|%0, %1}"; + } default: - return "mov{b}\t{%h1, %0|%0, %h1}"; + gcc_unreachable (); } } - [(set (attr "type") - (if_then_else (and (match_operand:QI 0 "register_operand" "") - (ior (not (match_operand:QI 0 "q_regs_operand" "")) - (ne (symbol_ref "TARGET_MOVX") - (const_int 0)))) - (const_string "imovx") - (const_string "imov"))) + [(set_attr "type" "sselog1,ssemov,ssemov") + (set_attr "prefix" "maybe_vex") (set (attr "mode") - (if_then_else (eq_attr "type" "imovx") - (const_string "SI") - (const_string "QI")))]) + (cond [(ior (eq (symbol_ref "TARGET_SSE2") (const_int 0)) + (ne (symbol_ref "optimize_function_for_size_p (cfun)") + (const_int 0))) + (const_string "V4SF") + (and (eq_attr "alternative" "2") + (ne (symbol_ref "TARGET_SSE_TYPELESS_STORES") + (const_int 0))) + (const_string "V4SF")] + (const_string "TI")))]) -(define_insn "*movqi_extzv_2_rex64" - [(set (match_operand:QI 0 "register_operand" "=Q,?R") - (subreg:QI (zero_extract:SI (match_operand 1 "ext_register_operand" "Q,Q") - (const_int 8) - (const_int 8)) 0))] - "TARGET_64BIT" +(define_insn "*movdi_internal_rex64" + [(set (match_operand:DI 0 "nonimmediate_operand" + "=r,r ,r,m ,!m,*y,*y,?r ,m ,?*Ym,?*y,*x,*x,?r ,m,?*Yi,*x,?*x,?*Ym") + (match_operand:DI 1 "general_operand" + "Z ,rem,i,re,n ,C ,*y,*Ym,*y,r ,m ,C ,*x,*Yi,*x,r ,m ,*Ym,*x"))] + "TARGET_64BIT && !(MEM_P (operands[0]) && MEM_P (operands[1]))" { switch (get_attr_type (insn)) { - case TYPE_IMOVX: - return "movz{bl|x}\t{%h1, %k0|%k0, %h1}"; - default: - return "mov{b}\t{%h1, %0|%0, %h1}"; - } -} - [(set (attr "type") - (if_then_else (ior (not (match_operand:QI 0 "q_regs_operand" "")) - (ne (symbol_ref "TARGET_MOVX") - (const_int 0))) - (const_string "imovx") - (const_string "imov"))) - (set (attr "mode") - (if_then_else (eq_attr "type" "imovx") - (const_string "SI") - (const_string "QI")))]) + case TYPE_SSECVT: + if (SSE_REG_P (operands[0])) + return "movq2dq\t{%1, %0|%0, %1}"; + else + return "movdq2q\t{%1, %0|%0, %1}"; -(define_insn "movsi_insv_1" - [(set (zero_extract:SI (match_operand 0 "ext_register_operand" "+Q") - (const_int 8) - (const_int 8)) - (match_operand:SI 1 "general_operand" "Qmn"))] - "!TARGET_64BIT" - "mov{b}\t{%b1, %h0|%h0, %b1}" - [(set_attr "type" "imov") - (set_attr "mode" "QI")]) + case TYPE_SSEMOV: + if (TARGET_AVX) + { + if (get_attr_mode (insn) == MODE_TI) + return "vmovdqa\t{%1, %0|%0, %1}"; + else + return "vmovq\t{%1, %0|%0, %1}"; + } -(define_insn "*movsi_insv_1_rex64" - [(set (zero_extract:SI (match_operand 0 "ext_register_operand" "+Q") - (const_int 8) - (const_int 8)) - (match_operand:SI 1 "nonmemory_operand" "Qn"))] - "TARGET_64BIT" - "mov{b}\t{%b1, %h0|%h0, %b1}" - [(set_attr "type" "imov") - (set_attr "mode" "QI")]) + if (get_attr_mode (insn) == MODE_TI) + return "movdqa\t{%1, %0|%0, %1}"; + /* FALLTHRU */ -(define_insn "movdi_insv_1_rex64" - [(set (zero_extract:DI (match_operand 0 "ext_register_operand" "+Q") - (const_int 8) - (const_int 8)) - (match_operand:DI 1 "nonmemory_operand" "Qn"))] - "TARGET_64BIT" - "mov{b}\t{%b1, %h0|%h0, %b1}" - [(set_attr "type" "imov") - (set_attr "mode" "QI")]) + case TYPE_MMXMOV: + /* Moves from and into integer register is done using movd + opcode with REX prefix. */ + if (GENERAL_REG_P (operands[0]) || GENERAL_REG_P (operands[1])) + return "movd\t{%1, %0|%0, %1}"; + return "movq\t{%1, %0|%0, %1}"; -(define_insn "*movqi_insv_2" - [(set (zero_extract:SI (match_operand 0 "ext_register_operand" "+Q") - (const_int 8) - (const_int 8)) - (lshiftrt:SI (match_operand:SI 1 "register_operand" "Q") - (const_int 8)))] - "" - "mov{b}\t{%h1, %h0|%h0, %h1}" - [(set_attr "type" "imov") - (set_attr "mode" "QI")]) + case TYPE_SSELOG1: + return "%vpxor\t%0, %d0"; -(define_expand "movdi" - [(set (match_operand:DI 0 "nonimmediate_operand" "") - (match_operand:DI 1 "general_operand" ""))] - "" - "ix86_expand_move (DImode, operands); DONE;") + case TYPE_MMX: + return "pxor\t%0, %0"; -(define_insn "*pushdi" - [(set (match_operand:DI 0 "push_operand" "=<") - (match_operand:DI 1 "general_no_elim_operand" "riF*m"))] - "!TARGET_64BIT" - "#") + case TYPE_MULTI: + return "#"; -(define_insn "*pushdi2_rex64" - [(set (match_operand:DI 0 "push_operand" "=<,!<") - (match_operand:DI 1 "general_no_elim_operand" "re*m,n"))] - "TARGET_64BIT" - "@ - push{q}\t%1 - #" - [(set_attr "type" "push,multi") - (set_attr "mode" "DI")]) + case TYPE_LEA: + return "lea{q}\t{%a1, %0|%0, %a1}"; + + default: + gcc_assert (!flag_pic || LEGITIMATE_PIC_OPERAND_P (operands[1])); + if (get_attr_mode (insn) == MODE_SI) + return "mov{l}\t{%k1, %k0|%k0, %k1}"; + else if (which_alternative == 2) + return "movabs{q}\t{%1, %0|%0, %1}"; + else + return "mov{q}\t{%1, %0|%0, %1}"; + } +} + [(set (attr "type") + (cond [(eq_attr "alternative" "5") + (const_string "mmx") + (eq_attr "alternative" "6,7,8,9,10") + (const_string "mmxmov") + (eq_attr "alternative" "11") + (const_string "sselog1") + (eq_attr "alternative" "12,13,14,15,16") + (const_string "ssemov") + (eq_attr "alternative" "17,18") + (const_string "ssecvt") + (eq_attr "alternative" "4") + (const_string "multi") + (match_operand:DI 1 "pic_32bit_operand" "") + (const_string "lea") + ] + (const_string "imov"))) + (set (attr "modrm") + (if_then_else + (and (eq_attr "alternative" "2") (eq_attr "type" "imov")) + (const_string "0") + (const_string "*"))) + (set (attr "length_immediate") + (if_then_else + (and (eq_attr "alternative" "2") (eq_attr "type" "imov")) + (const_string "8") + (const_string "*"))) + (set_attr "prefix_rex" "*,*,*,*,*,*,*,1,*,1,*,*,*,*,*,*,*,*,*") + (set_attr "prefix_data16" "*,*,*,*,*,*,*,*,*,*,*,*,*,*,*,1,*,*,*") + (set (attr "prefix") + (if_then_else (eq_attr "alternative" "11,12,13,14,15,16") + (const_string "maybe_vex") + (const_string "orig"))) + (set_attr "mode" "SI,DI,DI,DI,SI,DI,DI,DI,DI,DI,DI,TI,TI,DI,DI,DI,DI,DI,DI")]) -;; Convert impossible pushes of immediate to existing instructions. +;; Convert impossible stores of immediate to existing instructions. ;; First try to get scratch register and go through it. In case this -;; fails, push sign extended lower part first and then overwrite -;; upper part by 32bit move. +;; fails, move by 32bit parts. (define_peephole2 [(match_scratch:DI 2 "r") - (set (match_operand:DI 0 "push_operand" "") + (set (match_operand:DI 0 "memory_operand" "") (match_operand:DI 1 "immediate_operand" ""))] "TARGET_64BIT && !symbolic_operand (operands[1], DImode) && !x86_64_immediate_operand (operands[1], DImode)" @@ -2375,94 +2071,26 @@ ;; peephole2 pass is not run. ;; "&& 1" is needed to keep it from matching the previous pattern. (define_peephole2 - [(set (match_operand:DI 0 "push_operand" "") + [(set (match_operand:DI 0 "memory_operand" "") (match_operand:DI 1 "immediate_operand" ""))] "TARGET_64BIT && !symbolic_operand (operands[1], DImode) && !x86_64_immediate_operand (operands[1], DImode) && 1" - [(set (match_dup 0) (match_dup 1)) - (set (match_dup 2) (match_dup 3))] -{ - split_di (&operands[1], 1, &operands[2], &operands[3]); - - operands[1] = gen_lowpart (DImode, operands[2]); - operands[2] = gen_rtx_MEM (SImode, gen_rtx_PLUS (DImode, stack_pointer_rtx, - GEN_INT (4))); -}) + [(set (match_dup 2) (match_dup 3)) + (set (match_dup 4) (match_dup 5))] + "split_di (&operands[0], 2, &operands[2], &operands[4]);") (define_split - [(set (match_operand:DI 0 "push_operand" "") + [(set (match_operand:DI 0 "memory_operand" "") (match_operand:DI 1 "immediate_operand" ""))] "TARGET_64BIT && ((optimize > 0 && flag_peephole2) ? epilogue_completed : reload_completed) && !symbolic_operand (operands[1], DImode) && !x86_64_immediate_operand (operands[1], DImode)" - [(set (match_dup 0) (match_dup 1)) - (set (match_dup 2) (match_dup 3))] -{ - split_di (&operands[1], 1, &operands[2], &operands[3]); - - operands[1] = gen_lowpart (DImode, operands[2]); - operands[2] = gen_rtx_MEM (SImode, gen_rtx_PLUS (DImode, stack_pointer_rtx, - GEN_INT (4))); -}) - -(define_insn "*pushdi2_prologue_rex64" - [(set (match_operand:DI 0 "push_operand" "=<") - (match_operand:DI 1 "general_no_elim_operand" "re*m")) - (clobber (mem:BLK (scratch)))] - "TARGET_64BIT" - "push{q}\t%1" - [(set_attr "type" "push") - (set_attr "mode" "DI")]) - -(define_insn "*popdi1_epilogue_rex64" - [(set (match_operand:DI 0 "nonimmediate_operand" "=r*m") - (mem:DI (reg:DI SP_REG))) - (set (reg:DI SP_REG) - (plus:DI (reg:DI SP_REG) (const_int 8))) - (clobber (mem:BLK (scratch)))] - "TARGET_64BIT" - "pop{q}\t%0" - [(set_attr "type" "pop") - (set_attr "mode" "DI")]) - -(define_insn "popdi1" - [(set (match_operand:DI 0 "nonimmediate_operand" "=r*m") - (mem:DI (reg:DI SP_REG))) - (set (reg:DI SP_REG) - (plus:DI (reg:DI SP_REG) (const_int 8)))] - "TARGET_64BIT" - "pop{q}\t%0" - [(set_attr "type" "pop") - (set_attr "mode" "DI")]) - -(define_insn "*movdi_xor_rex64" - [(set (match_operand:DI 0 "register_operand" "=r") - (match_operand:DI 1 "const0_operand" "")) - (clobber (reg:CC FLAGS_REG))] - "TARGET_64BIT - && reload_completed" - "xor{l}\t%k0, %k0"; - [(set_attr "type" "alu1") - (set_attr "mode" "SI") - (set_attr "length_immediate" "0")]) - -(define_insn "*movdi_or_rex64" - [(set (match_operand:DI 0 "register_operand" "=r") - (match_operand:DI 1 "const_int_operand" "i")) - (clobber (reg:CC FLAGS_REG))] - "TARGET_64BIT - && reload_completed - && operands[1] == constm1_rtx" -{ - operands[1] = constm1_rtx; - return "or{q}\t{%1, %0|%0, %1}"; -} - [(set_attr "type" "alu1") - (set_attr "mode" "DI") - (set_attr "length_immediate" "1")]) + [(set (match_dup 2) (match_dup 3)) + (set (match_dup 4) (match_dup 5))] + "split_di (&operands[0], 2, &operands[2], &operands[4]);") -(define_insn "*movdi_2" +(define_insn "*movdi_internal" [(set (match_operand:DI 0 "nonimmediate_operand" "=r ,o ,*y,m*y,*y,*Y2,m ,*Y2,*Y2,*x,m ,*x,*x") (match_operand:DI 1 "general_operand" @@ -2489,402 +2117,655 @@ (const_string "orig"))) (set_attr "mode" "DI,DI,DI,DI,DI,TI,DI,TI,DI,V4SF,V2SF,V4SF,V2SF")]) -(define_split - [(set (match_operand:DI 0 "push_operand" "") - (match_operand:DI 1 "general_operand" ""))] - "!TARGET_64BIT && reload_completed - && (! MMX_REG_P (operands[1]) && !SSE_REG_P (operands[1]))" - [(const_int 0)] - "ix86_split_long_move (operands); DONE;") - -;; %%% This multiword shite has got to go. (define_split [(set (match_operand:DI 0 "nonimmediate_operand" "") (match_operand:DI 1 "general_operand" ""))] "!TARGET_64BIT && reload_completed - && (!MMX_REG_P (operands[0]) && !SSE_REG_P (operands[0])) - && (!MMX_REG_P (operands[1]) && !SSE_REG_P (operands[1]))" + && !(MMX_REG_P (operands[0]) || SSE_REG_P (operands[0])) + && !(MMX_REG_P (operands[1]) || SSE_REG_P (operands[1]))" [(const_int 0)] "ix86_split_long_move (operands); DONE;") -(define_insn "*movdi_1_rex64" - [(set (match_operand:DI 0 "nonimmediate_operand" - "=r,r ,r,m ,!m,*y,*y,?r ,m ,?*Ym,?*y,*x,*x,?r ,m,?*Yi,*x,?*x,?*Ym") - (match_operand:DI 1 "general_operand" - "Z ,rem,i,re,n ,C ,*y,*Ym,*y,r ,m ,C ,*x,*Yi,*x,r ,m ,*Ym,*x"))] - "TARGET_64BIT && !(MEM_P (operands[0]) && MEM_P (operands[1]))" +(define_insn "*movsi_internal" + [(set (match_operand:SI 0 "nonimmediate_operand" + "=r,m ,*y,*y,?rm,?*y,*x,*x,?r ,m ,?*Yi,*x") + (match_operand:SI 1 "general_operand" + "g ,ri,C ,*y,*y ,rm ,C ,*x,*Yi,*x,r ,m "))] + "!(MEM_P (operands[0]) && MEM_P (operands[1]))" { switch (get_attr_type (insn)) { - case TYPE_SSECVT: - if (SSE_REG_P (operands[0])) - return "movq2dq\t{%1, %0|%0, %1}"; - else - return "movdq2q\t{%1, %0|%0, %1}"; + case TYPE_SSELOG1: + if (get_attr_mode (insn) == MODE_TI) + return "%vpxor\t%0, %d0"; + return "%vxorps\t%0, %d0"; case TYPE_SSEMOV: - if (TARGET_AVX) + switch (get_attr_mode (insn)) { - if (get_attr_mode (insn) == MODE_TI) - return "vmovdqa\t{%1, %0|%0, %1}"; - else - return "vmovq\t{%1, %0|%0, %1}"; + case MODE_TI: + return "%vmovdqa\t{%1, %0|%0, %1}"; + case MODE_V4SF: + return "%vmovaps\t{%1, %0|%0, %1}"; + case MODE_SI: + return "%vmovd\t{%1, %0|%0, %1}"; + case MODE_SF: + return "%vmovss\t{%1, %0|%0, %1}"; + default: + gcc_unreachable (); } - if (get_attr_mode (insn) == MODE_TI) - return "movdqa\t{%1, %0|%0, %1}"; - /* FALLTHRU */ - - case TYPE_MMXMOV: - /* Moves from and into integer register is done using movd - opcode with REX prefix. */ - if (GENERAL_REG_P (operands[0]) || GENERAL_REG_P (operands[1])) - return "movd\t{%1, %0|%0, %1}"; - return "movq\t{%1, %0|%0, %1}"; - - case TYPE_SSELOG1: - return "%vpxor\t%0, %d0"; - case TYPE_MMX: return "pxor\t%0, %0"; - case TYPE_MULTI: - return "#"; + case TYPE_MMXMOV: + if (get_attr_mode (insn) == MODE_DI) + return "movq\t{%1, %0|%0, %1}"; + return "movd\t{%1, %0|%0, %1}"; case TYPE_LEA: - return "lea{q}\t{%a1, %0|%0, %a1}"; + return "lea{l}\t{%a1, %0|%0, %a1}"; default: gcc_assert (!flag_pic || LEGITIMATE_PIC_OPERAND_P (operands[1])); - if (get_attr_mode (insn) == MODE_SI) - return "mov{l}\t{%k1, %k0|%k0, %k1}"; - else if (which_alternative == 2) - return "movabs{q}\t{%1, %0|%0, %1}"; - else - return "mov{q}\t{%1, %0|%0, %1}"; + return "mov{l}\t{%1, %0|%0, %1}"; } } [(set (attr "type") - (cond [(eq_attr "alternative" "5") + (cond [(eq_attr "alternative" "2") (const_string "mmx") - (eq_attr "alternative" "6,7,8,9,10") + (eq_attr "alternative" "3,4,5") (const_string "mmxmov") - (eq_attr "alternative" "11") + (eq_attr "alternative" "6") (const_string "sselog1") - (eq_attr "alternative" "12,13,14,15,16") + (eq_attr "alternative" "7,8,9,10,11") (const_string "ssemov") - (eq_attr "alternative" "17,18") - (const_string "ssecvt") - (eq_attr "alternative" "4") - (const_string "multi") (match_operand:DI 1 "pic_32bit_operand" "") (const_string "lea") ] (const_string "imov"))) - (set (attr "modrm") - (if_then_else - (and (eq_attr "alternative" "2") (eq_attr "type" "imov")) - (const_string "0") - (const_string "*"))) - (set (attr "length_immediate") - (if_then_else - (and (eq_attr "alternative" "2") (eq_attr "type" "imov")) - (const_string "8") - (const_string "*"))) - (set_attr "prefix_rex" "*,*,*,*,*,*,*,1,*,1,*,*,*,*,*,*,*,*,*") - (set_attr "prefix_data16" "*,*,*,*,*,*,*,*,*,*,*,*,*,*,*,1,*,*,*") - (set (attr "prefix") - (if_then_else (eq_attr "alternative" "11,12,13,14,15,16") - (const_string "maybe_vex") - (const_string "orig"))) - (set_attr "mode" "SI,DI,DI,DI,SI,DI,DI,DI,DI,DI,DI,TI,TI,DI,DI,DI,DI,DI,DI")]) + (set (attr "prefix") + (if_then_else (eq_attr "alternative" "0,1,2,3,4,5") + (const_string "orig") + (const_string "maybe_vex"))) + (set (attr "prefix_data16") + (if_then_else (and (eq_attr "type" "ssemov") (eq_attr "mode" "SI")) + (const_string "1") + (const_string "*"))) + (set (attr "mode") + (cond [(eq_attr "alternative" "2,3") + (const_string "DI") + (eq_attr "alternative" "6,7") + (if_then_else + (eq (symbol_ref "TARGET_SSE2") (const_int 0)) + (const_string "V4SF") + (const_string "TI")) + (and (eq_attr "alternative" "8,9,10,11") + (eq (symbol_ref "TARGET_SSE2") (const_int 0))) + (const_string "SF") + ] + (const_string "SI")))]) + +(define_insn "*movhi_internal" + [(set (match_operand:HI 0 "nonimmediate_operand" "=r,r,r,m") + (match_operand:HI 1 "general_operand" "r,rn,rm,rn"))] + "!(MEM_P (operands[0]) && MEM_P (operands[1]))" +{ + switch (get_attr_type (insn)) + { + case TYPE_IMOVX: + /* movzwl is faster than movw on p2 due to partial word stalls, + though not as fast as an aligned movl. */ + return "movz{wl|x}\t{%1, %k0|%k0, %1}"; + default: + if (get_attr_mode (insn) == MODE_SI) + return "mov{l}\t{%k1, %k0|%k0, %k1}"; + else + return "mov{w}\t{%1, %0|%0, %1}"; + } +} + [(set (attr "type") + (cond [(ne (symbol_ref "optimize_function_for_size_p (cfun)") + (const_int 0)) + (const_string "imov") + (and (eq_attr "alternative" "0") + (ior (eq (symbol_ref "TARGET_PARTIAL_REG_STALL") + (const_int 0)) + (eq (symbol_ref "TARGET_HIMODE_MATH") + (const_int 0)))) + (const_string "imov") + (and (eq_attr "alternative" "1,2") + (match_operand:HI 1 "aligned_operand" "")) + (const_string "imov") + (and (ne (symbol_ref "TARGET_MOVX") + (const_int 0)) + (eq_attr "alternative" "0,2")) + (const_string "imovx") + ] + (const_string "imov"))) + (set (attr "mode") + (cond [(eq_attr "type" "imovx") + (const_string "SI") + (and (eq_attr "alternative" "1,2") + (match_operand:HI 1 "aligned_operand" "")) + (const_string "SI") + (and (eq_attr "alternative" "0") + (ior (eq (symbol_ref "TARGET_PARTIAL_REG_STALL") + (const_int 0)) + (eq (symbol_ref "TARGET_HIMODE_MATH") + (const_int 0)))) + (const_string "SI") + ] + (const_string "HI")))]) + +;; Situation is quite tricky about when to choose full sized (SImode) move +;; over QImode moves. For Q_REG -> Q_REG move we use full size only for +;; partial register dependency machines (such as AMD Athlon), where QImode +;; moves issue extra dependency and for partial register stalls machines +;; that don't use QImode patterns (and QImode move cause stall on the next +;; instruction). +;; +;; For loads of Q_REG to NONQ_REG we use full sized moves except for partial +;; register stall machines with, where we use QImode instructions, since +;; partial register stall can be caused there. Then we use movzx. +(define_insn "*movqi_internal" + [(set (match_operand:QI 0 "nonimmediate_operand" "=q,q ,q ,r,r ,?r,m") + (match_operand:QI 1 "general_operand" " q,qn,qm,q,rn,qm,qn"))] + "!(MEM_P (operands[0]) && MEM_P (operands[1]))" +{ + switch (get_attr_type (insn)) + { + case TYPE_IMOVX: + gcc_assert (ANY_QI_REG_P (operands[1]) || MEM_P (operands[1])); + return "movz{bl|x}\t{%1, %k0|%k0, %1}"; + default: + if (get_attr_mode (insn) == MODE_SI) + return "mov{l}\t{%k1, %k0|%k0, %k1}"; + else + return "mov{b}\t{%1, %0|%0, %1}"; + } +} + [(set (attr "type") + (cond [(and (eq_attr "alternative" "5") + (not (match_operand:QI 1 "aligned_operand" ""))) + (const_string "imovx") + (ne (symbol_ref "optimize_function_for_size_p (cfun)") + (const_int 0)) + (const_string "imov") + (and (eq_attr "alternative" "3") + (ior (eq (symbol_ref "TARGET_PARTIAL_REG_STALL") + (const_int 0)) + (eq (symbol_ref "TARGET_QIMODE_MATH") + (const_int 0)))) + (const_string "imov") + (eq_attr "alternative" "3,5") + (const_string "imovx") + (and (ne (symbol_ref "TARGET_MOVX") + (const_int 0)) + (eq_attr "alternative" "2")) + (const_string "imovx") + ] + (const_string "imov"))) + (set (attr "mode") + (cond [(eq_attr "alternative" "3,4,5") + (const_string "SI") + (eq_attr "alternative" "6") + (const_string "QI") + (eq_attr "type" "imovx") + (const_string "SI") + (and (eq_attr "type" "imov") + (and (eq_attr "alternative" "0,1") + (and (ne (symbol_ref "TARGET_PARTIAL_REG_DEPENDENCY") + (const_int 0)) + (and (eq (symbol_ref "optimize_function_for_size_p (cfun)") + (const_int 0)) + (eq (symbol_ref "TARGET_PARTIAL_REG_STALL") + (const_int 0)))))) + (const_string "SI") + ;; Avoid partial register stalls when not using QImode arithmetic + (and (eq_attr "type" "imov") + (and (eq_attr "alternative" "0,1") + (and (ne (symbol_ref "TARGET_PARTIAL_REG_STALL") + (const_int 0)) + (eq (symbol_ref "TARGET_QIMODE_MATH") + (const_int 0))))) + (const_string "SI") + ] + (const_string "QI")))]) ;; Stores and loads of ax to arbitrary constant address. ;; We fake an second form of instruction to force reload to load address ;; into register when rax is not available -(define_insn "*movabsdi_1_rex64" - [(set (mem:DI (match_operand:DI 0 "x86_64_movabs_operand" "i,r")) - (match_operand:DI 1 "nonmemory_operand" "a,er"))] +(define_insn "*movabs_1" + [(set (mem:SWI1248x (match_operand:DI 0 "x86_64_movabs_operand" "i,r")) + (match_operand:SWI1248x 1 "nonmemory_operand" "a,er"))] "TARGET_64BIT && ix86_check_movabs (insn, 0)" "@ - movabs{q}\t{%1, %P0|%P0, %1} - mov{q}\t{%1, %a0|%a0, %1}" + movabs{}\t{%1, %P0|%P0, %1} + mov{}\t{%1, %a0|%a0, %1}" [(set_attr "type" "imov") (set_attr "modrm" "0,*") (set_attr "length_address" "8,0") (set_attr "length_immediate" "0,*") (set_attr "memory" "store") - (set_attr "mode" "DI")]) + (set_attr "mode" "")]) -(define_insn "*movabsdi_2_rex64" - [(set (match_operand:DI 0 "register_operand" "=a,r") - (mem:DI (match_operand:DI 1 "x86_64_movabs_operand" "i,r")))] +(define_insn "*movabs_2" + [(set (match_operand:SWI1248x 0 "register_operand" "=a,r") + (mem:SWI1248x (match_operand:DI 1 "x86_64_movabs_operand" "i,r")))] "TARGET_64BIT && ix86_check_movabs (insn, 1)" "@ - movabs{q}\t{%P1, %0|%0, %P1} - mov{q}\t{%a1, %0|%0, %a1}" + movabs{}\t{%P1, %0|%0, %P1} + mov{}\t{%a1, %0|%0, %a1}" [(set_attr "type" "imov") (set_attr "modrm" "0,*") (set_attr "length_address" "8,0") (set_attr "length_immediate" "0") (set_attr "memory" "load") - (set_attr "mode" "DI")]) - -;; Convert impossible stores of immediate to existing instructions. -;; First try to get scratch register and go through it. In case this -;; fails, move by 32bit parts. -(define_peephole2 - [(match_scratch:DI 2 "r") - (set (match_operand:DI 0 "memory_operand" "") - (match_operand:DI 1 "immediate_operand" ""))] - "TARGET_64BIT && !symbolic_operand (operands[1], DImode) - && !x86_64_immediate_operand (operands[1], DImode)" - [(set (match_dup 2) (match_dup 1)) - (set (match_dup 0) (match_dup 2))] - "") - -;; We need to define this as both peepholer and splitter for case -;; peephole2 pass is not run. -;; "&& 1" is needed to keep it from matching the previous pattern. -(define_peephole2 - [(set (match_operand:DI 0 "memory_operand" "") - (match_operand:DI 1 "immediate_operand" ""))] - "TARGET_64BIT && !symbolic_operand (operands[1], DImode) - && !x86_64_immediate_operand (operands[1], DImode) && 1" - [(set (match_dup 2) (match_dup 3)) - (set (match_dup 4) (match_dup 5))] - "split_di (&operands[0], 2, &operands[2], &operands[4]);") + (set_attr "mode" "")]) -(define_split - [(set (match_operand:DI 0 "memory_operand" "") - (match_operand:DI 1 "immediate_operand" ""))] - "TARGET_64BIT && ((optimize > 0 && flag_peephole2) - ? epilogue_completed : reload_completed) - && !symbolic_operand (operands[1], DImode) - && !x86_64_immediate_operand (operands[1], DImode)" - [(set (match_dup 2) (match_dup 3)) - (set (match_dup 4) (match_dup 5))] - "split_di (&operands[0], 2, &operands[2], &operands[4]);") +(define_insn "*swap" + [(set (match_operand:SWI48 0 "register_operand" "+r") + (match_operand:SWI48 1 "register_operand" "+r")) + (set (match_dup 1) + (match_dup 0))] + "" + "xchg{}\t%1, %0" + [(set_attr "type" "imov") + (set_attr "mode" "") + (set_attr "pent_pair" "np") + (set_attr "athlon_decode" "vector") + (set_attr "amdfam10_decode" "double")]) -(define_insn "*swapdi_rex64" - [(set (match_operand:DI 0 "register_operand" "+r") - (match_operand:DI 1 "register_operand" "+r")) +(define_insn "*swap_1" + [(set (match_operand:SWI12 0 "register_operand" "+r") + (match_operand:SWI12 1 "register_operand" "+r")) (set (match_dup 1) (match_dup 0))] - "TARGET_64BIT" - "xchg{q}\t%1, %0" + "!TARGET_PARTIAL_REG_STALL || optimize_function_for_size_p (cfun)" + "xchg{l}\t%k1, %k0" [(set_attr "type" "imov") - (set_attr "mode" "DI") + (set_attr "mode" "SI") (set_attr "pent_pair" "np") (set_attr "athlon_decode" "vector") (set_attr "amdfam10_decode" "double")]) -(define_expand "movoi" - [(set (match_operand:OI 0 "nonimmediate_operand" "") - (match_operand:OI 1 "general_operand" ""))] - "TARGET_AVX" - "ix86_expand_move (OImode, operands); DONE;") +;; Not added amdfam10_decode since TARGET_PARTIAL_REG_STALL +;; is disabled for AMDFAM10 +(define_insn "*swap_2" + [(set (match_operand:SWI12 0 "register_operand" "+") + (match_operand:SWI12 1 "register_operand" "+")) + (set (match_dup 1) + (match_dup 0))] + "TARGET_PARTIAL_REG_STALL" + "xchg{}\t%1, %0" + [(set_attr "type" "imov") + (set_attr "mode" "") + (set_attr "pent_pair" "np") + (set_attr "athlon_decode" "vector")]) -(define_insn "*movoi_internal" - [(set (match_operand:OI 0 "nonimmediate_operand" "=x,x,m") - (match_operand:OI 1 "vector_move_operand" "C,xm,x"))] - "TARGET_AVX +(define_expand "movstrict" + [(set (strict_low_part (match_operand:SWI12 0 "nonimmediate_operand" "")) + (match_operand:SWI12 1 "general_operand" ""))] + "" +{ + if (TARGET_PARTIAL_REG_STALL && optimize_function_for_speed_p (cfun)) + FAIL; + /* Don't generate memory->memory moves, go through a register */ + if (MEM_P (operands[0]) && MEM_P (operands[1])) + operands[1] = force_reg (mode, operands[1]); +}) + +(define_insn "*movstrict_1" + [(set (strict_low_part + (match_operand:SWI12 0 "nonimmediate_operand" "+m,")) + (match_operand:SWI12 1 "general_operand" "n,m"))] + "(!TARGET_PARTIAL_REG_STALL || optimize_function_for_size_p (cfun)) && !(MEM_P (operands[0]) && MEM_P (operands[1]))" + "mov{}\t{%1, %0|%0, %1}" + [(set_attr "type" "imov") + (set_attr "mode" "")]) + +(define_insn "*movstrict_xor" + [(set (strict_low_part (match_operand:SWI12 0 "register_operand" "+")) + (match_operand:SWI12 1 "const0_operand" "")) + (clobber (reg:CC FLAGS_REG))] + "reload_completed" + "xor{}\t%0, %0" + [(set_attr "type" "alu1") + (set_attr "mode" "") + (set_attr "length_immediate" "0")]) + +(define_insn "*mov_extv_1" + [(set (match_operand:SWI24 0 "register_operand" "=R") + (sign_extract:SWI24 (match_operand 1 "ext_register_operand" "Q") + (const_int 8) + (const_int 8)))] + "" + "movs{bl|x}\t{%h1, %k0|%k0, %h1}" + [(set_attr "type" "imovx") + (set_attr "mode" "SI")]) + +(define_insn "*movqi_extv_1_rex64" + [(set (match_operand:QI 0 "register_operand" "=Q,?R") + (sign_extract:QI (match_operand 1 "ext_register_operand" "Q,Q") + (const_int 8) + (const_int 8)))] + "TARGET_64BIT" { - switch (which_alternative) + switch (get_attr_type (insn)) { - case 0: - return "vxorps\t%0, %0, %0"; - case 1: - case 2: - if (misaligned_operand (operands[0], OImode) - || misaligned_operand (operands[1], OImode)) - return "vmovdqu\t{%1, %0|%0, %1}"; - else - return "vmovdqa\t{%1, %0|%0, %1}"; + case TYPE_IMOVX: + return "movs{bl|x}\t{%h1, %k0|%k0, %h1}"; default: - gcc_unreachable (); + return "mov{b}\t{%h1, %0|%0, %h1}"; } } - [(set_attr "type" "sselog1,ssemov,ssemov") - (set_attr "prefix" "vex") - (set_attr "mode" "OI")]) - -(define_expand "movti" - [(set (match_operand:TI 0 "nonimmediate_operand" "") - (match_operand:TI 1 "nonimmediate_operand" ""))] - "TARGET_SSE || TARGET_64BIT" -{ - if (TARGET_64BIT) - ix86_expand_move (TImode, operands); - else if (push_operand (operands[0], TImode)) - ix86_expand_push (TImode, operands[1]); - else - ix86_expand_vector_move (TImode, operands); - DONE; -}) + [(set (attr "type") + (if_then_else (and (match_operand:QI 0 "register_operand" "") + (ior (not (match_operand:QI 0 "q_regs_operand" "")) + (ne (symbol_ref "TARGET_MOVX") + (const_int 0)))) + (const_string "imovx") + (const_string "imov"))) + (set (attr "mode") + (if_then_else (eq_attr "type" "imovx") + (const_string "SI") + (const_string "QI")))]) -(define_insn "*movti_internal" - [(set (match_operand:TI 0 "nonimmediate_operand" "=x,x,m") - (match_operand:TI 1 "vector_move_operand" "C,xm,x"))] - "TARGET_SSE && !TARGET_64BIT - && !(MEM_P (operands[0]) && MEM_P (operands[1]))" +(define_insn "*movqi_extv_1" + [(set (match_operand:QI 0 "nonimmediate_operand" "=Qm,?r") + (sign_extract:QI (match_operand 1 "ext_register_operand" "Q,Q") + (const_int 8) + (const_int 8)))] + "!TARGET_64BIT" { - switch (which_alternative) + switch (get_attr_type (insn)) { - case 0: - if (get_attr_mode (insn) == MODE_V4SF) - return "%vxorps\t%0, %d0"; - else - return "%vpxor\t%0, %d0"; - case 1: - case 2: - /* TDmode values are passed as TImode on the stack. Moving them - to stack may result in unaligned memory access. */ - if (misaligned_operand (operands[0], TImode) - || misaligned_operand (operands[1], TImode)) - { - if (get_attr_mode (insn) == MODE_V4SF) - return "%vmovups\t{%1, %0|%0, %1}"; - else - return "%vmovdqu\t{%1, %0|%0, %1}"; - } - else - { - if (get_attr_mode (insn) == MODE_V4SF) - return "%vmovaps\t{%1, %0|%0, %1}"; - else - return "%vmovdqa\t{%1, %0|%0, %1}"; - } + case TYPE_IMOVX: + return "movs{bl|x}\t{%h1, %k0|%k0, %h1}"; + default: + return "mov{b}\t{%h1, %0|%0, %h1}"; + } +} + [(set (attr "type") + (if_then_else (and (match_operand:QI 0 "register_operand" "") + (ior (not (match_operand:QI 0 "q_regs_operand" "")) + (ne (symbol_ref "TARGET_MOVX") + (const_int 0)))) + (const_string "imovx") + (const_string "imov"))) + (set (attr "mode") + (if_then_else (eq_attr "type" "imovx") + (const_string "SI") + (const_string "QI")))]) + +(define_insn "*mov_extzv_1" + [(set (match_operand:SWI48 0 "register_operand" "=R") + (zero_extract:SWI48 (match_operand 1 "ext_register_operand" "Q") + (const_int 8) + (const_int 8)))] + "" + "movz{bl|x}\t{%h1, %k0|%k0, %h1}" + [(set_attr "type" "imovx") + (set_attr "mode" "SI")]) + +(define_insn "*movqi_extzv_2_rex64" + [(set (match_operand:QI 0 "register_operand" "=Q,?R") + (subreg:QI + (zero_extract:SI (match_operand 1 "ext_register_operand" "Q,Q") + (const_int 8) + (const_int 8)) 0))] + "TARGET_64BIT" +{ + switch (get_attr_type (insn)) + { + case TYPE_IMOVX: + return "movz{bl|x}\t{%h1, %k0|%k0, %h1}"; default: - gcc_unreachable (); + return "mov{b}\t{%h1, %0|%0, %h1}"; } } - [(set_attr "type" "sselog1,ssemov,ssemov") - (set_attr "prefix" "maybe_vex") + [(set (attr "type") + (if_then_else (ior (not (match_operand:QI 0 "q_regs_operand" "")) + (ne (symbol_ref "TARGET_MOVX") + (const_int 0))) + (const_string "imovx") + (const_string "imov"))) (set (attr "mode") - (cond [(ior (eq (symbol_ref "TARGET_SSE2") (const_int 0)) - (ne (symbol_ref "optimize_function_for_size_p (cfun)") (const_int 0))) - (const_string "V4SF") - (and (eq_attr "alternative" "2") - (ne (symbol_ref "TARGET_SSE_TYPELESS_STORES") - (const_int 0))) - (const_string "V4SF")] - (const_string "TI")))]) + (if_then_else (eq_attr "type" "imovx") + (const_string "SI") + (const_string "QI")))]) -(define_insn "*movti_rex64" - [(set (match_operand:TI 0 "nonimmediate_operand" "=!r,o,x,x,xm") - (match_operand:TI 1 "general_operand" "riFo,riF,C,xm,x"))] - "TARGET_64BIT - && !(MEM_P (operands[0]) && MEM_P (operands[1]))" +(define_insn "*movqi_extzv_2" + [(set (match_operand:QI 0 "nonimmediate_operand" "=Qm,?R") + (subreg:QI + (zero_extract:SI (match_operand 1 "ext_register_operand" "Q,Q") + (const_int 8) + (const_int 8)) 0))] + "!TARGET_64BIT" { - switch (which_alternative) + switch (get_attr_type (insn)) { - case 0: - case 1: - return "#"; - case 2: - if (get_attr_mode (insn) == MODE_V4SF) - return "%vxorps\t%0, %d0"; - else - return "%vpxor\t%0, %d0"; - case 3: - case 4: - /* TDmode values are passed as TImode on the stack. Moving them - to stack may result in unaligned memory access. */ - if (misaligned_operand (operands[0], TImode) - || misaligned_operand (operands[1], TImode)) - { - if (get_attr_mode (insn) == MODE_V4SF) - return "%vmovups\t{%1, %0|%0, %1}"; - else - return "%vmovdqu\t{%1, %0|%0, %1}"; - } - else - { - if (get_attr_mode (insn) == MODE_V4SF) - return "%vmovaps\t{%1, %0|%0, %1}"; - else - return "%vmovdqa\t{%1, %0|%0, %1}"; - } + case TYPE_IMOVX: + return "movz{bl|x}\t{%h1, %k0|%k0, %h1}"; default: - gcc_unreachable (); + return "mov{b}\t{%h1, %0|%0, %h1}"; } } - [(set_attr "type" "*,*,sselog1,ssemov,ssemov") - (set_attr "prefix" "*,*,maybe_vex,maybe_vex,maybe_vex") + [(set (attr "type") + (if_then_else (and (match_operand:QI 0 "register_operand" "") + (ior (not (match_operand:QI 0 "q_regs_operand" "")) + (ne (symbol_ref "TARGET_MOVX") + (const_int 0)))) + (const_string "imovx") + (const_string "imov"))) (set (attr "mode") - (cond [(eq_attr "alternative" "2,3") - (if_then_else - (ne (symbol_ref "optimize_function_for_size_p (cfun)") - (const_int 0)) - (const_string "V4SF") - (const_string "TI")) - (eq_attr "alternative" "4") - (if_then_else - (ior (ne (symbol_ref "TARGET_SSE_TYPELESS_STORES") - (const_int 0)) - (ne (symbol_ref "optimize_function_for_size_p (cfun)") - (const_int 0))) - (const_string "V4SF") - (const_string "TI"))] - (const_string "DI")))]) + (if_then_else (eq_attr "type" "imovx") + (const_string "SI") + (const_string "QI")))]) + +(define_expand "mov_insv_1" + [(set (zero_extract:SWI48 (match_operand 0 "ext_register_operand" "") + (const_int 8) + (const_int 8)) + (match_operand:SWI48 1 "nonmemory_operand" ""))] + "" + "") + +(define_insn "*mov_insv_1_rex64" + [(set (zero_extract:SWI48x (match_operand 0 "ext_register_operand" "+Q") + (const_int 8) + (const_int 8)) + (match_operand:SWI48x 1 "nonmemory_operand" "Qn"))] + "TARGET_64BIT" + "mov{b}\t{%b1, %h0|%h0, %b1}" + [(set_attr "type" "imov") + (set_attr "mode" "QI")]) + +(define_insn "*movsi_insv_1" + [(set (zero_extract:SI (match_operand 0 "ext_register_operand" "+Q") + (const_int 8) + (const_int 8)) + (match_operand:SI 1 "general_operand" "Qmn"))] + "!TARGET_64BIT" + "mov{b}\t{%b1, %h0|%h0, %b1}" + [(set_attr "type" "imov") + (set_attr "mode" "QI")]) + +(define_insn "*movqi_insv_2" + [(set (zero_extract:SI (match_operand 0 "ext_register_operand" "+Q") + (const_int 8) + (const_int 8)) + (lshiftrt:SI (match_operand:SI 1 "register_operand" "Q") + (const_int 8)))] + "" + "mov{b}\t{%h1, %h0|%h0, %h1}" + [(set_attr "type" "imov") + (set_attr "mode" "QI")]) + +;; Floating point move instructions. + +(define_expand "movtf" + [(set (match_operand:TF 0 "nonimmediate_operand" "") + (match_operand:TF 1 "nonimmediate_operand" ""))] + "TARGET_SSE2" +{ + ix86_expand_move (TFmode, operands); + DONE; +}) + +(define_expand "mov" + [(set (match_operand:X87MODEF 0 "nonimmediate_operand" "") + (match_operand:X87MODEF 1 "general_operand" ""))] + "" + "ix86_expand_move (mode, operands); DONE;") + +(define_insn "*pushtf" + [(set (match_operand:TF 0 "push_operand" "=<,<,<") + (match_operand:TF 1 "general_no_elim_operand" "x,Fo,*r"))] + "TARGET_SSE2" +{ + /* This insn should be already split before reg-stack. */ + gcc_unreachable (); +} + [(set_attr "type" "multi") + (set_attr "unit" "sse,*,*") + (set_attr "mode" "TF,SI,SI")]) (define_split - [(set (match_operand:TI 0 "nonimmediate_operand" "") - (match_operand:TI 1 "general_operand" ""))] - "reload_completed && !SSE_REG_P (operands[0]) + [(set (match_operand:TF 0 "push_operand" "") + (match_operand:TF 1 "general_operand" ""))] + "TARGET_SSE2 && reload_completed && !SSE_REG_P (operands[1])" [(const_int 0)] "ix86_split_long_move (operands); DONE;") -;; This expands to what emit_move_complex would generate if we didn't -;; have a movti pattern. Having this avoids problems with reload on -;; 32-bit targets when SSE is present, but doesn't seem to be harmful -;; to have around all the time. -(define_expand "movcdi" - [(set (match_operand:CDI 0 "nonimmediate_operand" "") - (match_operand:CDI 1 "general_operand" ""))] - "" +(define_split + [(set (match_operand:TF 0 "push_operand" "") + (match_operand:TF 1 "any_fp_register_operand" ""))] + "TARGET_SSE2" + [(set (reg:P SP_REG) (plus:P (reg:P SP_REG) (const_int -16))) + (set (mem:TF (reg:P SP_REG)) (match_dup 1))] + "") + +(define_insn "*pushxf" + [(set (match_operand:XF 0 "push_operand" "=<,<") + (match_operand:XF 1 "general_no_elim_operand" "f,ro"))] + "optimize_function_for_speed_p (cfun)" { - if (push_operand (operands[0], CDImode)) - emit_move_complex_push (CDImode, operands[0], operands[1]); - else - emit_move_complex_parts (operands[0], operands[1]); - DONE; -}) + /* This insn should be already split before reg-stack. */ + gcc_unreachable (); +} + [(set_attr "type" "multi") + (set_attr "unit" "i387,*") + (set_attr "mode" "XF,SI")]) + +;; Size of pushxf is 3 (for sub) + 2 (for fstp) + memory operand size. +;; Size of pushxf using integer instructions is 3+3*memory operand size +;; Pushing using integer instructions is longer except for constants +;; and direct memory references (assuming that any given constant is pushed +;; only once, but this ought to be handled elsewhere). + +(define_insn "*pushxf_nointeger" + [(set (match_operand:XF 0 "push_operand" "=X,X,X") + (match_operand:XF 1 "general_no_elim_operand" "f,Fo,*r"))] + "optimize_function_for_size_p (cfun)" +{ + /* This insn should be already split before reg-stack. */ + gcc_unreachable (); +} + [(set_attr "type" "multi") + (set_attr "unit" "i387,*,*") + (set_attr "mode" "XF,SI,SI")]) + +(define_split + [(set (match_operand:XF 0 "push_operand" "") + (match_operand:XF 1 "any_fp_register_operand" ""))] + "reload_completed" + [(set (reg:P SP_REG) (plus:P (reg:P SP_REG) (match_dup 2))) + (set (mem:XF (reg:P SP_REG)) (match_dup 1))] + "operands[2] = GEN_INT (-GET_MODE_SIZE (XFmode));") + +(define_split + [(set (match_operand:XF 0 "push_operand" "") + (match_operand:XF 1 "general_operand" ""))] + "reload_completed + && !ANY_FP_REG_P (operands[1])" + [(const_int 0)] + "ix86_split_long_move (operands); DONE;") + +(define_insn "*pushdf" + [(set (match_operand:DF 0 "push_operand" "=<,<,<") + (match_operand:DF 1 "general_no_elim_operand" "f,rFo,Y2"))] + "TARGET_64BIT || TARGET_INTEGER_DFMODE_MOVES" +{ + /* This insn should be already split before reg-stack. */ + gcc_unreachable (); +} + [(set_attr "type" "multi") + (set_attr "unit" "i387,*,*") + (set_attr "mode" "DF,SI,DF")]) + +;; Size of pushdf is 3 (for sub) + 2 (for fstp) + memory operand size. +;; Size of pushdf using integer instructions is 2+2*memory operand size +;; On the average, pushdf using integers can be still shorter. Allow this +;; pattern for optimize_size too. + +(define_insn "*pushdf_nointeger" + [(set (match_operand:DF 0 "push_operand" "=<,<,<,<") + (match_operand:DF 1 "general_no_elim_operand" "f,Fo,*r,Y2"))] + "!(TARGET_64BIT || TARGET_INTEGER_DFMODE_MOVES)" +{ + /* This insn should be already split before reg-stack. */ + gcc_unreachable (); +} + [(set_attr "type" "multi") + (set_attr "unit" "i387,*,*,*") + (set_attr "mode" "DF,SI,SI,DF")]) + +;; %%% Kill this when call knows how to work this out. +(define_split + [(set (match_operand:DF 0 "push_operand" "") + (match_operand:DF 1 "any_fp_register_operand" ""))] + "reload_completed" + [(set (reg:P SP_REG) (plus:P (reg:P SP_REG) (const_int -8))) + (set (mem:DF (reg:P SP_REG)) (match_dup 1))] + "") -(define_expand "movsf" - [(set (match_operand:SF 0 "nonimmediate_operand" "") - (match_operand:SF 1 "general_operand" ""))] - "" - "ix86_expand_move (SFmode, operands); DONE;") +(define_split + [(set (match_operand:DF 0 "push_operand" "") + (match_operand:DF 1 "general_operand" ""))] + "reload_completed + && !ANY_FP_REG_P (operands[1])" + [(const_int 0)] + "ix86_split_long_move (operands); DONE;") -(define_insn "*pushsf" - [(set (match_operand:SF 0 "push_operand" "=<,<,<") - (match_operand:SF 1 "general_no_elim_operand" "f,rFm,x"))] - "!TARGET_64BIT" +(define_insn "*pushsf_rex64" + [(set (match_operand:SF 0 "push_operand" "=X,X,X") + (match_operand:SF 1 "nonmemory_no_elim_operand" "f,rF,x"))] + "TARGET_64BIT" { /* Anything else should be already split before reg-stack. */ gcc_assert (which_alternative == 1); - return "push{l}\t%1"; + return "push{q}\t%q1"; } [(set_attr "type" "multi,push,multi") (set_attr "unit" "i387,*,*") - (set_attr "mode" "SF,SI,SF")]) + (set_attr "mode" "SF,DI,SF")]) -(define_insn "*pushsf_rex64" - [(set (match_operand:SF 0 "push_operand" "=X,X,X") - (match_operand:SF 1 "nonmemory_no_elim_operand" "f,rF,x"))] - "TARGET_64BIT" +(define_insn "*pushsf" + [(set (match_operand:SF 0 "push_operand" "=<,<,<") + (match_operand:SF 1 "general_no_elim_operand" "f,rFm,x"))] + "!TARGET_64BIT" { /* Anything else should be already split before reg-stack. */ gcc_assert (which_alternative == 1); - return "push{q}\t%q1"; + return "push{l}\t%1"; } [(set_attr "type" "multi,push,multi") (set_attr "unit" "i387,*,*") - (set_attr "mode" "SF,DI,SF")]) + (set_attr "mode" "SF,SI,SF")]) (define_split [(set (match_operand:SF 0 "push_operand" "") @@ -2899,202 +2780,148 @@ (define_split [(set (match_operand:SF 0 "push_operand" "") (match_operand:SF 1 "any_fp_register_operand" ""))] - "!TARGET_64BIT" - [(set (reg:SI SP_REG) (plus:SI (reg:SI SP_REG) (const_int -4))) - (set (mem:SF (reg:SI SP_REG)) (match_dup 1))]) - -(define_split - [(set (match_operand:SF 0 "push_operand" "") - (match_operand:SF 1 "any_fp_register_operand" ""))] - "TARGET_64BIT" - [(set (reg:DI SP_REG) (plus:DI (reg:DI SP_REG) (const_int -8))) - (set (mem:SF (reg:DI SP_REG)) (match_dup 1))]) + "reload_completed" + [(set (reg:P SP_REG) (plus:P (reg:P SP_REG) (match_dup 2))) + (set (mem:SF (reg:P SP_REG)) (match_dup 1))] + "operands[2] = GEN_INT (-GET_MODE_SIZE (mode));") -(define_insn "*movsf_1" - [(set (match_operand:SF 0 "nonimmediate_operand" - "=f,m,f,r ,m ,x,x,x ,m,!*y,!m,!*y,?Yi,?r,!*Ym,!r") - (match_operand:SF 1 "general_operand" - "fm,f,G,rmF,Fr,C,x,xm,x,m ,*y,*y ,r ,Yi,r ,*Ym"))] - "!(MEM_P (operands[0]) && MEM_P (operands[1])) - && (reload_in_progress || reload_completed - || (ix86_cmodel == CM_MEDIUM || ix86_cmodel == CM_LARGE) - || (!TARGET_SSE_MATH && optimize_function_for_size_p (cfun) - && standard_80387_constant_p (operands[1])) - || GET_CODE (operands[1]) != CONST_DOUBLE - || memory_operand (operands[0], SFmode))" +(define_insn "*movtf_internal" + [(set (match_operand:TF 0 "nonimmediate_operand" "=x,m,x,?r,?o") + (match_operand:TF 1 "general_operand" "xm,x,C,roF,Fr"))] + "TARGET_SSE2 + && !(MEM_P (operands[0]) && MEM_P (operands[1]))" { switch (which_alternative) { case 0: case 1: - return output_387_reg_move (insn, operands); - - case 2: - return standard_80387_constant_opcode (operands[1]); - - case 3: - case 4: - return "mov{l}\t{%1, %0|%0, %1}"; - case 5: - if (get_attr_mode (insn) == MODE_TI) - return "%vpxor\t%0, %d0"; - else - return "%vxorps\t%0, %d0"; - case 6: if (get_attr_mode (insn) == MODE_V4SF) return "%vmovaps\t{%1, %0|%0, %1}"; else - return "%vmovss\t{%1, %d0|%d0, %1}"; - case 7: - if (TARGET_AVX) - return REG_P (operands[1]) ? "vmovss\t{%1, %0, %0|%0, %0, %1}" - : "vmovss\t{%1, %0|%0, %1}"; + return "%vmovdqa\t{%1, %0|%0, %1}"; + case 2: + if (get_attr_mode (insn) == MODE_V4SF) + return "%vxorps\t%0, %d0"; else - return "movss\t{%1, %0|%0, %1}"; - case 8: - return "%vmovss\t{%1, %0|%0, %1}"; - - case 9: case 10: case 14: case 15: - return "movd\t{%1, %0|%0, %1}"; - case 12: case 13: - return "%vmovd\t{%1, %0|%0, %1}"; - - case 11: - return "movq\t{%1, %0|%0, %1}"; - + return "%vpxor\t%0, %d0"; + case 3: + case 4: + return "#"; default: gcc_unreachable (); } } - [(set_attr "type" "fmov,fmov,fmov,imov,imov,sselog1,ssemov,ssemov,ssemov,mmxmov,mmxmov,mmxmov,ssemov,ssemov,mmxmov,mmxmov") - (set (attr "prefix") - (if_then_else (eq_attr "alternative" "5,6,7,8,12,13") - (const_string "maybe_vex") - (const_string "orig"))) + [(set_attr "type" "ssemov,ssemov,sselog1,*,*") + (set_attr "prefix" "maybe_vex,maybe_vex,maybe_vex,*,*") (set (attr "mode") - (cond [(eq_attr "alternative" "3,4,9,10") - (const_string "SI") - (eq_attr "alternative" "5") + (cond [(eq_attr "alternative" "0,2") (if_then_else - (and (and (ne (symbol_ref "TARGET_SSE_LOAD0_BY_PXOR") - (const_int 0)) - (ne (symbol_ref "TARGET_SSE2") - (const_int 0))) - (eq (symbol_ref "optimize_function_for_size_p (cfun)") - (const_int 0))) - (const_string "TI") - (const_string "V4SF")) - /* For architectures resolving dependencies on - whole SSE registers use APS move to break dependency - chains, otherwise use short move to avoid extra work. - - Do the same for architectures resolving dependencies on - the parts. While in DF mode it is better to always handle - just register parts, the SF mode is different due to lack - of instructions to load just part of the register. It is - better to maintain the whole registers in single format - to avoid problems on using packed logical operations. */ - (eq_attr "alternative" "6") + (ne (symbol_ref "optimize_function_for_size_p (cfun)") + (const_int 0)) + (const_string "V4SF") + (const_string "TI")) + (eq_attr "alternative" "1") (if_then_else - (ior (ne (symbol_ref "TARGET_SSE_PARTIAL_REG_DEPENDENCY") + (ior (ne (symbol_ref "TARGET_SSE_TYPELESS_STORES") (const_int 0)) - (ne (symbol_ref "TARGET_SSE_SPLIT_REGS") + (ne (symbol_ref "optimize_function_for_size_p (cfun)") (const_int 0))) (const_string "V4SF") - (const_string "SF")) - (eq_attr "alternative" "11") - (const_string "DI")] - (const_string "SF")))]) + (const_string "TI"))] + (const_string "DI")))]) -(define_insn "*swapsf" - [(set (match_operand:SF 0 "fp_register_operand" "+f") - (match_operand:SF 1 "fp_register_operand" "+f")) - (set (match_dup 1) - (match_dup 0))] - "reload_completed || TARGET_80387" +(define_split + [(set (match_operand:TF 0 "nonimmediate_operand" "") + (match_operand:TF 1 "general_operand" ""))] + "reload_completed + && !(SSE_REG_P (operands[0]) || SSE_REG_P (operands[1]))" + [(const_int 0)] + "ix86_split_long_move (operands); DONE;") + +(define_insn "*movxf_internal" + [(set (match_operand:XF 0 "nonimmediate_operand" "=f,m,f,r,o") + (match_operand:XF 1 "general_operand" "fm,f,G,roF,Fr"))] + "optimize_function_for_speed_p (cfun) + && !(MEM_P (operands[0]) && MEM_P (operands[1])) + && (reload_in_progress || reload_completed + || GET_CODE (operands[1]) != CONST_DOUBLE + || memory_operand (operands[0], XFmode))" { - if (STACK_TOP_P (operands[0])) - return "fxch\t%1"; - else - return "fxch\t%0"; -} - [(set_attr "type" "fxch") - (set_attr "mode" "SF")]) + switch (which_alternative) + { + case 0: + case 1: + return output_387_reg_move (insn, operands); -(define_expand "movdf" - [(set (match_operand:DF 0 "nonimmediate_operand" "") - (match_operand:DF 1 "general_operand" ""))] - "" - "ix86_expand_move (DFmode, operands); DONE;") + case 2: + return standard_80387_constant_opcode (operands[1]); -;; Size of pushdf is 3 (for sub) + 2 (for fstp) + memory operand size. -;; Size of pushdf using integer instructions is 2+2*memory operand size -;; On the average, pushdf using integers can be still shorter. Allow this -;; pattern for optimize_size too. + case 3: case 4: + return "#"; -(define_insn "*pushdf_nointeger" - [(set (match_operand:DF 0 "push_operand" "=<,<,<,<") - (match_operand:DF 1 "general_no_elim_operand" "f,Fo,*r,Y2"))] - "!TARGET_64BIT && !TARGET_INTEGER_DFMODE_MOVES" -{ - /* This insn should be already split before reg-stack. */ - gcc_unreachable (); + default: + gcc_unreachable (); + } } - [(set_attr "type" "multi") - (set_attr "unit" "i387,*,*,*") - (set_attr "mode" "DF,SI,SI,DF")]) + [(set_attr "type" "fmov,fmov,fmov,multi,multi") + (set_attr "mode" "XF,XF,XF,SI,SI")]) -(define_insn "*pushdf_integer" - [(set (match_operand:DF 0 "push_operand" "=<,<,<") - (match_operand:DF 1 "general_no_elim_operand" "f,rFo,Y2"))] - "TARGET_64BIT || TARGET_INTEGER_DFMODE_MOVES" +;; Do not use integer registers when optimizing for size +(define_insn "*movxf_internal_nointeger" + [(set (match_operand:XF 0 "nonimmediate_operand" "=f,m,f,*r,o") + (match_operand:XF 1 "general_operand" "fm,f,G,*roF,F*r"))] + "optimize_function_for_size_p (cfun) + && !(MEM_P (operands[0]) && MEM_P (operands[1])) + && (reload_in_progress || reload_completed + || standard_80387_constant_p (operands[1]) + || GET_CODE (operands[1]) != CONST_DOUBLE + || memory_operand (operands[0], XFmode))" { - /* This insn should be already split before reg-stack. */ - gcc_unreachable (); -} - [(set_attr "type" "multi") - (set_attr "unit" "i387,*,*") - (set_attr "mode" "DF,SI,DF")]) + switch (which_alternative) + { + case 0: + case 1: + return output_387_reg_move (insn, operands); -;; %%% Kill this when call knows how to work this out. -(define_split - [(set (match_operand:DF 0 "push_operand" "") - (match_operand:DF 1 "any_fp_register_operand" ""))] - "reload_completed" - [(set (reg:P SP_REG) (plus:P (reg:P SP_REG) (const_int -8))) - (set (mem:DF (reg:P SP_REG)) (match_dup 1))] - "") + case 2: + return standard_80387_constant_opcode (operands[1]); + + case 3: case 4: + return "#"; + default: + gcc_unreachable (); + } +} + [(set_attr "type" "fmov,fmov,fmov,multi,multi") + (set_attr "mode" "XF,XF,XF,SI,SI")]) (define_split - [(set (match_operand:DF 0 "push_operand" "") - (match_operand:DF 1 "general_operand" ""))] - "reload_completed" + [(set (match_operand:XF 0 "nonimmediate_operand" "") + (match_operand:XF 1 "general_operand" ""))] + "reload_completed + && !(MEM_P (operands[0]) && MEM_P (operands[1])) + && ! (ANY_FP_REG_P (operands[0]) || + (GET_CODE (operands[0]) == SUBREG + && ANY_FP_REG_P (SUBREG_REG (operands[0])))) + && ! (ANY_FP_REG_P (operands[1]) || + (GET_CODE (operands[1]) == SUBREG + && ANY_FP_REG_P (SUBREG_REG (operands[1]))))" [(const_int 0)] - "ix86_split_long_move (operands); DONE;") - -;; Moving is usually shorter when only FP registers are used. This separate -;; movdf pattern avoids the use of integer registers for FP operations -;; when optimizing for size. + "ix86_split_long_move (operands); DONE;") -(define_insn "*movdf_nointeger" +(define_insn "*movdf_internal_rex64" [(set (match_operand:DF 0 "nonimmediate_operand" - "=f,m,f,*r ,o ,Y2*x,Y2*x,Y2*x ,m ") + "=f,m,f,r ,m ,Y2*x,Y2*x,Y2*x,m ,Yi,r ") (match_operand:DF 1 "general_operand" - "fm,f,G,*roF,*Fr,C ,Y2*x,mY2*x,Y2*x"))] - "!(MEM_P (operands[0]) && MEM_P (operands[1])) - && ((optimize_function_for_size_p (cfun) - || !TARGET_INTEGER_DFMODE_MOVES) && !TARGET_64BIT) + "fm,f,G,rmF,Fr,C ,Y2*x,m ,Y2*x,r ,Yi"))] + "TARGET_64BIT && !(MEM_P (operands[0]) && MEM_P (operands[1])) && (reload_in_progress || reload_completed || (ix86_cmodel == CM_MEDIUM || ix86_cmodel == CM_LARGE) || (!(TARGET_SSE2 && TARGET_SSE_MATH) && optimize_function_for_size_p (cfun) - && !memory_operand (operands[0], DFmode) && standard_80387_constant_p (operands[1])) || GET_CODE (operands[1]) != CONST_DOUBLE - || ((optimize_function_for_size_p (cfun) - || !TARGET_MEMORY_MISMATCH_STALL - || reload_in_progress || reload_completed) - && memory_operand (operands[0], DFmode)))" + || memory_operand (operands[0], DFmode))" { switch (which_alternative) { @@ -3108,6 +2935,7 @@ case 3: case 4: return "#"; + case 5: switch (get_attr_mode (insn)) { @@ -3156,34 +2984,22 @@ else return "movsd\t{%1, %0|%0, %1}"; case MODE_V1DF: - if (TARGET_AVX) - { - if (REG_P (operands[0])) - return "vmovlpd\t{%1, %0, %0|%0, %0, %1}"; - else - return "vmovlpd\t{%1, %0|%0, %1}"; - } - else - return "movlpd\t{%1, %0|%0, %1}"; + return "%vmovlpd\t{%1, %d0|%d0, %1}"; case MODE_V2SF: - if (TARGET_AVX) - { - if (REG_P (operands[0])) - return "vmovlps\t{%1, %0, %0|%0, %0, %1}"; - else - return "vmovlps\t{%1, %0|%0, %1}"; - } - else - return "movlps\t{%1, %0|%0, %1}"; + return "%vmovlps\t{%1, %d0|%d0, %1}"; default: gcc_unreachable (); } + case 9: + case 10: + return "%vmovd\t{%1, %0|%0, %1}"; + default: - gcc_unreachable (); + gcc_unreachable(); } } - [(set_attr "type" "fmov,fmov,fmov,multi,multi,sselog1,ssemov,ssemov,ssemov") + [(set_attr "type" "fmov,fmov,fmov,multi,multi,sselog1,ssemov,ssemov,ssemov,ssemov,ssemov") (set (attr "prefix") (if_then_else (eq_attr "alternative" "0,1,2,3,4") (const_string "orig") @@ -3195,8 +3011,8 @@ (set (attr "mode") (cond [(eq_attr "alternative" "0,1,2") (const_string "DF") - (eq_attr "alternative" "3,4") - (const_string "SI") + (eq_attr "alternative" "3,4,9,10") + (const_string "DI") /* For SSE1, we have many fewer alternatives. */ (eq (symbol_ref "TARGET_SSE2") (const_int 0)) @@ -3243,12 +3059,14 @@ ] (const_string "DF")))]) -(define_insn "*movdf_integer_rex64" +(define_insn "*movdf_internal" [(set (match_operand:DF 0 "nonimmediate_operand" - "=f,m,f,r ,m ,Y2*x,Y2*x,Y2*x,m ,Yi,r ") + "=f,m,f,r ,o ,Y2*x,Y2*x,Y2*x,m ") (match_operand:DF 1 "general_operand" - "fm,f,G,rmF,Fr,C ,Y2*x,m ,Y2*x,r ,Yi"))] - "TARGET_64BIT && !(MEM_P (operands[0]) && MEM_P (operands[1])) + "fm,f,G,roF,Fr,C ,Y2*x,m ,Y2*x"))] + "!(MEM_P (operands[0]) && MEM_P (operands[1])) + && optimize_function_for_speed_p (cfun) + && TARGET_INTEGER_DFMODE_MOVES && (reload_in_progress || reload_completed || (ix86_cmodel == CM_MEDIUM || ix86_cmodel == CM_LARGE) || (!(TARGET_SSE2 && TARGET_SSE_MATH) @@ -3274,17 +3092,17 @@ switch (get_attr_mode (insn)) { case MODE_V4SF: - return "%vxorps\t%0, %d0"; + return "xorps\t%0, %0"; case MODE_V2DF: if (TARGET_SSE_PACKED_SINGLE_INSN_OPTIMAL) - return "%vxorps\t%0, %d0"; + return "xorps\t%0, %0"; else - return "%vxorpd\t%0, %d0"; + return "xorpd\t%0, %0"; case MODE_TI: if (TARGET_SSE_PACKED_SINGLE_INSN_OPTIMAL) - return "%vxorps\t%0, %d0"; + return "xorps\t%0, %0"; else - return "%vpxor\t%0, %d0"; + return "pxor\t%0, %0"; default: gcc_unreachable (); } @@ -3294,50 +3112,34 @@ switch (get_attr_mode (insn)) { case MODE_V4SF: - return "%vmovaps\t{%1, %0|%0, %1}"; + return "movaps\t{%1, %0|%0, %1}"; case MODE_V2DF: if (TARGET_SSE_PACKED_SINGLE_INSN_OPTIMAL) - return "%vmovaps\t{%1, %0|%0, %1}"; + return "movaps\t{%1, %0|%0, %1}"; else - return "%vmovapd\t{%1, %0|%0, %1}"; + return "movapd\t{%1, %0|%0, %1}"; case MODE_TI: if (TARGET_SSE_PACKED_SINGLE_INSN_OPTIMAL) - return "%vmovaps\t{%1, %0|%0, %1}"; + return "movaps\t{%1, %0|%0, %1}"; else - return "%vmovdqa\t{%1, %0|%0, %1}"; + return "movdqa\t{%1, %0|%0, %1}"; case MODE_DI: - return "%vmovq\t{%1, %0|%0, %1}"; + return "movq\t{%1, %0|%0, %1}"; case MODE_DF: - if (TARGET_AVX) - { - if (REG_P (operands[0]) && REG_P (operands[1])) - return "vmovsd\t{%1, %0, %0|%0, %0, %1}"; - else - return "vmovsd\t{%1, %0|%0, %1}"; - } - else - return "movsd\t{%1, %0|%0, %1}"; + return "movsd\t{%1, %0|%0, %1}"; case MODE_V1DF: - return "%vmovlpd\t{%1, %d0|%d0, %1}"; + return "movlpd\t{%1, %0|%0, %1}"; case MODE_V2SF: - return "%vmovlps\t{%1, %d0|%d0, %1}"; + return "movlps\t{%1, %0|%0, %1}"; default: gcc_unreachable (); } - case 9: - case 10: - return "%vmovd\t{%1, %0|%0, %1}"; - default: gcc_unreachable(); } } - [(set_attr "type" "fmov,fmov,fmov,multi,multi,sselog1,ssemov,ssemov,ssemov,ssemov,ssemov") - (set (attr "prefix") - (if_then_else (eq_attr "alternative" "0,1,2,3,4") - (const_string "orig") - (const_string "maybe_vex"))) + [(set_attr "type" "fmov,fmov,fmov,multi,multi,sselog1,ssemov,ssemov,ssemov") (set (attr "prefix_data16") (if_then_else (eq_attr "mode" "V1DF") (const_string "1") @@ -3345,8 +3147,8 @@ (set (attr "mode") (cond [(eq_attr "alternative" "0,1,2") (const_string "DF") - (eq_attr "alternative" "3,4,9,10") - (const_string "DI") + (eq_attr "alternative" "3,4") + (const_string "SI") /* For SSE1, we have many fewer alternatives. */ (eq (symbol_ref "TARGET_SSE2") (const_int 0)) @@ -3393,21 +3195,29 @@ ] (const_string "DF")))]) -(define_insn "*movdf_integer" +;; Moving is usually shorter when only FP registers are used. This separate +;; movdf pattern avoids the use of integer registers for FP operations +;; when optimizing for size. + +(define_insn "*movdf_internal_nointeger" [(set (match_operand:DF 0 "nonimmediate_operand" - "=f,m,f,r ,o ,Y2*x,Y2*x,Y2*x,m ") + "=f,m,f,*r ,o ,Y2*x,Y2*x,Y2*x ,m ") (match_operand:DF 1 "general_operand" - "fm,f,G,roF,Fr,C ,Y2*x,m ,Y2*x"))] + "fm,f,G,*roF,*Fr,C ,Y2*x,mY2*x,Y2*x"))] "!(MEM_P (operands[0]) && MEM_P (operands[1])) - && optimize_function_for_speed_p (cfun) - && TARGET_INTEGER_DFMODE_MOVES + && ((optimize_function_for_size_p (cfun) + || !TARGET_INTEGER_DFMODE_MOVES) && !TARGET_64BIT) && (reload_in_progress || reload_completed || (ix86_cmodel == CM_MEDIUM || ix86_cmodel == CM_LARGE) || (!(TARGET_SSE2 && TARGET_SSE_MATH) && optimize_function_for_size_p (cfun) + && !memory_operand (operands[0], DFmode) && standard_80387_constant_p (operands[1])) || GET_CODE (operands[1]) != CONST_DOUBLE - || memory_operand (operands[0], DFmode))" + || ((optimize_function_for_size_p (cfun) + || !TARGET_MEMORY_MISMATCH_STALL + || reload_in_progress || reload_completed) + && memory_operand (operands[0], DFmode)))" { switch (which_alternative) { @@ -3421,22 +3231,21 @@ case 3: case 4: return "#"; - case 5: switch (get_attr_mode (insn)) { case MODE_V4SF: - return "xorps\t%0, %0"; + return "%vxorps\t%0, %d0"; case MODE_V2DF: if (TARGET_SSE_PACKED_SINGLE_INSN_OPTIMAL) - return "xorps\t%0, %0"; + return "%vxorps\t%0, %d0"; else - return "xorpd\t%0, %0"; + return "%vxorpd\t%0, %d0"; case MODE_TI: if (TARGET_SSE_PACKED_SINGLE_INSN_OPTIMAL) - return "xorps\t%0, %0"; + return "%vxorps\t%0, %d0"; else - return "pxor\t%0, %0"; + return "%vpxor\t%0, %d0"; default: gcc_unreachable (); } @@ -3446,34 +3255,62 @@ switch (get_attr_mode (insn)) { case MODE_V4SF: - return "movaps\t{%1, %0|%0, %1}"; + return "%vmovaps\t{%1, %0|%0, %1}"; case MODE_V2DF: if (TARGET_SSE_PACKED_SINGLE_INSN_OPTIMAL) - return "movaps\t{%1, %0|%0, %1}"; + return "%vmovaps\t{%1, %0|%0, %1}"; else - return "movapd\t{%1, %0|%0, %1}"; + return "%vmovapd\t{%1, %0|%0, %1}"; case MODE_TI: if (TARGET_SSE_PACKED_SINGLE_INSN_OPTIMAL) - return "movaps\t{%1, %0|%0, %1}"; + return "%vmovaps\t{%1, %0|%0, %1}"; else - return "movdqa\t{%1, %0|%0, %1}"; + return "%vmovdqa\t{%1, %0|%0, %1}"; case MODE_DI: - return "movq\t{%1, %0|%0, %1}"; + return "%vmovq\t{%1, %0|%0, %1}"; case MODE_DF: - return "movsd\t{%1, %0|%0, %1}"; + if (TARGET_AVX) + { + if (REG_P (operands[0]) && REG_P (operands[1])) + return "vmovsd\t{%1, %0, %0|%0, %0, %1}"; + else + return "vmovsd\t{%1, %0|%0, %1}"; + } + else + return "movsd\t{%1, %0|%0, %1}"; case MODE_V1DF: - return "movlpd\t{%1, %0|%0, %1}"; + if (TARGET_AVX) + { + if (REG_P (operands[0])) + return "vmovlpd\t{%1, %0, %0|%0, %0, %1}"; + else + return "vmovlpd\t{%1, %0|%0, %1}"; + } + else + return "movlpd\t{%1, %0|%0, %1}"; case MODE_V2SF: - return "movlps\t{%1, %0|%0, %1}"; + if (TARGET_AVX) + { + if (REG_P (operands[0])) + return "vmovlps\t{%1, %0, %0|%0, %0, %1}"; + else + return "vmovlps\t{%1, %0|%0, %1}"; + } + else + return "movlps\t{%1, %0|%0, %1}"; default: gcc_unreachable (); } default: - gcc_unreachable(); + gcc_unreachable (); } } [(set_attr "type" "fmov,fmov,fmov,multi,multi,sselog1,ssemov,ssemov,ssemov") + (set (attr "prefix") + (if_then_else (eq_attr "alternative" "0,1,2,3,4") + (const_string "orig") + (const_string "maybe_vex"))) (set (attr "prefix_data16") (if_then_else (eq_attr "mode" "V1DF") (const_string "1") @@ -3510,146 +3347,51 @@ (eq_attr "alternative" "6") (cond [(ne (symbol_ref "optimize_function_for_size_p (cfun)") - (const_int 0)) - (const_string "V4SF") - (ne (symbol_ref "TARGET_SSE_PARTIAL_REG_DEPENDENCY") - (const_int 0)) - (const_string "V2DF") - ] - (const_string "DF")) - /* For architectures resolving dependencies on register - parts we may avoid extra work to zero out upper part - of register. */ - (eq_attr "alternative" "7") - (if_then_else - (ne (symbol_ref "TARGET_SSE_SPLIT_REGS") - (const_int 0)) - (const_string "V1DF") - (const_string "DF")) - ] - (const_string "DF")))]) - -(define_split - [(set (match_operand:DF 0 "nonimmediate_operand" "") - (match_operand:DF 1 "general_operand" ""))] - "reload_completed - && !(MEM_P (operands[0]) && MEM_P (operands[1])) - && ! (ANY_FP_REG_P (operands[0]) || - (GET_CODE (operands[0]) == SUBREG - && ANY_FP_REG_P (SUBREG_REG (operands[0])))) - && ! (ANY_FP_REG_P (operands[1]) || - (GET_CODE (operands[1]) == SUBREG - && ANY_FP_REG_P (SUBREG_REG (operands[1]))))" - [(const_int 0)] - "ix86_split_long_move (operands); DONE;") - -(define_insn "*swapdf" - [(set (match_operand:DF 0 "fp_register_operand" "+f") - (match_operand:DF 1 "fp_register_operand" "+f")) - (set (match_dup 1) - (match_dup 0))] - "reload_completed || TARGET_80387" -{ - if (STACK_TOP_P (operands[0])) - return "fxch\t%1"; - else - return "fxch\t%0"; -} - [(set_attr "type" "fxch") - (set_attr "mode" "DF")]) - -(define_expand "movxf" - [(set (match_operand:XF 0 "nonimmediate_operand" "") - (match_operand:XF 1 "general_operand" ""))] - "" - "ix86_expand_move (XFmode, operands); DONE;") - -;; Size of pushdf is 3 (for sub) + 2 (for fstp) + memory operand size. -;; Size of pushdf using integer instructions is 3+3*memory operand size -;; Pushing using integer instructions is longer except for constants -;; and direct memory references. -;; (assuming that any given constant is pushed only once, but this ought to be -;; handled elsewhere). - -(define_insn "*pushxf_nointeger" - [(set (match_operand:XF 0 "push_operand" "=X,X,X") - (match_operand:XF 1 "general_no_elim_operand" "f,Fo,*r"))] - "optimize_function_for_size_p (cfun)" -{ - /* This insn should be already split before reg-stack. */ - gcc_unreachable (); -} - [(set_attr "type" "multi") - (set_attr "unit" "i387,*,*") - (set_attr "mode" "XF,SI,SI")]) - -(define_insn "*pushxf_integer" - [(set (match_operand:XF 0 "push_operand" "=<,<") - (match_operand:XF 1 "general_no_elim_operand" "f,ro"))] - "optimize_function_for_speed_p (cfun)" -{ - /* This insn should be already split before reg-stack. */ - gcc_unreachable (); -} - [(set_attr "type" "multi") - (set_attr "unit" "i387,*") - (set_attr "mode" "XF,SI")]) + (const_int 0)) + (const_string "V4SF") + (ne (symbol_ref "TARGET_SSE_PARTIAL_REG_DEPENDENCY") + (const_int 0)) + (const_string "V2DF") + ] + (const_string "DF")) + /* For architectures resolving dependencies on register + parts we may avoid extra work to zero out upper part + of register. */ + (eq_attr "alternative" "7") + (if_then_else + (ne (symbol_ref "TARGET_SSE_SPLIT_REGS") + (const_int 0)) + (const_string "V1DF") + (const_string "DF")) + ] + (const_string "DF")))]) (define_split - [(set (match_operand 0 "push_operand" "") - (match_operand 1 "general_operand" ""))] + [(set (match_operand:DF 0 "nonimmediate_operand" "") + (match_operand:DF 1 "general_operand" ""))] "reload_completed - && (GET_MODE (operands[0]) == XFmode - || GET_MODE (operands[0]) == DFmode) - && !ANY_FP_REG_P (operands[1])" + && !(MEM_P (operands[0]) && MEM_P (operands[1])) + && ! (ANY_FP_REG_P (operands[0]) || + (GET_CODE (operands[0]) == SUBREG + && ANY_FP_REG_P (SUBREG_REG (operands[0])))) + && ! (ANY_FP_REG_P (operands[1]) || + (GET_CODE (operands[1]) == SUBREG + && ANY_FP_REG_P (SUBREG_REG (operands[1]))))" [(const_int 0)] "ix86_split_long_move (operands); DONE;") -(define_split - [(set (match_operand:XF 0 "push_operand" "") - (match_operand:XF 1 "any_fp_register_operand" ""))] - "" - [(set (reg:P SP_REG) (plus:P (reg:P SP_REG) (match_dup 2))) - (set (mem:XF (reg:P SP_REG)) (match_dup 1))] - "operands[2] = GEN_INT (TARGET_128BIT_LONG_DOUBLE ? -16 : -12);") - -;; Do not use integer registers when optimizing for size -(define_insn "*movxf_nointeger" - [(set (match_operand:XF 0 "nonimmediate_operand" "=f,m,f,*r,o") - (match_operand:XF 1 "general_operand" "fm,f,G,*roF,F*r"))] - "optimize_function_for_size_p (cfun) - && !(MEM_P (operands[0]) && MEM_P (operands[1])) - && (reload_in_progress || reload_completed - || standard_80387_constant_p (operands[1]) - || GET_CODE (operands[1]) != CONST_DOUBLE - || memory_operand (operands[0], XFmode))" -{ - switch (which_alternative) - { - case 0: - case 1: - return output_387_reg_move (insn, operands); - - case 2: - return standard_80387_constant_opcode (operands[1]); - - case 3: case 4: - return "#"; - default: - gcc_unreachable (); - } -} - [(set_attr "type" "fmov,fmov,fmov,multi,multi") - (set_attr "mode" "XF,XF,XF,SI,SI")]) - -(define_insn "*movxf_integer" - [(set (match_operand:XF 0 "nonimmediate_operand" "=f,m,f,r,o") - (match_operand:XF 1 "general_operand" "fm,f,G,roF,Fr"))] - "optimize_function_for_speed_p (cfun) - && !(MEM_P (operands[0]) && MEM_P (operands[1])) +(define_insn "*movsf_internal" + [(set (match_operand:SF 0 "nonimmediate_operand" + "=f,m,f,r ,m ,x,x,x ,m,!*y,!m,!*y,?Yi,?r,!*Ym,!r") + (match_operand:SF 1 "general_operand" + "fm,f,G,rmF,Fr,C,x,xm,x,m ,*y,*y ,r ,Yi,r ,*Ym"))] + "!(MEM_P (operands[0]) && MEM_P (operands[1])) && (reload_in_progress || reload_completed + || (ix86_cmodel == CM_MEDIUM || ix86_cmodel == CM_LARGE) + || (!TARGET_SSE_MATH && optimize_function_for_size_p (cfun) + && standard_80387_constant_p (operands[1])) || GET_CODE (operands[1]) != CONST_DOUBLE - || memory_operand (operands[0], XFmode))" + || memory_operand (operands[0], SFmode))" { switch (which_alternative) { @@ -3660,112 +3402,79 @@ case 2: return standard_80387_constant_opcode (operands[1]); - case 3: case 4: - return "#"; - - default: - gcc_unreachable (); - } -} - [(set_attr "type" "fmov,fmov,fmov,multi,multi") - (set_attr "mode" "XF,XF,XF,SI,SI")]) - -(define_expand "movtf" - [(set (match_operand:TF 0 "nonimmediate_operand" "") - (match_operand:TF 1 "nonimmediate_operand" ""))] - "TARGET_SSE2" -{ - ix86_expand_move (TFmode, operands); - DONE; -}) - -(define_insn "*movtf_internal" - [(set (match_operand:TF 0 "nonimmediate_operand" "=x,m,x,?r,?o") - (match_operand:TF 1 "general_operand" "xm,x,C,roF,Fr"))] - "TARGET_SSE2 - && !(MEM_P (operands[0]) && MEM_P (operands[1]))" -{ - switch (which_alternative) - { - case 0: - case 1: + case 3: + case 4: + return "mov{l}\t{%1, %0|%0, %1}"; + case 5: + if (get_attr_mode (insn) == MODE_TI) + return "%vpxor\t%0, %d0"; + else + return "%vxorps\t%0, %d0"; + case 6: if (get_attr_mode (insn) == MODE_V4SF) return "%vmovaps\t{%1, %0|%0, %1}"; else - return "%vmovdqa\t{%1, %0|%0, %1}"; - case 2: - if (get_attr_mode (insn) == MODE_V4SF) - return "%vxorps\t%0, %d0"; + return "%vmovss\t{%1, %d0|%d0, %1}"; + case 7: + if (TARGET_AVX) + return REG_P (operands[1]) ? "vmovss\t{%1, %0, %0|%0, %0, %1}" + : "vmovss\t{%1, %0|%0, %1}"; else - return "%vpxor\t%0, %d0"; - case 3: - case 4: - return "#"; + return "movss\t{%1, %0|%0, %1}"; + case 8: + return "%vmovss\t{%1, %0|%0, %1}"; + + case 9: case 10: case 14: case 15: + return "movd\t{%1, %0|%0, %1}"; + case 12: case 13: + return "%vmovd\t{%1, %0|%0, %1}"; + + case 11: + return "movq\t{%1, %0|%0, %1}"; + default: gcc_unreachable (); } } - [(set_attr "type" "ssemov,ssemov,sselog1,*,*") - (set_attr "prefix" "maybe_vex,maybe_vex,maybe_vex,*,*") + [(set_attr "type" "fmov,fmov,fmov,imov,imov,sselog1,ssemov,ssemov,ssemov,mmxmov,mmxmov,mmxmov,ssemov,ssemov,mmxmov,mmxmov") + (set (attr "prefix") + (if_then_else (eq_attr "alternative" "5,6,7,8,12,13") + (const_string "maybe_vex") + (const_string "orig"))) (set (attr "mode") - (cond [(eq_attr "alternative" "0,2") + (cond [(eq_attr "alternative" "3,4,9,10") + (const_string "SI") + (eq_attr "alternative" "5") (if_then_else - (ne (symbol_ref "optimize_function_for_size_p (cfun)") - (const_int 0)) - (const_string "V4SF") - (const_string "TI")) - (eq_attr "alternative" "1") + (and (and (ne (symbol_ref "TARGET_SSE_LOAD0_BY_PXOR") + (const_int 0)) + (ne (symbol_ref "TARGET_SSE2") + (const_int 0))) + (eq (symbol_ref "optimize_function_for_size_p (cfun)") + (const_int 0))) + (const_string "TI") + (const_string "V4SF")) + /* For architectures resolving dependencies on + whole SSE registers use APS move to break dependency + chains, otherwise use short move to avoid extra work. + + Do the same for architectures resolving dependencies on + the parts. While in DF mode it is better to always handle + just register parts, the SF mode is different due to lack + of instructions to load just part of the register. It is + better to maintain the whole registers in single format + to avoid problems on using packed logical operations. */ + (eq_attr "alternative" "6") (if_then_else - (ior (ne (symbol_ref "TARGET_SSE_TYPELESS_STORES") + (ior (ne (symbol_ref "TARGET_SSE_PARTIAL_REG_DEPENDENCY") (const_int 0)) - (ne (symbol_ref "optimize_function_for_size_p (cfun)") + (ne (symbol_ref "TARGET_SSE_SPLIT_REGS") (const_int 0))) (const_string "V4SF") - (const_string "TI"))] - (const_string "DI")))]) - -(define_insn "*pushtf_sse" - [(set (match_operand:TF 0 "push_operand" "=<,<,<") - (match_operand:TF 1 "general_no_elim_operand" "x,Fo,*r"))] - "TARGET_SSE2" -{ - /* This insn should be already split before reg-stack. */ - gcc_unreachable (); -} - [(set_attr "type" "multi") - (set_attr "unit" "sse,*,*") - (set_attr "mode" "TF,SI,SI")]) - -(define_split - [(set (match_operand:TF 0 "push_operand" "") - (match_operand:TF 1 "general_operand" ""))] - "TARGET_SSE2 && reload_completed - && !SSE_REG_P (operands[1])" - [(const_int 0)] - "ix86_split_long_move (operands); DONE;") - -(define_split - [(set (match_operand:TF 0 "push_operand" "") - (match_operand:TF 1 "any_fp_register_operand" ""))] - "TARGET_SSE2" - [(set (reg:P SP_REG) (plus:P (reg:P SP_REG) (const_int -16))) - (set (mem:TF (reg:P SP_REG)) (match_dup 1))] - "") - -(define_split - [(set (match_operand 0 "nonimmediate_operand" "") - (match_operand 1 "general_operand" ""))] - "reload_completed - && !(MEM_P (operands[0]) && MEM_P (operands[1])) - && GET_MODE (operands[0]) == XFmode - && ! (ANY_FP_REG_P (operands[0]) || - (GET_CODE (operands[0]) == SUBREG - && ANY_FP_REG_P (SUBREG_REG (operands[0])))) - && ! (ANY_FP_REG_P (operands[1]) || - (GET_CODE (operands[1]) == SUBREG - && ANY_FP_REG_P (SUBREG_REG (operands[1]))))" - [(const_int 0)] - "ix86_split_long_move (operands); DONE;") + (const_string "SF")) + (eq_attr "alternative" "11") + (const_string "DI")] + (const_string "SF")))]) (define_split [(set (match_operand 0 "register_operand" "") @@ -3774,8 +3483,8 @@ && MEM_P (operands[1]) && (GET_MODE (operands[0]) == TFmode || GET_MODE (operands[0]) == XFmode - || GET_MODE (operands[0]) == SFmode - || GET_MODE (operands[0]) == DFmode) + || GET_MODE (operands[0]) == DFmode + || GET_MODE (operands[0]) == SFmode) && (operands[2] = find_constant_src (insn))" [(set (match_dup 0) (match_dup 2))] { @@ -3806,8 +3515,8 @@ && MEM_P (operands[1]) && (GET_MODE (operands[0]) == TFmode || GET_MODE (operands[0]) == XFmode - || GET_MODE (operands[0]) == SFmode - || GET_MODE (operands[0]) == DFmode) + || GET_MODE (operands[0]) == DFmode + || GET_MODE (operands[0]) == SFmode) && (operands[2] = find_constant_src (insn))" [(set (match_dup 0) (match_dup 2))] { @@ -3831,12 +3540,47 @@ FAIL; }) +;; Split the load of -0.0 or -1.0 into fldz;fchs or fld1;fchs sequence +(define_split + [(set (match_operand:X87MODEF 0 "register_operand" "") + (match_operand:X87MODEF 1 "immediate_operand" ""))] + "reload_completed && FP_REGNO_P (REGNO (operands[0])) + && (standard_80387_constant_p (operands[1]) == 8 + || standard_80387_constant_p (operands[1]) == 9)" + [(set (match_dup 0)(match_dup 1)) + (set (match_dup 0) + (neg:X87MODEF (match_dup 0)))] +{ + REAL_VALUE_TYPE r; + + REAL_VALUE_FROM_CONST_DOUBLE (r, operands[1]); + if (real_isnegzero (&r)) + operands[1] = CONST0_RTX (mode); + else + operands[1] = CONST1_RTX (mode); +}) + (define_insn "swapxf" [(set (match_operand:XF 0 "register_operand" "+f") (match_operand:XF 1 "register_operand" "+f")) (set (match_dup 1) (match_dup 0))] - "TARGET_80387" + "TARGET_80387" +{ + if (STACK_TOP_P (operands[0])) + return "fxch\t%1"; + else + return "fxch\t%0"; +} + [(set_attr "type" "fxch") + (set_attr "mode" "XF")]) + +(define_insn "*swap" + [(set (match_operand:MODEF 0 "fp_register_operand" "+f") + (match_operand:MODEF 1 "fp_register_operand" "+f")) + (set (match_dup 1) + (match_dup 0))] + "TARGET_80387 || reload_completed" { if (STACK_TOP_P (operands[0])) return "fxch\t%1"; @@ -3844,35 +3588,7 @@ return "fxch\t%0"; } [(set_attr "type" "fxch") - (set_attr "mode" "XF")]) - -;; Split the load of -0.0 or -1.0 into fldz;fchs or fld1;fchs sequence -(define_split - [(set (match_operand:X87MODEF 0 "register_operand" "") - (match_operand:X87MODEF 1 "immediate_operand" ""))] - "reload_completed && FP_REGNO_P (REGNO (operands[0])) - && (standard_80387_constant_p (operands[1]) == 8 - || standard_80387_constant_p (operands[1]) == 9)" - [(set (match_dup 0)(match_dup 1)) - (set (match_dup 0) - (neg:X87MODEF (match_dup 0)))] -{ - REAL_VALUE_TYPE r; - - REAL_VALUE_FROM_CONST_DOUBLE (r, operands[1]); - if (real_isnegzero (&r)) - operands[1] = CONST0_RTX (mode); - else - operands[1] = CONST1_RTX (mode); -}) - -(define_split - [(set (match_operand:TF 0 "nonimmediate_operand" "") - (match_operand:TF 1 "general_operand" ""))] - "reload_completed - && !(SSE_REG_P (operands[0]) || SSE_REG_P (operands[1]))" - [(const_int 0)] - "ix86_split_long_move (operands); DONE;") + (set_attr "mode" "")]) ;; Zero extension instructions @@ -4136,7 +3852,7 @@ (zero_extend:DI (match_operand:SI 1 "general_operand" ""))) (clobber (reg:CC FLAGS_REG))] "!TARGET_64BIT && reload_completed - && !SSE_REG_P (operands[0]) && !MMX_REG_P (operands[0])" + && !(MMX_REG_P (operands[0]) || SSE_REG_P (operands[0]))" [(set (match_dup 3) (match_dup 1)) (set (match_dup 4) (const_int 0))] "split_di (&operands[0], 1, &operands[3], &operands[4]);") @@ -4411,7 +4127,7 @@ "" [(set (reg:P SP_REG) (plus:P (reg:P SP_REG) (match_dup 2))) (set (mem:XF (reg:P SP_REG)) (float_extend:XF (match_dup 1)))] - "operands[2] = GEN_INT (TARGET_128BIT_LONG_DOUBLE ? -16 : -12);") + "operands[2] = GEN_INT (-GET_MODE_SIZE (XFmode));") (define_split [(set (match_operand:XF 0 "push_operand" "") @@ -4419,7 +4135,7 @@ "" [(set (reg:P SP_REG) (plus:P (reg:P SP_REG) (match_dup 2))) (set (mem:DF (reg:P SP_REG)) (float_extend:XF (match_dup 1)))] - "operands[2] = GEN_INT (TARGET_128BIT_LONG_DOUBLE ? -16 : -12);") + "operands[2] = GEN_INT (-GET_MODE_SIZE (XFmode));") (define_expand "extendsfdf2" [(set (match_operand:DF 0 "nonimmediate_operand" "") @@ -5013,6 +4729,7 @@ (set (match_operand:SSEMODEI24 2 "register_operand" "") (fix:SSEMODEI24 (match_dup 0)))] "TARGET_SHORTEN_X87_SSE + && !(TARGET_AVOID_VECTOR_DECODE && optimize_insn_for_speed_p ()) && peep2_reg_dead_p (2, operands[0])" [(set (match_dup 2) (fix:SSEMODEI24 (match_dup 1)))] "") @@ -6118,10 +5835,6 @@ (const_string "lea") (eq_attr "alternative" "3") (const_string "lea") - ; Current assemblers are broken and do not allow @GOTOFF in - ; ought but a memory context. - (match_operand:SWI48 2 "pic_symbolic_operand" "") - (const_string "lea") (match_operand:SWI48 2 "incdec_operand" "") (const_string "incdec") ] @@ -6172,10 +5885,6 @@ [(set (attr "type") (cond [(eq_attr "alternative" "1") (const_string "lea") - ; Current assemblers are broken and do not allow @GOTOFF in - ; ought but a memory context. - (match_operand:SI 2 "pic_symbolic_operand" "") - (const_string "lea") (match_operand:SI 2 "incdec_operand" "") (const_string "incdec") ] @@ -6240,7 +5949,9 @@ { case TYPE_LEA: return "#"; + case TYPE_INCDEC: + gcc_assert (rtx_equal_p (operands[0], operands[1])); if (operands[2] == const1_rtx) return "inc{w}\t%0"; else @@ -6250,6 +5961,7 @@ } default: + gcc_assert (rtx_equal_p (operands[0], operands[1])); if (x86_maybe_negate_const_int (&operands[2], HImode)) return "sub{w}\t{%2, %0|%0, %2}"; @@ -6328,7 +6040,9 @@ { case TYPE_LEA: return "#"; + case TYPE_INCDEC: + gcc_assert (rtx_equal_p (operands[0], operands[1])); if (operands[2] == const1_rtx) return widen ? "inc{l}\t%k0" : "inc{b}\t%0"; else @@ -6338,6 +6052,7 @@ } default: + gcc_assert (rtx_equal_p (operands[0], operands[1])); if (x86_maybe_negate_const_int (&operands[2], QImode)) { if (widen) @@ -6403,22 +6118,18 @@ (define_insn "*add_2" [(set (reg FLAGS_REG) (compare - (plus:SWI48 - (match_operand:SWI48 1 "nonimmediate_operand" "%0,0") - (match_operand:SWI48 2 "" ",r")) + (plus:SWI + (match_operand:SWI 1 "nonimmediate_operand" "%0,0") + (match_operand:SWI 2 "" ",")) (const_int 0))) - (set (match_operand:SWI48 0 "nonimmediate_operand" "=r,rm") - (plus:SWI48 (match_dup 1) (match_dup 2)))] + (set (match_operand:SWI 0 "nonimmediate_operand" "=,m") + (plus:SWI (match_dup 1) (match_dup 2)))] "ix86_match_ccmode (insn, CCGOCmode) - && ix86_binary_operator_ok (PLUS, mode, operands) - /* Current assemblers are broken and do not allow @GOTOFF in - ought but a memory context. */ - && ! pic_symbolic_operand (operands[2], VOIDmode)" + && ix86_binary_operator_ok (PLUS, mode, operands)" { switch (get_attr_type (insn)) { case TYPE_INCDEC: - gcc_assert (rtx_equal_p (operands[0], operands[1])); if (operands[2] == const1_rtx) return "inc{}\t%0"; else @@ -6428,9 +6139,6 @@ } default: - gcc_assert (rtx_equal_p (operands[0], operands[1])); - /* ???? In DImode, we ought to handle there the 32bit case too - - do we need new constraint? */ if (x86_maybe_negate_const_int (&operands[2], mode)) return "sub{}\t{%2, %0|%0, %2}"; @@ -6438,7 +6146,7 @@ } } [(set (attr "type") - (if_then_else (match_operand:SWI48 2 "incdec_operand" "") + (if_then_else (match_operand:SWI 2 "incdec_operand" "") (const_string "incdec") (const_string "alu"))) (set (attr "length_immediate") @@ -6458,10 +6166,7 @@ (set (match_operand:DI 0 "register_operand" "=r") (zero_extend:DI (plus:SI (match_dup 1) (match_dup 2))))] "TARGET_64BIT && ix86_match_ccmode (insn, CCGOCmode) - && ix86_binary_operator_ok (PLUS, SImode, operands) - /* Current assemblers are broken and do not allow @GOTOFF in - ought but a memory context. */ - && ! pic_symbolic_operand (operands[2], VOIDmode)" + && ix86_binary_operator_ok (PLUS, SImode, operands)" { switch (get_attr_type (insn)) { @@ -6492,99 +6197,18 @@ (const_string "*"))) (set_attr "mode" "SI")]) -(define_insn "*addhi_2" - [(set (reg FLAGS_REG) - (compare - (plus:HI (match_operand:HI 1 "nonimmediate_operand" "%0,0") - (match_operand:HI 2 "general_operand" "rmn,rn")) - (const_int 0))) - (set (match_operand:HI 0 "nonimmediate_operand" "=r,rm") - (plus:HI (match_dup 1) (match_dup 2)))] - "ix86_match_ccmode (insn, CCGOCmode) - && ix86_binary_operator_ok (PLUS, HImode, operands)" -{ - switch (get_attr_type (insn)) - { - case TYPE_INCDEC: - if (operands[2] == const1_rtx) - return "inc{w}\t%0"; - else - { - gcc_assert (operands[2] == constm1_rtx); - return "dec{w}\t%0"; - } - - default: - if (x86_maybe_negate_const_int (&operands[2], HImode)) - return "sub{w}\t{%2, %0|%0, %2}"; - - return "add{w}\t{%2, %0|%0, %2}"; - } -} - [(set (attr "type") - (if_then_else (match_operand:HI 2 "incdec_operand" "") - (const_string "incdec") - (const_string "alu"))) - (set (attr "length_immediate") - (if_then_else - (and (eq_attr "type" "alu") (match_operand 2 "const128_operand" "")) - (const_string "1") - (const_string "*"))) - (set_attr "mode" "HI")]) - -(define_insn "*addqi_2" - [(set (reg FLAGS_REG) - (compare - (plus:QI (match_operand:QI 1 "nonimmediate_operand" "%0,0") - (match_operand:QI 2 "general_operand" "qmn,qn")) - (const_int 0))) - (set (match_operand:QI 0 "nonimmediate_operand" "=q,qm") - (plus:QI (match_dup 1) (match_dup 2)))] - "ix86_match_ccmode (insn, CCGOCmode) - && ix86_binary_operator_ok (PLUS, QImode, operands)" -{ - switch (get_attr_type (insn)) - { - case TYPE_INCDEC: - if (operands[2] == const1_rtx) - return "inc{b}\t%0"; - else - { - gcc_assert (operands[2] == constm1_rtx - || (CONST_INT_P (operands[2]) - && INTVAL (operands[2]) == 255)); - return "dec{b}\t%0"; - } - - default: - if (x86_maybe_negate_const_int (&operands[2], QImode)) - return "sub{b}\t{%2, %0|%0, %2}"; - - return "add{b}\t{%2, %0|%0, %2}"; - } -} - [(set (attr "type") - (if_then_else (match_operand:QI 2 "incdec_operand" "") - (const_string "incdec") - (const_string "alu"))) - (set_attr "mode" "QI")]) - (define_insn "*add_3" [(set (reg FLAGS_REG) (compare - (neg:SWI48 (match_operand:SWI48 2 "" "")) - (match_operand:SWI48 1 "nonimmediate_operand" "%0"))) - (clobber (match_scratch:SWI48 0 "=r"))] + (neg:SWI (match_operand:SWI 2 "" "")) + (match_operand:SWI 1 "nonimmediate_operand" "%0"))) + (clobber (match_scratch:SWI 0 "="))] "ix86_match_ccmode (insn, CCZmode) - && !(MEM_P (operands[1]) && MEM_P (operands[2])) - /* Current assemblers are broken and do not allow @GOTOFF in - ought but a memory context. */ - && ! pic_symbolic_operand (operands[2], VOIDmode)" + && !(MEM_P (operands[1]) && MEM_P (operands[2]))" { switch (get_attr_type (insn)) { case TYPE_INCDEC: - gcc_assert (rtx_equal_p (operands[0], operands[1])); if (operands[2] == const1_rtx) return "inc{}\t%0"; else @@ -6594,9 +6218,6 @@ } default: - gcc_assert (rtx_equal_p (operands[0], operands[1])); - /* ???? In DImode, we ought to handle there the 32bit case too - - do we need new constraint? */ if (x86_maybe_negate_const_int (&operands[2], mode)) return "sub{}\t{%2, %0|%0, %2}"; @@ -6604,7 +6225,7 @@ } } [(set (attr "type") - (if_then_else (match_operand:SWI48 2 "incdec_operand" "") + (if_then_else (match_operand:SWI 2 "incdec_operand" "") (const_string "incdec") (const_string "alu"))) (set (attr "length_immediate") @@ -6623,10 +6244,7 @@ (set (match_operand:DI 0 "register_operand" "=r") (zero_extend:DI (plus:SI (match_dup 1) (match_dup 2))))] "TARGET_64BIT && ix86_match_ccmode (insn, CCZmode) - && ix86_binary_operator_ok (PLUS, SImode, operands) - /* Current assemblers are broken and do not allow @GOTOFF in - ought but a memory context. */ - && ! pic_symbolic_operand (operands[2], VOIDmode)" + && ix86_binary_operator_ok (PLUS, SImode, operands)" { switch (get_attr_type (insn)) { @@ -6636,178 +6254,14 @@ else { gcc_assert (operands[2] == constm1_rtx); - return "dec{l}\t%k0"; - } - - default: - if (x86_maybe_negate_const_int (&operands[2], SImode)) - return "sub{l}\t{%2, %k0|%k0, %2}"; - - return "add{l}\t{%2, %k0|%k0, %2}"; - } -} - [(set (attr "type") - (if_then_else (match_operand:SI 2 "incdec_operand" "") - (const_string "incdec") - (const_string "alu"))) - (set (attr "length_immediate") - (if_then_else - (and (eq_attr "type" "alu") (match_operand 2 "const128_operand" "")) - (const_string "1") - (const_string "*"))) - (set_attr "mode" "SI")]) - -(define_insn "*addhi_3" - [(set (reg FLAGS_REG) - (compare - (neg:HI (match_operand:HI 2 "general_operand" "rmn")) - (match_operand:HI 1 "nonimmediate_operand" "%0"))) - (clobber (match_scratch:HI 0 "=r"))] - "ix86_match_ccmode (insn, CCZmode) - && !(MEM_P (operands[1]) && MEM_P (operands[2]))" -{ - switch (get_attr_type (insn)) - { - case TYPE_INCDEC: - if (operands[2] == const1_rtx) - return "inc{w}\t%0"; - else - { - gcc_assert (operands[2] == constm1_rtx); - return "dec{w}\t%0"; - } - - default: - if (x86_maybe_negate_const_int (&operands[2], HImode)) - return "sub{w}\t{%2, %0|%0, %2}"; - - return "add{w}\t{%2, %0|%0, %2}"; - } -} - [(set (attr "type") - (if_then_else (match_operand:HI 2 "incdec_operand" "") - (const_string "incdec") - (const_string "alu"))) - (set (attr "length_immediate") - (if_then_else - (and (eq_attr "type" "alu") (match_operand 2 "const128_operand" "")) - (const_string "1") - (const_string "*"))) - (set_attr "mode" "HI")]) - -(define_insn "*addqi_3" - [(set (reg FLAGS_REG) - (compare - (neg:QI (match_operand:QI 2 "general_operand" "qmn")) - (match_operand:QI 1 "nonimmediate_operand" "%0"))) - (clobber (match_scratch:QI 0 "=q"))] - "ix86_match_ccmode (insn, CCZmode) - && !(MEM_P (operands[1]) && MEM_P (operands[2]))" -{ - switch (get_attr_type (insn)) - { - case TYPE_INCDEC: - if (operands[2] == const1_rtx) - return "inc{b}\t%0"; - else - { - gcc_assert (operands[2] == constm1_rtx - || (CONST_INT_P (operands[2]) - && INTVAL (operands[2]) == 255)); - return "dec{b}\t%0"; - } - - default: - if (x86_maybe_negate_const_int (&operands[2], QImode)) - return "sub{b}\t{%2, %0|%0, %2}"; - - return "add{b}\t{%2, %0|%0, %2}"; - } -} - [(set (attr "type") - (if_then_else (match_operand:QI 2 "incdec_operand" "") - (const_string "incdec") - (const_string "alu"))) - (set_attr "mode" "QI")]) - -; For comparisons against 1, -1 and 128, we may generate better code -; by converting cmp to add, inc or dec as done by peephole2. This pattern -; is matched then. We can't accept general immediate, because for -; case of overflows, the result is messed up. -; Also carry flag is reversed compared to cmp, so this conversion is valid -; only for comparisons not depending on it. - -(define_insn "*adddi_4" - [(set (reg FLAGS_REG) - (compare - (match_operand:DI 1 "nonimmediate_operand" "0") - (match_operand:DI 2 "x86_64_immediate_operand" "e"))) - (clobber (match_scratch:DI 0 "=rm"))] - "TARGET_64BIT - && ix86_match_ccmode (insn, CCGCmode)" -{ - switch (get_attr_type (insn)) - { - case TYPE_INCDEC: - if (operands[2] == constm1_rtx) - return "inc{q}\t%0"; - else - { - gcc_assert (operands[2] == const1_rtx); - return "dec{q}\t%0"; - } - - default: - gcc_assert (rtx_equal_p (operands[0], operands[1])); - if (x86_maybe_negate_const_int (&operands[2], DImode)) - return "add{q}\t{%2, %0|%0, %2}"; - - return "sub{q}\t{%2, %0|%0, %2}"; - } -} - [(set (attr "type") - (if_then_else (match_operand:DI 2 "incdec_operand" "") - (const_string "incdec") - (const_string "alu"))) - (set (attr "length_immediate") - (if_then_else - (and (eq_attr "type" "alu") (match_operand 2 "const128_operand" "")) - (const_string "1") - (const_string "*"))) - (set_attr "mode" "DI")]) - -; For comparisons against 1, -1 and 128, we may generate better code -; by converting cmp to add, inc or dec as done by peephole2. This pattern -; is matched then. We can't accept general immediate, because for -; case of overflows, the result is messed up. -; Also carry flag is reversed compared to cmp, so this conversion is valid -; only for comparisons not depending on it. - -(define_insn "*addsi_4" - [(set (reg FLAGS_REG) - (compare - (match_operand:SI 1 "nonimmediate_operand" "0") - (match_operand:SI 2 "const_int_operand" "n"))) - (clobber (match_scratch:SI 0 "=rm"))] - "ix86_match_ccmode (insn, CCGCmode)" -{ - switch (get_attr_type (insn)) - { - case TYPE_INCDEC: - if (operands[2] == constm1_rtx) - return "inc{l}\t%0"; - else - { - gcc_assert (operands[2] == const1_rtx); - return "dec{l}\t%0"; + return "dec{l}\t%k0"; } default: - gcc_assert (rtx_equal_p (operands[0], operands[1])); if (x86_maybe_negate_const_int (&operands[2], SImode)) - return "add{l}\t{%2, %0|%0, %2}"; + return "sub{l}\t{%2, %k0|%k0, %2}"; - return "sub{l}\t{%2, %0|%0, %2}"; + return "add{l}\t{%2, %k0|%k0, %2}"; } } [(set (attr "type") @@ -6821,37 +6275,42 @@ (const_string "*"))) (set_attr "mode" "SI")]) -; See comments above addsi_4 for details. +; For comparisons against 1, -1 and 128, we may generate better code +; by converting cmp to add, inc or dec as done by peephole2. This pattern +; is matched then. We can't accept general immediate, because for +; case of overflows, the result is messed up. +; Also carry flag is reversed compared to cmp, so this conversion is valid +; only for comparisons not depending on it. -(define_insn "*addhi_4" +(define_insn "*adddi_4" [(set (reg FLAGS_REG) (compare - (match_operand:HI 1 "nonimmediate_operand" "0") - (match_operand:HI 2 "const_int_operand" "n"))) - (clobber (match_scratch:HI 0 "=rm"))] - "ix86_match_ccmode (insn, CCGCmode)" + (match_operand:DI 1 "nonimmediate_operand" "0") + (match_operand:DI 2 "x86_64_immediate_operand" "e"))) + (clobber (match_scratch:DI 0 "=rm"))] + "TARGET_64BIT + && ix86_match_ccmode (insn, CCGCmode)" { switch (get_attr_type (insn)) { case TYPE_INCDEC: if (operands[2] == constm1_rtx) - return "inc{w}\t%0"; + return "inc{q}\t%0"; else - { + { gcc_assert (operands[2] == const1_rtx); - return "dec{w}\t%0"; + return "dec{q}\t%0"; } default: - gcc_assert (rtx_equal_p (operands[0], operands[1])); - if (x86_maybe_negate_const_int (&operands[2], HImode)) - return "add{w}\t{%2, %0|%0, %2}"; + if (x86_maybe_negate_const_int (&operands[2], DImode)) + return "add{q}\t{%2, %0|%0, %2}"; - return "sub{w}\t{%2, %0|%0, %2}"; + return "sub{q}\t{%2, %0|%0, %2}"; } } [(set (attr "type") - (if_then_else (match_operand:HI 2 "incdec_operand" "") + (if_then_else (match_operand:DI 2 "incdec_operand" "") (const_string "incdec") (const_string "alu"))) (set (attr "length_immediate") @@ -6859,81 +6318,43 @@ (and (eq_attr "type" "alu") (match_operand 2 "const128_operand" "")) (const_string "1") (const_string "*"))) - (set_attr "mode" "HI")]) + (set_attr "mode" "DI")]) -; See comments above addsi_4 for details. +; For comparisons against 1, -1 and 128, we may generate better code +; by converting cmp to add, inc or dec as done by peephole2. This pattern +; is matched then. We can't accept general immediate, because for +; case of overflows, the result is messed up. +; Also carry flag is reversed compared to cmp, so this conversion is valid +; only for comparisons not depending on it. -(define_insn "*addqi_4" +(define_insn "*add_4" [(set (reg FLAGS_REG) (compare - (match_operand:QI 1 "nonimmediate_operand" "0") - (match_operand:QI 2 "const_int_operand" "n"))) - (clobber (match_scratch:QI 0 "=qm"))] + (match_operand:SWI124 1 "nonimmediate_operand" "0") + (match_operand:SWI124 2 "const_int_operand" "n"))) + (clobber (match_scratch:SWI124 0 "=m"))] "ix86_match_ccmode (insn, CCGCmode)" { switch (get_attr_type (insn)) { case TYPE_INCDEC: - if (operands[2] == constm1_rtx - || (CONST_INT_P (operands[2]) - && INTVAL (operands[2]) == 255)) - return "inc{b}\t%0"; - else - { - gcc_assert (operands[2] == const1_rtx); - return "dec{b}\t%0"; - } - - default: - gcc_assert (rtx_equal_p (operands[0], operands[1])); - if (x86_maybe_negate_const_int (&operands[2], QImode)) - return "add{b}\t{%2, %0|%0, %2}"; - - return "sub{b}\t{%2, %0|%0, %2}"; - } -} - [(set (attr "type") - (if_then_else (match_operand:HI 2 "incdec_operand" "") - (const_string "incdec") - (const_string "alu"))) - (set_attr "mode" "QI")]) - -(define_insn "*add_5" - [(set (reg FLAGS_REG) - (compare - (plus:SWI48 - (match_operand:SWI48 1 "nonimmediate_operand" "%0") - (match_operand:SWI48 2 "" "")) - (const_int 0))) - (clobber (match_scratch:SWI48 0 "=r"))] - "ix86_match_ccmode (insn, CCGOCmode) - && !(MEM_P (operands[1]) && MEM_P (operands[2])) - /* Current assemblers are broken and do not allow @GOTOFF in - ought but a memory context. */ - && ! pic_symbolic_operand (operands[2], VOIDmode)" -{ - switch (get_attr_type (insn)) - { - case TYPE_INCDEC: - gcc_assert (rtx_equal_p (operands[0], operands[1])); - if (operands[2] == const1_rtx) + if (operands[2] == constm1_rtx) return "inc{}\t%0"; else { - gcc_assert (operands[2] == constm1_rtx); + gcc_assert (operands[2] == const1_rtx); return "dec{}\t%0"; } default: - gcc_assert (rtx_equal_p (operands[0], operands[1])); if (x86_maybe_negate_const_int (&operands[2], mode)) - return "sub{}\t{%2, %0|%0, %2}"; + return "add{}\t{%2, %0|%0, %2}"; - return "add{}\t{%2, %0|%0, %2}"; + return "sub{}\t{%2, %0|%0, %2}"; } } [(set (attr "type") - (if_then_else (match_operand:SWI48 2 "incdec_operand" "") + (if_then_else (match_operand: 2 "incdec_operand" "") (const_string "incdec") (const_string "alu"))) (set (attr "length_immediate") @@ -6943,13 +6364,14 @@ (const_string "*"))) (set_attr "mode" "")]) -(define_insn "*addhi_5" +(define_insn "*add_5" [(set (reg FLAGS_REG) (compare - (plus:HI (match_operand:HI 1 "nonimmediate_operand" "%0") - (match_operand:HI 2 "general_operand" "rmn")) + (plus:SWI + (match_operand:SWI 1 "nonimmediate_operand" "%0") + (match_operand:SWI 2 "" "")) (const_int 0))) - (clobber (match_scratch:HI 0 "=r"))] + (clobber (match_scratch:SWI 0 "="))] "ix86_match_ccmode (insn, CCGOCmode) && !(MEM_P (operands[1]) && MEM_P (operands[2]))" { @@ -6957,22 +6379,22 @@ { case TYPE_INCDEC: if (operands[2] == const1_rtx) - return "inc{w}\t%0"; + return "inc{}\t%0"; else - { - gcc_assert (operands[2] == constm1_rtx); - return "dec{w}\t%0"; + { + gcc_assert (operands[2] == constm1_rtx); + return "dec{}\t%0"; } default: - if (x86_maybe_negate_const_int (&operands[2], HImode)) - return "sub{w}\t{%2, %0|%0, %2}"; + if (x86_maybe_negate_const_int (&operands[2], mode)) + return "sub{}\t{%2, %0|%0, %2}"; - return "add{w}\t{%2, %0|%0, %2}"; + return "add{}\t{%2, %0|%0, %2}"; } } [(set (attr "type") - (if_then_else (match_operand:HI 2 "incdec_operand" "") + (if_then_else (match_operand:SWI 2 "incdec_operand" "") (const_string "incdec") (const_string "alu"))) (set (attr "length_immediate") @@ -6980,43 +6402,7 @@ (and (eq_attr "type" "alu") (match_operand 2 "const128_operand" "")) (const_string "1") (const_string "*"))) - (set_attr "mode" "HI")]) - -(define_insn "*addqi_5" - [(set (reg FLAGS_REG) - (compare - (plus:QI (match_operand:QI 1 "nonimmediate_operand" "%0") - (match_operand:QI 2 "general_operand" "qmn")) - (const_int 0))) - (clobber (match_scratch:QI 0 "=q"))] - "ix86_match_ccmode (insn, CCGOCmode) - && !(MEM_P (operands[1]) && MEM_P (operands[2]))" -{ - switch (get_attr_type (insn)) - { - case TYPE_INCDEC: - if (operands[2] == const1_rtx) - return "inc{b}\t%0"; - else - { - gcc_assert (operands[2] == constm1_rtx - || (CONST_INT_P (operands[2]) - && INTVAL (operands[2]) == 255)); - return "dec{b}\t%0"; - } - - default: - if (x86_maybe_negate_const_int (&operands[2], QImode)) - return "sub{b}\t{%2, %0|%0, %2}"; - - return "add{b}\t{%2, %0|%0, %2}"; - } -} - [(set (attr "type") - (if_then_else (match_operand:QI 2 "incdec_operand" "") - (const_string "incdec") - (const_string "alu"))) - (set_attr "mode" "QI")]) + (set_attr "mode" "")]) (define_insn "*addqi_ext_1_rex64" [(set (zero_extract:SI (match_operand 0 "ext_register_operand" "=Q") @@ -7038,9 +6424,7 @@ return "inc{b}\t%h0"; else { - gcc_assert (operands[2] == constm1_rtx - || (CONST_INT_P (operands[2]) - && INTVAL (operands[2]) == 255)); + gcc_assert (operands[2] == constm1_rtx); return "dec{b}\t%h0"; } @@ -7075,9 +6459,7 @@ return "inc{b}\t%h0"; else { - gcc_assert (operands[2] == constm1_rtx - || (CONST_INT_P (operands[2]) - && INTVAL (operands[2]) == 255)); + gcc_assert (operands[2] == constm1_rtx); return "dec{b}\t%h0"; } @@ -7890,17 +7272,6 @@ ;; Divide instructions -(define_insn "divqi3" - [(set (match_operand:QI 0 "register_operand" "=a") - (any_div:QI - (match_operand:HI 1 "register_operand" "0") - (match_operand:QI 2 "nonimmediate_operand" "qm"))) - (clobber (reg:CC FLAGS_REG))] - "TARGET_QIMODE_MATH" - "div{b}\t%2" - [(set_attr "type" "idiv") - (set_attr "mode" "QI")]) - ;; The patterns that match these are at the end of this file. (define_expand "divxf3" @@ -7937,6 +7308,92 @@ ;; Divmod instructions. +(define_expand "divmodqi4" + [(parallel [(set (match_operand:QI 0 "register_operand" "") + (any_div:QI + (match_operand:QI 1 "register_operand" "") + (match_operand:QI 2 "nonimmediate_operand" ""))) + (set (match_operand:QI 3 "register_operand" "") + (mod:QI (match_dup 1) (match_dup 2))) + (clobber (reg:CC FLAGS_REG))])] + "TARGET_QIMODE_MATH" +{ + rtx div, mod, insn; + rtx tmp0, tmp1; + + tmp0 = gen_reg_rtx (HImode); + tmp1 = gen_reg_rtx (HImode); + + /* Extend operands[1] to HImode. Generate 8bit divide. Result is + in AX. */ + if ( == SIGN_EXTRACT) + { + emit_insn (gen_extendqihi2 (tmp1, operands[1])); + emit_insn (gen_divmodhiqi3 (tmp0, tmp1, operands[2])); + + div = gen_rtx_DIV (QImode, operands[1], operands[2]); + mod = gen_rtx_MOD (QImode, operands[1], operands[2]); + + tmp1 = gen_rtx_ (QImode, tmp0, + GEN_INT (8), GEN_INT (8)); + } + else + { + emit_insn (gen_zero_extendqihi2 (tmp1, operands[1])); + emit_insn (gen_udivmodhiqi3 (tmp0, tmp1, operands[2])); + + div = gen_rtx_UDIV (QImode, operands[1], operands[2]); + mod = gen_rtx_UMOD (QImode, operands[1], operands[2]); + + tmp1 = gen_rtx_ (SImode, tmp0, + GEN_INT (8), GEN_INT (8)); + tmp1 = simplify_gen_subreg (QImode, tmp1, SImode, 0); + } + + /* Extract remainder from AH. */ + insn = emit_move_insn (operands[3], tmp1); + set_unique_reg_note (insn, REG_EQUAL, mod); + + /* Extract quotient from AL. */ + insn = emit_move_insn (operands[0], gen_lowpart (QImode, tmp0)); + set_unique_reg_note (insn, REG_EQUAL, div); + + DONE; +}) + +;; Divide AX by r/m8, with result stored in +;; AL <- Quotient +;; AH <- Remainder +(define_insn "divmodhiqi3" + [(set (match_operand:HI 0 "register_operand" "=a") + (ior:HI + (ashift:HI + (zero_extend:HI + (mod:QI (match_operand:HI 1 "register_operand" "0") + (match_operand:QI 2 "nonimmediate_operand" "qm"))) + (const_int 8)) + (zero_extend:HI (div:QI (match_dup 1) (match_dup 2))))) + (clobber (reg:CC FLAGS_REG))] + "TARGET_QIMODE_MATH" + "idiv{b}\t%2" + [(set_attr "type" "idiv") + (set_attr "mode" "QI")]) + +(define_insn "udivmodhiqi3" + [(set (match_operand:HI 0 "register_operand" "=a") + (ior:HI + (ashift:HI + (zero_extend:HI + (umod:QI (match_operand:HI 1 "register_operand" "0") + (match_operand:QI 2 "nonimmediate_operand" "qm"))) + (const_int 8)) + (zero_extend:HI (udiv:QI (match_dup 1) (match_dup 2))))) + (clobber (reg:CC FLAGS_REG))] + "TARGET_QIMODE_MATH" + "div{b}\t%2" + [(set_attr "type" "idiv") + (set_attr "mode" "QI")]) + (define_expand "divmod4" [(parallel [(set (match_operand:SWIM248 0 "register_operand" "") (div:SWIM248 @@ -10142,7 +9599,7 @@ "TARGET_64BIT && reload_completed && true_regnum (operands[0]) != true_regnum (operands[1])" [(set (match_dup 0) - (zero_extend:DI (subreg:SI (mult:SI (match_dup 1) (match_dup 2)) 0)))] + (zero_extend:DI (subreg:SI (mult:DI (match_dup 1) (match_dup 2)) 0)))] { operands[1] = gen_lowpart (Pmode, operands[1]); operands[2] = gen_int_mode (1 << INTVAL (operands[2]), Pmode); @@ -10854,7 +10311,7 @@ FAIL; if (TARGET_64BIT) - emit_insn (gen_movdi_insv_1_rex64 (operands[0], operands[3])); + emit_insn (gen_movdi_insv_1 (operands[0], operands[3])); else emit_insn (gen_movsi_insv_1 (operands[0], operands[3])); @@ -11420,7 +10877,7 @@ ;; Define combination compare-and-branch fp compare instructions to help ;; combine. -(define_insn "*fp_jcc_3_387" +(define_insn "*fp_jcc_1_387" [(set (pc) (if_then_else (match_operator 0 "ix86_fp_comparison_operator" [(match_operand 1 "register_operand" "f") @@ -11438,7 +10895,7 @@ && !TARGET_CMOVE" "#") -(define_insn "*fp_jcc_4_387" +(define_insn "*fp_jcc_1r_387" [(set (pc) (if_then_else (match_operator 0 "ix86_fp_comparison_operator" [(match_operand 1 "register_operand" "f") @@ -11456,7 +10913,7 @@ && !TARGET_CMOVE" "#") -(define_insn "*fp_jcc_5_387" +(define_insn "*fp_jcc_2_387" [(set (pc) (if_then_else (match_operator 0 "ix86_fp_comparison_operator" [(match_operand 1 "register_operand" "f") @@ -11471,7 +10928,7 @@ && !TARGET_CMOVE" "#") -(define_insn "*fp_jcc_6_387" +(define_insn "*fp_jcc_2r_387" [(set (pc) (if_then_else (match_operator 0 "ix86_fp_comparison_operator" [(match_operand 1 "register_operand" "f") @@ -11486,7 +10943,7 @@ && !TARGET_CMOVE" "#") -(define_insn "*fp_jcc_7_387" +(define_insn "*fp_jcc_3_387" [(set (pc) (if_then_else (match_operator 0 "ix86_fp_comparison_operator" [(match_operand 1 "register_operand" "f") @@ -11503,29 +10960,6 @@ && !TARGET_CMOVE" "#") -;; The order of operands in *fp_jcc_8_387 is forced by combine in -;; simplify_comparison () function. Float operator is treated as RTX_OBJ -;; with a precedence over other operators and is always put in the first -;; place. Swap condition and operands to match ficom instruction. - -(define_insn "*fp_jcc_8_387" - [(set (pc) - (if_then_else (match_operator 0 "ix86_fp_comparison_operator" - [(match_operator 1 "float_operator" - [(match_operand:X87MODEI12 2 "nonimmediate_operand" "m,?r")]) - (match_operand 3 "register_operand" "f,f")]) - (label_ref (match_operand 4 "" "")) - (pc))) - (clobber (reg:CCFP FPSR_REG)) - (clobber (reg:CCFP FLAGS_REG)) - (clobber (match_scratch:HI 5 "=a,a"))] - "X87_FLOAT_MODE_P (GET_MODE (operands[3])) - && (TARGET_USE_MODE_FIOP || optimize_function_for_size_p (cfun)) - && GET_MODE (operands[1]) == GET_MODE (operands[3]) - && ix86_fp_compare_mode (swap_condition (GET_CODE (operands[0]))) == CCFPmode - && !TARGET_CMOVE" - "#") - (define_split [(set (pc) (if_then_else (match_operator 0 "ix86_fp_comparison_operator" @@ -11561,12 +10995,37 @@ DONE; }) +;; The order of operands in *fp_jcc_4_387 is forced by combine in +;; simplify_comparison () function. Float operator is treated as RTX_OBJ +;; with a precedence over other operators and is always put in the first +;; place. Swap condition and operands to match ficom instruction. + +(define_insn "*fp_jcc_4__387" + [(set (pc) + (if_then_else + (match_operator 0 "ix86_swapped_fp_comparison_operator" + [(match_operator 1 "float_operator" + [(match_operand:X87MODEI12 2 "nonimmediate_operand" "m,?r")]) + (match_operand 3 "register_operand" "f,f")]) + (label_ref (match_operand 4 "" "")) + (pc))) + (clobber (reg:CCFP FPSR_REG)) + (clobber (reg:CCFP FLAGS_REG)) + (clobber (match_scratch:HI 5 "=a,a"))] + "X87_FLOAT_MODE_P (GET_MODE (operands[3])) + && (TARGET_USE_MODE_FIOP || optimize_function_for_size_p (cfun)) + && GET_MODE (operands[1]) == GET_MODE (operands[3]) + && ix86_fp_compare_mode (swap_condition (GET_CODE (operands[0]))) == CCFPmode + && !TARGET_CMOVE" + "#") + (define_split [(set (pc) - (if_then_else (match_operator 0 "ix86_fp_comparison_operator" - [(match_operator 1 "float_operator" - [(match_operand:X87MODEI12 2 "memory_operand" "")]) - (match_operand 3 "register_operand" "")]) + (if_then_else + (match_operator 0 "ix86_swapped_fp_comparison_operator" + [(match_operator 1 "float_operator" + [(match_operand:X87MODEI12 2 "memory_operand" "")]) + (match_operand 3 "register_operand" "")]) (match_operand 4 "" "") (match_operand 5 "" ""))) (clobber (reg:CCFP FPSR_REG)) @@ -11586,10 +11045,11 @@ ;; %%% Kill this when reload knows how to do it. (define_split [(set (pc) - (if_then_else (match_operator 0 "ix86_fp_comparison_operator" - [(match_operator 1 "float_operator" - [(match_operand:X87MODEI12 2 "register_operand" "")]) - (match_operand 3 "register_operand" "")]) + (if_then_else + (match_operator 0 "ix86_swapped_fp_comparison_operator" + [(match_operator 1 "float_operator" + [(match_operand:X87MODEI12 2 "register_operand" "")]) + (match_operand 3 "register_operand" "")]) (match_operand 4 "" "") (match_operand 5 "" ""))) (clobber (reg:CCFP FPSR_REG)) @@ -12521,7 +11981,8 @@ (define_insn_and_split "paritydi2_cmp" [(set (reg:CC FLAGS_REG) - (parity:CC (match_operand:DI 3 "register_operand" "0"))) + (unspec:CC [(match_operand:DI 3 "register_operand" "0")] + UNSPEC_PARITY)) (clobber (match_scratch:DI 0 "=r")) (clobber (match_scratch:SI 1 "=&r")) (clobber (match_scratch:HI 2 "=Q"))] @@ -12534,7 +11995,7 @@ (clobber (reg:CC FLAGS_REG))]) (parallel [(set (reg:CC FLAGS_REG) - (parity:CC (match_dup 1))) + (unspec:CC [(match_dup 1)] UNSPEC_PARITY)) (clobber (match_dup 1)) (clobber (match_dup 2))])] { @@ -12551,7 +12012,8 @@ (define_insn_and_split "paritysi2_cmp" [(set (reg:CC FLAGS_REG) - (parity:CC (match_operand:SI 2 "register_operand" "0"))) + (unspec:CC [(match_operand:SI 2 "register_operand" "0")] + UNSPEC_PARITY)) (clobber (match_scratch:SI 0 "=r")) (clobber (match_scratch:HI 1 "=&Q"))] "! TARGET_POPCNT" @@ -12563,7 +12025,7 @@ (clobber (reg:CC FLAGS_REG))]) (parallel [(set (reg:CC FLAGS_REG) - (parity:CC (match_dup 1))) + (unspec:CC [(match_dup 1)] UNSPEC_PARITY)) (clobber (match_dup 1))])] { operands[3] = gen_lowpart (HImode, operands[2]); @@ -12574,20 +12036,13 @@ (define_insn "*parityhi2_cmp" [(set (reg:CC FLAGS_REG) - (parity:CC (match_operand:HI 1 "register_operand" "0"))) + (unspec:CC [(match_operand:HI 1 "register_operand" "0")] + UNSPEC_PARITY)) (clobber (match_scratch:HI 0 "=Q"))] "! TARGET_POPCNT" "xor{b}\t{%h0, %b0|%b0, %h0}" [(set_attr "length" "2") (set_attr "mode" "HI")]) - -(define_insn "*parityqi2_cmp" - [(set (reg:CC FLAGS_REG) - (parity:CC (match_operand:QI 0 "register_operand" "q")))] - "! TARGET_POPCNT" - "test{b}\t%0, %0" - [(set_attr "length" "2") - (set_attr "mode" "QI")]) ;; Thread-local storage patterns for ELF. ;; @@ -16874,22 +16329,15 @@ return "mov{l}\t{%1, %0|%0, %1}"; case TYPE_ALU: - if (CONST_INT_P (operands[2]) - && (INTVAL (operands[2]) == 128 - || (INTVAL (operands[2]) < 0 - && INTVAL (operands[2]) != -128))) - { - operands[2] = GEN_INT (-INTVAL (operands[2])); - return "sub{l}\t{%2, %0|%0, %2}"; - } + gcc_assert (rtx_equal_p (operands[0], operands[1])); + if (x86_maybe_negate_const_int (&operands[2], SImode)) + return "sub{l}\t{%2, %0|%0, %2}"; + return "add{l}\t{%2, %0|%0, %2}"; - case TYPE_LEA: + default: operands[2] = SET_SRC (XVECEXP (PATTERN (insn), 0, 0)); return "lea{l}\t{%a2, %0|%0, %a2}"; - - default: - gcc_unreachable (); } } [(set (attr "type") @@ -16924,24 +16372,15 @@ return "mov{q}\t{%1, %0|%0, %1}"; case TYPE_ALU: - if (CONST_INT_P (operands[2]) - /* Avoid overflows. */ - && ((INTVAL (operands[2]) & ((((unsigned int) 1) << 31) - 1))) - && (INTVAL (operands[2]) == 128 - || (INTVAL (operands[2]) < 0 - && INTVAL (operands[2]) != -128))) - { - operands[2] = GEN_INT (-INTVAL (operands[2])); - return "sub{q}\t{%2, %0|%0, %2}"; - } + gcc_assert (rtx_equal_p (operands[0], operands[1])); + if (x86_maybe_negate_const_int (&operands[2], DImode)) + return "sub{q}\t{%2, %0|%0, %2}"; + return "add{q}\t{%2, %0|%0, %2}"; - case TYPE_LEA: + default: operands[2] = SET_SRC (XVECEXP (PATTERN (insn), 0, 0)); return "lea{q}\t{%a2, %0|%0, %a2}"; - - default: - gcc_unreachable (); } } [(set (attr "type") @@ -18120,15 +17559,14 @@ ;; leal (%edx,%eax,4), %eax (define_peephole2 - [(parallel [(set (match_operand 0 "register_operand" "") + [(match_scratch:P 5 "r") + (parallel [(set (match_operand 0 "register_operand" "") (ashift (match_operand 1 "register_operand" "") (match_operand 2 "const_int_operand" ""))) (clobber (reg:CC FLAGS_REG))]) - (set (match_operand 3 "register_operand") - (match_operand 4 "x86_64_general_operand" "")) - (parallel [(set (match_operand 5 "register_operand" "") - (plus (match_operand 6 "register_operand" "") - (match_operand 7 "register_operand" ""))) + (parallel [(set (match_operand 3 "register_operand" "") + (plus (match_dup 0) + (match_operand 4 "x86_64_general_operand" ""))) (clobber (reg:CC FLAGS_REG))])] "INTVAL (operands[2]) >= 0 && INTVAL (operands[2]) <= 3 /* Validate MODE for lea. */ @@ -18137,31 +17575,27 @@ || GET_MODE (operands[0]) == HImode)) || GET_MODE (operands[0]) == SImode || (TARGET_64BIT && GET_MODE (operands[0]) == DImode)) + && (rtx_equal_p (operands[0], operands[3]) + || peep2_reg_dead_p (2, operands[0])) /* We reorder load and the shift. */ - && !rtx_equal_p (operands[1], operands[3]) - && !reg_overlap_mentioned_p (operands[0], operands[4]) - /* Last PLUS must consist of operand 0 and 3. */ - && !rtx_equal_p (operands[0], operands[3]) - && (rtx_equal_p (operands[3], operands[6]) - || rtx_equal_p (operands[3], operands[7])) - && (rtx_equal_p (operands[0], operands[6]) - || rtx_equal_p (operands[0], operands[7])) - /* The intermediate operand 0 must die or be same as output. */ - && (rtx_equal_p (operands[0], operands[5]) - || peep2_reg_dead_p (3, operands[0]))" - [(set (match_dup 3) (match_dup 4)) + && !reg_overlap_mentioned_p (operands[0], operands[4])" + [(set (match_dup 5) (match_dup 4)) (set (match_dup 0) (match_dup 1))] { - enum machine_mode mode = GET_MODE (operands[5]) == DImode ? DImode : SImode; + enum machine_mode mode = GET_MODE (operands[1]) == DImode ? DImode : SImode; int scale = 1 << INTVAL (operands[2]); rtx index = gen_lowpart (Pmode, operands[1]); - rtx base = gen_lowpart (Pmode, operands[3]); - rtx dest = gen_lowpart (mode, operands[5]); + rtx base = gen_lowpart (Pmode, operands[5]); + rtx dest = gen_lowpart (mode, operands[3]); operands[1] = gen_rtx_PLUS (Pmode, base, gen_rtx_MULT (Pmode, index, GEN_INT (scale))); + operands[5] = base; if (mode != Pmode) - operands[1] = gen_rtx_SUBREG (mode, operands[1], 0); + { + operands[1] = gen_rtx_SUBREG (mode, operands[1], 0); + operands[5] = gen_rtx_SUBREG (mode, operands[5], 0); + } operands[0] = dest; }) @@ -18549,31 +17983,11 @@ operands[1] = const0_rtx; }) -(define_insn "*prefetch_sse" - [(prefetch (match_operand:SI 0 "address_operand" "p") - (const_int 0) - (match_operand:SI 1 "const_int_operand" ""))] - "TARGET_PREFETCH_SSE && !TARGET_64BIT" -{ - static const char * const patterns[4] = { - "prefetchnta\t%a0", "prefetcht2\t%a0", "prefetcht1\t%a0", "prefetcht0\t%a0" - }; - - int locality = INTVAL (operands[1]); - gcc_assert (locality >= 0 && locality <= 3); - - return patterns[locality]; -} - [(set_attr "type" "sse") - (set_attr "atom_sse_attr" "prefetch") - (set (attr "length_address") (symbol_ref "memory_address_length (operands[0])")) - (set_attr "memory" "none")]) - -(define_insn "*prefetch_sse_rex" - [(prefetch (match_operand:DI 0 "address_operand" "p") +(define_insn "*prefetch_sse_" + [(prefetch (match_operand:P 0 "address_operand" "p") (const_int 0) (match_operand:SI 1 "const_int_operand" ""))] - "TARGET_PREFETCH_SSE && TARGET_64BIT" + "TARGET_PREFETCH_SSE" { static const char * const patterns[4] = { "prefetchnta\t%a0", "prefetcht2\t%a0", "prefetcht1\t%a0", "prefetcht0\t%a0" @@ -18586,29 +18000,15 @@ } [(set_attr "type" "sse") (set_attr "atom_sse_attr" "prefetch") - (set (attr "length_address") (symbol_ref "memory_address_length (operands[0])")) - (set_attr "memory" "none")]) - -(define_insn "*prefetch_3dnow" - [(prefetch (match_operand:SI 0 "address_operand" "p") - (match_operand:SI 1 "const_int_operand" "n") - (const_int 3))] - "TARGET_3DNOW && !TARGET_64BIT" -{ - if (INTVAL (operands[1]) == 0) - return "prefetch\t%a0"; - else - return "prefetchw\t%a0"; -} - [(set_attr "type" "mmx") - (set (attr "length_address") (symbol_ref "memory_address_length (operands[0])")) + (set (attr "length_address") + (symbol_ref "memory_address_length (operands[0])")) (set_attr "memory" "none")]) -(define_insn "*prefetch_3dnow_rex" - [(prefetch (match_operand:DI 0 "address_operand" "p") +(define_insn "*prefetch_3dnow_" + [(prefetch (match_operand:P 0 "address_operand" "p") (match_operand:SI 1 "const_int_operand" "n") (const_int 3))] - "TARGET_3DNOW && TARGET_64BIT" + "TARGET_3DNOW" { if (INTVAL (operands[1]) == 0) return "prefetch\t%a0"; @@ -18616,7 +18016,8 @@ return "prefetchw\t%a0"; } [(set_attr "type" "mmx") - (set (attr "length_address") (symbol_ref "memory_address_length (operands[0])")) + (set (attr "length_address") + (symbol_ref "memory_address_length (operands[0])")) (set_attr "memory" "none")]) (define_expand "stack_protect_set" @@ -18660,7 +18061,8 @@ (define_insn "stack_tls_protect_set_si" [(set (match_operand:SI 0 "memory_operand" "=m") - (unspec:SI [(match_operand:SI 1 "const_int_operand" "i")] UNSPEC_SP_TLS_SET)) + (unspec:SI [(match_operand:SI 1 "const_int_operand" "i")] + UNSPEC_SP_TLS_SET)) (set (match_scratch:SI 2 "=&r") (const_int 0)) (clobber (reg:CC FLAGS_REG))] "" @@ -18669,7 +18071,8 @@ (define_insn "stack_tls_protect_set_di" [(set (match_operand:DI 0 "memory_operand" "=m") - (unspec:DI [(match_operand:DI 1 "const_int_operand" "i")] UNSPEC_SP_TLS_SET)) + (unspec:DI [(match_operand:DI 1 "const_int_operand" "i")] + UNSPEC_SP_TLS_SET)) (set (match_scratch:DI 2 "=&r") (const_int 0)) (clobber (reg:CC FLAGS_REG))] "TARGET_64BIT" diff --git a/gcc/config/i386/msformat-c.c b/gcc/config/i386/msformat-c.c index af5c0f95f94..635c2ca6b62 100644 --- a/gcc/config/i386/msformat-c.c +++ b/gcc/config/i386/msformat-c.c @@ -25,12 +25,12 @@ along with GCC; see the file COPYING3. If not see #include "tm.h" #include "tree.h" #include "flags.h" -#include "c-common.h" +#include "c-family/c-common.h" #include "toplev.h" #include "intl.h" #include "diagnostic.h" #include "langhooks.h" -#include "c-format.h" +#include "c-family/c-format.h" #include "alloc-pool.h" /* Mingw specific format attributes ms_printf, ms_scanf, and ms_strftime. */ diff --git a/gcc/config/i386/ppro.md b/gcc/config/i386/ppro.md index 5e163d8296f..20f457ab192 100644 --- a/gcc/config/i386/ppro.md +++ b/gcc/config/i386/ppro.md @@ -731,7 +731,7 @@ (define_insn_reservation "ppro_insn" 1 (and (eq_attr "cpu" "pentiumpro") (and (eq_attr "memory" "none,unknown") - (eq_attr "type" "alu,alu1,negnot,incdec,icmp,test,setcc,icmov,push,pop,fxch,sseiadd,sseishft,sseimul,mmx,mmxadd,mmxcmp"))) + (eq_attr "type" "alu,alu1,negnot,incdec,icmp,test,setcc,icmov,push,pop,fxch,sseiadd,sseishft,sseishft1,sseimul,mmx,mmxadd,mmxcmp"))) "decodern,(p0|p1)") ;; read-modify and register-memory instructions have 2 or three uops, @@ -739,13 +739,13 @@ (define_insn_reservation "ppro_insn_load" 3 (and (eq_attr "cpu" "pentiumpro") (and (eq_attr "memory" "load") - (eq_attr "type" "alu,alu1,negnot,incdec,icmp,test,setcc,icmov,push,pop,fxch,sseiadd,sseishft,sseimul,mmx,mmxadd,mmxcmp"))) + (eq_attr "type" "alu,alu1,negnot,incdec,icmp,test,setcc,icmov,push,pop,fxch,sseiadd,sseishft,sseishft1,sseimul,mmx,mmxadd,mmxcmp"))) "decoder0,p2+(p0|p1)") (define_insn_reservation "ppro_insn_store" 1 (and (eq_attr "cpu" "pentiumpro") (and (eq_attr "memory" "store") - (eq_attr "type" "alu,alu1,negnot,incdec,icmp,test,setcc,icmov,push,pop,fxch,sseiadd,sseishft,sseimul,mmx,mmxadd,mmxcmp"))) + (eq_attr "type" "alu,alu1,negnot,incdec,icmp,test,setcc,icmov,push,pop,fxch,sseiadd,sseishft,sseishft1,sseimul,mmx,mmxadd,mmxcmp"))) "decoder0,(p0|p1),p4+p3") ;; read-modify-store instructions produce 4 uops so they have to be @@ -753,6 +753,6 @@ (define_insn_reservation "ppro_insn_both" 4 (and (eq_attr "cpu" "pentiumpro") (and (eq_attr "memory" "both") - (eq_attr "type" "alu,alu1,negnot,incdec,icmp,test,setcc,icmov,push,pop,fxch,sseiadd,sseishft,sseimul,mmx,mmxadd,mmxcmp"))) + (eq_attr "type" "alu,alu1,negnot,incdec,icmp,test,setcc,icmov,push,pop,fxch,sseiadd,sseishft,sseishft1,sseimul,mmx,mmxadd,mmxcmp"))) "decoder0,p2+(p0|p1),p4+p3") diff --git a/gcc/config/i386/predicates.md b/gcc/config/i386/predicates.md index 8f901cd8754..e5fea4a29d9 100644 --- a/gcc/config/i386/predicates.md +++ b/gcc/config/i386/predicates.md @@ -420,36 +420,6 @@ } }) -;; Return true if the operand contains a @GOT or @GOTOFF reference. -(define_predicate "pic_symbolic_operand" - (match_code "const") -{ - op = XEXP (op, 0); - if (TARGET_64BIT) - { - if (GET_CODE (op) == UNSPEC - && XINT (op, 1) == UNSPEC_GOTPCREL) - return 1; - if (GET_CODE (op) == PLUS - && GET_CODE (XEXP (op, 0)) == UNSPEC - && XINT (XEXP (op, 0), 1) == UNSPEC_GOTPCREL) - return 1; - } - else - { - if (GET_CODE (op) == UNSPEC) - return 1; - if (GET_CODE (op) != PLUS - || !CONST_INT_P (XEXP (op, 1))) - return 0; - op = XEXP (op, 0); - if (GET_CODE (op) == UNSPEC - && XINT (op, 1) != UNSPEC_MACHOPIC_OFFSET) - return 1; - } - return 0; -}) - ;; Return true if OP is a symbolic operand that resolves locally. (define_predicate "local_symbolic_operand" (match_code "const,label_ref,symbol_ref") @@ -1083,6 +1053,19 @@ (match_operand 0 "comparison_operator") (match_operand 0 "ix86_trivial_fp_comparison_operator"))) +;; Same as above, but for swapped comparison used in fp_jcc_4_387. +(define_predicate "ix86_swapped_fp_comparison_operator" + (match_operand 0 "comparison_operator") +{ + enum rtx_code code = GET_CODE (op); + int ret; + + PUT_CODE (op, swap_condition (code)); + ret = ix86_fp_comparison_operator (op, mode); + PUT_CODE (op, code); + return ret; +}) + ;; Nearly general operand, but accept any const_double, since we wish ;; to be able to drop them into memory rather than have them get pulled ;; into registers. diff --git a/gcc/config/i386/sol2.h b/gcc/config/i386/sol2.h index 6a014651be5..11eaa15dd80 100644 --- a/gcc/config/i386/sol2.h +++ b/gcc/config/i386/sol2.h @@ -145,7 +145,7 @@ along with GCC; see the file COPYING3. If not see do \ { \ fprintf (FILE, "\tcall\t"); \ - print_operand (FILE, XEXP (DECL_RTL (FN), 0), 'P'); \ + ix86_print_operand (FILE, XEXP (DECL_RTL (FN), 0), 'P'); \ fprintf (FILE, "\n"); \ } \ while (0) diff --git a/gcc/config/i386/sse.md b/gcc/config/i386/sse.md index dd95f3ff7d2..763b48de510 100644 --- a/gcc/config/i386/sse.md +++ b/gcc/config/i386/sse.md @@ -89,18 +89,13 @@ ;; Mapping from integer vector mode to mnemonic suffix (define_mode_attr ssevecsize [(V16QI "b") (V8HI "w") (V4SI "d") (V2DI "q")]) -;; Mapping of the fma4 suffix -(define_mode_attr fma4modesuffixf4 [(V8SF "ps") (V4DF "pd")]) -(define_mode_attr ssemodesuffixf2s [(SF "ss") (DF "sd") - (V4SF "ss") (V2DF "sd")]) - -;; Mapping of the avx suffix -(define_mode_attr ssemodesuffixf4 [(SF "ss") (DF "sd") - (V4SF "ps") (V2DF "pd")]) - -(define_mode_attr ssemodesuffixf2c [(V4SF "s") (V2DF "d")]) - -(define_mode_attr ssescalarmodesuffix2s [(V4SF "ss") (V4SI "d")]) +;; Mapping of the insn mnemonic suffix +(define_mode_attr ssemodesuffix + [(SF "ss") (DF "sd") (V4SF "ps") (V2DF "pd") (V8SF "ps") (V4DF "pd") + (V8SI "ps") (V4DI "pd")]) +(define_mode_attr ssescalarmodesuffix + [(SF "ss") (DF "sd") (V4SF "ss") (V2DF "sd") (V8SF "ss") (V4DF "sd") + (V4SI "d")]) ;; Mapping of the max integer size for xop rotate immediate constraint (define_mode_attr sserotatemax [(V16QI "7") (V8HI "15") (V4SI "31") (V2DI "63")]) @@ -141,8 +136,6 @@ [(V4SF "V4SI") (V8SF "V8SI") (V4SI "V4SF") (V8SI "V8SF")]) (define_mode_attr avxpermvecmode [(V2DF "V2DI") (V4SF "V4SI") (V4DF "V4DI") (V8SF "V8SI")]) -(define_mode_attr avxmodesuffixf2c - [(V4SF "s") (V2DF "d") (V8SI "s") (V8SF "s") (V4DI "d") (V4DF "d")]) (define_mode_attr avxmodesuffixp [(V2DF "pd") (V4SI "si") (V4SF "ps") (V8SF "ps") (V8SI "si") (V4DF "pd")]) @@ -366,14 +359,14 @@ DONE; }) -(define_insn "avx_movup" +(define_insn "avx_movu" [(set (match_operand:AVXMODEF2P 0 "nonimmediate_operand" "=x,m") (unspec:AVXMODEF2P [(match_operand:AVXMODEF2P 1 "nonimmediate_operand" "xm,x")] UNSPEC_MOVU))] "AVX_VEC_FLOAT_MODE_P (mode) && !(MEM_P (operands[0]) && MEM_P (operands[1]))" - "vmovup\t{%1, %0|%0, %1}" + "vmovu\t{%1, %0|%0, %1}" [(set_attr "type" "ssemov") (set_attr "movu" "1") (set_attr "prefix" "vex") @@ -392,14 +385,14 @@ (set_attr "prefix" "maybe_vex") (set_attr "mode" "TI")]) -(define_insn "_movup" +(define_insn "_movu" [(set (match_operand:SSEMODEF2P 0 "nonimmediate_operand" "=x,m") (unspec:SSEMODEF2P [(match_operand:SSEMODEF2P 1 "nonimmediate_operand" "xm,x")] UNSPEC_MOVU))] "SSE_VEC_FLOAT_MODE_P (mode) && !(MEM_P (operands[0]) && MEM_P (operands[1]))" - "movup\t{%1, %0|%0, %1}" + "movu\t{%1, %0|%0, %1}" [(set_attr "type" "ssemov") (set_attr "movu" "1") (set_attr "mode" "")]) @@ -433,7 +426,7 @@ [(match_operand:AVXMODEF2P 1 "register_operand" "x")] UNSPEC_MOVNT))] "AVX_VEC_FLOAT_MODE_P (mode)" - "vmovntp\t{%1, %0|%0, %1}" + "vmovnt\t{%1, %0|%0, %1}" [(set_attr "type" "ssemov") (set_attr "prefix" "vex") (set_attr "mode" "")]) @@ -444,7 +437,7 @@ [(match_operand:SSEMODEF2P 1 "register_operand" "x")] UNSPEC_MOVNT))] "SSE_VEC_FLOAT_MODE_P (mode)" - "movntp\t{%1, %0|%0, %1}" + "movnt\t{%1, %0|%0, %1}" [(set_attr "type" "ssemov") (set_attr "mode" "")]) @@ -580,7 +573,7 @@ (match_operand:AVXMODEF2P 2 "nonimmediate_operand" "xm")))] "AVX_VEC_FLOAT_MODE_P (mode) && ix86_binary_operator_ok (, mode, operands)" - "vp\t{%2, %1, %0|%0, %1, %2}" + "v\t{%2, %1, %0|%0, %1, %2}" [(set_attr "type" "sseadd") (set_attr "prefix" "vex") (set_attr "mode" "")]) @@ -600,7 +593,7 @@ (match_operand:SSEMODEF2P 2 "nonimmediate_operand" "xm")))] "SSE_VEC_FLOAT_MODE_P (mode) && ix86_binary_operator_ok (, mode, operands)" - "p\t{%2, %0|%0, %2}" + "\t{%2, %0|%0, %2}" [(set_attr "type" "sseadd") (set_attr "mode" "")]) @@ -613,7 +606,7 @@ (match_dup 1) (const_int 1)))] "AVX128_VEC_FLOAT_MODE_P (mode)" - "vs\t{%2, %1, %0|%0, %1, %2}" + "v\t{%2, %1, %0|%0, %1, %2}" [(set_attr "type" "sseadd") (set_attr "prefix" "vex") (set_attr "mode" "")]) @@ -627,7 +620,7 @@ (match_dup 1) (const_int 1)))] "SSE_VEC_FLOAT_MODE_P (mode)" - "s\t{%2, %0|%0, %2}" + "\t{%2, %0|%0, %2}" [(set_attr "type" "sseadd") (set_attr "mode" "")]) @@ -646,7 +639,7 @@ (match_operand:AVXMODEF2P 2 "nonimmediate_operand" "xm")))] "AVX_VEC_FLOAT_MODE_P (mode) && ix86_binary_operator_ok (MULT, mode, operands)" - "vmulp\t{%2, %1, %0|%0, %1, %2}" + "vmul\t{%2, %1, %0|%0, %1, %2}" [(set_attr "type" "ssemul") (set_attr "prefix" "vex") (set_attr "mode" "")]) @@ -666,7 +659,7 @@ (match_operand:SSEMODEF2P 2 "nonimmediate_operand" "xm")))] "SSE_VEC_FLOAT_MODE_P (mode) && ix86_binary_operator_ok (MULT, mode, operands)" - "mulp\t{%2, %0|%0, %2}" + "mul\t{%2, %0|%0, %2}" [(set_attr "type" "ssemul") (set_attr "mode" "")]) @@ -679,7 +672,7 @@ (match_dup 1) (const_int 1)))] "AVX_VEC_FLOAT_MODE_P (mode)" - "vmuls\t{%2, %1, %0|%0, %1, %2}" + "vmul\t{%2, %1, %0|%0, %1, %2}" [(set_attr "type" "ssemul") (set_attr "prefix" "vex") (set_attr "mode" "")]) @@ -693,7 +686,7 @@ (match_dup 1) (const_int 1)))] "SSE_VEC_FLOAT_MODE_P (mode)" - "muls\t{%2, %0|%0, %2}" + "mul\t{%2, %0|%0, %2}" [(set_attr "type" "ssemul") (set_attr "mode" "")]) @@ -728,7 +721,7 @@ (match_operand:AVXMODEF2P 1 "register_operand" "x") (match_operand:AVXMODEF2P 2 "nonimmediate_operand" "xm")))] "AVX_VEC_FLOAT_MODE_P (mode)" - "vdivp\t{%2, %1, %0|%0, %1, %2}" + "vdiv\t{%2, %1, %0|%0, %1, %2}" [(set_attr "type" "ssediv") (set_attr "prefix" "vex") (set_attr "mode" "")]) @@ -762,7 +755,7 @@ (match_operand:SSEMODEF2P 1 "register_operand" "x") (match_operand:SSEMODEF2P 2 "nonimmediate_operand" "xm")))] "AVX128_VEC_FLOAT_MODE_P (mode)" - "vdivp\t{%2, %1, %0|%0, %1, %2}" + "vdiv\t{%2, %1, %0|%0, %1, %2}" [(set_attr "type" "ssediv") (set_attr "prefix" "vex") (set_attr "mode" "")]) @@ -773,7 +766,7 @@ (match_operand:SSEMODEF2P 1 "register_operand" "0") (match_operand:SSEMODEF2P 2 "nonimmediate_operand" "xm")))] "SSE_VEC_FLOAT_MODE_P (mode)" - "divp\t{%2, %0|%0, %2}" + "div\t{%2, %0|%0, %2}" [(set_attr "type" "ssediv") (set_attr "mode" "")]) @@ -786,7 +779,7 @@ (match_dup 1) (const_int 1)))] "AVX128_VEC_FLOAT_MODE_P (mode)" - "vdivs\t{%2, %1, %0|%0, %1, %2}" + "vdiv\t{%2, %1, %0|%0, %1, %2}" [(set_attr "type" "ssediv") (set_attr "prefix" "vex") (set_attr "mode" "")]) @@ -800,7 +793,7 @@ (match_dup 1) (const_int 1)))] "SSE_VEC_FLOAT_MODE_P (mode)" - "divs\t{%2, %0|%0, %2}" + "div\t{%2, %0|%0, %2}" [(set_attr "type" "ssediv") (set_attr "mode" "")]) @@ -924,7 +917,7 @@ (match_operand:SSEMODEF2P 2 "register_operand" "x") (const_int 1)))] "AVX_VEC_FLOAT_MODE_P (mode)" - "vsqrts\t{%1, %2, %0|%0, %2, %1}" + "vsqrt\t{%1, %2, %0|%0, %2, %1}" [(set_attr "type" "sse") (set_attr "prefix" "vex") (set_attr "mode" "")]) @@ -937,7 +930,7 @@ (match_operand:SSEMODEF2P 2 "register_operand" "0") (const_int 1)))] "SSE_VEC_FLOAT_MODE_P (mode)" - "sqrts\t{%1, %0|%0, %1}" + "sqrt\t{%1, %0|%0, %1}" [(set_attr "type" "sse") (set_attr "atom_sse_attr" "sqrt") (set_attr "mode" "")]) @@ -1042,7 +1035,7 @@ (match_operand:AVXMODEF2P 2 "nonimmediate_operand" "xm")))] "AVX_VEC_FLOAT_MODE_P (mode) && flag_finite_math_only && ix86_binary_operator_ok (, mode, operands)" - "vp\t{%2, %1, %0|%0, %1, %2}" + "v\t{%2, %1, %0|%0, %1, %2}" [(set_attr "type" "sseadd") (set_attr "prefix" "vex") (set_attr "mode" "")]) @@ -1054,7 +1047,7 @@ (match_operand:SSEMODEF2P 2 "nonimmediate_operand" "xm")))] "SSE_VEC_FLOAT_MODE_P (mode) && flag_finite_math_only && ix86_binary_operator_ok (, mode, operands)" - "p\t{%2, %0|%0, %2}" + "\t{%2, %0|%0, %2}" [(set_attr "type" "sseadd") (set_attr "mode" "")]) @@ -1064,7 +1057,7 @@ (match_operand:AVXMODEF2P 1 "nonimmediate_operand" "%x") (match_operand:AVXMODEF2P 2 "nonimmediate_operand" "xm")))] "AVX_VEC_FLOAT_MODE_P (mode)" - "vp\t{%2, %1, %0|%0, %1, %2}" + "v\t{%2, %1, %0|%0, %1, %2}" [(set_attr "type" "sseadd") (set_attr "prefix" "vex") (set_attr "mode" "")]) @@ -1075,7 +1068,7 @@ (match_operand:SSEMODEF2P 1 "register_operand" "0") (match_operand:SSEMODEF2P 2 "nonimmediate_operand" "xm")))] "SSE_VEC_FLOAT_MODE_P (mode)" - "p\t{%2, %0|%0, %2}" + "\t{%2, %0|%0, %2}" [(set_attr "type" "sseadd") (set_attr "mode" "")]) @@ -1088,7 +1081,7 @@ (match_dup 1) (const_int 1)))] "AVX128_VEC_FLOAT_MODE_P (mode)" - "vs\t{%2, %1, %0|%0, %1, %2}" + "v\t{%2, %1, %0|%0, %1, %2}" [(set_attr "type" "sse") (set_attr "prefix" "vex") (set_attr "mode" "")]) @@ -1102,7 +1095,7 @@ (match_dup 1) (const_int 1)))] "SSE_VEC_FLOAT_MODE_P (mode)" - "s\t{%2, %0|%0, %2}" + "\t{%2, %0|%0, %2}" [(set_attr "type" "sseadd") (set_attr "mode" "")]) @@ -1119,7 +1112,7 @@ (match_operand:AVXMODEF2P 2 "nonimmediate_operand" "xm")] UNSPEC_IEEE_MIN))] "AVX_VEC_FLOAT_MODE_P (mode)" - "vminp\t{%2, %1, %0|%0, %1, %2}" + "vmin\t{%2, %1, %0|%0, %1, %2}" [(set_attr "type" "sseadd") (set_attr "prefix" "vex") (set_attr "mode" "")]) @@ -1131,7 +1124,7 @@ (match_operand:AVXMODEF2P 2 "nonimmediate_operand" "xm")] UNSPEC_IEEE_MAX))] "AVX_VEC_FLOAT_MODE_P (mode)" - "vmaxp\t{%2, %1, %0|%0, %1, %2}" + "vmax\t{%2, %1, %0|%0, %1, %2}" [(set_attr "type" "sseadd") (set_attr "prefix" "vex") (set_attr "mode" "")]) @@ -1143,7 +1136,7 @@ (match_operand:SSEMODEF2P 2 "nonimmediate_operand" "xm")] UNSPEC_IEEE_MIN))] "SSE_VEC_FLOAT_MODE_P (mode)" - "minp\t{%2, %0|%0, %2}" + "min\t{%2, %0|%0, %2}" [(set_attr "type" "sseadd") (set_attr "mode" "")]) @@ -1154,7 +1147,7 @@ (match_operand:SSEMODEF2P 2 "nonimmediate_operand" "xm")] UNSPEC_IEEE_MAX))] "SSE_VEC_FLOAT_MODE_P (mode)" - "maxp\t{%2, %0|%0, %2}" + "max\t{%2, %0|%0, %2}" [(set_attr "type" "sseadd") (set_attr "mode" "")]) @@ -1477,7 +1470,7 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define_insn "avx_cmpp3" +(define_insn "avx_cmp3" [(set (match_operand:AVXMODEF2P 0 "register_operand" "=x") (unspec:AVXMODEF2P [(match_operand:AVXMODEF2P 1 "register_operand" "x") @@ -1485,13 +1478,13 @@ (match_operand:SI 3 "const_0_to_31_operand" "n")] UNSPEC_PCMP))] "TARGET_AVX" - "vcmpp\t{%3, %2, %1, %0|%0, %1, %2, %3}" + "vcmp\t{%3, %2, %1, %0|%0, %1, %2, %3}" [(set_attr "type" "ssecmp") (set_attr "length_immediate" "1") (set_attr "prefix" "vex") (set_attr "mode" "")]) -(define_insn "avx_cmps3" +(define_insn "avx_cmp3" [(set (match_operand:SSEMODEF2P 0 "register_operand" "") (vec_merge:SSEMODEF2P (unspec:SSEMODEF2P @@ -1502,7 +1495,7 @@ (match_dup 1) (const_int 1)))] "TARGET_AVX" - "vcmps\t{%3, %2, %1, %0|%0, %1, %2, %3}" + "vcmp\t{%3, %2, %1, %0|%0, %1, %2, %3}" [(set_attr "type" "ssecmp") (set_attr "length_immediate" "1") (set_attr "prefix" "vex") @@ -1516,7 +1509,7 @@ [(match_operand:AVXMODEF2P 1 "register_operand" "x") (match_operand:AVXMODEF2P 2 "nonimmediate_operand" "xm")]))] "AVX_VEC_FLOAT_MODE_P (mode)" - "vcmp%D3p\t{%2, %1, %0|%0, %1, %2}" + "vcmp%D3\t{%2, %1, %0|%0, %1, %2}" [(set_attr "type" "ssecmp") (set_attr "prefix" "vex") (set_attr "length_immediate" "1") @@ -1529,7 +1522,7 @@ (match_operand:SSEMODEF4 2 "nonimmediate_operand" "xm")]))] "!TARGET_XOP && (SSE_FLOAT_MODE_P (mode) || SSE_VEC_FLOAT_MODE_P (mode))" - "cmp%D3\t{%2, %0|%0, %2}" + "cmp%D3\t{%2, %0|%0, %2}" [(set_attr "type" "ssecmp") (set_attr "length_immediate" "1") (set_attr "mode" "")]) @@ -1543,7 +1536,7 @@ (match_dup 1) (const_int 1)))] "AVX_VEC_FLOAT_MODE_P (mode)" - "vcmp%D3s\t{%2, %1, %0|%0, %1, %2}" + "vcmp%D3\t{%2, %1, %0|%0, %1, %2}" [(set_attr "type" "ssecmp") (set_attr "prefix" "vex") (set_attr "mode" "")]) @@ -1557,7 +1550,7 @@ (match_dup 1) (const_int 1)))] "SSE_VEC_FLOAT_MODE_P (mode)" - "cmp%D3s\t{%2, %0|%0, %2}" + "cmp%D3\t{%2, %0|%0, %2}" [(set_attr "type" "ssecmp") (set_attr "length_immediate" "1") (set_attr "mode" "")]) @@ -1631,7 +1624,7 @@ (match_operand:AVXMODEF2P 1 "register_operand" "x")) (match_operand:AVXMODEF2P 2 "nonimmediate_operand" "xm")))] "AVX_VEC_FLOAT_MODE_P (mode)" - "vandnp\t{%2, %1, %0|%0, %1, %2}" + "vandn\t{%2, %1, %0|%0, %1, %2}" [(set_attr "type" "sselog") (set_attr "prefix" "vex") (set_attr "mode" "")]) @@ -1643,7 +1636,7 @@ (match_operand:SSEMODEF2P 1 "register_operand" "0")) (match_operand:SSEMODEF2P 2 "nonimmediate_operand" "xm")))] "SSE_VEC_FLOAT_MODE_P (mode)" - "andnp\t{%2, %0|%0, %2}" + "andn\t{%2, %0|%0, %2}" [(set_attr "type" "sselog") (set_attr "mode" "")]) @@ -1666,7 +1659,7 @@ if (TARGET_SSE_PACKED_SINGLE_INSN_OPTIMAL) return "vps\t{%2, %1, %0|%0, %1, %2}"; else - return "vp\t{%2, %1, %0|%0, %1, %2}"; + return "v\t{%2, %1, %0|%0, %1, %2}"; } [(set_attr "type" "sselog") (set_attr "prefix" "vex") @@ -1691,7 +1684,7 @@ if (TARGET_SSE_PACKED_SINGLE_INSN_OPTIMAL) return "ps\t{%2, %0|%0, %2}"; else - return "p\t{%2, %0|%0, %2}"; + return "\t{%2, %0|%0, %2}"; } [(set_attr "type" "sselog") (set_attr "mode" "")]) @@ -1818,7 +1811,7 @@ (match_operand:FMA4MODEF4 2 "nonimmediate_operand" "x,m")) (match_operand:FMA4MODEF4 3 "nonimmediate_operand" "xm,x")))] "TARGET_FMA4 && TARGET_FUSED_MADD" - "vfmadd\t{%3, %2, %1, %0|%0, %1, %2, %3}" + "vfmadd\t{%3, %2, %1, %0|%0, %1, %2, %3}" [(set_attr "type" "ssemuladd") (set_attr "mode" "")]) @@ -1831,7 +1824,7 @@ (match_operand:FMA4MODEF4 2 "nonimmediate_operand" "x,m")) (match_operand:FMA4MODEF4 3 "nonimmediate_operand" "xm,x")))] "TARGET_FMA4 && TARGET_FUSED_MADD" - "vfmsub\t{%3, %2, %1, %0|%0, %1, %2, %3}" + "vfmsub\t{%3, %2, %1, %0|%0, %1, %2, %3}" [(set_attr "type" "ssemuladd") (set_attr "mode" "")]) @@ -1845,7 +1838,7 @@ (match_operand:FMA4MODEF4 1 "nonimmediate_operand" "%x,x") (match_operand:FMA4MODEF4 2 "nonimmediate_operand" "x,m"))))] "TARGET_FMA4 && TARGET_FUSED_MADD" - "vfnmadd\t{%3, %2, %1, %0|%0, %1, %2, %3}" + "vfnmadd\t{%3, %2, %1, %0|%0, %1, %2, %3}" [(set_attr "type" "ssemuladd") (set_attr "mode" "")]) @@ -1859,7 +1852,7 @@ (match_operand:FMA4MODEF4 2 "nonimmediate_operand" "x,m")) (match_operand:FMA4MODEF4 3 "nonimmediate_operand" "xm,x")))] "TARGET_FMA4 && TARGET_FUSED_MADD" - "vfnmsub\t{%3, %2, %1, %0|%0, %1, %2, %3}" + "vfnmsub\t{%3, %2, %1, %0|%0, %1, %2, %3}" [(set_attr "type" "ssemuladd") (set_attr "mode" "")]) @@ -1871,7 +1864,7 @@ (match_operand:SSEMODEF4 2 "nonimmediate_operand" "x,m")) (match_operand:SSEMODEF4 3 "nonimmediate_operand" "xm,x")))] "TARGET_FMA4 && TARGET_FUSED_MADD" - "vfmadd\t{%3, %2, %1, %0|%0, %1, %2, %3}" + "vfmadd\t{%3, %2, %1, %0|%0, %1, %2, %3}" [(set_attr "type" "ssemuladd") (set_attr "mode" "")]) @@ -1889,7 +1882,7 @@ (match_dup 0) (const_int 1)))] "TARGET_FMA4 && TARGET_FUSED_MADD" - "vfmadd\t{%3, %2, %1, %0|%0, %1, %2, %3}" + "vfmadd\t{%3, %2, %1, %0|%0, %1, %2, %3}" [(set_attr "type" "ssemuladd") (set_attr "mode" "")]) @@ -1903,7 +1896,7 @@ (match_operand:SSEMODEF4 2 "nonimmediate_operand" "x,m")) (match_operand:SSEMODEF4 3 "nonimmediate_operand" "xm,x")))] "TARGET_FMA4 && TARGET_FUSED_MADD" - "vfmsub\t{%3, %2, %1, %0|%0, %1, %2, %3}" + "vfmsub\t{%3, %2, %1, %0|%0, %1, %2, %3}" [(set_attr "type" "ssemuladd") (set_attr "mode" "")]) @@ -1921,7 +1914,7 @@ (match_dup 0) (const_int 1)))] "TARGET_FMA4 && TARGET_FUSED_MADD" - "vfmsub\t{%3, %2, %1, %0|%0, %1, %2, %3}" + "vfmsub\t{%3, %2, %1, %0|%0, %1, %2, %3}" [(set_attr "type" "ssemuladd") (set_attr "mode" "")]) @@ -1935,7 +1928,7 @@ (match_operand:SSEMODEF4 1 "nonimmediate_operand" "%x,x") (match_operand:SSEMODEF4 2 "nonimmediate_operand" "x,m"))))] "TARGET_FMA4 && TARGET_FUSED_MADD" - "vfnmadd\t{%3, %2, %1, %0|%0, %1, %2, %3}" + "vfnmadd\t{%3, %2, %1, %0|%0, %1, %2, %3}" [(set_attr "type" "ssemuladd") (set_attr "mode" "")]) @@ -1953,7 +1946,7 @@ (match_dup 0) (const_int 1)))] "TARGET_FMA4 && TARGET_FUSED_MADD" - "vfnmadd\t{%3, %2, %1, %0|%0, %1, %2, %3}" + "vfnmadd\t{%3, %2, %1, %0|%0, %1, %2, %3}" [(set_attr "type" "ssemuladd") (set_attr "mode" "")]) @@ -1968,7 +1961,7 @@ (match_operand:SSEMODEF4 2 "nonimmediate_operand" "x,m")) (match_operand:SSEMODEF4 3 "nonimmediate_operand" "xm,x")))] "TARGET_FMA4 && TARGET_FUSED_MADD" - "vfnmsub\t{%3, %2, %1, %0|%0, %1, %2, %3}" + "vfnmsub\t{%3, %2, %1, %0|%0, %1, %2, %3}" [(set_attr "type" "ssemuladd") (set_attr "mode" "")]) @@ -1987,7 +1980,7 @@ (match_dup 0) (const_int 1)))] "TARGET_FMA4 && TARGET_FUSED_MADD" - "vfnmsub\t{%3, %2, %1, %0|%0, %1, %2, %3}" + "vfnmsub\t{%3, %2, %1, %0|%0, %1, %2, %3}" [(set_attr "type" "ssemuladd") (set_attr "mode" "")]) @@ -2001,7 +1994,7 @@ (match_operand:FMA4MODEF4 3 "nonimmediate_operand" "xm,x"))] UNSPEC_FMA4_INTRINSIC))] "TARGET_FMA4" - "vfmadd\t{%3, %2, %1, %0|%0, %1, %2, %3}" + "vfmadd\t{%3, %2, %1, %0|%0, %1, %2, %3}" [(set_attr "type" "ssemuladd") (set_attr "mode" "")]) @@ -2015,7 +2008,7 @@ (match_operand:FMA4MODEF4 3 "nonimmediate_operand" "xm,x"))] UNSPEC_FMA4_INTRINSIC))] "TARGET_FMA4" - "vfmsub\t{%3, %2, %1, %0|%0, %1, %2, %3}" + "vfmsub\t{%3, %2, %1, %0|%0, %1, %2, %3}" [(set_attr "type" "ssemuladd") (set_attr "mode" "")]) @@ -2029,7 +2022,7 @@ (match_operand:FMA4MODEF4 2 "nonimmediate_operand" "x,m")))] UNSPEC_FMA4_INTRINSIC))] "TARGET_FMA4" - "vfnmadd\t{%3, %2, %1, %0|%0, %1, %2, %3}" + "vfnmadd\t{%3, %2, %1, %0|%0, %1, %2, %3}" [(set_attr "type" "ssemuladd") (set_attr "mode" "")]) @@ -2044,7 +2037,7 @@ (match_operand:FMA4MODEF4 3 "nonimmediate_operand" "xm,x"))] UNSPEC_FMA4_INTRINSIC))] "TARGET_FMA4" - "vfnmsub\t{%3, %2, %1, %0|%0, %1, %2, %3}" + "vfnmsub\t{%3, %2, %1, %0|%0, %1, %2, %3}" [(set_attr "type" "ssemuladd") (set_attr "mode" "")]) @@ -2058,7 +2051,7 @@ (match_operand:SSEMODEF2P 3 "nonimmediate_operand" "xm,x"))] UNSPEC_FMA4_INTRINSIC))] "TARGET_FMA4" - "vfmadd\t{%3, %2, %1, %0|%0, %1, %2, %3}" + "vfmadd\t{%3, %2, %1, %0|%0, %1, %2, %3}" [(set_attr "type" "ssemuladd") (set_attr "mode" "")]) @@ -2072,7 +2065,7 @@ (match_operand:SSEMODEF2P 3 "nonimmediate_operand" "xm,x"))] UNSPEC_FMA4_INTRINSIC))] "TARGET_FMA4" - "vfmsub\t{%3, %2, %1, %0|%0, %1, %2, %3}" + "vfmsub\t{%3, %2, %1, %0|%0, %1, %2, %3}" [(set_attr "type" "ssemuladd") (set_attr "mode" "")]) @@ -2086,7 +2079,7 @@ (match_operand:SSEMODEF2P 2 "nonimmediate_operand" "x,m")))] UNSPEC_FMA4_INTRINSIC))] "TARGET_FMA4" - "vfnmadd\t{%3, %2, %1, %0|%0, %1, %2, %3}" + "vfnmadd\t{%3, %2, %1, %0|%0, %1, %2, %3}" [(set_attr "type" "ssemuladd") (set_attr "mode" "")]) @@ -2101,7 +2094,7 @@ (match_operand:SSEMODEF2P 3 "nonimmediate_operand" "xm,x"))] UNSPEC_FMA4_INTRINSIC))] "TARGET_FMA4" - "vfnmsub\t{%3, %2, %1, %0|%0, %1, %2, %3}" + "vfnmsub\t{%3, %2, %1, %0|%0, %1, %2, %3}" [(set_attr "type" "ssemuladd") (set_attr "mode" "")]) @@ -2120,7 +2113,7 @@ (const_int 1))] UNSPEC_FMA4_INTRINSIC))] "TARGET_FMA4" - "vfmadd\t{%3, %2, %1, %0|%0, %1, %2, %3}" + "vfmadd\t{%3, %2, %1, %0|%0, %1, %2, %3}" [(set_attr "type" "ssemuladd") (set_attr "mode" "")]) @@ -2137,7 +2130,7 @@ (const_int 1))] UNSPEC_FMA4_INTRINSIC))] "TARGET_FMA4" - "vfmsub\t{%3, %2, %1, %0|%0, %1, %2, %3}" + "vfmsub\t{%3, %2, %1, %0|%0, %1, %2, %3}" [(set_attr "type" "ssemuladd") (set_attr "mode" "")]) @@ -2154,7 +2147,7 @@ (const_int 1))] UNSPEC_FMA4_INTRINSIC))] "TARGET_FMA4" - "vfnmadd\t{%3, %2, %1, %0|%0, %1, %2, %3}" + "vfnmadd\t{%3, %2, %1, %0|%0, %1, %2, %3}" [(set_attr "type" "ssemuladd") (set_attr "mode" "")]) @@ -2172,7 +2165,7 @@ (const_int 1))] UNSPEC_FMA4_INTRINSIC))] "TARGET_FMA4" - "vfnmsub\t{%3, %2, %1, %0|%0, %1, %2, %3}" + "vfnmsub\t{%3, %2, %1, %0|%0, %1, %2, %3}" [(set_attr "type" "ssemuladd") (set_attr "mode" "")]) @@ -4201,7 +4194,7 @@ "TARGET_AVX" "@ vinsertps\t{$0xe, %2, %2, %0|%0, %2, %2, 0xe} - vmov\t{%2, %0|%0, %2} + vmov\t{%2, %0|%0, %2} vmovd\t{%2, %0|%0, %2} vmovss\t{%2, %1, %0|%0, %1, %2} vpinsrd\t{$0, %2, %1, %0|%0, %1, %2, 0} @@ -4223,7 +4216,7 @@ "TARGET_SSE4_1" "@ insertps\t{$0xe, %2, %0|%0, %2, 0xe} - mov\t{%2, %0|%0, %2} + mov\t{%2, %0|%0, %2} movd\t{%2, %0|%0, %2} movss\t{%2, %0|%0, %2} pinsrd\t{$0, %2, %0|%0, %2, 0} @@ -4243,7 +4236,7 @@ (const_int 1)))] "TARGET_SSE2" "@ - mov\t{%2, %0|%0, %2} + mov\t{%2, %0|%0, %2} movd\t{%2, %0|%0, %2} movss\t{%2, %0|%0, %2} #" @@ -4395,19 +4388,24 @@ DONE; }) -(define_insn "vec_extract_lo_" +(define_insn_and_split "vec_extract_lo_" [(set (match_operand: 0 "nonimmediate_operand" "=x,m") (vec_select: - (match_operand:AVX256MODE4P 1 "register_operand" "x,x") + (match_operand:AVX256MODE4P 1 "nonimmediate_operand" "xm,x") (parallel [(const_int 0) (const_int 1)])))] "TARGET_AVX" - "vextractf128\t{$0x0, %1, %0|%0, %1, 0x0}" - [(set_attr "type" "sselog") - (set_attr "prefix_extra" "1") - (set_attr "length_immediate" "1") - (set_attr "memory" "none,store") - (set_attr "prefix" "vex") - (set_attr "mode" "V8SF")]) + "#" + "&& reload_completed" + [(const_int 0)] +{ + rtx op1 = operands[1]; + if (REG_P (op1)) + op1 = gen_rtx_REG (mode, REGNO (op1)); + else + op1 = gen_lowpart (mode, op1); + emit_move_insn (operands[0], op1); + DONE; +}) (define_insn "vec_extract_hi_" [(set (match_operand: 0 "nonimmediate_operand" "=x,m") @@ -4423,20 +4421,25 @@ (set_attr "prefix" "vex") (set_attr "mode" "V8SF")]) -(define_insn "vec_extract_lo_" +(define_insn_and_split "vec_extract_lo_" [(set (match_operand: 0 "nonimmediate_operand" "=x,m") (vec_select: - (match_operand:AVX256MODE8P 1 "register_operand" "x,x") + (match_operand:AVX256MODE8P 1 "nonimmediate_operand" "xm,x") (parallel [(const_int 0) (const_int 1) (const_int 2) (const_int 3)])))] "TARGET_AVX" - "vextractf128\t{$0x1, %1, %0|%0, %1, 0x1}" - [(set_attr "type" "sselog") - (set_attr "prefix_extra" "1") - (set_attr "length_immediate" "1") - (set_attr "memory" "none,store") - (set_attr "prefix" "vex") - (set_attr "mode" "V8SF")]) + "#" + "&& reload_completed" + [(const_int 0)] +{ + rtx op1 = operands[1]; + if (REG_P (op1)) + op1 = gen_rtx_REG (mode, REGNO (op1)); + else + op1 = gen_lowpart (mode, op1); + emit_move_insn (operands[0], op1); + DONE; +}) (define_insn "vec_extract_hi_" [(set (match_operand: 0 "nonimmediate_operand" "=x,m") @@ -4453,22 +4456,27 @@ (set_attr "prefix" "vex") (set_attr "mode" "V8SF")]) -(define_insn "vec_extract_lo_v16hi" +(define_insn_and_split "vec_extract_lo_v16hi" [(set (match_operand:V8HI 0 "nonimmediate_operand" "=x,m") (vec_select:V8HI - (match_operand:V16HI 1 "register_operand" "x,x") + (match_operand:V16HI 1 "nonimmediate_operand" "xm,x") (parallel [(const_int 0) (const_int 1) (const_int 2) (const_int 3) (const_int 4) (const_int 5) (const_int 6) (const_int 7)])))] "TARGET_AVX" - "vextractf128\t{$0x1, %1, %0|%0, %1, 0x1}" - [(set_attr "type" "sselog") - (set_attr "prefix_extra" "1") - (set_attr "length_immediate" "1") - (set_attr "memory" "none,store") - (set_attr "prefix" "vex") - (set_attr "mode" "V8SF")]) + "#" + "&& reload_completed" + [(const_int 0)] +{ + rtx op1 = operands[1]; + if (REG_P (op1)) + op1 = gen_rtx_REG (V8HImode, REGNO (op1)); + else + op1 = gen_lowpart (V8HImode, op1); + emit_move_insn (operands[0], op1); + DONE; +}) (define_insn "vec_extract_hi_v16hi" [(set (match_operand:V8HI 0 "nonimmediate_operand" "=x,m") @@ -4487,10 +4495,10 @@ (set_attr "prefix" "vex") (set_attr "mode" "V8SF")]) -(define_insn "vec_extract_lo_v32qi" +(define_insn_and_split "vec_extract_lo_v32qi" [(set (match_operand:V16QI 0 "nonimmediate_operand" "=x,m") (vec_select:V16QI - (match_operand:V32QI 1 "register_operand" "x,x") + (match_operand:V32QI 1 "nonimmediate_operand" "xm,x") (parallel [(const_int 0) (const_int 1) (const_int 2) (const_int 3) (const_int 4) (const_int 5) @@ -4500,13 +4508,18 @@ (const_int 12) (const_int 13) (const_int 14) (const_int 15)])))] "TARGET_AVX" - "vextractf128\t{$0x1, %1, %0|%0, %1, 0x1}" - [(set_attr "type" "sselog") - (set_attr "prefix_extra" "1") - (set_attr "length_immediate" "1") - (set_attr "memory" "none,store") - (set_attr "prefix" "vex") - (set_attr "mode" "V8SF")]) + "#" + "&& reload_completed" + [(const_int 0)] +{ + rtx op1 = operands[1]; + if (REG_P (op1)) + op1 = gen_rtx_REG (V16QImode, REGNO (op1)); + else + op1 = gen_lowpart (V16QImode, op1); + emit_move_insn (operands[0], op1); + DONE; +}) (define_insn "vec_extract_hi_v32qi" [(set (match_operand:V16QI 0 "nonimmediate_operand" "=x,m") @@ -6261,6 +6274,7 @@ [(set_attr "type" "sseishft") (set_attr "prefix_data16" "1") (set_attr "length_immediate" "1") + (set_attr "atom_unit" "sishuf") (set_attr "mode" "TI")]) (define_insn "lshr3" @@ -7691,7 +7705,7 @@ vpsrldq\t{$8, %1, %0|%0, %1, 8} vmovq\t{%H1, %0|%0, %H1} vmov{q}\t{%H1, %0|%0, %H1}" - [(set_attr "type" "ssemov,sseishft,ssemov,imov") + [(set_attr "type" "ssemov,sseishft1,ssemov,imov") (set_attr "length_immediate" "*,1,*,*") (set_attr "memory" "*,none,*,*") (set_attr "prefix" "vex") @@ -7708,9 +7722,8 @@ psrldq\t{$8, %0|%0, 8} movq\t{%H1, %0|%0, %H1} mov{q}\t{%H1, %0|%0, %H1}" - [(set_attr "type" "ssemov,sseishft,ssemov,imov") + [(set_attr "type" "ssemov,sseishft1,ssemov,imov") (set_attr "length_immediate" "*,1,*,*") - (set_attr "atom_unit" "*,sishuf,*,*") (set_attr "memory" "*,none,*,*") (set_attr "mode" "V2SF,TI,TI,DI")]) @@ -7726,7 +7739,7 @@ vmovhps\t{%1, %0|%0, %1} vpsrldq\t{$8, %1, %0|%0, %1, 8} vmovq\t{%H1, %0|%0, %H1}" - [(set_attr "type" "ssemov,sseishft,ssemov") + [(set_attr "type" "ssemov,sseishft1,ssemov") (set_attr "length_immediate" "*,1,*") (set_attr "memory" "*,none,*") (set_attr "prefix" "vex") @@ -7743,9 +7756,8 @@ movhps\t{%1, %0|%0, %1} psrldq\t{$8, %0|%0, 8} movq\t{%H1, %0|%0, %H1}" - [(set_attr "type" "ssemov,sseishft,ssemov") + [(set_attr "type" "ssemov,sseishft1,ssemov") (set_attr "length_immediate" "*,1,*") - (set_attr "atom_unit" "*,sishuf,*") (set_attr "memory" "*,none,*") (set_attr "mode" "V2SF,TI,TI")]) @@ -8318,24 +8330,24 @@ (set_attr "prefix_data16" "1") (set_attr "mode" "TI")]) -(define_insn "avx_movmskp256" +(define_insn "avx_movmsk256" [(set (match_operand:SI 0 "register_operand" "=r") (unspec:SI [(match_operand:AVX256MODEF2P 1 "register_operand" "x")] UNSPEC_MOVMSK))] "AVX256_VEC_FLOAT_MODE_P (mode)" - "vmovmskp\t{%1, %0|%0, %1}" + "vmovmsk\t{%1, %0|%0, %1}" [(set_attr "type" "ssecvt") (set_attr "prefix" "vex") (set_attr "mode" "")]) -(define_insn "_movmskp" +(define_insn "_movmsk" [(set (match_operand:SI 0 "register_operand" "=r") (unspec:SI [(match_operand:SSEMODEF2P 1 "register_operand" "x")] UNSPEC_MOVMSK))] "SSE_VEC_FLOAT_MODE_P (mode)" - "%vmovmskp\t{%1, %0|%0, %1}" + "%vmovmsk\t{%1, %0|%0, %1}" [(set_attr "type" "ssemov") (set_attr "prefix" "maybe_vex") (set_attr "mode" "")]) @@ -9575,7 +9587,7 @@ (parallel [(const_int 0)]))] UNSPEC_MOVNT))] "TARGET_SSE4A" - "movnts\t{%1, %0|%0, %1}" + "movnt\t{%1, %0|%0, %1}" [(set_attr "type" "ssemov") (set_attr "mode" "")]) @@ -9636,21 +9648,21 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define_insn "avx_blendp" +(define_insn "avx_blend" [(set (match_operand:AVXMODEF2P 0 "register_operand" "=x") (vec_merge:AVXMODEF2P (match_operand:AVXMODEF2P 2 "nonimmediate_operand" "xm") (match_operand:AVXMODEF2P 1 "register_operand" "x") (match_operand:SI 3 "const_0_to__operand" "n")))] "TARGET_AVX" - "vblendp\t{%3, %2, %1, %0|%0, %1, %2, %3}" + "vblend\t{%3, %2, %1, %0|%0, %1, %2, %3}" [(set_attr "type" "ssemov") (set_attr "prefix_extra" "1") (set_attr "length_immediate" "1") (set_attr "prefix" "vex") (set_attr "mode" "")]) -(define_insn "avx_blendvp" +(define_insn "avx_blendv" [(set (match_operand:AVXMODEF2P 0 "register_operand" "=x") (unspec:AVXMODEF2P [(match_operand:AVXMODEF2P 1 "register_operand" "x") @@ -9658,28 +9670,28 @@ (match_operand:AVXMODEF2P 3 "register_operand" "x")] UNSPEC_BLENDV))] "TARGET_AVX" - "vblendvp\t{%3, %2, %1, %0|%0, %1, %2, %3}" + "vblendv\t{%3, %2, %1, %0|%0, %1, %2, %3}" [(set_attr "type" "ssemov") (set_attr "prefix_extra" "1") (set_attr "length_immediate" "1") (set_attr "prefix" "vex") (set_attr "mode" "")]) -(define_insn "sse4_1_blendp" +(define_insn "sse4_1_blend" [(set (match_operand:SSEMODEF2P 0 "register_operand" "=x") (vec_merge:SSEMODEF2P (match_operand:SSEMODEF2P 2 "nonimmediate_operand" "xm") (match_operand:SSEMODEF2P 1 "register_operand" "0") (match_operand:SI 3 "const_0_to__operand" "n")))] "TARGET_SSE4_1" - "blendp\t{%3, %2, %0|%0, %2, %3}" + "blend\t{%3, %2, %0|%0, %2, %3}" [(set_attr "type" "ssemov") (set_attr "prefix_data16" "1") (set_attr "prefix_extra" "1") (set_attr "length_immediate" "1") (set_attr "mode" "")]) -(define_insn "sse4_1_blendvp" +(define_insn "sse4_1_blendv" [(set (match_operand:SSEMODEF2P 0 "reg_not_xmm0_operand" "=x") (unspec:SSEMODEF2P [(match_operand:SSEMODEF2P 1 "reg_not_xmm0_operand" "0") @@ -9687,13 +9699,13 @@ (match_operand:SSEMODEF2P 3 "register_operand" "Yz")] UNSPEC_BLENDV))] "TARGET_SSE4_1" - "blendvp\t{%3, %2, %0|%0, %2, %3}" + "blendv\t{%3, %2, %0|%0, %2, %3}" [(set_attr "type" "ssemov") (set_attr "prefix_data16" "1") (set_attr "prefix_extra" "1") (set_attr "mode" "")]) -(define_insn "avx_dpp" +(define_insn "avx_dp" [(set (match_operand:AVXMODEF2P 0 "register_operand" "=x") (unspec:AVXMODEF2P [(match_operand:AVXMODEF2P 1 "nonimmediate_operand" "%x") @@ -9701,14 +9713,14 @@ (match_operand:SI 3 "const_0_to_255_operand" "n")] UNSPEC_DP))] "TARGET_AVX" - "vdpp\t{%3, %2, %1, %0|%0, %1, %2, %3}" + "vdp\t{%3, %2, %1, %0|%0, %1, %2, %3}" [(set_attr "type" "ssemul") (set_attr "prefix" "vex") (set_attr "prefix_extra" "1") (set_attr "length_immediate" "1") (set_attr "mode" "")]) -(define_insn "sse4_1_dpp" +(define_insn "sse4_1_dp" [(set (match_operand:SSEMODEF2P 0 "register_operand" "=x") (unspec:SSEMODEF2P [(match_operand:SSEMODEF2P 1 "nonimmediate_operand" "%0") @@ -9716,7 +9728,7 @@ (match_operand:SI 3 "const_0_to_255_operand" "n")] UNSPEC_DP))] "TARGET_SSE4_1" - "dpp\t{%3, %2, %0|%0, %2, %3}" + "dp\t{%3, %2, %0|%0, %2, %3}" [(set_attr "type" "ssemul") (set_attr "prefix_data16" "1") (set_attr "prefix_extra" "1") @@ -10242,13 +10254,13 @@ ;; ptestps/ptestpd are very similar to comiss and ucomiss when ;; setting FLAGS_REG. But it is not a really compare instruction. -(define_insn "avx_vtestp" +(define_insn "avx_vtest" [(set (reg:CC FLAGS_REG) (unspec:CC [(match_operand:AVXMODEF2P 0 "register_operand" "x") (match_operand:AVXMODEF2P 1 "nonimmediate_operand" "xm")] UNSPEC_VTESTP))] "TARGET_AVX" - "vtestp\t{%1, %0|%0, %1}" + "vtest\t{%1, %0|%0, %1}" [(set_attr "type" "ssecomi") (set_attr "prefix_extra" "1") (set_attr "prefix" "vex") @@ -10280,28 +10292,28 @@ (set_attr "prefix" "maybe_vex") (set_attr "mode" "TI")]) -(define_insn "avx_roundp256" +(define_insn "avx_round256" [(set (match_operand:AVX256MODEF2P 0 "register_operand" "=x") (unspec:AVX256MODEF2P [(match_operand:AVX256MODEF2P 1 "nonimmediate_operand" "xm") (match_operand:SI 2 "const_0_to_15_operand" "n")] UNSPEC_ROUND))] "TARGET_AVX" - "vroundp\t{%2, %1, %0|%0, %1, %2}" + "vround\t{%2, %1, %0|%0, %1, %2}" [(set_attr "type" "ssecvt") (set_attr "prefix_extra" "1") (set_attr "length_immediate" "1") (set_attr "prefix" "vex") (set_attr "mode" "")]) -(define_insn "sse4_1_roundp" +(define_insn "sse4_1_round" [(set (match_operand:SSEMODEF2P 0 "register_operand" "=x") (unspec:SSEMODEF2P [(match_operand:SSEMODEF2P 1 "nonimmediate_operand" "xm") (match_operand:SI 2 "const_0_to_15_operand" "n")] UNSPEC_ROUND))] "TARGET_ROUND" - "%vroundp\t{%2, %1, %0|%0, %1, %2}" + "%vround\t{%2, %1, %0|%0, %1, %2}" [(set_attr "type" "ssecvt") (set_attr "prefix_data16" "1") (set_attr "prefix_extra" "1") @@ -10309,7 +10321,7 @@ (set_attr "prefix" "maybe_vex") (set_attr "mode" "")]) -(define_insn "*avx_rounds" +(define_insn "*avx_round" [(set (match_operand:SSEMODEF2P 0 "register_operand" "=x") (vec_merge:SSEMODEF2P (unspec:SSEMODEF2P @@ -10319,14 +10331,14 @@ (match_operand:SSEMODEF2P 1 "register_operand" "x") (const_int 1)))] "TARGET_AVX" - "vrounds\t{%3, %2, %1, %0|%0, %1, %2, %3}" + "vround\t{%3, %2, %1, %0|%0, %1, %2, %3}" [(set_attr "type" "ssecvt") (set_attr "prefix_extra" "1") (set_attr "length_immediate" "1") (set_attr "prefix" "vex") (set_attr "mode" "")]) -(define_insn "sse4_1_rounds" +(define_insn "sse4_1_round" [(set (match_operand:SSEMODEF2P 0 "register_operand" "=x") (vec_merge:SSEMODEF2P (unspec:SSEMODEF2P @@ -10336,7 +10348,7 @@ (match_operand:SSEMODEF2P 1 "register_operand" "0") (const_int 1)))] "TARGET_ROUND" - "rounds\t{%3, %2, %0|%0, %2, %3}" + "round\t{%3, %2, %0|%0, %2, %3}" [(set_attr "type" "ssecvt") (set_attr "prefix_data16" "1") (set_attr "prefix_extra" "1") @@ -11778,7 +11790,7 @@ [(match_operand:SSEMODEF2P 1 "nonimmediate_operand" "xm")] UNSPEC_FRCZ))] "TARGET_XOP" - "vfrcz\t{%1, %0|%0, %1}" + "vfrcz\t{%1, %0|%0, %1}" [(set_attr "type" "ssecvt1") (set_attr "mode" "")]) @@ -11792,7 +11804,7 @@ (match_operand:SSEMODEF2P 1 "register_operand" "0") (const_int 1)))] "TARGET_XOP" - "vfrcz\t{%2, %0|%0, %2}" + "vfrcz\t{%2, %0|%0, %2}" [(set_attr "type" "ssecvt1") (set_attr "mode" "")]) @@ -11802,7 +11814,7 @@ [(match_operand:FMA4MODEF4 1 "nonimmediate_operand" "xm")] UNSPEC_FRCZ))] "TARGET_XOP" - "vfrcz\t{%1, %0|%0, %1}" + "vfrcz\t{%1, %0|%0, %1}" [(set_attr "type" "ssecvt1") (set_attr "mode" "")]) @@ -11882,7 +11894,7 @@ (match_operand:SI 4 "const_0_to_3_operand" "n")] UNSPEC_VPERMIL2))] "TARGET_XOP" - "vpermil2p\t{%4, %3, %2, %1, %0|%0, %1, %2, %3, %4}" + "vpermil2\t{%4, %3, %2, %1, %0|%0, %1, %2, %3, %4}" [(set_attr "type" "sse4arg") (set_attr "length_immediate" "1") (set_attr "mode" "")]) @@ -12099,7 +12111,7 @@ (match_operand: 1 "nonimmediate_operand" "m,?x")))] "TARGET_AVX" "@ - vbroadcasts\t{%1, %0|%0, %1} + vbroadcast\t{%1, %0|%0, %1} #" "&& reload_completed && REG_P (operands[1])" [(set (match_dup 2) (vec_duplicate: (match_dup 1))) @@ -12253,7 +12265,7 @@ { int mask = avx_vpermilp_parallel (operands[2], mode) - 1; operands[2] = GEN_INT (mask); - return "vpermilp\t{%2, %1, %0|%0, %1, %2}"; + return "vpermil\t{%2, %1, %0|%0, %1, %2}"; } [(set_attr "type" "sselog") (set_attr "prefix_extra" "1") @@ -12268,7 +12280,7 @@ (match_operand: 2 "nonimmediate_operand" "xm")] UNSPEC_VPERMIL))] "TARGET_AVX" - "vpermilp\t{%2, %1, %0|%0, %1, %2}" + "vpermil\t{%2, %1, %0|%0, %1, %2}" [(set_attr "type" "sselog") (set_attr "prefix_extra" "1") (set_attr "prefix" "vex") @@ -12511,7 +12523,7 @@ (set_attr "prefix" "vex") (set_attr "mode" "V8SF")]) -(define_insn "avx_maskloadp" +(define_insn "avx_maskload" [(set (match_operand:AVXMODEF2P 0 "register_operand" "=x") (unspec:AVXMODEF2P [(match_operand:AVXMODEF2P 1 "memory_operand" "m") @@ -12519,13 +12531,13 @@ (match_dup 0)] UNSPEC_MASKLOAD))] "TARGET_AVX" - "vmaskmovp\t{%1, %2, %0|%0, %2, %1}" + "vmaskmov\t{%1, %2, %0|%0, %2, %1}" [(set_attr "type" "sselog1") (set_attr "prefix_extra" "1") (set_attr "prefix" "vex") (set_attr "mode" "")]) -(define_insn "avx_maskstorep" +(define_insn "avx_maskstore" [(set (match_operand:AVXMODEF2P 0 "memory_operand" "=m") (unspec:AVXMODEF2P [(match_operand:AVXMODEF2P 1 "register_operand" "x") @@ -12533,83 +12545,30 @@ (match_dup 0)] UNSPEC_MASKSTORE))] "TARGET_AVX" - "vmaskmovp\t{%2, %1, %0|%0, %1, %2}" + "vmaskmov\t{%2, %1, %0|%0, %1, %2}" [(set_attr "type" "sselog1") (set_attr "prefix_extra" "1") (set_attr "prefix" "vex") (set_attr "mode" "")]) -(define_insn "avx__" - [(set (match_operand:AVX256MODE2P 0 "register_operand" "=x,x") +(define_insn_and_split "avx__" + [(set (match_operand:AVX256MODE2P 0 "nonimmediate_operand" "=x,m") (unspec:AVX256MODE2P - [(match_operand: 1 "nonimmediate_operand" "0,xm")] - UNSPEC_CAST))] - "TARGET_AVX" -{ - switch (which_alternative) - { - case 0: - return ""; - case 1: - switch (get_attr_mode (insn)) - { - case MODE_V8SF: - return "vmovaps\t{%1, %x0|%x0, %1}"; - case MODE_V4DF: - return "vmovapd\t{%1, %x0|%x0, %1}"; - case MODE_OI: - return "vmovdqa\t{%1, %x0|%x0, %1}"; - default: - break; - } - default: - break; - } - gcc_unreachable (); -} - [(set_attr "type" "ssemov") - (set_attr "prefix" "vex") - (set_attr "mode" "") - (set (attr "length") - (if_then_else (eq_attr "alternative" "0") - (const_string "0") - (const_string "*")))]) - -(define_insn "avx__" - [(set (match_operand: 0 "register_operand" "=x,x") - (unspec: - [(match_operand:AVX256MODE2P 1 "nonimmediate_operand" "0,xm")] + [(match_operand: 1 "nonimmediate_operand" "xm,x")] UNSPEC_CAST))] "TARGET_AVX" + "#" + "&& reload_completed" + [(const_int 0)] { - switch (which_alternative) - { - case 0: - return ""; - case 1: - switch (get_attr_mode (insn)) - { - case MODE_V8SF: - return "vmovaps\t{%x1, %0|%0, %x1}"; - case MODE_V4DF: - return "vmovapd\t{%x1, %0|%0, %x1}"; - case MODE_OI: - return "vmovdqa\t{%x1, %0|%0, %x1}"; - default: - break; - } - default: - break; - } - gcc_unreachable (); -} - [(set_attr "type" "ssemov") - (set_attr "prefix" "vex") - (set_attr "mode" "") - (set (attr "length") - (if_then_else (eq_attr "alternative" "0") - (const_string "0") - (const_string "*")))]) + rtx op1 = operands[1]; + if (REG_P (op1)) + op1 = gen_rtx_REG (mode, REGNO (op1)); + else + op1 = gen_lowpart (mode, op1); + emit_move_insn (operands[0], op1); + DONE; +}) (define_expand "vec_init" [(match_operand:AVX256MODE 0 "register_operand" "") diff --git a/gcc/config/i386/winnt.c b/gcc/config/i386/winnt.c index 3750e0c4b08..c20a2ae89fc 100644 --- a/gcc/config/i386/winnt.c +++ b/gcc/config/i386/winnt.c @@ -576,7 +576,7 @@ i386_pe_record_external_function (tree decl, const char *name) { struct extern_list *p; - p = (struct extern_list *) ggc_alloc (sizeof *p); + p = ggc_alloc_extern_list (); p->next = extern_head; p->decl = decl; p->name = name; @@ -617,7 +617,7 @@ i386_pe_maybe_record_exported_symbol (tree decl, const char *name, int is_data) gcc_assert (TREE_PUBLIC (decl)); - p = (struct export_list *) ggc_alloc (sizeof *p); + p = ggc_alloc_export_list (); p->next = export_head; p->name = name; p->is_data = is_data; diff --git a/gcc/config/ia64/ia64-c.c b/gcc/config/ia64/ia64-c.c index c89a83cd99b..7a0bdd7a3cd 100644 --- a/gcc/config/ia64/ia64-c.c +++ b/gcc/config/ia64/ia64-c.c @@ -24,8 +24,8 @@ along with GCC; see the file COPYING3. If not see #include "tm.h" #include "tree.h" #include "cpplib.h" -#include "c-common.h" -#include "c-pragma.h" +#include "c-family/c-common.h" +#include "c-family/c-pragma.h" #include "toplev.h" #include "tm_p.h" diff --git a/gcc/config/ia64/ia64-protos.h b/gcc/config/ia64/ia64-protos.h index 3c6a153498e..a5914b1a5ac 100644 --- a/gcc/config/ia64/ia64-protos.h +++ b/gcc/config/ia64/ia64-protos.h @@ -1,5 +1,5 @@ /* Definitions of target machine for GNU compiler for IA-64. - Copyright (C) 1999, 2000, 2002, 2003, 2004, 2005, 2007 + Copyright (C) 1999, 2000, 2002, 2003, 2004, 2005, 2007, 2010 Free Software Foundation, Inc. This file is part of GCC. @@ -69,7 +69,6 @@ extern rtx ia64_function_arg (CUMULATIVE_ARGS *, enum machine_mode, tree, int, int); extern rtx ia64_expand_builtin (tree, rtx, rtx, enum machine_mode, int); extern rtx ia64_va_arg (tree, tree); -extern rtx ia64_function_value (const_tree, const_tree); #endif /* RTX_CODE */ extern void ia64_function_arg_advance (CUMULATIVE_ARGS *, enum machine_mode, @@ -80,10 +79,9 @@ extern void ia64_vms_output_aligned_decl_common (FILE *, tree, const char *, unsigned HOST_WIDE_INT, unsigned int); extern void ia64_vms_elf_asm_named_section (const char *, unsigned int, tree); +extern void ia64_start_function (FILE *, const char *, tree); #endif /* TREE_CODE */ -extern int ia64_register_move_cost (enum machine_mode, enum reg_class, - enum reg_class); extern int ia64_epilogue_uses (int); extern int ia64_eh_uses (int); extern void emit_safe_across_calls (void); diff --git a/gcc/config/ia64/ia64.c b/gcc/config/ia64/ia64.c index e1e3dff8b59..7df747bf986 100644 --- a/gcc/config/ia64/ia64.c +++ b/gcc/config/ia64/ia64.c @@ -207,6 +207,11 @@ static int ia64_arg_partial_bytes (CUMULATIVE_ARGS *, enum machine_mode, tree, bool); static bool ia64_function_ok_for_sibcall (tree, tree); static bool ia64_return_in_memory (const_tree, const_tree); +static rtx ia64_function_value (const_tree, const_tree, bool); +static rtx ia64_libcall_value (enum machine_mode, const_rtx); +static bool ia64_function_value_regno_p (const unsigned int); +static int ia64_register_move_cost (enum machine_mode, reg_class_t, + reg_class_t); static bool ia64_rtx_costs (rtx, int, int, int *, bool); static int ia64_unspec_may_trap_p (const_rtx, unsigned); static void fix_range (const char *); @@ -451,6 +456,8 @@ static const struct attribute_spec ia64_attribute_table[] = #undef TARGET_ASM_GLOBALIZE_DECL_NAME #define TARGET_ASM_GLOBALIZE_DECL_NAME ia64_globalize_decl_name +#undef TARGET_REGISTER_MOVE_COST +#define TARGET_REGISTER_MOVE_COST ia64_register_move_cost #undef TARGET_RTX_COSTS #define TARGET_RTX_COSTS ia64_rtx_costs #undef TARGET_ADDRESS_COST @@ -482,6 +489,13 @@ static const struct attribute_spec ia64_attribute_table[] = #define TARGET_PROMOTE_PROTOTYPES hook_bool_tree_true #endif +#undef TARGET_FUNCTION_VALUE +#define TARGET_FUNCTION_VALUE ia64_function_value +#undef TARGET_LIBCALL_VALUE +#define TARGET_LIBCALL_VALUE ia64_libcall_value +#undef TARGET_FUNCTION_VALUE_REGNO_P +#define TARGET_FUNCTION_VALUE_REGNO_P ia64_function_value_regno_p + #undef TARGET_STRUCT_VALUE_RTX #define TARGET_STRUCT_VALUE_RTX ia64_struct_value_rtx #undef TARGET_RETURN_IN_MEMORY @@ -496,8 +510,8 @@ static const struct attribute_spec ia64_attribute_table[] = #undef TARGET_GIMPLIFY_VA_ARG_EXPR #define TARGET_GIMPLIFY_VA_ARG_EXPR ia64_gimplify_va_arg -#undef TARGET_UNWIND_EMIT -#define TARGET_UNWIND_EMIT process_for_unwind_directive +#undef TARGET_ASM_UNWIND_EMIT +#define TARGET_ASM_UNWIND_EMIT process_for_unwind_directive #undef TARGET_SCALAR_MODE_SUPPORTED_P #define TARGET_SCALAR_MODE_SUPPORTED_P ia64_scalar_mode_supported_p @@ -3413,6 +3427,29 @@ ia64_expand_prologue (void) finish_spill_pointers (); } +/* Output the textual info surrounding the prologue. */ + +void +ia64_start_function (FILE *file, const char *fnname, + tree decl ATTRIBUTE_UNUSED) +{ +#if VMS_DEBUGGING_INFO + if (vms_debug_main + && strncmp (vms_debug_main, fnname, strlen (vms_debug_main)) == 0) + { + targetm.asm_out.globalize_label (asm_out_file, VMS_DEBUG_MAIN_POINTER); + ASM_OUTPUT_DEF (asm_out_file, VMS_DEBUG_MAIN_POINTER, fnname); + dwarf2out_vms_debug_main_pointer (); + vms_debug_main = 0; + } +#endif + + fputs ("\t.proc ", file); + assemble_name (file, fnname); + fputc ('\n', file); + ASM_OUTPUT_LABEL (file, fnname); +} + /* Called after register allocation to add any instructions needed for the epilogue. Using an epilogue insn is favored compared to putting all of the instructions in output_function_prologue(), since it allows the scheduler @@ -4637,13 +4674,20 @@ ia64_return_in_memory (const_tree valtype, const_tree fntype ATTRIBUTE_UNUSED) /* Return rtx for register that holds the function return value. */ -rtx -ia64_function_value (const_tree valtype, const_tree func) +static rtx +ia64_function_value (const_tree valtype, + const_tree fn_decl_or_type, + bool outgoing ATTRIBUTE_UNUSED) { enum machine_mode mode; enum machine_mode hfa_mode; int unsignedp; + const_tree func = fn_decl_or_type; + if (fn_decl_or_type + && !DECL_P (fn_decl_or_type)) + func = NULL; + mode = TYPE_MODE (valtype); hfa_mode = hfa_element_mode (valtype, 0); @@ -4721,6 +4765,28 @@ ia64_function_value (const_tree valtype, const_tree func) } } +/* Worker function for TARGET_LIBCALL_VALUE. */ + +static rtx +ia64_libcall_value (enum machine_mode mode, + const_rtx fun ATTRIBUTE_UNUSED) +{ + return gen_rtx_REG (mode, + (((GET_MODE_CLASS (mode) == MODE_FLOAT + || GET_MODE_CLASS (mode) == MODE_COMPLEX_FLOAT) + && (mode) != TFmode) + ? FR_RET_FIRST : GR_RET_FIRST)); +} + +/* Worker function for FUNCTION_VALUE_REGNO_P. */ + +static bool +ia64_function_value_regno_p (const unsigned int regno) +{ + return ((regno >= GR_RET_FIRST && regno <= GR_RET_LAST) + || (regno >= FR_RET_FIRST && regno <= FR_RET_LAST)); +} + /* This is called from dwarf2out.c via TARGET_ASM_OUTPUT_DWARF_DTPREL. We need to emit DTP-relative relocations. */ @@ -5140,10 +5206,13 @@ ia64_rtx_costs (rtx x, int code, int outer_code, int *total, /* Calculate the cost of moving data from a register in class FROM to one in class TO, using MODE. */ -int -ia64_register_move_cost (enum machine_mode mode, enum reg_class from, - enum reg_class to) +static int +ia64_register_move_cost (enum machine_mode mode, reg_class_t from_i, + reg_class_t to_i) { + enum reg_class from = (enum reg_class) from_i; + enum reg_class to = (enum reg_class) to_i; + /* ADDL_REGS is the same as GR_REGS for movement purposes. */ if (to == ADDL_REGS) to = GR_REGS; @@ -5540,7 +5609,7 @@ void ia64_init_expanders (void) static struct machine_function * ia64_init_machine_status (void) { - return GGC_CNEW (struct machine_function); + return ggc_alloc_cleared_machine_function (); } static enum attr_itanium_class ia64_safe_itanium_class (rtx); diff --git a/gcc/config/ia64/ia64.h b/gcc/config/ia64/ia64.h index c019aa48184..d3821f6c6f4 100644 --- a/gcc/config/ia64/ia64.h +++ b/gcc/config/ia64/ia64.h @@ -1042,12 +1042,6 @@ enum reg_class #define ACCUMULATE_OUTGOING_ARGS 1 -/* A C expression that should indicate the number of bytes of its own arguments - that a function pops on returning, or 0 if the function pops no arguments - and the caller must therefore pop them all after the function returns. */ - -#define RETURN_POPS_ARGS(FUNDECL, FUNTYPE, STACK_SIZE) 0 - /* Function Arguments in Registers */ @@ -1146,31 +1140,6 @@ do { \ #define FUNCTION_ARG_REGNO_P(REGNO) \ (((REGNO) >= AR_ARG_FIRST && (REGNO) < (AR_ARG_FIRST + MAX_ARGUMENT_SLOTS)) \ || ((REGNO) >= FR_ARG_FIRST && (REGNO) < (FR_ARG_FIRST + MAX_ARGUMENT_SLOTS))) - -/* How Scalar Function Values are Returned */ - -/* A C expression to create an RTX representing the place where a function - returns a value of data type VALTYPE. */ - -#define FUNCTION_VALUE(VALTYPE, FUNC) \ - ia64_function_value (VALTYPE, FUNC) - -/* A C expression to create an RTX representing the place where a library - function returns a value of mode MODE. */ - -#define LIBCALL_VALUE(MODE) \ - gen_rtx_REG (MODE, \ - (((GET_MODE_CLASS (MODE) == MODE_FLOAT \ - || GET_MODE_CLASS (MODE) == MODE_COMPLEX_FLOAT) && \ - (MODE) != TFmode) \ - ? FR_RET_FIRST : GR_RET_FIRST)) - -/* A C expression that is nonzero if REGNO is the number of a hard register in - which the values of called function may come back. */ - -#define FUNCTION_VALUE_REGNO_P(REGNO) \ - (((REGNO) >= GR_RET_FIRST && (REGNO) <= GR_RET_LAST) \ - || ((REGNO) >= FR_RET_FIRST && (REGNO) <= FR_RET_LAST)) /* How Large Values are Returned */ @@ -1335,11 +1304,6 @@ do { \ /* Describing Relative Costs of Operations */ -/* A C expression for the cost of moving data from a register in class FROM to - one in class TO, using MODE. */ - -#define REGISTER_MOVE_COST ia64_register_move_cost - /* A C expression for the cost of moving data of mode M between a register and memory. */ #define MEMORY_MOVE_COST(MODE,CLASS,IN) \ diff --git a/gcc/config/ia64/sysv4.h b/gcc/config/ia64/sysv4.h index 678a81ec628..0d760731b46 100644 --- a/gcc/config/ia64/sysv4.h +++ b/gcc/config/ia64/sysv4.h @@ -1,7 +1,7 @@ /* Override definitions in elfos.h/svr4.h to be correct for IA64. Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, -2007 Free Software Foundation, Inc. +2007, 2010 Free Software Foundation, Inc. This file is part of GCC. @@ -127,12 +127,7 @@ do { \ #undef ASM_DECLARE_FUNCTION_NAME #define ASM_DECLARE_FUNCTION_NAME(FILE, NAME, DECL) \ -do { \ - fputs ("\t.proc ", FILE); \ - assemble_name (FILE, NAME); \ - fputc ('\n', FILE); \ - ASM_OUTPUT_LABEL (FILE, NAME); \ -} while (0) + ia64_start_function(FILE,NAME,DECL) /* We redefine this to use the ia64 .endp pseudo-op. */ diff --git a/gcc/config/ia64/t-ia64 b/gcc/config/ia64/t-ia64 index db7a8298d17..212bef7cfab 100644 --- a/gcc/config/ia64/t-ia64 +++ b/gcc/config/ia64/t-ia64 @@ -46,7 +46,7 @@ LIB2ADDEH = $(srcdir)/config/ia64/unwind-ia64.c $(srcdir)/unwind-sjlj.c \ $(srcdir)/unwind-c.c ia64-c.o: $(srcdir)/config/ia64/ia64-c.c $(CONFIG_H) $(SYSTEM_H) \ - coretypes.h $(TM_H) $(TREE_H) $(CPPLIB_H) $(C_COMMON_H) c-pragma.h toplev.h + coretypes.h $(TM_H) $(TREE_H) $(CPPLIB_H) $(C_COMMON_H) $(C_PRAGMA_H) toplev.h $(COMPILER) -c $(ALL_COMPILERFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) \ $(srcdir)/config/ia64/ia64-c.c diff --git a/gcc/config/ia64/vms.h b/gcc/config/ia64/vms.h index 279586c0398..3d678ce5f85 100644 --- a/gcc/config/ia64/vms.h +++ b/gcc/config/ia64/vms.h @@ -1,5 +1,5 @@ /* Definitions of target machine GNU compiler. IA64-VMS version. - Copyright (C) 2003-2009 Free Software Foundation, Inc. + Copyright (C) 2003-2010 Free Software Foundation, Inc. Contributed by Douglas B Rupp (rupp@gnat.com). This file is part of GCC. @@ -72,13 +72,13 @@ along with GCC; see the file COPYING3. If not see /* Turn on VMS specific Dwarf2 features. */ #define VMS_DEBUGGING_INFO 1 -#define ASM_OUTPUT_DWARF_DELTA_UNITS(FILE,SIZE,LABEL1,LABEL2,UNITS) \ -do { \ - fprintf (FILE, "\tdata4.ua\t ("); \ - assemble_name (FILE, LABEL1); \ - fprintf (FILE, "-"); \ - assemble_name (FILE, LABEL2); \ - fprintf (FILE, ")/16*3"); \ +#define ASM_OUTPUT_DWARF_VMS_DELTA(FILE,SIZE,LABEL1,LABEL2) \ +do { \ + fprintf (FILE, "\tdata4.ua\t@slotcount("); \ + assemble_name (FILE, LABEL1); \ + fprintf (FILE, "-"); \ + assemble_name (FILE, LABEL2); \ + fprintf (FILE, ")"); \ } while (0) #undef STARTFILE_SPEC diff --git a/gcc/config/iq2000/iq2000-protos.h b/gcc/config/iq2000/iq2000-protos.h index c01b6eee3b9..56fd39e7bc6 100644 --- a/gcc/config/iq2000/iq2000-protos.h +++ b/gcc/config/iq2000/iq2000-protos.h @@ -35,8 +35,6 @@ extern void iq2000_expand_eh_return (rtx); extern int iq2000_can_use_return_insn (void); extern int iq2000_adjust_insn_length (rtx, int); extern char * iq2000_output_conditional_branch (rtx, rtx *, int, int, int, int); -extern void print_operand_address (FILE *, rtx); -extern void print_operand (FILE *, rtx, int); #ifdef RTX_CODE extern rtx gen_int_relational (enum rtx_code, rtx, rtx, rtx, int *); diff --git a/gcc/config/iq2000/iq2000.c b/gcc/config/iq2000/iq2000.c index 0e51eca7965..559d88433fa 100644 --- a/gcc/config/iq2000/iq2000.c +++ b/gcc/config/iq2000/iq2000.c @@ -108,8 +108,8 @@ struct GTY(()) machine_function /* Global variables for machine-dependent things. */ -/* List of all IQ2000 punctuation characters used by print_operand. */ -char iq2000_print_operand_punct[256]; +/* List of all IQ2000 punctuation characters used by iq2000_print_operand. */ +static char iq2000_print_operand_punct[256]; /* The target cpu for optimization and scheduling. */ enum processor_type iq2000_tune; @@ -169,6 +169,9 @@ static void iq2000_asm_trampoline_template (FILE *); static void iq2000_trampoline_init (rtx, tree, rtx); static rtx iq2000_function_value (const_tree, const_tree, bool); static rtx iq2000_libcall_value (enum machine_mode, const_rtx); +static void iq2000_print_operand (FILE *, rtx, int); +static void iq2000_print_operand_address (FILE *, rtx); +static bool iq2000_print_operand_punct_valid_p (unsigned char code); #undef TARGET_INIT_BUILTINS #define TARGET_INIT_BUILTINS iq2000_init_builtins @@ -193,6 +196,13 @@ static rtx iq2000_libcall_value (enum machine_mode, const_rtx); #undef TARGET_HAVE_SWITCHABLE_BSS_SECTIONS #define TARGET_HAVE_SWITCHABLE_BSS_SECTIONS false +#undef TARGET_PRINT_OPERAND +#define TARGET_PRINT_OPERAND iq2000_print_operand +#undef TARGET_PRINT_OPERAND_ADDRESS +#define TARGET_PRINT_OPERAND_ADDRESS iq2000_print_operand_address +#undef TARGET_PRINT_OPERAND_PUNCT_VALID_P +#define TARGET_PRINT_OPERAND_PUNCT_VALID_P iq2000_print_operand_punct_valid_p + #undef TARGET_PROMOTE_FUNCTION_MODE #define TARGET_PROMOTE_FUNCTION_MODE default_promote_function_mode_always_promote #undef TARGET_PROMOTE_PROTOTYPES @@ -1385,11 +1395,7 @@ iq2000_va_start (tree valist, rtx nextarg) static struct machine_function * iq2000_init_machine_status (void) { - struct machine_function *f; - - f = GGC_CNEW (struct machine_function); - - return f; + return ggc_alloc_cleared_machine_function (); } /* Implement TARGET_HANDLE_OPTION. */ @@ -2924,8 +2930,8 @@ iq2000_setup_incoming_varargs (CUMULATIVE_ARGS *cum, assembler syntax for an instruction operand that is a memory reference whose address is ADDR. ADDR is an RTL expression. */ -void -print_operand_address (FILE * file, rtx addr) +static void +iq2000_print_operand_address (FILE * file, rtx addr) { if (!addr) error ("PRINT_OPERAND_ADDRESS, null pointer"); @@ -2950,7 +2956,7 @@ print_operand_address (FILE * file, rtx addr) "PRINT_OPERAND_ADDRESS, LO_SUM with #1 not REG."); fprintf (file, "%%lo("); - print_operand_address (file, arg1); + iq2000_print_operand_address (file, arg1); fprintf (file, ")(%s)", reg_names [REGNO (arg0)]); } break; @@ -3052,12 +3058,12 @@ print_operand_address (FILE * file, rtx addr) '$' Print the name of the stack pointer register (sp or $29). '+' Print the name of the gp register (gp or $28). */ -void -print_operand (FILE *file, rtx op, int letter) +static void +iq2000_print_operand (FILE *file, rtx op, int letter) { enum rtx_code code; - if (PRINT_OPERAND_PUNCT_VALID_P (letter)) + if (iq2000_print_operand_punct_valid_p (letter)) { switch (letter) { @@ -3238,13 +3244,18 @@ print_operand (FILE *file, rtx op, int letter) else if (code == CONST && GET_CODE (XEXP (op, 0)) == REG) { - print_operand (file, XEXP (op, 0), letter); + iq2000_print_operand (file, XEXP (op, 0), letter); } else output_addr_const (file, op); } +static bool +iq2000_print_operand_punct_valid_p (unsigned char code) +{ + return iq2000_print_operand_punct[code]; +} /* For the IQ2000, transform: diff --git a/gcc/config/iq2000/iq2000.h b/gcc/config/iq2000/iq2000.h index fe97f206f96..07d4c2d864b 100644 --- a/gcc/config/iq2000/iq2000.h +++ b/gcc/config/iq2000/iq2000.h @@ -365,8 +365,6 @@ enum reg_class #define OUTGOING_REG_PARM_STACK_SPACE(FNTYPE) 1 -#define RETURN_POPS_ARGS(FUNDECL,FUNTYPE,SIZE) 0 - /* Function Arguments in Registers. */ @@ -571,13 +569,6 @@ typedef struct iq2000_args #define FINAL_PRESCAN_INSN(INSN, OPVEC, NOPERANDS) \ final_prescan_insn (INSN, OPVEC, NOPERANDS) -/* See iq2000.c for the IQ2000 specific codes. */ -#define PRINT_OPERAND(FILE, X, CODE) print_operand (FILE, X, CODE) - -#define PRINT_OPERAND_PUNCT_VALID_P(CODE) iq2000_print_operand_punct[CODE] - -#define PRINT_OPERAND_ADDRESS(FILE, ADDR) print_operand_address (FILE, ADDR) - #define DBR_OUTPUT_SEQEND(STREAM) \ do \ { \ @@ -920,9 +911,6 @@ enum processor_type #define SDATA_SECTION_ASM_OP "\t.sdata" /* Small data. */ -/* List of all IQ2000 punctuation characters used by print_operand. */ -extern char iq2000_print_operand_punct[256]; - /* The target cpu for optimization and scheduling. */ extern enum processor_type iq2000_tune; diff --git a/gcc/config/lm32/lm32.h b/gcc/config/lm32/lm32.h index 3a814576722..0bf37455627 100644 --- a/gcc/config/lm32/lm32.h +++ b/gcc/config/lm32/lm32.h @@ -273,8 +273,6 @@ enum reg_class #define ACCUMULATE_OUTGOING_ARGS 1 -#define RETURN_POPS_ARGS(DECL, FUNTYPE, SIZE) 0 - /*--------------------------------*/ /* Passing Arguments in Registers */ /*--------------------------------*/ diff --git a/gcc/config/m32c/m32c-pragma.c b/gcc/config/m32c/m32c-pragma.c index 4e309377465..b57615265a2 100644 --- a/gcc/config/m32c/m32c-pragma.c +++ b/gcc/config/m32c/m32c-pragma.c @@ -24,9 +24,8 @@ #include "coretypes.h" #include "tm.h" #include "tree.h" -#include "rtl.h" #include "toplev.h" -#include "c-pragma.h" +#include "c-family/c-pragma.h" #include "cpplib.h" #include "hard-reg-set.h" #include "output.h" @@ -88,9 +87,47 @@ m32c_pragma_memregs (cpp_reader * reader ATTRIBUTE_UNUSED) error ("#pragma GCC memregs takes a number [0..16]"); } +/* Implements the "pragma ADDRESS" pragma. This pragma takes a + variable name and an address, and arranges for that variable to be + "at" that address. The variable is also made volatile. */ +static void +m32c_pragma_address (cpp_reader * reader ATTRIBUTE_UNUSED) +{ + /* on off */ + tree var, addr; + enum cpp_ttype type; + const char *var_str; + + type = pragma_lex (&var); + if (type == CPP_NAME) + { + var_str = IDENTIFIER_POINTER (var); + + type = pragma_lex (&addr); + if (type == CPP_NUMBER) + { + if (var != error_mark_node) + { + unsigned uaddr = tree_low_cst (addr, 1); + m32c_note_pragma_address (IDENTIFIER_POINTER (var), uaddr); + } + + type = pragma_lex (&var); + if (type != CPP_EOF) + { + error ("junk at end of #pragma ADDRESS"); + } + return; + } + } + error ("malformed #pragma ADDRESS variable address"); +} + /* Implements REGISTER_TARGET_PRAGMAS. */ void m32c_register_pragmas (void) { c_register_pragma ("GCC", "memregs", m32c_pragma_memregs); + c_register_pragma (NULL, "ADDRESS", m32c_pragma_address); + c_register_pragma (NULL, "address", m32c_pragma_address); } diff --git a/gcc/config/m32c/m32c-protos.h b/gcc/config/m32c/m32c-protos.h index 42b92feb506..89231fc2d5d 100644 --- a/gcc/config/m32c/m32c-protos.h +++ b/gcc/config/m32c/m32c-protos.h @@ -42,6 +42,7 @@ int m32c_print_operand_punct_valid_p (int); int m32c_push_rounding (int); int m32c_reg_class_from_constraint (char, const char *); void m32c_register_pragmas (void); +void m32c_note_pragma_address (const char *, unsigned); int m32c_regno_ok_for_base_p (int); int m32c_trampoline_alignment (void); int m32c_trampoline_size (void); @@ -104,6 +105,8 @@ tree m32c_gimplify_va_arg_expr (tree, tree, gimple_seq *, gimple_seq *); void m32c_init_cumulative_args (CUMULATIVE_ARGS *, tree, rtx, tree, int); bool m32c_promote_function_return (const_tree); int m32c_special_page_vector_p (tree); +void m32c_output_aligned_common (FILE *, tree, const char *, + int, int, int); #endif diff --git a/gcc/config/m32c/m32c.c b/gcc/config/m32c/m32c.c index cfc4a1593b6..443325f8dd9 100644 --- a/gcc/config/m32c/m32c.c +++ b/gcc/config/m32c/m32c.c @@ -83,6 +83,9 @@ static int need_to_save (int); static rtx m32c_function_value (const_tree, const_tree, bool); static rtx m32c_libcall_value (enum machine_mode, const_rtx); +/* Returns true if an address is specified, else false. */ +static bool m32c_get_pragma_address (const char *varname, unsigned *addr); + int current_function_special_page_vector (rtx); #define SYMBOL_FLAG_FUNCVEC_FUNCTION (SYMBOL_FLAG_MACH_DEP << 0) @@ -435,11 +438,7 @@ m32c_override_options (void) static struct machine_function * m32c_init_machine_status (void) { - struct machine_function *machine; - machine = - (machine_function *) ggc_alloc_cleared (sizeof (machine_function)); - - return machine; + return ggc_alloc_cleared_machine_function (); } /* Implements INIT_EXPANDERS. We just set up to call the above @@ -2933,7 +2932,107 @@ static void m32c_insert_attributes (tree node ATTRIBUTE_UNUSED, tree * attr_ptr ATTRIBUTE_UNUSED) { - /* Nothing to do here. */ + unsigned addr; + /* See if we need to make #pragma address variables volatile. */ + + if (TREE_CODE (node) == VAR_DECL) + { + char *name = IDENTIFIER_POINTER (DECL_NAME (node)); + if (m32c_get_pragma_address (name, &addr)) + { + TREE_THIS_VOLATILE (node) = true; + } + } +} + + +struct GTY(()) pragma_entry { + const char *varname; + unsigned address; +}; +typedef struct pragma_entry pragma_entry; + +/* Hash table of pragma info. */ +static GTY((param_is (pragma_entry))) htab_t pragma_htab; + +static int +pragma_entry_eq (const void *p1, const void *p2) +{ + const pragma_entry *old = (const pragma_entry *) p1; + const char *new_name = (const char *) p2; + + return strcmp (old->varname, new_name) == 0; +} + +static hashval_t +pragma_entry_hash (const void *p) +{ + const pragma_entry *old = (const pragma_entry *) p; + return htab_hash_string (old->varname); +} + +void +m32c_note_pragma_address (const char *varname, unsigned address) +{ + pragma_entry **slot; + + if (!pragma_htab) + pragma_htab = htab_create_ggc (31, pragma_entry_hash, + pragma_entry_eq, NULL); + + slot = (pragma_entry **) + htab_find_slot_with_hash (pragma_htab, varname, + htab_hash_string (varname), INSERT); + + if (!*slot) + { + *slot = ggc_alloc_pragma_entry (); + (*slot)->varname = ggc_strdup (varname); + } + (*slot)->address = address; +} + +static bool +m32c_get_pragma_address (const char *varname, unsigned *address) +{ + pragma_entry **slot; + + if (!pragma_htab) + return false; + + slot = (pragma_entry **) + htab_find_slot_with_hash (pragma_htab, varname, + htab_hash_string (varname), NO_INSERT); + if (slot && *slot) + { + *address = (*slot)->address; + return true; + } + return false; +} + +void +m32c_output_aligned_common (FILE *stream, tree decl, const char *name, + int size, int align, int global) +{ + unsigned address; + + if (m32c_get_pragma_address (name, &address)) + { + /* We never output these as global. */ + assemble_name (stream, name); + fprintf (stream, " = 0x%04x\n", address); + return; + } + if (!global) + { + fprintf (stream, "\t.local\t"); + assemble_name (stream, name); + fprintf (stream, "\n"); + } + fprintf (stream, "\t.comm\t"); + assemble_name (stream, name); + fprintf (stream, ",%u,%u\n", size, align / BITS_PER_UNIT); } /* Predicates */ @@ -2964,7 +3063,7 @@ static const struct { }; /* Returns TRUE if OP is a subreg of a hard reg which we don't - support. */ + support. We also bail on MEMs with illegal addresses. */ bool m32c_illegal_subreg_p (rtx op) { @@ -2972,6 +3071,12 @@ m32c_illegal_subreg_p (rtx op) unsigned int i; int src_mode, dest_mode; + if (GET_CODE (op) == MEM + && ! m32c_legitimate_address_p (Pmode, XEXP (op, 0), false)) + { + return true; + } + if (GET_CODE (op) != SUBREG) return false; diff --git a/gcc/config/m32c/m32c.h b/gcc/config/m32c/m32c.h index 85dc2d1dce2..8f7b720c696 100644 --- a/gcc/config/m32c/m32c.h +++ b/gcc/config/m32c/m32c.h @@ -503,7 +503,6 @@ enum reg_class #define PUSH_ARGS 1 #define PUSH_ROUNDING(N) m32c_push_rounding (N) -#define RETURN_POPS_ARGS(D,T,S) 0 #define CALL_POPS_ARGS(C) 0 /* Passing Arguments in Registers */ @@ -644,6 +643,13 @@ typedef struct m32c_cumulative_args #define ASM_OUTPUT_REG_PUSH(S,R) m32c_output_reg_push (S, R) #define ASM_OUTPUT_REG_POP(S,R) m32c_output_reg_pop (S, R) +#define ASM_OUTPUT_ALIGNED_DECL_COMMON(STREAM, DECL, NAME, SIZE, ALIGNMENT) \ + m32c_output_aligned_common (STREAM, DECL, NAME, SIZE, ALIGNMENT, 1) + +#define ASM_OUTPUT_ALIGNED_DECL_LOCAL(STREAM, DECL, NAME, SIZE, ALIGNMENT) \ + m32c_output_aligned_common (STREAM, DECL, NAME, SIZE, ALIGNMENT, 0) + + /* Output of Dispatch Tables */ #define ASM_OUTPUT_ADDR_VEC_ELT(S,V) \ diff --git a/gcc/config/m32c/predicates.md b/gcc/config/m32c/predicates.md index 321debfd2ca..98a1c16e7c5 100644 --- a/gcc/config/m32c/predicates.md +++ b/gcc/config/m32c/predicates.md @@ -26,7 +26,7 @@ (define_predicate "m32c_any_operand" (ior (match_operand 0 "general_operand") - (match_operand 1 "memory_operand")) + (match_code "mem,const_int,const_double")) { return ! m32c_illegal_subreg_p (op); } @@ -36,7 +36,11 @@ (define_predicate "m32c_nonimmediate_operand" (ior (match_operand 0 "nonimmediate_operand") - (match_operand 1 "memory_operand"))) + (match_code "mem")) + { + return ! m32c_illegal_subreg_p (op); + } +) ; TRUE if the operand is a pseudo-register. (define_predicate "m32c_pseudo" @@ -135,7 +139,7 @@ ; Likewise, plus TRUE for memory references. (define_predicate "mra_operand" - (and (and (match_operand 0 "nonimmediate_operand" "") + (and (and (match_operand 0 "m32c_nonimmediate_operand" "") (not (match_operand 1 "cr_operand" ""))) (not (match_operand 2 "m32c_wide_subreg" "")))) diff --git a/gcc/config/m32r/m32r-protos.h b/gcc/config/m32r/m32r-protos.h index 2b7d09afeb5..56ad708cda5 100644 --- a/gcc/config/m32r/m32r-protos.h +++ b/gcc/config/m32r/m32r-protos.h @@ -43,8 +43,6 @@ extern int zero_and_one (rtx, rtx); extern char * emit_cond_move (rtx *, rtx); extern void m32r_output_block_move (rtx, rtx *); extern int m32r_expand_block_move (rtx *); -extern void m32r_print_operand (FILE *, rtx, int); -extern void m32r_print_operand_address (FILE *, rtx); extern int m32r_not_same_reg (rtx, rtx); extern int m32r_hard_regno_rename_ok (unsigned int, unsigned int); extern int m32r_legitimate_pic_operand_p (rtx); diff --git a/gcc/config/m32r/m32r.c b/gcc/config/m32r/m32r.c index 36265e6221d..a700ec9a581 100644 --- a/gcc/config/m32r/m32r.c +++ b/gcc/config/m32r/m32r.c @@ -44,7 +44,7 @@ #include "tm-constrs.h" /* Array of valid operand punctuation characters. */ -char m32r_punct_chars[256]; +static char m32r_punct_chars[256]; /* Selected code model. */ enum m32r_model m32r_model = M32R_MODEL_DEFAULT; @@ -67,6 +67,9 @@ static void block_move_call (rtx, rtx, rtx); static int m32r_is_insn (rtx); static rtx m32r_legitimize_address (rtx, rtx, enum machine_mode); static tree m32r_handle_model_attribute (tree *, tree, tree, int, bool *); +static void m32r_print_operand (FILE *, rtx, int); +static void m32r_print_operand_address (FILE *, rtx); +static bool m32r_print_operand_punct_valid_p (unsigned char code); static void m32r_output_function_prologue (FILE *, HOST_WIDE_INT); static void m32r_output_function_epilogue (FILE *, HOST_WIDE_INT); @@ -111,6 +114,13 @@ static const struct attribute_spec m32r_attribute_table[] = #undef TARGET_ASM_ALIGNED_SI_OP #define TARGET_ASM_ALIGNED_SI_OP "\t.word\t" +#undef TARGET_PRINT_OPERAND +#define TARGET_PRINT_OPERAND m32r_print_operand +#undef TARGET_PRINT_OPERAND_ADDRESS +#define TARGET_PRINT_OPERAND_ADDRESS m32r_print_operand_address +#undef TARGET_PRINT_OPERAND_PUNCT_VALID_P +#define TARGET_PRINT_OPERAND_PUNCT_VALID_P m32r_print_operand_punct_valid_p + #undef TARGET_ASM_FUNCTION_PROLOGUE #define TARGET_ASM_FUNCTION_PROLOGUE m32r_output_function_prologue #undef TARGET_ASM_FUNCTION_EPILOGUE @@ -216,7 +226,7 @@ m32r_init (void) { init_reg_tables (); - /* Initialize array for PRINT_OPERAND_PUNCT_VALID_P. */ + /* Initialize array for TARGET_PRINT_OPERAND_PUNCT_VALID_P. */ memset (m32r_punct_chars, 0, sizeof (m32r_punct_chars)); m32r_punct_chars['#'] = 1; m32r_punct_chars['@'] = 1; /* ??? no longer used */ @@ -1933,7 +1943,7 @@ m32r_file_start (void) CODE is a letter or dot (`z' in `%z0') or 0 if no letter was specified. For `%' followed by punctuation, CODE is the punctuation and X is null. */ -void +static void m32r_print_operand (FILE * file, rtx x, int code) { rtx addr; @@ -2160,7 +2170,7 @@ m32r_print_operand (FILE * file, rtx x, int code) /* Print a memory address as an operand to reference that memory location. */ -void +static void m32r_print_operand_address (FILE * file, rtx addr) { rtx base; @@ -2248,6 +2258,12 @@ m32r_print_operand_address (FILE * file, rtx addr) } } +static bool +m32r_print_operand_punct_valid_p (unsigned char code) +{ + return m32r_punct_chars[code]; +} + /* Return true if the operands are the constants 0 and 1. */ int diff --git a/gcc/config/m32r/m32r.h b/gcc/config/m32r/m32r.h index 7b6237a7c22..91d055bcb5b 100644 --- a/gcc/config/m32r/m32r.h +++ b/gcc/config/m32r/m32r.h @@ -823,14 +823,6 @@ extern enum reg_class m32r_regno_reg_class[FIRST_PSEUDO_REGISTER]; increase the stack frame size by this amount. */ #define ACCUMULATE_OUTGOING_ARGS 1 -/* Value is the number of bytes of arguments automatically - popped when returning from a subroutine call. - FUNDECL is the declaration node of the function (as a tree), - FUNTYPE is the data type of the function (as a tree), - or for a library call it is an identifier node for the subroutine name. - SIZE is the number of bytes of arguments passed on the stack. */ -#define RETURN_POPS_ARGS(DECL, FUNTYPE, SIZE) 0 - /* Define a data type for recording info about an argument list during the scan of that argument list. This data type should hold all necessary information about the function itself @@ -1274,24 +1266,6 @@ L2: .word STATIC SUBTARGET_ADDITIONAL_REGISTER_NAMES \ } -/* A C expression which evaluates to true if CODE is a valid - punctuation character for use in the `PRINT_OPERAND' macro. */ -extern char m32r_punct_chars[256]; -#define PRINT_OPERAND_PUNCT_VALID_P(CHAR) \ - m32r_punct_chars[(unsigned char) (CHAR)] - -/* Print operand X (an rtx) in assembler syntax to file FILE. - CODE is a letter or dot (`z' in `%z0') or 0 if no letter was specified. - For `%' followed by punctuation, CODE is the punctuation and X is null. */ -#define PRINT_OPERAND(FILE, X, CODE) \ - m32r_print_operand (FILE, X, CODE) - -/* A C compound statement to output to stdio stream STREAM the - assembler syntax for an instruction operand that is a memory - reference whose address is ADDR. ADDR is an RTL expression. */ -#define PRINT_OPERAND_ADDRESS(FILE, ADDR) \ - m32r_print_operand_address (FILE, ADDR) - /* If defined, C string expressions to be used for the `%R', `%L', `%U', and `%I' options of `asm_fprintf' (see `final.c'). These are useful when a single `md' file must support multiple assembler diff --git a/gcc/config/m68hc11/m68hc11-protos.h b/gcc/config/m68hc11/m68hc11-protos.h index 59154faf00b..d8ae8e078a9 100644 --- a/gcc/config/m68hc11/m68hc11-protos.h +++ b/gcc/config/m68hc11/m68hc11-protos.h @@ -1,5 +1,5 @@ /* Prototypes for exported functions defined in m68hc11.c - Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2009 + Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2009, 2010 Free Software Foundation, Inc. Contributed by Stephane Carrez (stcarrez@nerim.fr) @@ -57,9 +57,6 @@ extern void m68hc11_output_swap (rtx, rtx*); extern int next_insn_test_reg (rtx, rtx); -extern void print_operand (FILE*, rtx, int); -extern void print_operand_address (FILE*, rtx); - extern int m68hc11_reload_operands (rtx*); extern int dead_register_here (rtx, rtx); diff --git a/gcc/config/m68hc11/m68hc11.c b/gcc/config/m68hc11/m68hc11.c index 397413f61b7..ad63ee8153d 100644 --- a/gcc/config/m68hc11/m68hc11.c +++ b/gcc/config/m68hc11/m68hc11.c @@ -1,6 +1,6 @@ /* Subroutines for code generation on Motorola 68HC11 and 68HC12. Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, - 2009 Free Software Foundation, Inc. + 2009, 2010 Free Software Foundation, Inc. Contributed by Stephane Carrez (stcarrez@nerim.fr) This file is part of GCC. @@ -78,6 +78,8 @@ static tree m68hc11_handle_page0_attribute (tree *, tree, tree, int, bool *); void create_regs_rtx (void); static void asm_print_register (FILE *, int); +static void m68hc11_print_operand (FILE *, rtx, int); +static void m68hc11_print_operand_address (FILE *, rtx); static void m68hc11_output_function_epilogue (FILE *, HOST_WIDE_INT); static void m68hc11_asm_out_constructor (rtx, int); static void m68hc11_asm_out_destructor (rtx, int); @@ -238,6 +240,11 @@ static const struct attribute_spec m68hc11_attribute_table[] = #undef TARGET_ASM_ALIGNED_HI_OP #define TARGET_ASM_ALIGNED_HI_OP "\t.word\t" +#undef TARGET_PRINT_OPERAND +#define TARGET_PRINT_OPERAND m68hc11_print_operand +#undef TARGET_PRINT_OPERAND_ADDRESS +#define TARGET_PRINT_OPERAND_ADDRESS m68hc11_print_operand_address + #undef TARGET_ASM_FUNCTION_EPILOGUE #define TARGET_ASM_FUNCTION_EPILOGUE m68hc11_output_function_epilogue @@ -2123,8 +2130,8 @@ asm_print_register (FILE *file, int regno) 'T' generate the low-part temporary scratch register. The operand is ignored. */ -void -print_operand (FILE *file, rtx op, int letter) +static void +m68hc11_print_operand (FILE *file, rtx op, int letter) { if (letter == 't') { @@ -2316,8 +2323,8 @@ must_parenthesize (rtx op) assembler syntax for an instruction operand that is a memory reference whose address is ADDR. ADDR is an RTL expression. */ -void -print_operand_address (FILE *file, rtx addr) +static void +m68hc11_print_operand_address (FILE *file, rtx addr) { rtx base; rtx offset; diff --git a/gcc/config/m68hc11/m68hc11.h b/gcc/config/m68hc11/m68hc11.h index b9626e1ecca..2ea80a76396 100644 --- a/gcc/config/m68hc11/m68hc11.h +++ b/gcc/config/m68hc11/m68hc11.h @@ -1,6 +1,6 @@ /* Definitions of target machine for GNU compiler. Motorola 68HC11 and 68HC12. - Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009 + Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. Contributed by Stephane Carrez (stcarrez@nerim.fr) @@ -896,15 +896,6 @@ extern enum reg_class m68hc11_tmp_regs_class; stack pointer really advances by. No rounding or alignment needed for MC6811. */ #define PUSH_ROUNDING(BYTES) (BYTES) - -/* Value is 1 if returning from a function call automatically pops the - arguments described by the number-of-args field in the call. FUNTYPE is - the data type of the function (as a tree), or for a library call it is - an identifier node for the subroutine name. - - The standard MC6811 call, with arg count word, includes popping the - args as part of the call template. */ -#define RETURN_POPS_ARGS(FUNDECL,FUNTYPE,SIZE) 0 /* Passing Arguments in Registers. */ @@ -1351,17 +1342,6 @@ do { \ "*_.frame", "*_.tmp", "*_.z", "*_.xy", "*fake clobber", \ SOFT_REG_NAMES, "*sframe", "*ap"} -/* Print an instruction operand X on file FILE. CODE is the code from the - %-spec for printing this operand. If `%z3' was used to print operand - 3, then CODE is 'z'. */ - -#define PRINT_OPERAND(FILE, X, CODE) \ - print_operand (FILE, X, CODE) - -/* Print a memory operand whose address is X, on file FILE. */ -#define PRINT_OPERAND_ADDRESS(FILE, ADDR) \ - print_operand_address (FILE, ADDR) - /* This is how to output an insn to push/pop a register on the stack. It need not be very fast code. diff --git a/gcc/config/m68k/m68k.c b/gcc/config/m68k/m68k.c index de6442aa6be..253d621d074 100644 --- a/gcc/config/m68k/m68k.c +++ b/gcc/config/m68k/m68k.c @@ -153,6 +153,7 @@ static bool m68k_return_in_memory (const_tree, const_tree); #endif static void m68k_output_dwarf_dtprel (FILE *, int, rtx) ATTRIBUTE_UNUSED; static void m68k_trampoline_init (rtx, tree, rtx); +static int m68k_return_pops_args (tree, tree, int); static rtx m68k_delegitimize_address (rtx); @@ -271,6 +272,9 @@ const char *m68k_library_id_string = "_current_shared_library_a5_offset_"; #undef TARGET_TRAMPOLINE_INIT #define TARGET_TRAMPOLINE_INIT m68k_trampoline_init +#undef TARGET_RETURN_POPS_ARGS +#define TARGET_RETURN_POPS_ARGS m68k_return_pops_args + #undef TARGET_DELEGITIMIZE_ADDRESS #define TARGET_DELEGITIMIZE_ADDRESS m68k_delegitimize_address @@ -4597,7 +4601,8 @@ m68k_output_addr_const_extra (FILE *file, rtx x) case UNSPEC_RELOC16: case UNSPEC_RELOC32: output_addr_const (file, XVECEXP (x, 0, 0)); - fputs (m68k_get_reloc_decoration (INTVAL (XVECEXP (x, 0, 1))), file); + fputs (m68k_get_reloc_decoration + ((enum m68k_reloc) INTVAL (XVECEXP (x, 0, 1))), file); return true; default: @@ -4624,16 +4629,17 @@ m68k_output_dwarf_dtprel (FILE *file, int size, rtx x) and turn them back into a direct symbol reference. */ static rtx -m68k_delegitimize_address (rtx x) +m68k_delegitimize_address (rtx orig_x) { - rtx orig_x = delegitimize_mem_from_attrs (x); - rtx y; + rtx x, y; rtx addend = NULL_RTX; rtx result; - x = orig_x; - if (MEM_P (x)) - x = XEXP (x, 0); + orig_x = delegitimize_mem_from_attrs (orig_x); + if (! MEM_P (orig_x)) + return orig_x; + + x = XEXP (orig_x, 0); if (GET_CODE (x) == PLUS && GET_CODE (XEXP (x, 1)) == CONST @@ -5608,7 +5614,6 @@ m68k_sched_attr_opx_type (rtx insn, int address_p) default: gcc_unreachable (); - return 0; } } @@ -5652,7 +5657,6 @@ m68k_sched_attr_opy_type (rtx insn, int address_p) default: gcc_unreachable (); - return 0; } } @@ -5758,7 +5762,6 @@ m68k_sched_attr_size (rtx insn) default: gcc_unreachable (); - return 0; } } @@ -5790,7 +5793,6 @@ sched_get_opxy_mem_type (rtx insn, bool opx_p) default: gcc_unreachable (); - return 0; } } else @@ -5816,7 +5818,6 @@ sched_get_opxy_mem_type (rtx insn, bool opx_p) default: gcc_unreachable (); - return 0; } } } @@ -5849,7 +5850,6 @@ m68k_sched_attr_op_mem (rtx insn) default: gcc_unreachable (); - return 0; } } @@ -5868,7 +5868,6 @@ m68k_sched_attr_op_mem (rtx insn) default: gcc_unreachable (); - return 0; } } @@ -6150,7 +6149,7 @@ m68k_sched_first_cycle_multipass_dfa_lookahead (void) return m68k_sched_issue_rate () - 1; } -/* Implementation of targetm.sched.md_init_global () hook. +/* Implementation of targetm.sched.init_global () hook. It is invoked once per scheduling pass and is used here to initialize scheduler constants. */ static void @@ -6258,7 +6257,7 @@ m68k_sched_md_finish_global (FILE *dump ATTRIBUTE_UNUSED, sched_branch_type = NULL; } -/* Implementation of targetm.sched.md_init () hook. +/* Implementation of targetm.sched.init () hook. It is invoked each time scheduler starts on the new block (basic block or extended basic block). */ static void @@ -6525,4 +6524,25 @@ m68k_trampoline_init (rtx m_tramp, tree fndecl, rtx chain_value) FINALIZE_TRAMPOLINE (XEXP (m_tramp, 0)); } +/* On the 68000, the RTS insn cannot pop anything. + On the 68010, the RTD insn may be used to pop them if the number + of args is fixed, but if the number is variable then the caller + must pop them all. RTD can't be used for library calls now + because the library is compiled with the Unix compiler. + Use of RTD is a selectable option, since it is incompatible with + standard Unix calling sequences. If the option is not selected, + the caller must always pop the args. */ + +static int +m68k_return_pops_args (tree fundecl, tree funtype, int size) +{ + return ((TARGET_RTD + && (!fundecl + || TREE_CODE (fundecl) != IDENTIFIER_NODE) + && (TYPE_ARG_TYPES (funtype) == 0 + || (TREE_VALUE (tree_last (TYPE_ARG_TYPES (funtype))) + == void_type_node))) + ? size : 0); +} + #include "gt-m68k.h" diff --git a/gcc/config/m68k/m68k.h b/gcc/config/m68k/m68k.h index 5787e8aa1fd..ac478619f73 100644 --- a/gcc/config/m68k/m68k.h +++ b/gcc/config/m68k/m68k.h @@ -534,21 +534,6 @@ extern enum reg_class regno_reg_class[]; #define FIRST_PARM_OFFSET(FNDECL) 8 -/* On the 68000, the RTS insn cannot pop anything. - On the 68010, the RTD insn may be used to pop them if the number - of args is fixed, but if the number is variable then the caller - must pop them all. RTD can't be used for library calls now - because the library is compiled with the Unix compiler. - Use of RTD is a selectable option, since it is incompatible with - standard Unix calling sequences. If the option is not selected, - the caller must always pop the args. */ -#define RETURN_POPS_ARGS(FUNDECL,FUNTYPE,SIZE) \ - ((TARGET_RTD && (!(FUNDECL) || TREE_CODE (FUNDECL) != IDENTIFIER_NODE) \ - && (TYPE_ARG_TYPES (FUNTYPE) == 0 \ - || (TREE_VALUE (tree_last (TYPE_ARG_TYPES (FUNTYPE))) \ - == void_type_node))) \ - ? (SIZE) : 0) - /* On the m68k the return value defaults to D0. */ #define FUNCTION_VALUE(VALTYPE, FUNC) \ gen_rtx_REG (TYPE_MODE (VALTYPE), D0_REG) diff --git a/gcc/config/mcore/mcore-protos.h b/gcc/config/mcore/mcore-protos.h index 331cf7191d7..9be73236aa2 100644 --- a/gcc/config/mcore/mcore-protos.h +++ b/gcc/config/mcore/mcore-protos.h @@ -54,8 +54,6 @@ extern int mcore_is_dead (rtx, rtx); extern int mcore_expand_insv (rtx *); extern bool mcore_expand_block_move (rtx *); extern const char * mcore_output_andn (rtx, rtx *); -extern void mcore_print_operand_address (FILE *, rtx); -extern void mcore_print_operand (FILE *, rtx, int); extern bool mcore_gen_compare (RTX_CODE, rtx, rtx); extern int mcore_symbolic_address_p (rtx); extern bool mcore_r15_operand_p (rtx); diff --git a/gcc/config/mcore/mcore.c b/gcc/config/mcore/mcore.c index 574b5f6d5cd..6bb4e6476fb 100644 --- a/gcc/config/mcore/mcore.c +++ b/gcc/config/mcore/mcore.c @@ -131,6 +131,9 @@ static tree mcore_handle_naked_attribute (tree *, tree, tree, int, bool * static void mcore_asm_named_section (const char *, unsigned int, tree); #endif +static void mcore_print_operand (FILE *, rtx, int); +static void mcore_print_operand_address (FILE *, rtx); +static bool mcore_print_operand_punct_valid_p (unsigned char code); static void mcore_unique_section (tree, int); static void mcore_encode_section_info (tree, rtx, int); static const char *mcore_strip_name_encoding (const char *); @@ -173,6 +176,13 @@ static const struct attribute_spec mcore_attribute_table[] = #define TARGET_ASM_UNALIGNED_SI_OP "\t.long\t" #endif +#undef TARGET_PRINT_OPERAND +#define TARGET_PRINT_OPERAND mcore_print_operand +#undef TARGET_PRINT_OPERAND_ADDRESS +#define TARGET_PRINT_OPERAND_ADDRESS mcore_print_operand_address +#undef TARGET_PRINT_OPERAND_PUNCT_VALID_P +#define TARGET_PRINT_OPERAND_PUNCT_VALID_P mcore_print_operand_punct_valid_p + #undef TARGET_ATTRIBUTE_TABLE #define TARGET_ATTRIBUTE_TABLE mcore_attribute_table #undef TARGET_ASM_UNIQUE_SECTION @@ -287,7 +297,7 @@ calc_live_regs (int * count) /* Print the operand address in x to the stream. */ -void +static void mcore_print_operand_address (FILE * stream, rtx x) { switch (GET_CODE (x)) @@ -329,6 +339,13 @@ mcore_print_operand_address (FILE * stream, rtx x) } } +static bool +mcore_print_operand_punct_valid_p (unsigned char code) +{ + return (code == '.' || code == '#' || code == '*' || code == '^' + || code == '!'); +} + /* Print operand x (an rtx) in assembler syntax to file stream according to modifier code. @@ -341,7 +358,7 @@ mcore_print_operand_address (FILE * stream, rtx x) 'U' print register for ldm/stm instruction 'X' print byte number for xtrbN instruction. */ -void +static void mcore_print_operand (FILE * stream, rtx x, int code) { switch (code) diff --git a/gcc/config/mcore/mcore.h b/gcc/config/mcore/mcore.h index 8167400633f..7421d5dbb85 100644 --- a/gcc/config/mcore/mcore.h +++ b/gcc/config/mcore/mcore.h @@ -540,16 +540,6 @@ extern const enum reg_class reg_class_from_letter[]; /* Offset of first parameter from the argument pointer register value. */ #define FIRST_PARM_OFFSET(FNDECL) 0 -/* Value is the number of byte of arguments automatically - popped when returning from a subroutine call. - FUNTYPE is the data type of the function (as a tree), - or for a library call it is an identifier node for the subroutine name. - SIZE is the number of bytes of arguments passed on the stack. - - On the MCore, the callee does not pop any of its arguments that were passed - on the stack. */ -#define RETURN_POPS_ARGS(FUNDECL,FUNTYPE,SIZE) 0 - /* Define how to find the value returned by a function. VALTYPE is the data type of the value (as a tree). If the precise function being called is known, FUNC is its FUNCTION_DECL; @@ -960,15 +950,4 @@ extern long mcore_current_compilation_timestamp; } \ while (0) -/* Print operand X (an rtx) in assembler syntax to file FILE. - CODE is a letter or dot (`z' in `%z0') or 0 if no letter was specified. - For `%' followed by punctuation, CODE is the punctuation and X is null. */ -#define PRINT_OPERAND(STREAM, X, CODE) mcore_print_operand (STREAM, X, CODE) - -/* Print a memory address as an operand to reference that memory location. */ -#define PRINT_OPERAND_ADDRESS(STREAM,X) mcore_print_operand_address (STREAM, X) - -#define PRINT_OPERAND_PUNCT_VALID_P(CHAR) \ - ((CHAR)=='.' || (CHAR) == '#' || (CHAR) == '*' || (CHAR) == '^' || (CHAR) == '!') - #endif /* ! GCC_MCORE_H */ diff --git a/gcc/config/mep/mep-pragma.c b/gcc/config/mep/mep-pragma.c index 3f9fc5a7071..1d79a3bd19f 100644 --- a/gcc/config/mep/mep-pragma.c +++ b/gcc/config/mep/mep-pragma.c @@ -26,7 +26,7 @@ along with GCC; see the file COPYING3. If not see #include "tree.h" #include "rtl.h" #include "toplev.h" -#include "c-pragma.h" +#include "c-family/c-pragma.h" #include "cpplib.h" #include "hard-reg-set.h" #include "output.h" diff --git a/gcc/config/mep/mep.c b/gcc/config/mep/mep.c index a4b167da4b7..9e23e45f8bb 100644 --- a/gcc/config/mep/mep.c +++ b/gcc/config/mep/mep.c @@ -2369,11 +2369,7 @@ mep_register_move_cost (enum machine_mode mode, enum reg_class from, enum reg_cl static struct machine_function * mep_init_machine_status (void) { - struct machine_function *f; - - f = (struct machine_function *) ggc_alloc_cleared (sizeof (struct machine_function)); - - return f; + return ggc_alloc_cleared_machine_function (); } static rtx @@ -4234,7 +4230,7 @@ mep_note_pragma_flag (const char *funcname, int flag) if (!*slot) { - *slot = GGC_NEW (pragma_entry); + *slot = ggc_alloc_pragma_entry (); (*slot)->flag = 0; (*slot)->used = 0; (*slot)->funcname = ggc_strdup (funcname); @@ -6333,7 +6329,7 @@ mep_expand_builtin (tree exp, rtx target ATTRIBUTE_UNUSED, unsigned int n_args; tree fnname; const struct cgen_insn *cgen_insn; - const struct insn_data *idata; + const struct insn_data_d *idata; unsigned int first_arg = 0; tree return_type = void_type_node; unsigned int builtin_n_args; @@ -7213,7 +7209,7 @@ bool mep_emit_intrinsic (int intrinsic, const rtx *operands) { const struct cgen_insn *cgen_insn; - const struct insn_data *idata; + const struct insn_data_d *idata; rtx newop[10]; int i; diff --git a/gcc/config/mep/mep.h b/gcc/config/mep/mep.h index 9d286e33b94..d3af0734951 100644 --- a/gcc/config/mep/mep.h +++ b/gcc/config/mep/mep.h @@ -503,8 +503,6 @@ extern unsigned int mep_selected_isa; #define ACCUMULATE_OUTGOING_ARGS 1 -#define RETURN_POPS_ARGS(FUNDECL, FUNTYPE, STACK_SIZE) 0 - /* The ABI is thus: Arguments are in $1, $2, $3, $4, stack. Arguments diff --git a/gcc/config/mep/t-mep b/gcc/config/mep/t-mep index 5fd7f944116..9608d6c46d3 100644 --- a/gcc/config/mep/t-mep +++ b/gcc/config/mep/t-mep @@ -33,7 +33,7 @@ CRTSTUFF_CFLAGS = -O0 $(GCC_CFLAGS) $(INCLUDES) $(MULTILIB_CFLAGS) -g0 \ TCFLAGS = -mlibrary mep-pragma.o: $(srcdir)/config/mep/mep-pragma.c $(CONFIG_H) $(SYSTEM_H) \ - coretypes.h $(TM_H) $(TREE_H) $(RTL_H) toplev.h c-pragma.h \ + coretypes.h $(TM_H) $(TREE_H) $(RTL_H) toplev.h $(C_PRAGMA_H) \ $(CPPLIB_H) hard-reg-set.h output.h $(srcdir)/config/mep/mep-protos.h \ function.h insn-config.h reload.h $(TARGET_H) $(CC) -c $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) $< diff --git a/gcc/config/mips/crtfastmath.c b/gcc/config/mips/crtfastmath.c new file mode 100644 index 00000000000..a9586b0a797 --- /dev/null +++ b/gcc/config/mips/crtfastmath.c @@ -0,0 +1,53 @@ +/* Copyright (C) 2010 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 3, 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. + + Under Section 7 of GPL version 3, you are granted additional + permissions described in the GCC Runtime Library Exception, version + 3.1, as published by the Free Software Foundation. + + You should have received a copy of the GNU General Public License + and a copy of the GCC Runtime Library Exception along with this + program; see the files COPYING3 and COPYING.RUNTIME respectively. + If not, see . */ + +#ifdef __mips_hard_float + +/* Flush denormalized numbers to zero. */ +#define _FPU_FLUSH_TZ 0x1000000 + +/* Rounding control. */ +#define _FPU_RC_NEAREST 0x0 /* RECOMMENDED */ +#define _FPU_RC_ZERO 0x1 +#define _FPU_RC_UP 0x2 +#define _FPU_RC_DOWN 0x3 + +/* Enable interrupts for IEEE exceptions. */ +#define _FPU_IEEE 0x00000F80 + +/* Macros for accessing the hardware control word. */ +#define _FPU_GETCW(cw) __asm__ ("cfc1 %0,$31" : "=r" (cw)) +#define _FPU_SETCW(cw) __asm__ ("ctc1 %0,$31" : : "r" (cw)) + +static void __attribute__((constructor)) +set_fast_math (void) +{ + unsigned int fcr; + + /* Flush to zero, round to nearest, IEEE exceptions disabled. */ + fcr = _FPU_FLUSH_TZ | _FPU_RC_NEAREST; + + _FPU_SETCW(fcr); +} + +#endif /* __mips_hard_float */ diff --git a/gcc/config/mips/linux.h b/gcc/config/mips/linux.h index 0512ef7d14f..8087e8ffd12 100644 --- a/gcc/config/mips/linux.h +++ b/gcc/config/mips/linux.h @@ -147,3 +147,9 @@ extern const char *host_detect_local_cpu (int argc, const char **argv); #define DRIVER_SELF_SPECS \ BASE_DRIVER_SELF_SPECS, \ LINUX_DRIVER_SELF_SPECS + +/* Similar to standard Linux, but adding -ffast-math support. */ +#undef ENDFILE_SPEC +#define ENDFILE_SPEC \ + "%{ffast-math|funsafe-math-optimizations:crtfastmath.o%s} \ + %{shared|pie:crtendS.o%s;:crtend.o%s} crtn.o%s" diff --git a/gcc/config/mips/linux64.h b/gcc/config/mips/linux64.h index 2f24dfa1416..a68e8b4da9b 100644 --- a/gcc/config/mips/linux64.h +++ b/gcc/config/mips/linux64.h @@ -39,8 +39,10 @@ along with GCC; see the file COPYING3. If not see #define GLIBC_DYNAMIC_LINKER64 "/lib64/ld.so.1" #define GLIBC_DYNAMIC_LINKERN32 "/lib32/ld.so.1" #define UCLIBC_DYNAMIC_LINKERN32 "/lib32/ld-uClibc.so.0" +#define BIONIC_DYNAMIC_LINKERN32 "/system/bin/linker32" #define LINUX_DYNAMIC_LINKERN32 \ - CHOOSE_DYNAMIC_LINKER (GLIBC_DYNAMIC_LINKERN32, UCLIBC_DYNAMIC_LINKERN32) + CHOOSE_DYNAMIC_LINKER (GLIBC_DYNAMIC_LINKERN32, UCLIBC_DYNAMIC_LINKERN32, \ + BIONIC_DYNAMIC_LINKERN32) #undef LINK_SPEC #define LINK_SPEC "\ diff --git a/gcc/config/mips/loongson.md b/gcc/config/mips/loongson.md index f952cf672ee..10703bb7b08 100644 --- a/gcc/config/mips/loongson.md +++ b/gcc/config/mips/loongson.md @@ -18,6 +18,31 @@ ;; along with GCC; see the file COPYING3. If not see ;; . +(define_c_enum "unspec" [ + UNSPEC_LOONGSON_PAVG + UNSPEC_LOONGSON_PCMPEQ + UNSPEC_LOONGSON_PCMPGT + UNSPEC_LOONGSON_PEXTR + UNSPEC_LOONGSON_PINSR_0 + UNSPEC_LOONGSON_PINSR_1 + UNSPEC_LOONGSON_PINSR_2 + UNSPEC_LOONGSON_PINSR_3 + UNSPEC_LOONGSON_PMADD + UNSPEC_LOONGSON_PMOVMSK + UNSPEC_LOONGSON_PMULHU + UNSPEC_LOONGSON_PMULH + UNSPEC_LOONGSON_PMULL + UNSPEC_LOONGSON_PMULU + UNSPEC_LOONGSON_PASUBUB + UNSPEC_LOONGSON_BIADD + UNSPEC_LOONGSON_PSADBH + UNSPEC_LOONGSON_PSHUFH + UNSPEC_LOONGSON_PUNPCKH + UNSPEC_LOONGSON_PUNPCKL + UNSPEC_LOONGSON_PADDD + UNSPEC_LOONGSON_PSUBD +]) + ;; Mode iterators and attributes. ;; 64-bit vectors of bytes. diff --git a/gcc/config/mips/loongson2ef.md b/gcc/config/mips/loongson2ef.md index df3de33f809..1238f20ecae 100644 --- a/gcc/config/mips/loongson2ef.md +++ b/gcc/config/mips/loongson2ef.md @@ -17,6 +17,13 @@ ;; along with GCC; see the file COPYING3. If not see ;; . +(define_c_enum "unspec" [ + UNSPEC_LOONGSON_ALU1_TURN_ENABLED_INSN + UNSPEC_LOONGSON_ALU2_TURN_ENABLED_INSN + UNSPEC_LOONGSON_FALU1_TURN_ENABLED_INSN + UNSPEC_LOONGSON_FALU2_TURN_ENABLED_INSN +]) + ;; Automaton for integer instructions. (define_automaton "ls2_alu") diff --git a/gcc/config/mips/mips-dsp.md b/gcc/config/mips/mips-dsp.md index 9e02f7214f9..faa22bdd364 100644 --- a/gcc/config/mips/mips-dsp.md +++ b/gcc/config/mips/mips-dsp.md @@ -16,6 +16,78 @@ ;; along with GCC; see the file COPYING3. If not see ;; . +;; MIPS DSP ASE Revision 0.98 3/24/2005 +(define_c_enum "unspec" [ + UNSPEC_ADDQ + UNSPEC_ADDQ_S + UNSPEC_SUBQ + UNSPEC_SUBQ_S + UNSPEC_ADDSC + UNSPEC_ADDWC + UNSPEC_MODSUB + UNSPEC_RADDU_W_QB + UNSPEC_ABSQ_S + UNSPEC_PRECRQ_QB_PH + UNSPEC_PRECRQ_PH_W + UNSPEC_PRECRQ_RS_PH_W + UNSPEC_PRECRQU_S_QB_PH + UNSPEC_PRECEQ_W_PHL + UNSPEC_PRECEQ_W_PHR + UNSPEC_PRECEQU_PH_QBL + UNSPEC_PRECEQU_PH_QBR + UNSPEC_PRECEQU_PH_QBLA + UNSPEC_PRECEQU_PH_QBRA + UNSPEC_PRECEU_PH_QBL + UNSPEC_PRECEU_PH_QBR + UNSPEC_PRECEU_PH_QBLA + UNSPEC_PRECEU_PH_QBRA + UNSPEC_SHLL + UNSPEC_SHLL_S + UNSPEC_SHRL_QB + UNSPEC_SHRA_PH + UNSPEC_SHRA_R + UNSPEC_MULEU_S_PH_QBL + UNSPEC_MULEU_S_PH_QBR + UNSPEC_MULQ_RS_PH + UNSPEC_MULEQ_S_W_PHL + UNSPEC_MULEQ_S_W_PHR + UNSPEC_DPAU_H_QBL + UNSPEC_DPAU_H_QBR + UNSPEC_DPSU_H_QBL + UNSPEC_DPSU_H_QBR + UNSPEC_DPAQ_S_W_PH + UNSPEC_DPSQ_S_W_PH + UNSPEC_MULSAQ_S_W_PH + UNSPEC_DPAQ_SA_L_W + UNSPEC_DPSQ_SA_L_W + UNSPEC_MAQ_S_W_PHL + UNSPEC_MAQ_S_W_PHR + UNSPEC_MAQ_SA_W_PHL + UNSPEC_MAQ_SA_W_PHR + UNSPEC_BITREV + UNSPEC_INSV + UNSPEC_REPL_QB + UNSPEC_REPL_PH + UNSPEC_CMP_EQ + UNSPEC_CMP_LT + UNSPEC_CMP_LE + UNSPEC_CMPGU_EQ_QB + UNSPEC_CMPGU_LT_QB + UNSPEC_CMPGU_LE_QB + UNSPEC_PICK + UNSPEC_PACKRL_PH + UNSPEC_EXTR_W + UNSPEC_EXTR_R_W + UNSPEC_EXTR_RS_W + UNSPEC_EXTR_S_H + UNSPEC_EXTP + UNSPEC_EXTPDP + UNSPEC_SHILO + UNSPEC_MTHLIP + UNSPEC_WRDSP + UNSPEC_RDDSP +]) + (define_constants [(CCDSP_PO_REGNUM 182) (CCDSP_SC_REGNUM 183) diff --git a/gcc/config/mips/mips-dspr2.md b/gcc/config/mips/mips-dspr2.md index 52495d43daa..9c3cbd58435 100644 --- a/gcc/config/mips/mips-dspr2.md +++ b/gcc/config/mips/mips-dspr2.md @@ -18,6 +18,58 @@ ;; ; MIPS DSP ASE REV 2 Revision 0.02 11/24/2006 +(define_c_enum "unspec" [ + UNSPEC_ABSQ_S_QB + UNSPEC_ADDU_PH + UNSPEC_ADDU_S_PH + UNSPEC_ADDUH_QB + UNSPEC_ADDUH_R_QB + UNSPEC_APPEND + UNSPEC_BALIGN + UNSPEC_CMPGDU_EQ_QB + UNSPEC_CMPGDU_LT_QB + UNSPEC_CMPGDU_LE_QB + UNSPEC_DPA_W_PH + UNSPEC_DPS_W_PH + UNSPEC_MADD + UNSPEC_MADDU + UNSPEC_MSUB + UNSPEC_MSUBU + UNSPEC_MUL_PH + UNSPEC_MUL_S_PH + UNSPEC_MULQ_RS_W + UNSPEC_MULQ_S_PH + UNSPEC_MULQ_S_W + UNSPEC_MULSA_W_PH + UNSPEC_MULT + UNSPEC_MULTU + UNSPEC_PRECR_QB_PH + UNSPEC_PRECR_SRA_PH_W + UNSPEC_PRECR_SRA_R_PH_W + UNSPEC_PREPEND + UNSPEC_SHRA_QB + UNSPEC_SHRA_R_QB + UNSPEC_SHRL_PH + UNSPEC_SUBU_PH + UNSPEC_SUBU_S_PH + UNSPEC_SUBUH_QB + UNSPEC_SUBUH_R_QB + UNSPEC_ADDQH_PH + UNSPEC_ADDQH_R_PH + UNSPEC_ADDQH_W + UNSPEC_ADDQH_R_W + UNSPEC_SUBQH_PH + UNSPEC_SUBQH_R_PH + UNSPEC_SUBQH_W + UNSPEC_SUBQH_R_W + UNSPEC_DPAX_W_PH + UNSPEC_DPSX_W_PH + UNSPEC_DPAQX_S_W_PH + UNSPEC_DPAQX_SA_W_PH + UNSPEC_DPSQX_S_W_PH + UNSPEC_DPSQX_SA_W_PH +]) + (define_insn "mips_absq_s_qb" [(parallel [(set (match_operand:V4QI 0 "register_operand" "=d") diff --git a/gcc/config/mips/mips-protos.h b/gcc/config/mips/mips-protos.h index e4fbb32b959..70920fd64a0 100644 --- a/gcc/config/mips/mips-protos.h +++ b/gcc/config/mips/mips-protos.h @@ -260,8 +260,6 @@ extern HOST_WIDE_INT mips_debugger_offset (rtx, HOST_WIDE_INT); extern void mips_push_asm_switch (struct mips_asm_switch *); extern void mips_pop_asm_switch (struct mips_asm_switch *); -extern void mips_print_operand (FILE *, rtx, int); -extern void mips_print_operand_address (FILE *, rtx); extern void mips_output_external (FILE *, tree, const char *); extern void mips_output_filename (FILE *, const char *); extern void mips_output_ascii (FILE *, const char *, size_t); diff --git a/gcc/config/mips/mips-ps-3d.md b/gcc/config/mips/mips-ps-3d.md index c13c7a69b28..780fb03c706 100644 --- a/gcc/config/mips/mips-ps-3d.md +++ b/gcc/config/mips/mips-ps-3d.md @@ -17,6 +17,30 @@ ;; along with GCC; see the file COPYING3. If not see ;; . +(define_c_enum "unspec" [ + UNSPEC_MOVE_TF_PS + UNSPEC_C + + ;; MIPS64/MIPS32R2 alnv.ps + UNSPEC_ALNV_PS + + ;; MIPS-3D instructions + UNSPEC_CABS + + UNSPEC_ADDR_PS + UNSPEC_CVT_PW_PS + UNSPEC_CVT_PS_PW + UNSPEC_MULR_PS + UNSPEC_ABS_PS + + UNSPEC_RSQRT1 + UNSPEC_RSQRT2 + UNSPEC_RECIP1 + UNSPEC_RECIP2 + UNSPEC_SINGLE_CC + UNSPEC_SCC +]) + (define_insn "*movcc_v2sf_" [(set (match_operand:V2SF 0 "register_operand" "=f,f") (if_then_else:V2SF diff --git a/gcc/config/mips/mips.c b/gcc/config/mips/mips.c index a00b10680f8..ccdfbbc3fd1 100644 --- a/gcc/config/mips/mips.c +++ b/gcc/config/mips/mips.c @@ -504,11 +504,11 @@ struct mips_asm_switch mips_noat = { "at", 0 }; static bool mips_branch_likely; /* The current instruction-set architecture. */ -enum processor_type mips_arch; +enum processor mips_arch; const struct mips_cpu_info *mips_arch_info; /* The processor that we should tune the code for. */ -enum processor_type mips_tune; +enum processor mips_tune; const struct mips_cpu_info *mips_tune_info; /* The ISA level associated with mips_arch. */ @@ -548,7 +548,7 @@ bool mips_hard_regno_mode_ok[(int) MAX_MACHINE_MODE][FIRST_PSEUDO_REGISTER]; /* Index C is true if character C is a valid PRINT_OPERAND punctation character. */ -bool mips_print_operand_punct[256]; +static bool mips_print_operand_punct[256]; static GTY (()) int mips_output_filename_first_time = 1; @@ -797,7 +797,8 @@ static const struct mips_rtx_cost_data mips_rtx_cost_optimize_size = { }; /* Costs to use when optimizing for speed, indexed by processor. */ -static const struct mips_rtx_cost_data mips_rtx_cost_data[PROCESSOR_MAX] = { +static const struct mips_rtx_cost_data + mips_rtx_cost_data[NUM_PROCESSOR_VALUES] = { { /* R3000 */ COSTS_N_INSNS (2), /* fp_add */ COSTS_N_INSNS (4), /* fp_mult_sf */ @@ -1217,7 +1218,7 @@ mflip_mips16_use_mips16_p (tree decl) if (!entry) { mips16_flipper = !mips16_flipper; - entry = GGC_NEW (struct mflip_mips16_entry); + entry = ggc_alloc_mflip_mips16_entry (); entry->name = name; entry->mips16_p = mips16_flipper ? !mips_base_mips16 : mips_base_mips16; *slot = entry; @@ -5851,7 +5852,7 @@ mips16_local_alias (rtx func) SYMBOL_REF_FLAGS (local) = SYMBOL_REF_FLAGS (func) | SYMBOL_FLAG_LOCAL; /* Create a new structure to represent the mapping. */ - alias = GGC_NEW (struct mips16_local_alias); + alias = ggc_alloc_mips16_local_alias (); alias->func = func; alias->local = local; *slot = alias; @@ -7446,7 +7447,15 @@ mips_print_float_branch_condition (FILE *file, enum rtx_code code, int letter) } } -/* Implement the PRINT_OPERAND macro. The MIPS-specific operand codes are: +/* Implement TARGET_PRINT_OPERAND_PUNCT_VALID_P. */ + +static bool +mips_print_operand_punct_valid_p (unsigned char code) +{ + return mips_print_operand_punct[code]; +} + +/* Implement TARGET_PRINT_OPERAND. The MIPS-specific operand codes are: 'X' Print CONST_INT OP in hexadecimal format. 'x' Print the low 16 bits of CONST_INT OP in hexadecimal format. @@ -7470,12 +7479,12 @@ mips_print_float_branch_condition (FILE *file, enum rtx_code code, int letter) 'M' Print high-order register in a double-word register operand. 'z' Print $0 if OP is zero, otherwise print OP normally. */ -void +static void mips_print_operand (FILE *file, rtx op, int letter) { enum rtx_code code; - if (PRINT_OPERAND_PUNCT_VALID_P (letter)) + if (mips_print_operand_punct_valid_p (letter)) { mips_print_operand_punctuation (file, letter); return; @@ -7617,9 +7626,9 @@ mips_print_operand (FILE *file, rtx op, int letter) } } -/* Output address operand X to FILE. */ +/* Implement TARGET_PRINT_OPERAND_ADDRESS. */ -void +static void mips_print_operand_address (FILE *file, rtx x) { struct mips_address_info addr; @@ -10920,14 +10929,14 @@ mips_register_move_cost (enum machine_mode mode, /* Implement TARGET_IRA_COVER_CLASSES. */ -static const enum reg_class * +static const reg_class_t * mips_ira_cover_classes (void) { - static const enum reg_class acc_classes[] = { + static const reg_class_t acc_classes[] = { GR_AND_ACC_REGS, FP_REGS, COP0_REGS, COP2_REGS, COP3_REGS, ST_REGS, LIM_REG_CLASSES }; - static const enum reg_class no_acc_classes[] = { + static const reg_class_t no_acc_classes[] = { GR_REGS, FP_REGS, COP0_REGS, COP2_REGS, COP3_REGS, ST_REGS, LIM_REG_CLASSES }; @@ -15213,8 +15222,7 @@ mips_set_current_function (tree fndecl) static struct machine_function * mips_init_machine_status (void) { - return ((struct machine_function *) - ggc_alloc_cleared (sizeof (struct machine_function))); + return ggc_alloc_cleared_machine_function (); } /* Return the processor associated with the given ISA level, or null @@ -16377,6 +16385,13 @@ void mips_function_profiler (FILE *file) #undef TARGET_ASM_CAN_OUTPUT_MI_THUNK #define TARGET_ASM_CAN_OUTPUT_MI_THUNK hook_bool_const_tree_hwi_hwi_const_tree_true +#undef TARGET_PRINT_OPERAND +#define TARGET_PRINT_OPERAND mips_print_operand +#undef TARGET_PRINT_OPERAND_ADDRESS +#define TARGET_PRINT_OPERAND_ADDRESS mips_print_operand_address +#undef TARGET_PRINT_OPERAND_PUNCT_VALID_P +#define TARGET_PRINT_OPERAND_PUNCT_VALID_P mips_print_operand_punct_valid_p + #undef TARGET_SETUP_INCOMING_VARARGS #define TARGET_SETUP_INCOMING_VARARGS mips_setup_incoming_varargs #undef TARGET_STRICT_ARGUMENT_NAMING diff --git a/gcc/config/mips/mips.h b/gcc/config/mips/mips.h index c2816cf9f68..988deab22e5 100644 --- a/gcc/config/mips/mips.h +++ b/gcc/config/mips/mips.h @@ -28,53 +28,6 @@ along with GCC; see the file COPYING3. If not see /* MIPS external variables defined in mips.c. */ -/* Which processor to schedule for. Since there is no difference between - a R2000 and R3000 in terms of the scheduler, we collapse them into - just an R3000. The elements of the enumeration must match exactly - the cpu attribute in the mips.md machine description. */ - -enum processor_type { - PROCESSOR_R3000, - PROCESSOR_4KC, - PROCESSOR_4KP, - PROCESSOR_5KC, - PROCESSOR_5KF, - PROCESSOR_20KC, - PROCESSOR_24KC, - PROCESSOR_24KF2_1, - PROCESSOR_24KF1_1, - PROCESSOR_74KC, - PROCESSOR_74KF2_1, - PROCESSOR_74KF1_1, - PROCESSOR_74KF3_2, - PROCESSOR_LOONGSON_2E, - PROCESSOR_LOONGSON_2F, - PROCESSOR_M4K, - PROCESSOR_OCTEON, - PROCESSOR_R3900, - PROCESSOR_R6000, - PROCESSOR_R4000, - PROCESSOR_R4100, - PROCESSOR_R4111, - PROCESSOR_R4120, - PROCESSOR_R4130, - PROCESSOR_R4300, - PROCESSOR_R4600, - PROCESSOR_R4650, - PROCESSOR_R5000, - PROCESSOR_R5400, - PROCESSOR_R5500, - PROCESSOR_R7000, - PROCESSOR_R8000, - PROCESSOR_R9000, - PROCESSOR_R10000, - PROCESSOR_SB1, - PROCESSOR_SB1A, - PROCESSOR_SR71000, - PROCESSOR_XLR, - PROCESSOR_MAX -}; - /* Costs of various operations on the different architectures. */ struct mips_rtx_cost_data @@ -121,7 +74,7 @@ struct mips_cpu_info { /* The internal processor number that most closely matches this entry. Several processors can have the same value, if there's no difference between them from GCC's point of view. */ - enum processor_type cpu; + enum processor cpu; /* The ISA level that the processor implements. */ int isa; @@ -2209,8 +2162,6 @@ enum reg_class #define STACK_BOUNDARY (TARGET_NEWABI ? 128 : 64) -#define RETURN_POPS_ARGS(FUNDECL,FUNTYPE,SIZE) 0 - /* Symbolic macros for the registers used to return integer and floating point values. */ @@ -2704,10 +2655,6 @@ typedef struct mips_args { #define ALL_COP_ADDITIONAL_REGISTER_NAMES -#define PRINT_OPERAND mips_print_operand -#define PRINT_OPERAND_PUNCT_VALID_P(CODE) mips_print_operand_punct[CODE] -#define PRINT_OPERAND_ADDRESS mips_print_operand_address - #define DBR_OUTPUT_SEQEND(STREAM) \ do \ { \ @@ -3060,7 +3007,6 @@ struct mips_asm_switch { extern const enum reg_class mips_regno_to_class[]; extern bool mips_hard_regno_mode_ok[][FIRST_PSEUDO_REGISTER]; -extern bool mips_print_operand_punct[256]; extern const char *current_function_file; /* filename current function is in */ extern int num_source_filenames; /* current .file # */ extern struct mips_asm_switch mips_noreorder; @@ -3070,8 +3016,8 @@ extern int mips_dbx_regno[]; extern int mips_dwarf_regno[]; extern bool mips_split_p[]; extern bool mips_split_hi_p[]; -extern enum processor_type mips_arch; /* which cpu to codegen for */ -extern enum processor_type mips_tune; /* which cpu to schedule for */ +extern enum processor mips_arch; /* which cpu to codegen for */ +extern enum processor mips_tune; /* which cpu to schedule for */ extern int mips_isa; /* architectural level */ extern int mips_abi; /* which ABI to use */ extern const struct mips_cpu_info *mips_arch_info; @@ -3087,10 +3033,6 @@ extern enum mips_code_readable_setting mips_code_readable; #define FINAL_PRESCAN_INSN(INSN, OPVEC, NOPERANDS) \ mips_final_prescan_insn (INSN, OPVEC, NOPERANDS) -/* This is necessary to avoid a warning about comparing different enum - types. */ -#define mips_tune_attr ((enum attr_cpu) mips_tune) - /* As on most targets, we want the .eh_frame section to be read-only where possible. And as on most targets, this means two things: diff --git a/gcc/config/mips/mips.md b/gcc/config/mips/mips.md index a8543274328..9b09344d9c9 100644 --- a/gcc/config/mips/mips.md +++ b/gcc/config/mips/mips.md @@ -23,247 +23,119 @@ ;; along with GCC; see the file COPYING3. If not see ;; . +(define_enum "processor" [ + r3000 + 4kc + 4kp + 5kc + 5kf + 20kc + 24kc + 24kf2_1 + 24kf1_1 + 74kc + 74kf2_1 + 74kf1_1 + 74kf3_2 + loongson_2e + loongson_2f + m4k + octeon + r3900 + r6000 + r4000 + r4100 + r4111 + r4120 + r4130 + r4300 + r4600 + r4650 + r5000 + r5400 + r5500 + r7000 + r8000 + r9000 + r10000 + sb1 + sb1a + sr71000 + xlr +]) + +(define_c_enum "unspec" [ + ;; Unaligned accesses. + UNSPEC_LOAD_LEFT + UNSPEC_LOAD_RIGHT + UNSPEC_STORE_LEFT + UNSPEC_STORE_RIGHT + + ;; Floating-point moves. + UNSPEC_LOAD_LOW + UNSPEC_LOAD_HIGH + UNSPEC_STORE_WORD + UNSPEC_MFHC1 + UNSPEC_MTHC1 + + ;; HI/LO moves. + UNSPEC_MFHI + UNSPEC_MTHI + UNSPEC_SET_HILO + + ;; GP manipulation. + UNSPEC_LOADGP + UNSPEC_COPYGP + UNSPEC_MOVE_GP + UNSPEC_POTENTIAL_CPRESTORE + UNSPEC_CPRESTORE + UNSPEC_RESTORE_GP + UNSPEC_EH_RETURN + UNSPEC_GP + UNSPEC_SET_GOT_VERSION + UNSPEC_UPDATE_GOT_VERSION + + ;; Symbolic accesses. + UNSPEC_LOAD_CALL + UNSPEC_LOAD_GOT + UNSPEC_TLS_LDM + UNSPEC_TLS_GET_TP + + ;; MIPS16 constant pools. + UNSPEC_ALIGN + UNSPEC_CONSTTABLE_INT + UNSPEC_CONSTTABLE_FLOAT + + ;; Blockage and synchronisation. + UNSPEC_BLOCKAGE + UNSPEC_CLEAR_HAZARD + UNSPEC_RDHWR + UNSPEC_SYNCI + UNSPEC_SYNC + + ;; Cache manipulation. + UNSPEC_MIPS_CACHE + UNSPEC_R10K_CACHE_BARRIER + + ;; Interrupt handling. + UNSPEC_ERET + UNSPEC_DERET + UNSPEC_DI + UNSPEC_EHB + UNSPEC_RDPGPR + UNSPEC_COP0 + + ;; Used in a call expression in place of args_size. It's present for PIC + ;; indirect calls where it contains args_size and the function symbol. + UNSPEC_CALL_ATTR +]) + (define_constants - [(UNSPEC_LOAD_LOW 0) - (UNSPEC_LOAD_HIGH 1) - (UNSPEC_STORE_WORD 2) - (UNSPEC_GET_FNADDR 3) - (UNSPEC_BLOCKAGE 4) - (UNSPEC_POTENTIAL_CPRESTORE 5) - (UNSPEC_CPRESTORE 6) - (UNSPEC_RESTORE_GP 7) - (UNSPEC_MOVE_GP 8) - (UNSPEC_EH_RETURN 9) - (UNSPEC_CONSTTABLE_INT 10) - (UNSPEC_CONSTTABLE_FLOAT 11) - (UNSPEC_ALIGN 14) - (UNSPEC_HIGH 17) - (UNSPEC_LOAD_LEFT 18) - (UNSPEC_LOAD_RIGHT 19) - (UNSPEC_STORE_LEFT 20) - (UNSPEC_STORE_RIGHT 21) - (UNSPEC_LOADGP 22) - (UNSPEC_LOAD_CALL 23) - (UNSPEC_LOAD_GOT 24) - (UNSPEC_GP 25) - (UNSPEC_MFHI 26) - (UNSPEC_MTHI 27) - (UNSPEC_SET_HILO 28) - (UNSPEC_TLS_LDM 29) - (UNSPEC_TLS_GET_TP 30) - (UNSPEC_MFHC1 31) - (UNSPEC_MTHC1 32) - (UNSPEC_CLEAR_HAZARD 33) - (UNSPEC_RDHWR 34) - (UNSPEC_SYNCI 35) - (UNSPEC_SYNC 36) - (UNSPEC_COMPARE_AND_SWAP 37) - (UNSPEC_COMPARE_AND_SWAP_12 38) - (UNSPEC_SYNC_OLD_OP 39) - (UNSPEC_SYNC_NEW_OP 40) - (UNSPEC_SYNC_NEW_OP_12 41) - (UNSPEC_SYNC_OLD_OP_12 42) - (UNSPEC_SYNC_EXCHANGE 43) - (UNSPEC_SYNC_EXCHANGE_12 44) - (UNSPEC_MEMORY_BARRIER 45) - (UNSPEC_SET_GOT_VERSION 46) - (UNSPEC_UPDATE_GOT_VERSION 47) - (UNSPEC_COPYGP 48) - (UNSPEC_ERET 49) - (UNSPEC_DERET 50) - (UNSPEC_DI 51) - (UNSPEC_EHB 52) - (UNSPEC_RDPGPR 53) - (UNSPEC_COP0 54) - ;; Used in a call expression in place of args_size. It's present for PIC - ;; indirect calls where it contains args_size and the function symbol. - (UNSPEC_CALL_ATTR 55) - - (UNSPEC_ADDRESS_FIRST 100) - - (TLS_GET_TP_REGNUM 3) + [(TLS_GET_TP_REGNUM 3) (RETURN_ADDR_REGNUM 31) (CPRESTORE_SLOT_REGNUM 76) (GOT_VERSION_REGNUM 79) - ;; For MIPS Paired-Singled Floating Point Instructions. - - (UNSPEC_MOVE_TF_PS 200) - (UNSPEC_C 201) - - ;; MIPS64/MIPS32R2 alnv.ps - (UNSPEC_ALNV_PS 202) - - ;; MIPS-3D instructions - (UNSPEC_CABS 203) - - (UNSPEC_ADDR_PS 204) - (UNSPEC_CVT_PW_PS 205) - (UNSPEC_CVT_PS_PW 206) - (UNSPEC_MULR_PS 207) - (UNSPEC_ABS_PS 208) - - (UNSPEC_RSQRT1 209) - (UNSPEC_RSQRT2 210) - (UNSPEC_RECIP1 211) - (UNSPEC_RECIP2 212) - (UNSPEC_SINGLE_CC 213) - (UNSPEC_SCC 214) - - ;; MIPS DSP ASE Revision 0.98 3/24/2005 - (UNSPEC_ADDQ 300) - (UNSPEC_ADDQ_S 301) - (UNSPEC_SUBQ 302) - (UNSPEC_SUBQ_S 303) - (UNSPEC_ADDSC 304) - (UNSPEC_ADDWC 305) - (UNSPEC_MODSUB 306) - (UNSPEC_RADDU_W_QB 307) - (UNSPEC_ABSQ_S 308) - (UNSPEC_PRECRQ_QB_PH 309) - (UNSPEC_PRECRQ_PH_W 310) - (UNSPEC_PRECRQ_RS_PH_W 311) - (UNSPEC_PRECRQU_S_QB_PH 312) - (UNSPEC_PRECEQ_W_PHL 313) - (UNSPEC_PRECEQ_W_PHR 314) - (UNSPEC_PRECEQU_PH_QBL 315) - (UNSPEC_PRECEQU_PH_QBR 316) - (UNSPEC_PRECEQU_PH_QBLA 317) - (UNSPEC_PRECEQU_PH_QBRA 318) - (UNSPEC_PRECEU_PH_QBL 319) - (UNSPEC_PRECEU_PH_QBR 320) - (UNSPEC_PRECEU_PH_QBLA 321) - (UNSPEC_PRECEU_PH_QBRA 322) - (UNSPEC_SHLL 323) - (UNSPEC_SHLL_S 324) - (UNSPEC_SHRL_QB 325) - (UNSPEC_SHRA_PH 326) - (UNSPEC_SHRA_R 327) - (UNSPEC_MULEU_S_PH_QBL 328) - (UNSPEC_MULEU_S_PH_QBR 329) - (UNSPEC_MULQ_RS_PH 330) - (UNSPEC_MULEQ_S_W_PHL 331) - (UNSPEC_MULEQ_S_W_PHR 332) - (UNSPEC_DPAU_H_QBL 333) - (UNSPEC_DPAU_H_QBR 334) - (UNSPEC_DPSU_H_QBL 335) - (UNSPEC_DPSU_H_QBR 336) - (UNSPEC_DPAQ_S_W_PH 337) - (UNSPEC_DPSQ_S_W_PH 338) - (UNSPEC_MULSAQ_S_W_PH 339) - (UNSPEC_DPAQ_SA_L_W 340) - (UNSPEC_DPSQ_SA_L_W 341) - (UNSPEC_MAQ_S_W_PHL 342) - (UNSPEC_MAQ_S_W_PHR 343) - (UNSPEC_MAQ_SA_W_PHL 344) - (UNSPEC_MAQ_SA_W_PHR 345) - (UNSPEC_BITREV 346) - (UNSPEC_INSV 347) - (UNSPEC_REPL_QB 348) - (UNSPEC_REPL_PH 349) - (UNSPEC_CMP_EQ 350) - (UNSPEC_CMP_LT 351) - (UNSPEC_CMP_LE 352) - (UNSPEC_CMPGU_EQ_QB 353) - (UNSPEC_CMPGU_LT_QB 354) - (UNSPEC_CMPGU_LE_QB 355) - (UNSPEC_PICK 356) - (UNSPEC_PACKRL_PH 357) - (UNSPEC_EXTR_W 358) - (UNSPEC_EXTR_R_W 359) - (UNSPEC_EXTR_RS_W 360) - (UNSPEC_EXTR_S_H 361) - (UNSPEC_EXTP 362) - (UNSPEC_EXTPDP 363) - (UNSPEC_SHILO 364) - (UNSPEC_MTHLIP 365) - (UNSPEC_WRDSP 366) - (UNSPEC_RDDSP 367) - - ;; MIPS DSP ASE REV 2 Revision 0.02 11/24/2006 - (UNSPEC_ABSQ_S_QB 400) - (UNSPEC_ADDU_PH 401) - (UNSPEC_ADDU_S_PH 402) - (UNSPEC_ADDUH_QB 403) - (UNSPEC_ADDUH_R_QB 404) - (UNSPEC_APPEND 405) - (UNSPEC_BALIGN 406) - (UNSPEC_CMPGDU_EQ_QB 407) - (UNSPEC_CMPGDU_LT_QB 408) - (UNSPEC_CMPGDU_LE_QB 409) - (UNSPEC_DPA_W_PH 410) - (UNSPEC_DPS_W_PH 411) - (UNSPEC_MADD 412) - (UNSPEC_MADDU 413) - (UNSPEC_MSUB 414) - (UNSPEC_MSUBU 415) - (UNSPEC_MUL_PH 416) - (UNSPEC_MUL_S_PH 417) - (UNSPEC_MULQ_RS_W 418) - (UNSPEC_MULQ_S_PH 419) - (UNSPEC_MULQ_S_W 420) - (UNSPEC_MULSA_W_PH 421) - (UNSPEC_MULT 422) - (UNSPEC_MULTU 423) - (UNSPEC_PRECR_QB_PH 424) - (UNSPEC_PRECR_SRA_PH_W 425) - (UNSPEC_PRECR_SRA_R_PH_W 426) - (UNSPEC_PREPEND 427) - (UNSPEC_SHRA_QB 428) - (UNSPEC_SHRA_R_QB 429) - (UNSPEC_SHRL_PH 430) - (UNSPEC_SUBU_PH 431) - (UNSPEC_SUBU_S_PH 432) - (UNSPEC_SUBUH_QB 433) - (UNSPEC_SUBUH_R_QB 434) - (UNSPEC_ADDQH_PH 435) - (UNSPEC_ADDQH_R_PH 436) - (UNSPEC_ADDQH_W 437) - (UNSPEC_ADDQH_R_W 438) - (UNSPEC_SUBQH_PH 439) - (UNSPEC_SUBQH_R_PH 440) - (UNSPEC_SUBQH_W 441) - (UNSPEC_SUBQH_R_W 442) - (UNSPEC_DPAX_W_PH 443) - (UNSPEC_DPSX_W_PH 444) - (UNSPEC_DPAQX_S_W_PH 445) - (UNSPEC_DPAQX_SA_W_PH 446) - (UNSPEC_DPSQX_S_W_PH 447) - (UNSPEC_DPSQX_SA_W_PH 448) - - ;; ST Microelectronics Loongson-2E/2F. - (UNSPEC_LOONGSON_PAVG 500) - (UNSPEC_LOONGSON_PCMPEQ 501) - (UNSPEC_LOONGSON_PCMPGT 502) - (UNSPEC_LOONGSON_PEXTR 503) - (UNSPEC_LOONGSON_PINSR_0 504) - (UNSPEC_LOONGSON_PINSR_1 505) - (UNSPEC_LOONGSON_PINSR_2 506) - (UNSPEC_LOONGSON_PINSR_3 507) - (UNSPEC_LOONGSON_PMADD 508) - (UNSPEC_LOONGSON_PMOVMSK 509) - (UNSPEC_LOONGSON_PMULHU 510) - (UNSPEC_LOONGSON_PMULH 511) - (UNSPEC_LOONGSON_PMULL 512) - (UNSPEC_LOONGSON_PMULU 513) - (UNSPEC_LOONGSON_PASUBUB 514) - (UNSPEC_LOONGSON_BIADD 515) - (UNSPEC_LOONGSON_PSADBH 516) - (UNSPEC_LOONGSON_PSHUFH 517) - (UNSPEC_LOONGSON_PUNPCKH 518) - (UNSPEC_LOONGSON_PUNPCKL 519) - (UNSPEC_LOONGSON_PADDD 520) - (UNSPEC_LOONGSON_PSUBD 521) - - ;; Used in loongson2ef.md - (UNSPEC_LOONGSON_ALU1_TURN_ENABLED_INSN 530) - (UNSPEC_LOONGSON_ALU2_TURN_ENABLED_INSN 531) - (UNSPEC_LOONGSON_FALU1_TURN_ENABLED_INSN 532) - (UNSPEC_LOONGSON_FALU2_TURN_ENABLED_INSN 533) - - (UNSPEC_MIPS_CACHE 600) - (UNSPEC_R10K_CACHE_BARRIER 601) - ;; PIC long branch sequences are never longer than 100 bytes. (MAX_PIC_BRANCH_LENGTH 100) ] @@ -327,6 +199,9 @@ shift_shift,lui_movf" (const_string "unknown")) +(define_attr "alu_type" "unknown,add,sub,not,nor,and,or,xor" + (const_string "unknown")) + ;; Main data type used by the insn (define_attr "mode" "unknown,none,QI,HI,SI,DI,TI,SF,DF,TF,FPSW" (const_string "unknown")) @@ -403,6 +278,10 @@ (cond [(eq_attr "jal" "!unset") (const_string "call") (eq_attr "got" "load") (const_string "load") + (eq_attr "alu_type" "add,sub") (const_string "arith") + + (eq_attr "alu_type" "not,nor,and,or,xor") (const_string "logical") + ;; If a doubleword move uses these expensive instructions, ;; it is usually better to schedule them in the same way ;; as the singleword form, rather than as "multi". @@ -636,11 +515,9 @@ (symbol_ref "mips_sync_loop_insns (insn, operands) * 4") ] (const_int 4))) -;; Attribute describing the processor. This attribute must match exactly -;; with the processor_type enumeration in mips.h. -(define_attr "cpu" - "r3000,4kc,4kp,5kc,5kf,20kc,24kc,24kf2_1,24kf1_1,74kc,74kf2_1,74kf1_1,74kf3_2,loongson_2e,loongson_2f,m4k,octeon,r3900,r6000,r4000,r4100,r4111,r4120,r4130,r4300,r4600,r4650,r5000,r5400,r5500,r7000,r8000,r9000,r10000,sb1,sb1a,sr71000,xlr" - (const (symbol_ref "mips_tune_attr"))) +;; Attribute describing the processor. +(define_enum_attr "cpu" "processor" + (const (symbol_ref "mips_tune"))) ;; The type of hardware hazard associated with this instruction. ;; DELAY means that the next instruction cannot read the result @@ -1108,7 +985,7 @@ "@ addu\t%0,%1,%2 addiu\t%0,%1,%2" - [(set_attr "type" "arith") + [(set_attr "alu_type" "add") (set_attr "mode" "")]) (define_insn "*add3_mips16" @@ -1122,7 +999,7 @@ addiu\t%0,%2 addiu\t%0,%1,%2 addu\t%0,%1,%2" - [(set_attr "type" "arith") + [(set_attr "alu_type" "add") (set_attr "mode" "") (set_attr_alternative "length" [(if_then_else (match_operand 2 "m16_simm8_8") @@ -1260,7 +1137,7 @@ "@ addu\t%0,%1,%2 addiu\t%0,%1,%2" - [(set_attr "type" "arith") + [(set_attr "alu_type" "add") (set_attr "mode" "SI")]) ;; Split this insn so that the addiu splitters can have a crack at it. @@ -1275,7 +1152,7 @@ "&& reload_completed" [(set (match_dup 3) (plus:SI (match_dup 1) (match_dup 2)))] { operands[3] = gen_lowpart (SImode, operands[0]); } - [(set_attr "type" "arith") + [(set_attr "alu_type" "add") (set_attr "mode" "SI") (set_attr "extended_mips16" "yes")]) @@ -1289,7 +1166,7 @@ (match_operand:SI 2 "register_operand" "d")) 3)))] "ISA_HAS_BADDU && BYTES_BIG_ENDIAN" "baddu\\t%0,%1,%2" - [(set_attr "type" "arith")]) + [(set_attr "alu_type" "add")]) (define_insn "*baddu_si_el" [(set (match_operand:SI 0 "register_operand" "=d") @@ -1299,7 +1176,7 @@ (match_operand:SI 2 "register_operand" "d")) 0)))] "ISA_HAS_BADDU && !BYTES_BIG_ENDIAN" "baddu\\t%0,%1,%2" - [(set_attr "type" "arith")]) + [(set_attr "alu_type" "add")]) (define_insn "*baddu_di" [(set (match_operand:GPR 0 "register_operand" "=d") @@ -1309,7 +1186,7 @@ (match_operand:DI 2 "register_operand" "d")))))] "ISA_HAS_BADDU && TARGET_64BIT" "baddu\\t%0,%1,%2" - [(set_attr "type" "arith")]) + [(set_attr "alu_type" "add")]) ;; ;; .................... @@ -1334,7 +1211,7 @@ (match_operand:GPR 2 "register_operand" "d")))] "" "subu\t%0,%1,%2" - [(set_attr "type" "arith") + [(set_attr "alu_type" "sub") (set_attr "mode" "")]) (define_insn "*subsi3_extended" @@ -1344,7 +1221,7 @@ (match_operand:SI 2 "register_operand" "d"))))] "TARGET_64BIT" "subu\t%0,%1,%2" - [(set_attr "type" "arith") + [(set_attr "alu_type" "sub") (set_attr "mode" "DI")]) ;; @@ -2613,7 +2490,7 @@ else return "subu\t%0,%.,%1"; } - [(set_attr "type" "arith") + [(set_attr "alu_type" "sub") (set_attr "mode" "SI")]) (define_insn "negdi2" @@ -2621,7 +2498,7 @@ (neg:DI (match_operand:DI 1 "register_operand" "d")))] "TARGET_64BIT && !TARGET_MIPS16" "dsubu\t%0,%.,%1" - [(set_attr "type" "arith") + [(set_attr "alu_type" "sub") (set_attr "mode" "DI")]) ;; neg.fmt is an arithmetic instruction and treats all NaN inputs as @@ -2646,7 +2523,7 @@ else return "nor\t%0,%.,%1"; } - [(set_attr "type" "logical") + [(set_attr "alu_type" "not") (set_attr "mode" "")]) ;; @@ -2768,7 +2645,7 @@ "@ or\t%0,%1,%2 ori\t%0,%1,%x2" - [(set_attr "type" "logical") + [(set_attr "alu_type" "or") (set_attr "mode" "")]) (define_insn "*ior3_mips16" @@ -2777,7 +2654,7 @@ (match_operand:GPR 2 "register_operand" "d")))] "TARGET_MIPS16" "or\t%0,%2" - [(set_attr "type" "logical") + [(set_attr "alu_type" "or") (set_attr "mode" "")]) (define_expand "xor3" @@ -2795,7 +2672,7 @@ "@ xor\t%0,%1,%2 xori\t%0,%1,%x2" - [(set_attr "type" "logical") + [(set_attr "alu_type" "xor") (set_attr "mode" "")]) (define_insn "" @@ -2807,7 +2684,7 @@ xor\t%0,%2 cmpi\t%1,%2 cmp\t%1,%2" - [(set_attr "type" "logical,arith,arith") + [(set_attr "alu_type" "xor") (set_attr "mode" "") (set_attr_alternative "length" [(const_int 4) @@ -2822,7 +2699,7 @@ (not:GPR (match_operand:GPR 2 "register_operand" "d"))))] "!TARGET_MIPS16" "nor\t%0,%1,%2" - [(set_attr "type" "logical") + [(set_attr "alu_type" "nor") (set_attr "mode" "")]) ;; @@ -3040,7 +2917,7 @@ operands[2] = GEN_INT (GET_MODE_MASK (mode)); return "andi\t%0,%1,%x2"; } - [(set_attr "type" "logical") + [(set_attr "alu_type" "and") (set_attr "mode" "")]) (define_insn "*zero_extendhi_truncqi" @@ -3049,7 +2926,7 @@ (truncate:QI (match_operand:DI 1 "register_operand" "d"))))] "TARGET_64BIT && !TARGET_MIPS16" "andi\t%0,%1,0xff" - [(set_attr "type" "logical") + [(set_attr "alu_type" "and") (set_attr "mode" "HI")]) ;; @@ -3981,7 +3858,7 @@ (match_operand:P 2 "immediate_operand" "")))] "!TARGET_MIPS16" "addiu\t%0,%1,%R2" - [(set_attr "type" "arith") + [(set_attr "alu_type" "add") (set_attr "mode" "")]) (define_insn "*low_mips16" @@ -3990,7 +3867,7 @@ (match_operand:P 2 "immediate_operand" "")))] "TARGET_MIPS16" "addiu\t%0,%R2" - [(set_attr "type" "arith") + [(set_attr "alu_type" "add") (set_attr "mode" "") (set_attr "extended_mips16" "yes")]) @@ -6581,3 +6458,7 @@ ; ST-Microelectronics Loongson-2E/2F-specific patterns. (include "loongson.md") + +(define_c_enum "unspec" [ + UNSPEC_ADDRESS_FIRST +]) diff --git a/gcc/config/mips/sync.md b/gcc/config/mips/sync.md index e28f56c601a..ee41d2c9740 100644 --- a/gcc/config/mips/sync.md +++ b/gcc/config/mips/sync.md @@ -19,6 +19,18 @@ ;; along with GCC; see the file COPYING3. If not see ;; . +(define_c_enum "unspec" [ + UNSPEC_COMPARE_AND_SWAP + UNSPEC_COMPARE_AND_SWAP_12 + UNSPEC_SYNC_OLD_OP + UNSPEC_SYNC_NEW_OP + UNSPEC_SYNC_NEW_OP_12 + UNSPEC_SYNC_OLD_OP_12 + UNSPEC_SYNC_EXCHANGE + UNSPEC_SYNC_EXCHANGE_12 + UNSPEC_MEMORY_BARRIER +]) + ;; Atomic fetch bitwise operations. (define_code_iterator fetchop_bit [ior xor and]) diff --git a/gcc/config/mmix/mmix.c b/gcc/config/mmix/mmix.c index de66ac4e40d..4b35e06df4f 100644 --- a/gcc/config/mmix/mmix.c +++ b/gcc/config/mmix/mmix.c @@ -263,7 +263,7 @@ mmix_init_expanders (void) static struct machine_function * mmix_init_machine_status (void) { - return GGC_CNEW (struct machine_function); + return ggc_alloc_cleared_machine_function (); } /* DATA_ALIGNMENT. diff --git a/gcc/config/mmix/mmix.h b/gcc/config/mmix/mmix.h index 2886443c66d..48551028d5b 100644 --- a/gcc/config/mmix/mmix.h +++ b/gcc/config/mmix/mmix.h @@ -586,8 +586,6 @@ enum reg_class #define ACCUMULATE_OUTGOING_ARGS 1 -#define RETURN_POPS_ARGS(FUNDECL, FUNTYPE, STACKSIZE) 0 - /* Node: Register Arguments */ #define FUNCTION_ARG(CUM, MODE, TYPE, NAMED) \ diff --git a/gcc/config/mn10300/mn10300.h b/gcc/config/mn10300/mn10300.h index 12e78612014..1700f1a25be 100644 --- a/gcc/config/mn10300/mn10300.h +++ b/gcc/config/mn10300/mn10300.h @@ -492,15 +492,6 @@ enum reg_class { them whenever possible. */ #define CAN_DEBUG_WITHOUT_FP -/* Value is the number of bytes of arguments automatically - popped when returning from a subroutine call. - FUNDECL is the declaration node of the function (as a tree), - FUNTYPE is the data type of the function (as a tree), - or for a library call it is an identifier node for the subroutine name. - SIZE is the number of bytes of arguments passed on the stack. */ - -#define RETURN_POPS_ARGS(FUNDECL,FUNTYPE,SIZE) 0 - /* We use d0/d1 for passing parameters, so allocate 8 bytes of space for a register flushback area. */ #define REG_PARM_STACK_SPACE(DECL) 8 diff --git a/gcc/config/moxie/moxie-protos.h b/gcc/config/moxie/moxie-protos.h index 17bb4fc7cf7..471fd99a67d 100644 --- a/gcc/config/moxie/moxie-protos.h +++ b/gcc/config/moxie/moxie-protos.h @@ -1,5 +1,6 @@ /* Prototypes for moxie.c functions used in the md file & elsewhere. - Copyright (C) 2009 Free Software Foundation, Inc. + Copyright (C) 2009, 2010 + Free Software Foundation, Inc. This file is part of GCC. @@ -21,8 +22,6 @@ extern void moxie_override_options (void); extern void moxie_expand_prologue (void); extern void moxie_expand_epilogue (void); extern int moxie_initial_elimination_offset (int, int); -extern rtx moxie_function_value (const_tree, const_tree, - bool ATTRIBUTE_UNUSED); extern void moxie_print_operand (FILE *, rtx, int); extern void moxie_print_operand_address (FILE *, rtx); #ifdef RTX_CODE diff --git a/gcc/config/moxie/moxie.c b/gcc/config/moxie/moxie.c index 1e692b18d7e..1ce7107daff 100644 --- a/gcc/config/moxie/moxie.c +++ b/gcc/config/moxie/moxie.c @@ -70,7 +70,7 @@ moxie_return_in_memory (const_tree type, const_tree fntype ATTRIBUTE_UNUSED) We always return values in register $r0 for moxie. */ -rtx +static rtx moxie_function_value (const_tree valtype, const_tree fntype_or_decl ATTRIBUTE_UNUSED, bool outgoing ATTRIBUTE_UNUSED) @@ -78,6 +78,27 @@ moxie_function_value (const_tree valtype, return gen_rtx_REG (TYPE_MODE (valtype), MOXIE_R0); } +/* Define how to find the value returned by a library function. + + We always return values in register $r0 for moxie. */ + +static rtx +moxie_libcall_value (enum machine_mode mode, + const_rtx fun ATTRIBUTE_UNUSED) +{ + return gen_rtx_REG (mode, MOXIE_R0); +} + +/* Handle TARGET_FUNCTION_VALUE_REGNO_P. + + We always return values in register $r0 for moxie. */ + +static bool +moxie_function_value_regno_p (const unsigned int regno) +{ + return (regno == MOXIE_R0); +} + /* Emit an error message when we're in an asm, and a fatal error for "normal" insns. Formatted output isn't easily implemented, since we use output_operand_lossage to output the actual message and handle the @@ -205,7 +226,7 @@ struct GTY(()) machine_function static struct machine_function * moxie_init_machine_status (void) { - return GGC_CNEW (struct machine_function); + return ggc_alloc_cleared_machine_function (); } @@ -530,6 +551,10 @@ moxie_trampoline_init (rtx m_tramp, tree fndecl, rtx chain_value) node node representing a data type. */ #undef TARGET_FUNCTION_VALUE #define TARGET_FUNCTION_VALUE moxie_function_value +#undef TARGET_LIBCALL_VALUE +#define TARGET_LIBCALL_VALUE moxie_libcall_value +#undef TARGET_FUNCTION_VALUE_REGNO_P +#define TARGET_FUNCTION_VALUE_REGNO_P moxie_function_value_regno_p #undef TARGET_FRAME_POINTER_REQUIRED #define TARGET_FRAME_POINTER_REQUIRED hook_bool_void_true diff --git a/gcc/config/moxie/moxie.h b/gcc/config/moxie/moxie.h index 928ca8838a7..0a53b6b7216 100644 --- a/gcc/config/moxie/moxie.h +++ b/gcc/config/moxie/moxie.h @@ -268,18 +268,6 @@ enum reg_class /* How Scalar Function Values Are Returned */ -/* These macros are deprecated, but we still need them for now since - the version of gcc we're using doesn't fully support - TARGET_FUNCTION_VALUE. */ -#define FUNCTION_VALUE(VALTYPE, FUNC) \ - moxie_function_value (VALTYPE, FUNC, 0) -#define FUNCTION_OUTGOING_VALUE(VALTYPE, FUNC) \ - moxie_function_value (VALTYPE, FUNC, 1) - -/* A C expression to create an RTX representing the place where a - library function returns a value of mode MODE. */ -#define LIBCALL_VALUE(MODE) gen_rtx_REG (MODE, 2) - /* STACK AND CALLING */ /* Define this macro if pushing a word onto the stack moves the stack @@ -429,10 +417,6 @@ enum reg_class register in which function arguments are sometimes passed. */ #define FUNCTION_ARG_REGNO_P(r) (r >= MOXIE_R0 && r <= MOXIE_R5) -/* A C expression that is nonzero if REGNO is the number of a hard - register in which the values of called function may come back. */ -#define FUNCTION_VALUE_REGNO_P(r) (r == MOXIE_R0) - /* A macro whose definition is the name of the class to which a valid base register must belong. A base register is one used in an address which is the register value plus a displacement. */ @@ -469,8 +453,6 @@ enum reg_class /* All load operations zero extend. */ #define LOAD_EXTEND_OP(MEM) ZERO_EXTEND -#define RETURN_POPS_ARGS(FUNDECL, FUNTYPE, STACK_SIZE) 0 - /* A C expression that is nonzero if X is a legitimate constant for an immediate operand on the target machine. */ #define LEGITIMATE_CONSTANT_P(X) 1 diff --git a/gcc/config/pa/pa.c b/gcc/config/pa/pa.c index 5ef405b4f44..2640f05e1bc 100644 --- a/gcc/config/pa/pa.c +++ b/gcc/config/pa/pa.c @@ -155,9 +155,9 @@ static bool pa_pass_by_reference (CUMULATIVE_ARGS *, enum machine_mode, static int pa_arg_partial_bytes (CUMULATIVE_ARGS *, enum machine_mode, tree, bool); static struct machine_function * pa_init_machine_status (void); -static enum reg_class pa_secondary_reload (bool, rtx, enum reg_class, - enum machine_mode, - secondary_reload_info *); +static reg_class_t pa_secondary_reload (bool, rtx, reg_class_t, + enum machine_mode, + secondary_reload_info *); static void pa_extra_live_on_entry (bitmap); static enum machine_mode pa_promote_function_mode (const_tree, enum machine_mode, int *, @@ -519,6 +519,17 @@ override_options (void) if (flag_pic == 1 || TARGET_64BIT) flag_pic = 2; + /* Disable -freorder-blocks-and-partition as we don't support hot and + cold partitioning. */ + if (flag_reorder_blocks_and_partition) + { + inform (input_location, + "-freorder-blocks-and-partition does not work " + "on this architecture"); + flag_reorder_blocks_and_partition = 0; + flag_reorder_blocks = 1; + } + /* We can't guarantee that .dword is available for 32-bit targets. */ if (UNITS_PER_WORD == 4) targetm.asm_out.aligned_op.di = NULL; @@ -558,7 +569,7 @@ pa_init_builtins (void) static struct machine_function * pa_init_machine_status (void) { - return GGC_CNEW (machine_function); + return ggc_alloc_cleared_machine_function (); } /* If FROM is a probable pointer register, mark TO as a probable @@ -1696,10 +1707,6 @@ emit_move_sequence (rtx *operands, enum machine_mode mode, rtx scratch_reg) && !REG_POINTER (operand0) && !HARD_REGISTER_P (operand0)) copy_reg_pointer (operand0, operand1); - else if (REG_POINTER (operand0) - && !REG_POINTER (operand1) - && !HARD_REGISTER_P (operand1)) - copy_reg_pointer (operand1, operand0); } /* When MEMs are broken out, the REG_POINTER flag doesn't @@ -5375,13 +5382,11 @@ get_deferred_plabel (rtx symbol) tree id; if (deferred_plabels == 0) - deferred_plabels = (struct deferred_plabel *) - ggc_alloc (sizeof (struct deferred_plabel)); + deferred_plabels = ggc_alloc_deferred_plabel (); else - deferred_plabels = (struct deferred_plabel *) - ggc_realloc (deferred_plabels, - ((n_deferred_plabels + 1) - * sizeof (struct deferred_plabel))); + deferred_plabels = GGC_RESIZEVEC (struct deferred_plabel, + deferred_plabels, + n_deferred_plabels + 1); i = n_deferred_plabels++; deferred_plabels[i].internal_label = gen_label_rtx (); @@ -5683,11 +5688,12 @@ output_arg_descriptor (rtx call_insn) fputc ('\n', asm_out_file); } -static enum reg_class -pa_secondary_reload (bool in_p, rtx x, enum reg_class rclass, +static reg_class_t +pa_secondary_reload (bool in_p, rtx x, reg_class_t rclass_i, enum machine_mode mode, secondary_reload_info *sri) { int is_symbolic, regno; + enum reg_class rclass = (enum reg_class) rclass_i; /* Handle the easy stuff first. */ if (rclass == R1_REGS) diff --git a/gcc/config/pa/pa.h b/gcc/config/pa/pa.h index 4b10a0a3b9b..4eae700b077 100644 --- a/gcc/config/pa/pa.h +++ b/gcc/config/pa/pa.h @@ -1,6 +1,6 @@ /* Definitions of target machine for GNU compiler, for the HP Spectrum. Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, - 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 + 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. Contributed by Michael Tiemann (tiemann@cygnus.com) of Cygnus Support and Tim Moore (moore@defmacro.cs.utah.edu) of the Center for @@ -222,15 +222,6 @@ do { \ #define LIB_SPEC "%{!p:%{!pg:-lc}}%{p:-lc_p}%{pg:-lc_p}" #endif -/* This macro defines command-line switches that modify the default - target name. - - The definition is be an initializer for an array of structures. Each - array element has have three elements: the switch name, one of the - enumeration codes ADD or DELETE to indicate whether the string should be - inserted or deleted, and the string to be inserted or deleted. */ -#define MODIFY_TARGET_NAME {{"-32", DELETE, "64"}, {"-64", ADD, "64"}} - /* Make gcc agree with */ #define SIZE_TYPE "unsigned int" @@ -562,14 +553,6 @@ extern struct rtx_def *hppa_pic_save_rtx (void); ? (STACK_POINTER_OFFSET) \ : ((STACK_POINTER_OFFSET) - crtl->outgoing_args_size)) -/* Value is 1 if returning from a function call automatically - pops the arguments described by the number-of-args field in the call. - FUNDECL is the declaration node of the function (as a tree), - FUNTYPE is the data type of the function (as a tree), - or for a library call it is an identifier node for the subroutine name. */ - -#define RETURN_POPS_ARGS(FUNDECL,FUNTYPE,SIZE) 0 - /* Define how to find the value returned by a library function assuming the value has mode MODE. */ diff --git a/gcc/config/pdp11/pdp11.c b/gcc/config/pdp11/pdp11.c index 733bf756c3e..15e8a545f09 100644 --- a/gcc/config/pdp11/pdp11.c +++ b/gcc/config/pdp11/pdp11.c @@ -1,6 +1,6 @@ /* Subroutines for gcc2 for pdp11. Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2001, 2004, 2005, - 2006, 2007, 2008, 2009 Free Software Foundation, Inc. + 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. Contributed by Michael K. Gschwind (mike@vlsivie.tuwien.ac.at). This file is part of GCC. @@ -151,6 +151,9 @@ static void pdp11_output_function_prologue (FILE *, HOST_WIDE_INT); static void pdp11_output_function_epilogue (FILE *, HOST_WIDE_INT); static bool pdp11_rtx_costs (rtx, int, int, int *, bool); static bool pdp11_return_in_memory (const_tree, const_tree); +static rtx pdp11_function_value (const_tree, const_tree, bool); +static rtx pdp11_libcall_value (enum machine_mode, const_rtx); +static bool pdp11_function_value_regno_p (const unsigned int); static void pdp11_trampoline_init (rtx, tree, rtx); /* Initialize the GCC target structure. */ @@ -185,6 +188,13 @@ static void pdp11_trampoline_init (rtx, tree, rtx); #undef TARGET_RETURN_IN_MEMORY #define TARGET_RETURN_IN_MEMORY pdp11_return_in_memory +#undef TARGET_FUNCTION_VALUE +#define TARGET_FUNCTION_VALUE pdp11_function_value +#undef TARGET_LIBCALL_VALUE +#define TARGET_LIBCALL_VALUE pdp11_libcall_value +#undef TARGET_FUNCTION_VALUE_REGNO_P +#define TARGET_FUNCTION_VALUE_REGNO_P pdp11_function_value_regno_p + #undef TARGET_TRAMPOLINE_INIT #define TARGET_TRAMPOLINE_INIT pdp11_trampoline_init @@ -1744,6 +1754,40 @@ pdp11_return_in_memory (const_tree type, const_tree fntype ATTRIBUTE_UNUSED) || (TYPE_MODE (type) == DFmode && ! TARGET_AC0)); } +/* Worker function for TARGET_FUNCTION_VALUE. + + On the pdp11 the value is found in R0 (or ac0??? not without FPU!!!! ) */ + +static rtx +pdp11_function_value (const_tree valtype, + const_tree fntype_or_decl ATTRIBUTE_UNUSED, + bool outgoing ATTRIBUTE_UNUSED) +{ + return gen_rtx_REG (TYPE_MODE (valtype), + BASE_RETURN_VALUE_REG(TYPE_MODE(valtype))); +} + +/* Worker function for TARGET_LIBCALL_VALUE. */ + +static rtx +pdp11_libcall_value (enum machine_mode mode, + const_rtx fun ATTRIBUTE_UNUSED) +{ + return gen_rtx_REG (mode, BASE_RETURN_VALUE_REG(mode)); +} + +/* Worker function for TARGET_FUNCTION_VALUE_REGNO_P. + + On the pdp, the first "output" reg is the only register thus used. + + maybe ac0 ? - as option someday! */ + +static bool +pdp11_function_value_regno_p (const unsigned int regno) +{ + return (regno == 0) || (TARGET_AC0 && (regno == 8)); +} + /* Worker function for TARGET_TRAMPOLINE_INIT. trampoline - how should i do it in separate i+d ? diff --git a/gcc/config/pdp11/pdp11.h b/gcc/config/pdp11/pdp11.h index a08f7239e10..006fb4cbd86 100644 --- a/gcc/config/pdp11/pdp11.h +++ b/gcc/config/pdp11/pdp11.h @@ -1,6 +1,6 @@ /* Definitions of target machine for GNU compiler, for the pdp-11 Copyright (C) 1994, 1995, 1996, 1998, 1999, 2000, 2001, 2002, 2004, 2005, - 2006, 2007, 2008 Free Software Foundation, Inc. + 2006, 2007, 2008, 2010 Free Software Foundation, Inc. Contributed by Michael K. Gschwind (mike@vlsivie.tuwien.ac.at). This file is part of GCC. @@ -435,14 +435,6 @@ extern int current_first_parm_offset; */ #define FIRST_PARM_OFFSET(FNDECL) 4 -/* Value is 1 if returning from a function call automatically - pops the arguments described by the number-of-args field in the call. - FUNDECL is the declaration node of the function (as a tree), - FUNTYPE is the data type of the function (as a tree), - or for a library call it is an identifier node for the subroutine name. */ - -#define RETURN_POPS_ARGS(FUNDECL,FUNTYPE,SIZE) 0 - /* Define how to find the value returned by a function. VALTYPE is the data type of the value (as a tree). If the precise function being called is known, FUNC is its FUNCTION_DECL; @@ -450,31 +442,6 @@ extern int current_first_parm_offset; #define BASE_RETURN_VALUE_REG(MODE) \ ((MODE) == DFmode ? 8 : 0) -/* On the pdp11 the value is found in R0 (or ac0??? -not without FPU!!!! ) */ - -#define FUNCTION_VALUE(VALTYPE, FUNC) \ - gen_rtx_REG (TYPE_MODE (VALTYPE), BASE_RETURN_VALUE_REG(TYPE_MODE(VALTYPE))) - -/* and the called function leaves it in the first register. - Difference only on machines with register windows. */ - -#define FUNCTION_OUTGOING_VALUE(VALTYPE, FUNC) \ - gen_rtx_REG (TYPE_MODE (VALTYPE), BASE_RETURN_VALUE_REG(TYPE_MODE(VALTYPE))) - -/* Define how to find the value returned by a library function - assuming the value has mode MODE. */ - -#define LIBCALL_VALUE(MODE) gen_rtx_REG (MODE, BASE_RETURN_VALUE_REG(MODE)) - -/* 1 if N is a possible register number for a function value - as seen by the caller. - On the pdp, the first "output" reg is the only register thus used. - -maybe ac0 ? - as option someday! */ - -#define FUNCTION_VALUE_REGNO_P(N) (((N) == 0) || (TARGET_AC0 && (N) == 8)) - /* 1 if N is a possible register number for function argument passing. - not used on pdp */ diff --git a/gcc/config/picochip/picochip-protos.h b/gcc/config/picochip/picochip-protos.h index 875bb1d2a31..4a80bd16d5d 100644 --- a/gcc/config/picochip/picochip-protos.h +++ b/gcc/config/picochip/picochip-protos.h @@ -73,9 +73,9 @@ extern int picochip_symbol_offset (rtx operand); extern int picochip_get_function_arg_boundary (enum machine_mode mode); -extern enum reg_class picochip_secondary_reload(bool in_p, +extern reg_class_t picochip_secondary_reload(bool in_p, rtx x, - enum reg_class cla, + reg_class_t cla, enum machine_mode mode, secondary_reload_info *sri); diff --git a/gcc/config/picochip/picochip.c b/gcc/config/picochip/picochip.c index 499c55d9677..2e8dbb92355 100644 --- a/gcc/config/picochip/picochip.c +++ b/gcc/config/picochip/picochip.c @@ -1,5 +1,5 @@ /* Subroutines used for code generation on picoChip processors. - Copyright (C) 2001,2008, 2009 Free Software Foundation, Inc. + Copyright (C) 2001, 2008, 2009, 2010 Free Software Foundation, Inc. Contributed by picoChip Designs Ltd. (http://www.picochip.com) Maintained by Daniel Towner (daniel.towner@picochip.com) and Hariharan Sandanagobalane (hariharan@picochip.com) @@ -103,12 +103,12 @@ int picochip_legitimize_reload_address (rtx *x, enum machine_mode mode, rtx picochip_struct_value_rtx(tree fntype ATTRIBUTE_UNUSED, int incoming ATTRIBUTE_UNUSED); rtx picochip_function_value (const_tree valtype, const_tree func ATTRIBUTE_UNUSED, bool outgoing ATTRIBUTE_UNUSED); -enum reg_class +reg_class_t picochip_secondary_reload (bool in_p, - rtx x ATTRIBUTE_UNUSED, - enum reg_class cla ATTRIBUTE_UNUSED, - enum machine_mode mode, - secondary_reload_info *sri); + rtx x ATTRIBUTE_UNUSED, + reg_class_t cla ATTRIBUTE_UNUSED, + enum machine_mode mode, + secondary_reload_info *sri); void picochip_asm_named_section (const char *name, unsigned int flags ATTRIBUTE_UNUSED, @@ -4363,12 +4363,12 @@ picochip_get_high_const (rtx value) choice of two registers to choose from, so that we a guaranteed to get at least one register which is different to the output register. This trick is taken from the alpha implementation. */ -enum reg_class +reg_class_t picochip_secondary_reload (bool in_p, - rtx x ATTRIBUTE_UNUSED, - enum reg_class cla ATTRIBUTE_UNUSED, - enum machine_mode mode, - secondary_reload_info *sri) + rtx x ATTRIBUTE_UNUSED, + reg_class_t cla ATTRIBUTE_UNUSED, + enum machine_mode mode, + secondary_reload_info *sri) { if (mode == QImode && !TARGET_HAS_BYTE_ACCESS) { diff --git a/gcc/config/picochip/picochip.h b/gcc/config/picochip/picochip.h index 7269fa062ad..b4aec727df5 100644 --- a/gcc/config/picochip/picochip.h +++ b/gcc/config/picochip/picochip.h @@ -406,9 +406,6 @@ extern const enum reg_class picochip_regno_reg_class[FIRST_PSEUDO_REGISTER]; #define PUSH_ARGS 0 -/* Functions don't pop their args. */ -#define RETURN_POPS_ARGS(FNDECL, FNTYPE, STACK) 0 - /* Passing Arguments in Registers */ /* Store the offset of the next argument. */ diff --git a/gcc/config/rs6000/altivec.h b/gcc/config/rs6000/altivec.h index bc4f30f7cb2..5f4510adc30 100644 --- a/gcc/config/rs6000/altivec.h +++ b/gcc/config/rs6000/altivec.h @@ -163,6 +163,8 @@ #define vec_vpkshus __builtin_vec_vpkshus #define vec_re __builtin_vec_re #define vec_round __builtin_vec_round +#define vec_recipdiv __builtin_vec_recipdiv +#define vec_rsqrt __builtin_vec_rsqrt #define vec_rsqrte __builtin_vec_rsqrte #define vec_vsubfp __builtin_vec_vsubfp #define vec_subc __builtin_vec_subc diff --git a/gcc/config/rs6000/altivec.md b/gcc/config/rs6000/altivec.md index 6fbb7cdcdac..7bf3c660312 100644 --- a/gcc/config/rs6000/altivec.md +++ b/gcc/config/rs6000/altivec.md @@ -75,9 +75,7 @@ (UNSPEC_VCTSXS 154) (UNSPEC_VLOGEFP 155) (UNSPEC_VEXPTEFP 156) - (UNSPEC_VRSQRTEFP 157) - (UNSPEC_VREFP 158) - ;; 159-162 deleted + ;; 157-162 deleted (UNSPEC_VLSDOI 163) (UNSPEC_VUPKHSB 167) (UNSPEC_VUPKHPX 168) @@ -141,10 +139,11 @@ (UNSPEC_VPERMHI 321) (UNSPEC_INTERHI 322) (UNSPEC_INTERLO 323) - (UNSPEC_VUPKHS_V4SF 324) - (UNSPEC_VUPKLS_V4SF 325) - (UNSPEC_VUPKHU_V4SF 326) - (UNSPEC_VUPKLU_V4SF 327) + (UNSPEC_VUPKHS_V4SF 324) + (UNSPEC_VUPKLS_V4SF 325) + (UNSPEC_VUPKHU_V4SF 326) + (UNSPEC_VUPKLU_V4SF 327) + (UNSPEC_VNMSUBFP 328) ]) (define_constants @@ -628,11 +627,64 @@ }") ;; Fused multiply subtract -(define_insn "altivec_vnmsubfp" +(define_expand "altivec_vnmsubfp" + [(match_operand:V4SF 0 "register_operand" "") + (match_operand:V4SF 1 "register_operand" "") + (match_operand:V4SF 2 "register_operand" "") + (match_operand:V4SF 3 "register_operand" "")] + "VECTOR_UNIT_ALTIVEC_P (V4SFmode)" +{ + if (TARGET_FUSED_MADD && HONOR_SIGNED_ZEROS (SFmode)) + { + emit_insn (gen_altivec_vnmsubfp_1 (operands[0], operands[1], + operands[2], operands[3])); + DONE; + } + else if (TARGET_FUSED_MADD && !HONOR_SIGNED_ZEROS (DFmode)) + { + emit_insn (gen_altivec_vnmsubfp_2 (operands[0], operands[1], + operands[2], operands[3])); + DONE; + } + else + { + emit_insn (gen_altivec_vnmsubfp_3 (operands[0], operands[1], + operands[2], operands[3])); + DONE; + } +}) + +(define_insn "altivec_vnmsubfp_1" [(set (match_operand:V4SF 0 "register_operand" "=v") - (neg:V4SF (minus:V4SF (mult:V4SF (match_operand:V4SF 1 "register_operand" "v") - (match_operand:V4SF 2 "register_operand" "v")) - (match_operand:V4SF 3 "register_operand" "v"))))] + (neg:V4SF + (minus:V4SF + (mult:V4SF + (match_operand:V4SF 1 "register_operand" "v") + (match_operand:V4SF 2 "register_operand" "v")) + (match_operand:V4SF 3 "register_operand" "v"))))] + "VECTOR_UNIT_ALTIVEC_P (V4SFmode) && TARGET_FUSED_MADD + && HONOR_SIGNED_ZEROS (SFmode)" + "vnmsubfp %0,%1,%2,%3" + [(set_attr "type" "vecfloat")]) + +(define_insn "altivec_vnmsubfp_2" + [(set (match_operand:V4SF 0 "register_operand" "=v") + (minus:V4SF + (match_operand:V4SF 3 "register_operand" "v") + (mult:V4SF + (match_operand:V4SF 1 "register_operand" "v") + (match_operand:V4SF 2 "register_operand" "v"))))] + "VECTOR_UNIT_ALTIVEC_P (V4SFmode) && TARGET_FUSED_MADD + && !HONOR_SIGNED_ZEROS (SFmode)" + "vnmsubfp %0,%1,%2,%3" + [(set_attr "type" "vecfloat")]) + +(define_insn "altivec_vnmsubfp_3" + [(set (match_operand:V4SF 0 "register_operand" "=v") + (unspec:V4SF [(match_operand:V4SF 1 "register_operand" "v") + (match_operand:V4SF 2 "register_operand" "v") + (match_operand:V4SF 3 "register_operand" "v")] + UNSPEC_VNMSUBFP))] "VECTOR_UNIT_ALTIVEC_P (V4SFmode)" "vnmsubfp %0,%1,%2,%3" [(set_attr "type" "vecfloat")]) @@ -1444,19 +1496,19 @@ "vexptefp %0,%1" [(set_attr "type" "vecfloat")]) -(define_insn "altivec_vrsqrtefp" +(define_insn "*altivec_vrsqrtefp" [(set (match_operand:V4SF 0 "register_operand" "=v") (unspec:V4SF [(match_operand:V4SF 1 "register_operand" "v")] - UNSPEC_VRSQRTEFP))] - "TARGET_ALTIVEC" + UNSPEC_RSQRT))] + "VECTOR_UNIT_ALTIVEC_P (V4SFmode)" "vrsqrtefp %0,%1" [(set_attr "type" "vecfloat")]) (define_insn "altivec_vrefp" [(set (match_operand:V4SF 0 "register_operand" "=v") (unspec:V4SF [(match_operand:V4SF 1 "register_operand" "v")] - UNSPEC_VREFP))] - "TARGET_ALTIVEC" + UNSPEC_FRES))] + "VECTOR_UNIT_ALTIVEC_P (V4SFmode)" "vrefp %0,%1" [(set_attr "type" "vecfloat")]) diff --git a/gcc/config/rs6000/constraints.md b/gcc/config/rs6000/constraints.md index bd4a1a1b8ae..7eb991a326f 100644 --- a/gcc/config/rs6000/constraints.md +++ b/gcc/config/rs6000/constraints.md @@ -166,7 +166,7 @@ usually better to use @samp{m} or @samp{es} in @code{asm} statements)" (define_constraint "R" "AIX TOC entry" - (match_test "legitimate_constant_pool_address_p (op)")) + (match_test "legitimate_constant_pool_address_p (op, false)")) ;; General constraints diff --git a/gcc/config/rs6000/e500.h b/gcc/config/rs6000/e500.h index 05b20ad1139..744f4de4c58 100644 --- a/gcc/config/rs6000/e500.h +++ b/gcc/config/rs6000/e500.h @@ -1,5 +1,5 @@ /* Enable E500 support. - Copyright (C) 2003, 2004, 2006, 2007, 2008, 2009 Free Software + Copyright (C) 2003, 2004, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. This file is part of GCC. @@ -46,3 +46,10 @@ error ("E500 and FPRs not supported"); \ } \ } while (0) + +/* When setting up caller-save slots (MODE == VOIDmode) ensure we + allocate space for DFmode. Save gprs in the correct mode too. */ +#define HARD_REGNO_CALLER_SAVE_MODE(REGNO, NREGS, MODE) \ + (TARGET_E500_DOUBLE && ((MODE) == VOIDmode || (MODE) == DFmode) \ + ? DFmode \ + : choose_hard_reg_mode ((REGNO), (NREGS), false)) diff --git a/gcc/config/rs6000/linux64.h b/gcc/config/rs6000/linux64.h index 39d440a01c3..900570f2ea1 100644 --- a/gcc/config/rs6000/linux64.h +++ b/gcc/config/rs6000/linux64.h @@ -63,6 +63,16 @@ extern int dot_symbols; #define TARGET_PROFILE_KERNEL profile_kernel +#define TARGET_USES_LINUX64_OPT 1 +#ifdef HAVE_LD_LARGE_TOC +extern enum rs6000_cmodel cmodel; +#undef TARGET_CMODEL +#define TARGET_CMODEL cmodel +#define SET_CMODEL(opt) cmodel = opt +#else +#define SET_CMODEL(opt) do {} while (0) +#endif + #undef PROCESSOR_DEFAULT #define PROCESSOR_DEFAULT PROCESSOR_POWER6 #undef PROCESSOR_DEFAULT64 @@ -114,6 +124,23 @@ extern int dot_symbols; target_flags |= MASK_POWERPC64; \ error ("-m64 requires a PowerPC64 cpu"); \ } \ + if ((target_flags_explicit & MASK_MINIMAL_TOC) != 0) \ + { \ + if (rs6000_explicit_options.cmodel \ + && cmodel != CMODEL_SMALL) \ + error ("-mcmodel incompatible with other toc options"); \ + SET_CMODEL (CMODEL_SMALL); \ + } \ + else \ + { \ + if (!rs6000_explicit_options.cmodel) \ + SET_CMODEL (CMODEL_LARGE); \ + if (cmodel != CMODEL_SMALL) \ + { \ + TARGET_NO_FP_IN_TOC = 0; \ + TARGET_NO_SUM_IN_TOC = 0; \ + } \ + } \ } \ else \ { \ @@ -124,6 +151,11 @@ extern int dot_symbols; TARGET_PROFILE_KERNEL = 0; \ error (INVALID_32BIT, "profile-kernel"); \ } \ + if (rs6000_explicit_options.cmodel) \ + { \ + SET_CMODEL (CMODEL_SMALL); \ + error (INVALID_32BIT, "cmodel"); \ + } \ } \ } \ while (0) diff --git a/gcc/config/rs6000/linux64.opt b/gcc/config/rs6000/linux64.opt index 0d52820691c..9d0e26ace33 100644 --- a/gcc/config/rs6000/linux64.opt +++ b/gcc/config/rs6000/linux64.opt @@ -22,3 +22,7 @@ mprofile-kernel Target Report Var(profile_kernel) Call mcount for profiling before a function prologue + +mcmodel= +Target RejectNegative Joined +Select code model diff --git a/gcc/config/rs6000/predicates.md b/gcc/config/rs6000/predicates.md index b4de82b6612..c94af469fcd 100644 --- a/gcc/config/rs6000/predicates.md +++ b/gcc/config/rs6000/predicates.md @@ -837,7 +837,7 @@ return 1; /* A SYMBOL_REF referring to the TOC is valid. */ - if (legitimate_constant_pool_address_p (op)) + if (legitimate_constant_pool_address_p (op, false)) return 1; /* A constant pool expression (relative to the TOC) is valid */ diff --git a/gcc/config/rs6000/rs6000-builtin.def b/gcc/config/rs6000/rs6000-builtin.def index 7c5619a8e14..9f45a72e2c0 100644 --- a/gcc/config/rs6000/rs6000-builtin.def +++ b/gcc/config/rs6000/rs6000-builtin.def @@ -159,6 +159,7 @@ RS6000_BUILTIN(ALTIVEC_BUILTIN_VRFIZ, RS6000_BTC_FP_PURE) RS6000_BUILTIN(ALTIVEC_BUILTIN_VRLB, RS6000_BTC_CONST) RS6000_BUILTIN(ALTIVEC_BUILTIN_VRLH, RS6000_BTC_CONST) RS6000_BUILTIN(ALTIVEC_BUILTIN_VRLW, RS6000_BTC_CONST) +RS6000_BUILTIN(ALTIVEC_BUILTIN_VRSQRTFP, RS6000_BTC_FP_PURE) RS6000_BUILTIN(ALTIVEC_BUILTIN_VRSQRTEFP, RS6000_BTC_FP_PURE) RS6000_BUILTIN(ALTIVEC_BUILTIN_VSLB, RS6000_BTC_CONST) RS6000_BUILTIN(ALTIVEC_BUILTIN_VSLH, RS6000_BTC_CONST) @@ -269,6 +270,7 @@ RS6000_BUILTIN(ALTIVEC_BUILTIN_VEC_EXT_V8HI, RS6000_BTC_CONST) RS6000_BUILTIN(ALTIVEC_BUILTIN_VEC_EXT_V16QI, RS6000_BTC_CONST) RS6000_BUILTIN(ALTIVEC_BUILTIN_VEC_EXT_V4SF, RS6000_BTC_CONST) RS6000_BUILTIN(ALTIVEC_BUILTIN_COPYSIGN_V4SF, RS6000_BTC_CONST) +RS6000_BUILTIN(ALTIVEC_BUILTIN_VRECIPFP, RS6000_BTC_FP_PURE) /* Altivec overloaded builtins. */ /* For now, don't set the classification for overloaded functions. @@ -351,10 +353,12 @@ RS6000_BUILTIN(ALTIVEC_BUILTIN_VEC_PACKS, RS6000_BTC_MISC) RS6000_BUILTIN(ALTIVEC_BUILTIN_VEC_PACKSU, RS6000_BTC_MISC) RS6000_BUILTIN(ALTIVEC_BUILTIN_VEC_PERM, RS6000_BTC_MISC) RS6000_BUILTIN(ALTIVEC_BUILTIN_VEC_RE, RS6000_BTC_MISC) +RS6000_BUILTIN(ALTIVEC_BUILTIN_VEC_RECIP, RS6000_BTC_FP_PURE) RS6000_BUILTIN(ALTIVEC_BUILTIN_VEC_RL, RS6000_BTC_MISC) RS6000_BUILTIN(ALTIVEC_BUILTIN_VEC_RINT, RS6000_BTC_MISC) RS6000_BUILTIN(ALTIVEC_BUILTIN_VEC_ROUND, RS6000_BTC_MISC) -RS6000_BUILTIN(ALTIVEC_BUILTIN_VEC_RSQRTE, RS6000_BTC_MISC) +RS6000_BUILTIN(ALTIVEC_BUILTIN_VEC_RSQRT, RS6000_BTC_FP_PURE) +RS6000_BUILTIN(ALTIVEC_BUILTIN_VEC_RSQRTE, RS6000_BTC_FP_PURE) RS6000_BUILTIN(ALTIVEC_BUILTIN_VEC_SEL, RS6000_BTC_MISC) RS6000_BUILTIN(ALTIVEC_BUILTIN_VEC_SL, RS6000_BTC_MISC) RS6000_BUILTIN(ALTIVEC_BUILTIN_VEC_SLD, RS6000_BTC_MISC) @@ -959,6 +963,10 @@ RS6000_BUILTIN(VSX_BUILTIN_VEC_MERGEL_V2DF, RS6000_BTC_CONST) RS6000_BUILTIN(VSX_BUILTIN_VEC_MERGEL_V2DI, RS6000_BTC_CONST) RS6000_BUILTIN(VSX_BUILTIN_VEC_MERGEH_V2DF, RS6000_BTC_CONST) RS6000_BUILTIN(VSX_BUILTIN_VEC_MERGEH_V2DI, RS6000_BTC_CONST) +RS6000_BUILTIN(VSX_BUILTIN_VEC_RSQRT_V4SF, RS6000_BTC_FP_PURE) +RS6000_BUILTIN(VSX_BUILTIN_VEC_RSQRT_V2DF, RS6000_BTC_FP_PURE) +RS6000_BUILTIN(VSX_BUILTIN_RECIP_V4SF, RS6000_BTC_FP_PURE) +RS6000_BUILTIN(VSX_BUILTIN_RECIP_V2DF, RS6000_BTC_FP_PURE) /* VSX overloaded builtins, add the overloaded functions not present in Altivec. */ @@ -991,4 +999,5 @@ RS6000_BUILTIN(POWER7_BUILTIN_BPERMD, RS6000_BTC_CONST) RS6000_BUILTIN(RS6000_BUILTIN_RECIP, RS6000_BTC_FP_PURE) RS6000_BUILTIN(RS6000_BUILTIN_RECIPF, RS6000_BTC_FP_PURE) RS6000_BUILTIN(RS6000_BUILTIN_RSQRTF, RS6000_BTC_FP_PURE) +RS6000_BUILTIN(RS6000_BUILTIN_RSQRT, RS6000_BTC_FP_PURE) RS6000_BUILTIN(RS6000_BUILTIN_BSWAP_HI, RS6000_BTC_CONST) diff --git a/gcc/config/rs6000/rs6000-c.c b/gcc/config/rs6000/rs6000-c.c index ac11336aee9..20f594a33e9 100644 --- a/gcc/config/rs6000/rs6000-c.c +++ b/gcc/config/rs6000/rs6000-c.c @@ -27,8 +27,8 @@ #include "tm.h" #include "cpplib.h" #include "tree.h" -#include "c-common.h" -#include "c-pragma.h" +#include "c-family/c-common.h" +#include "c-family/c-pragma.h" #include "toplev.h" #include "tm_p.h" #include "target.h" @@ -362,6 +362,16 @@ rs6000_cpu_cpp_builtins (cpp_reader *pfile) builtin_define ("__builtin_vsx_xvnmsubasp=__builtin_vsx_xvnmsubsp"); builtin_define ("__builtin_vsx_xvnmsubmsp=__builtin_vsx_xvnmsubsp"); } + if (RS6000_RECIP_HAVE_RE_P (DFmode)) + builtin_define ("__RECIP__"); + if (RS6000_RECIP_HAVE_RE_P (SFmode)) + builtin_define ("__RECIPF__"); + if (RS6000_RECIP_HAVE_RSQRTE_P (DFmode)) + builtin_define ("__RSQRTE__"); + if (RS6000_RECIP_HAVE_RSQRTE_P (SFmode)) + builtin_define ("__RSQRTEF__"); + if (TARGET_RECIP_PRECISION) + builtin_define ("__RECIP_PRECISION__"); /* Tell users they can use __builtin_bswap{16,64}. */ builtin_define ("__HAVE_BSWAP__"); @@ -479,10 +489,22 @@ const struct altivec_builtin_types altivec_overloaded_builtins[] = { RS6000_BTI_void, RS6000_BTI_bool_V16QI, 0, 0 }, { ALTIVEC_BUILTIN_VEC_RE, ALTIVEC_BUILTIN_VREFP, RS6000_BTI_V4SF, RS6000_BTI_V4SF, 0, 0 }, + { ALTIVEC_BUILTIN_VEC_RE, VSX_BUILTIN_XVREDP, + RS6000_BTI_V2DF, RS6000_BTI_V2DF, 0, 0 }, { ALTIVEC_BUILTIN_VEC_ROUND, ALTIVEC_BUILTIN_VRFIN, RS6000_BTI_V4SF, RS6000_BTI_V4SF, 0, 0 }, + { ALTIVEC_BUILTIN_VEC_RECIP, ALTIVEC_BUILTIN_VRECIPFP, + RS6000_BTI_V4SF, RS6000_BTI_V4SF, RS6000_BTI_V4SF, 0 }, + { ALTIVEC_BUILTIN_VEC_RECIP, VSX_BUILTIN_RECIP_V2DF, + RS6000_BTI_V2DF, RS6000_BTI_V2DF, RS6000_BTI_V2DF, 0 }, + { ALTIVEC_BUILTIN_VEC_RSQRT, ALTIVEC_BUILTIN_VRSQRTFP, + RS6000_BTI_V4SF, RS6000_BTI_V4SF, 0, 0 }, + { ALTIVEC_BUILTIN_VEC_RSQRT, VSX_BUILTIN_VEC_RSQRT_V2DF, + RS6000_BTI_V2DF, RS6000_BTI_V2DF, 0, 0 }, { ALTIVEC_BUILTIN_VEC_RSQRTE, ALTIVEC_BUILTIN_VRSQRTEFP, RS6000_BTI_V4SF, RS6000_BTI_V4SF, 0, 0 }, + { ALTIVEC_BUILTIN_VEC_RSQRTE, VSX_BUILTIN_XVRSQRTEDP, + RS6000_BTI_V2DF, RS6000_BTI_V2DF, 0, 0 }, { ALTIVEC_BUILTIN_VEC_TRUNC, ALTIVEC_BUILTIN_VRFIZ, RS6000_BTI_V4SF, RS6000_BTI_V4SF, 0, 0 }, { ALTIVEC_BUILTIN_VEC_TRUNC, VSX_BUILTIN_XVRDPIZ, diff --git a/gcc/config/rs6000/rs6000-protos.h b/gcc/config/rs6000/rs6000-protos.h index 43ed634495b..9e978bdae89 100644 --- a/gcc/config/rs6000/rs6000-protos.h +++ b/gcc/config/rs6000/rs6000-protos.h @@ -39,7 +39,7 @@ extern int small_data_operand (rtx, enum machine_mode); extern bool toc_relative_expr_p (rtx); extern bool invalid_e500_subreg (rtx, enum machine_mode); extern void validate_condition_mode (enum rtx_code, enum machine_mode); -extern bool legitimate_constant_pool_address_p (rtx); +extern bool legitimate_constant_pool_address_p (const_rtx, bool); extern bool legitimate_indirect_address_p (rtx, int); extern bool legitimate_indexed_address_p (rtx, int); extern bool avoiding_indexed_address_p (enum machine_mode); @@ -106,13 +106,12 @@ extern void rs6000_split_compare_and_swap (rtx, rtx, rtx, rtx, rtx); extern void rs6000_expand_compare_and_swapqhi (rtx, rtx, rtx, rtx); extern void rs6000_split_compare_and_swapqhi (rtx, rtx, rtx, rtx, rtx, rtx); extern void rs6000_split_lock_test_and_set (rtx, rtx, rtx, rtx); -extern void rs6000_emit_swdivsf (rtx, rtx, rtx); -extern void rs6000_emit_swdivdf (rtx, rtx, rtx); -extern void rs6000_emit_swrsqrtsf (rtx, rtx); +extern void rs6000_emit_swdiv (rtx, rtx, rtx, bool); +extern void rs6000_emit_swrsqrt (rtx, rtx); extern void output_toc (FILE *, rtx, int, enum machine_mode); extern rtx rs6000_longcall_ref (rtx); extern void rs6000_fatal_bad_address (rtx); -extern rtx create_TOC_reference (rtx); +extern rtx create_TOC_reference (rtx, rtx); extern void rs6000_split_multireg_move (rtx, rtx); extern void rs6000_emit_move (rtx, rtx, enum machine_mode); extern rtx rs6000_secondary_memory_needed_rtx (enum machine_mode); diff --git a/gcc/config/rs6000/rs6000.c b/gcc/config/rs6000/rs6000.c index a7434ca5257..36187c95cd5 100644 --- a/gcc/config/rs6000/rs6000.c +++ b/gcc/config/rs6000/rs6000.c @@ -279,6 +279,9 @@ static GTY(()) section *toc_section; /* String from -malign-XXXXX. */ int rs6000_alignment_flags; +/* Code model for 64-bit linux. */ +enum rs6000_cmodel cmodel; + /* True for any options that were explicitly set. */ static struct { bool aix_struct_ret; /* True if -maix-struct-ret was used. */ @@ -290,6 +293,7 @@ static struct { bool long_double; /* True if -mlong-double- was used. */ bool ieee; /* True if -mabi=ieee/ibmlongdouble used. */ bool vrsave; /* True if -mvrsave was used. */ + bool cmodel; /* True if -mcmodel was used. */ } rs6000_explicit_options; struct builtin_description @@ -316,6 +320,61 @@ int rs6000_vector_align[NUM_MACHINE_MODES]; /* Map selected modes to types for builtins. */ static GTY(()) tree builtin_mode_to_type[MAX_MACHINE_MODE][2]; + +/* What modes to automatically generate reciprocal divide estimate (fre) and + reciprocal sqrt (frsqrte) for. */ +unsigned char rs6000_recip_bits[MAX_MACHINE_MODE]; + +/* Masks to determine which reciprocal esitmate instructions to generate + automatically. */ +enum rs6000_recip_mask { + RECIP_SF_DIV = 0x001, /* Use divide estimate */ + RECIP_DF_DIV = 0x002, + RECIP_V4SF_DIV = 0x004, + RECIP_V2DF_DIV = 0x008, + + RECIP_SF_RSQRT = 0x010, /* Use reciprocal sqrt estimate. */ + RECIP_DF_RSQRT = 0x020, + RECIP_V4SF_RSQRT = 0x040, + RECIP_V2DF_RSQRT = 0x080, + + /* Various combination of flags for -mrecip=xxx. */ + RECIP_NONE = 0, + RECIP_ALL = (RECIP_SF_DIV | RECIP_DF_DIV | RECIP_V4SF_DIV + | RECIP_V2DF_DIV | RECIP_SF_RSQRT | RECIP_DF_RSQRT + | RECIP_V4SF_RSQRT | RECIP_V2DF_RSQRT), + + RECIP_HIGH_PRECISION = RECIP_ALL, + + /* On low precision machines like the power5, don't enable double precision + reciprocal square root estimate, since it isn't accurate enough. */ + RECIP_LOW_PRECISION = (RECIP_ALL & ~(RECIP_DF_RSQRT | RECIP_V2DF_RSQRT)) +}; + +static unsigned int rs6000_recip_control; +static const char *rs6000_recip_name; + +/* -mrecip options. */ +static struct +{ + const char *string; /* option name */ + unsigned int mask; /* mask bits to set */ +} recip_options[] = { + { "all", RECIP_ALL }, + { "none", RECIP_NONE }, + { "div", (RECIP_SF_DIV | RECIP_DF_DIV | RECIP_V4SF_DIV + | RECIP_V2DF_DIV) }, + { "divf", (RECIP_SF_DIV | RECIP_V4SF_DIV) }, + { "divd", (RECIP_DF_DIV | RECIP_V2DF_DIV) }, + { "rsqrt", (RECIP_SF_RSQRT | RECIP_DF_RSQRT | RECIP_V4SF_RSQRT + | RECIP_V2DF_RSQRT) }, + { "rsqrtf", (RECIP_SF_RSQRT | RECIP_V4SF_RSQRT) }, + { "rsqrtd", (RECIP_DF_RSQRT | RECIP_V2DF_RSQRT) }, +}; + +/* 2 argument gen function typedef. */ +typedef rtx (*gen_2arg_fn_t) (rtx, rtx, rtx); + /* Target cpu costs. */ @@ -779,6 +838,25 @@ struct processor_costs ppce500mc64_cost = { 1, /* prefetch streams /*/ }; +/* Instruction costs on AppliedMicro Titan processors. */ +static const +struct processor_costs titan_cost = { + COSTS_N_INSNS (5), /* mulsi */ + COSTS_N_INSNS (5), /* mulsi_const */ + COSTS_N_INSNS (5), /* mulsi_const9 */ + COSTS_N_INSNS (5), /* muldi */ + COSTS_N_INSNS (18), /* divsi */ + COSTS_N_INSNS (18), /* divdi */ + COSTS_N_INSNS (10), /* fp */ + COSTS_N_INSNS (10), /* dmul */ + COSTS_N_INSNS (46), /* sdiv */ + COSTS_N_INSNS (72), /* ddiv */ + 32, /* cache line size */ + 32, /* l1 cache */ + 512, /* l2 cache */ + 1, /* prefetch streams /*/ +}; + /* Instruction costs on POWER4 and POWER5 processors. */ static const struct processor_costs power4_cost = { @@ -1162,11 +1240,11 @@ bool (*rs6000_cannot_change_mode_class_ptr) (enum machine_mode, enum reg_class) = rs6000_cannot_change_mode_class; -static enum reg_class rs6000_secondary_reload (bool, rtx, enum reg_class, - enum machine_mode, - struct secondary_reload_info *); +static reg_class_t rs6000_secondary_reload (bool, rtx, reg_class_t, + enum machine_mode, + struct secondary_reload_info *); -static const enum reg_class *rs6000_ira_cover_classes (void); +static const reg_class_t *rs6000_ira_cover_classes (void); const int INSN_NOT_AVAILABLE = -1; static enum machine_mode rs6000_eh_return_filter_mode (void); @@ -1384,11 +1462,11 @@ static const struct attribute_spec rs6000_attribute_table[] = #define TARGET_VECTORIZE_BUILTIN_CONVERSION rs6000_builtin_conversion #undef TARGET_VECTORIZE_BUILTIN_VEC_PERM #define TARGET_VECTORIZE_BUILTIN_VEC_PERM rs6000_builtin_vec_perm -#undef TARGET_SUPPORT_VECTOR_MISALIGNMENT -#define TARGET_SUPPORT_VECTOR_MISALIGNMENT \ +#undef TARGET_VECTORIZE_SUPPORT_VECTOR_MISALIGNMENT +#define TARGET_VECTORIZE_SUPPORT_VECTOR_MISALIGNMENT \ rs6000_builtin_support_vector_misalignment -#undef TARGET_VECTOR_ALIGNMENT_REACHABLE -#define TARGET_VECTOR_ALIGNMENT_REACHABLE rs6000_vector_alignment_reachable +#undef TARGET_VECTORIZE_VECTOR_ALIGNMENT_REACHABLE +#define TARGET_VECTORIZE_VECTOR_ALIGNMENT_REACHABLE rs6000_vector_alignment_reachable #undef TARGET_INIT_BUILTINS #define TARGET_INIT_BUILTINS rs6000_init_builtins @@ -1807,6 +1885,27 @@ rs6000_debug_reg_global (void) if (nl) fputs (nl, stderr); + if (rs6000_recip_control) + { + fprintf (stderr, "\nReciprocal mask = 0x%x\n", rs6000_recip_control); + + for (m = 0; m < NUM_MACHINE_MODES; ++m) + if (rs6000_recip_bits[m]) + { + fprintf (stderr, + "Reciprocal estimate mode: %-5s divide: %s rsqrt: %s\n", + GET_MODE_NAME (m), + (RS6000_RECIP_AUTO_RE_P (m) + ? "auto" + : (RS6000_RECIP_HAVE_RE_P (m) ? "have" : "none")), + (RS6000_RECIP_AUTO_RSQRTE_P (m) + ? "auto" + : (RS6000_RECIP_HAVE_RSQRTE_P (m) ? "have" : "none"))); + } + + fputs ("\n", stderr); + } + switch (rs6000_sched_costly_dep) { case max_dep_latency: @@ -2014,8 +2113,9 @@ rs6000_init_hard_regno_mode_ok (void) rs6000_constraints[RS6000_CONSTRAINT_wa] = VSX_REGS; rs6000_constraints[RS6000_CONSTRAINT_wf] = VSX_REGS; rs6000_constraints[RS6000_CONSTRAINT_wd] = VSX_REGS; - if (TARGET_VSX_SCALAR_DOUBLE) - rs6000_constraints[RS6000_CONSTRAINT_ws] = VSX_REGS; + rs6000_constraints[RS6000_CONSTRAINT_ws] = (TARGET_VSX_SCALAR_MEMORY + ? VSX_REGS + : FLOAT_REGS); } if (TARGET_ALTIVEC) @@ -2093,8 +2193,111 @@ rs6000_init_hard_regno_mode_ok (void) if (TARGET_E500_DOUBLE) rs6000_class_max_nregs[DFmode][GENERAL_REGS] = 1; + /* Calculate which modes to automatically generate code to use a the + reciprocal divide and square root instructions. In the future, possibly + automatically generate the instructions even if the user did not specify + -mrecip. The older machines double precision reciprocal sqrt estimate is + not accurate enough. */ + memset (rs6000_recip_bits, 0, sizeof (rs6000_recip_bits)); + if (TARGET_FRES) + rs6000_recip_bits[SFmode] = RS6000_RECIP_MASK_HAVE_RE; + if (TARGET_FRE) + rs6000_recip_bits[DFmode] = RS6000_RECIP_MASK_HAVE_RE; + if (VECTOR_UNIT_ALTIVEC_OR_VSX_P (V4SFmode)) + rs6000_recip_bits[V4SFmode] = RS6000_RECIP_MASK_HAVE_RE; + if (VECTOR_UNIT_VSX_P (V2DFmode)) + rs6000_recip_bits[V2DFmode] = RS6000_RECIP_MASK_HAVE_RE; + + if (TARGET_FRSQRTES) + rs6000_recip_bits[SFmode] |= RS6000_RECIP_MASK_HAVE_RSQRTE; + if (TARGET_FRSQRTE) + rs6000_recip_bits[DFmode] |= RS6000_RECIP_MASK_HAVE_RSQRTE; + if (VECTOR_UNIT_ALTIVEC_OR_VSX_P (V4SFmode)) + rs6000_recip_bits[V4SFmode] |= RS6000_RECIP_MASK_HAVE_RSQRTE; + if (VECTOR_UNIT_VSX_P (V2DFmode)) + rs6000_recip_bits[V2DFmode] |= RS6000_RECIP_MASK_HAVE_RSQRTE; + + if (rs6000_recip_control) + { + if (!TARGET_FUSED_MADD) + warning (0, "-mrecip requires -mfused-madd"); + if (!flag_finite_math_only) + warning (0, "-mrecip requires -ffinite-math or -ffast-math"); + if (flag_trapping_math) + warning (0, "-mrecip requires -fno-trapping-math or -ffast-math"); + if (!flag_reciprocal_math) + warning (0, "-mrecip requires -freciprocal-math or -ffast-math"); + if (TARGET_FUSED_MADD && flag_finite_math_only && !flag_trapping_math + && flag_reciprocal_math) + { + if (RS6000_RECIP_HAVE_RE_P (SFmode) + && (rs6000_recip_control & RECIP_SF_DIV) != 0) + rs6000_recip_bits[SFmode] |= RS6000_RECIP_MASK_AUTO_RE; + + if (RS6000_RECIP_HAVE_RE_P (DFmode) + && (rs6000_recip_control & RECIP_DF_DIV) != 0) + rs6000_recip_bits[DFmode] |= RS6000_RECIP_MASK_AUTO_RE; + + if (RS6000_RECIP_HAVE_RE_P (V4SFmode) + && (rs6000_recip_control & RECIP_V4SF_DIV) != 0) + rs6000_recip_bits[V4SFmode] |= RS6000_RECIP_MASK_AUTO_RE; + + if (RS6000_RECIP_HAVE_RE_P (V2DFmode) + && (rs6000_recip_control & RECIP_V2DF_DIV) != 0) + rs6000_recip_bits[V2DFmode] |= RS6000_RECIP_MASK_AUTO_RE; + + if (RS6000_RECIP_HAVE_RSQRTE_P (SFmode) + && (rs6000_recip_control & RECIP_SF_RSQRT) != 0) + rs6000_recip_bits[SFmode] |= RS6000_RECIP_MASK_AUTO_RSQRTE; + + if (RS6000_RECIP_HAVE_RSQRTE_P (DFmode) + && (rs6000_recip_control & RECIP_DF_RSQRT) != 0) + rs6000_recip_bits[DFmode] |= RS6000_RECIP_MASK_AUTO_RSQRTE; + + if (RS6000_RECIP_HAVE_RSQRTE_P (V4SFmode) + && (rs6000_recip_control & RECIP_V4SF_RSQRT) != 0) + rs6000_recip_bits[V4SFmode] |= RS6000_RECIP_MASK_AUTO_RSQRTE; + + if (RS6000_RECIP_HAVE_RSQRTE_P (V2DFmode) + && (rs6000_recip_control & RECIP_V2DF_RSQRT) != 0) + rs6000_recip_bits[V2DFmode] |= RS6000_RECIP_MASK_AUTO_RSQRTE; + } + } + if (TARGET_DEBUG_REG) rs6000_debug_reg_global (); + + if (TARGET_DEBUG_COST || TARGET_DEBUG_REG) + fprintf (stderr, + "SImode variable mult cost = %d\n" + "SImode constant mult cost = %d\n" + "SImode short constant mult cost = %d\n" + "DImode multipliciation cost = %d\n" + "SImode division cost = %d\n" + "DImode division cost = %d\n" + "Simple fp operation cost = %d\n" + "DFmode multiplication cost = %d\n" + "SFmode division cost = %d\n" + "DFmode division cost = %d\n" + "cache line size = %d\n" + "l1 cache size = %d\n" + "l2 cache size = %d\n" + "simultaneous prefetches = %d\n" + "\n", + rs6000_cost->mulsi, + rs6000_cost->mulsi_const, + rs6000_cost->mulsi_const9, + rs6000_cost->muldi, + rs6000_cost->divsi, + rs6000_cost->divdi, + rs6000_cost->fp, + rs6000_cost->dmul, + rs6000_cost->sdiv, + rs6000_cost->ddiv, + rs6000_cost->cache_line_size, + rs6000_cost->l1_cache_size, + rs6000_cost->l2_cache_size, + rs6000_cost->simultaneous_prefetches); } #if TARGET_MACHO @@ -2255,6 +2458,8 @@ rs6000_override_options (const char *default_cpu) {"G4", PROCESSOR_PPC7450, POWERPC_7400_MASK}, {"G5", PROCESSOR_POWER4, POWERPC_7400_MASK | MASK_PPC_GPOPT | MASK_MFCRF | MASK_POWERPC64}, + {"titan", PROCESSOR_TITAN, + POWERPC_BASE_MASK | MASK_MULHW | MASK_DLMZB}, {"power", PROCESSOR_POWER, MASK_POWER | MASK_MULTIPLE | MASK_STRING}, {"power2", PROCESSOR_POWER, MASK_POWER | MASK_POWER2 | MASK_MULTIPLE | MASK_STRING}, @@ -2271,15 +2476,16 @@ rs6000_override_options (const char *default_cpu) | MASK_MFCRF | MASK_POPCNTB | MASK_FPRND}, {"power6", PROCESSOR_POWER6, POWERPC_BASE_MASK | MASK_POWERPC64 | MASK_PPC_GPOPT | MASK_PPC_GFXOPT - | MASK_MFCRF | MASK_POPCNTB | MASK_FPRND | MASK_CMPB | MASK_DFP}, + | MASK_MFCRF | MASK_POPCNTB | MASK_FPRND | MASK_CMPB | MASK_DFP + | MASK_RECIP_PRECISION}, {"power6x", PROCESSOR_POWER6, POWERPC_BASE_MASK | MASK_POWERPC64 | MASK_PPC_GPOPT | MASK_PPC_GFXOPT | MASK_MFCRF | MASK_POPCNTB | MASK_FPRND | MASK_CMPB | MASK_DFP - | MASK_MFPGPR}, + | MASK_MFPGPR | MASK_RECIP_PRECISION}, {"power7", PROCESSOR_POWER7, POWERPC_7400_MASK | MASK_POWERPC64 | MASK_PPC_GPOPT | MASK_MFCRF | MASK_POPCNTB | MASK_FPRND | MASK_CMPB | MASK_DFP | MASK_POPCNTD - | MASK_VSX}, /* Don't add MASK_ISEL by default */ + | MASK_VSX| MASK_RECIP_PRECISION}, /* Don't add MASK_ISEL by default */ {"powerpc", PROCESSOR_POWERPC, POWERPC_BASE_MASK}, {"powerpc64", PROCESSOR_POWERPC64, POWERPC_BASE_MASK | MASK_PPC_GFXOPT | MASK_POWERPC64}, @@ -2307,7 +2513,24 @@ rs6000_override_options (const char *default_cpu) | MASK_PPC_GFXOPT | MASK_POWERPC64 | MASK_ALTIVEC | MASK_MFCRF | MASK_POPCNTB | MASK_FPRND | MASK_MULHW | MASK_DLMZB | MASK_CMPB | MASK_MFPGPR | MASK_DFP - | MASK_POPCNTD | MASK_VSX | MASK_ISEL | MASK_NO_UPDATE) + | MASK_POPCNTD | MASK_VSX | MASK_ISEL | MASK_NO_UPDATE + | MASK_RECIP_PRECISION) + }; + + /* Masks for instructions set at various powerpc ISAs. */ + enum { + ISA_2_1_MASKS = MASK_MFCRF, + ISA_2_2_MASKS = (ISA_2_1_MASKS | MASK_POPCNTB | MASK_FPRND), + + /* For ISA 2.05, do not add MFPGPR, since it isn't in ISA 2.06, and + don't add ALTIVEC, since in general it isn't a win on power6. */ + ISA_2_5_MASKS = (ISA_2_2_MASKS | MASK_CMPB | MASK_RECIP_PRECISION + | MASK_DFP), + + /* For ISA 2.06, don't add ISEL, since in general it isn't a win, but + altivec is a win so enable it. */ + ISA_2_6_MASKS = (ISA_2_5_MASKS | MASK_ALTIVEC | MASK_POPCNTD + | MASK_VSX | MASK_RECIP_PRECISION) }; /* Numerous experiment shows that IRA based loop pressure @@ -2449,10 +2672,17 @@ rs6000_override_options (const char *default_cpu) warning (0, msg); target_flags &= ~ MASK_VSX; } - else if (TARGET_VSX && !TARGET_ALTIVEC) - target_flags |= MASK_ALTIVEC; } + /* For the newer switches (vsx, dfp, etc.) set some of the older options, + unless the user explicitly used the -mno-